integer*4 function deldo(idwrk,mode,buf,vlst) integer*4 idwrk(2),mode,buf(32),jdid(2) integer*4 ifid(2) integer*2 ufid(4) parameter lib$k_julian_date=20 parameter lib$k_second_of_day=16 equivalence(ifid(1),ufid(1)) character*1600 vlst byte wknm(16) integer*4 wkn4(4),ldelc integer*4 ccol character*16 cwknm character*256 cw1,cw2,cwa1,cdelc,dvcnm,sqdbn equivalence (cwknm,wknm(1),wkn4(1)) character*256 cwrkn,cwfid equivalence (cwrkn,cwknm) integer*4 iunit,sys$assign,sys$dassgn,sys$qiow integer*4 fib(16),fib2(16),ichan integer*4 fibd1(2),fibd2(2) byte filspc(512) character*512 cfilsp character*128 ofilsp character*1023 workss character*512 fincl,fexcl equivalence(cfilsp,filspc(1)) external sys$qiow,sys$assign,sys$dassgn integer*4 jflag,conv$pass_files,conv$convert integer*4 conv$pass_options external conv$pass_options integer*4 lib$cvt_from_internal_time external lib$cvt_from_internal_time external conv$pass_files,conv$convert integer*4 istart,for$rab,sys$flush,lib$spawn,jtspawn external for$rab,sys$flush,lib$spawn,jtspawn integer*4 str$match_wild external str$match_wild include '($strdef)' Integer*4 lib$sys_trnlog External lib$sys_trnlog integer*4 lstsec save lstsec,istart integer*4 convopts(19) data convopts/18,1,0,1,0,0,1,2,0,0,0,0,0,0,0,0,0,0,0/ data istart/0/,lstsec/0/ c xx becomes time since midnight in seconds. c Arrange that every day we close & reopen the delete journal xx=secnds(0.) c ii=xx c if lstsec = last time thru > curr time, must have wrapped. if(lstsec.gt.ii)then lstsec=ii close(unit=14) istart=0 endif if(istart.eq.0)then lstsec=ii c Use one file for all devices & flush after use. Should be faster c than opening each time. c Open file shared so other daemons can get at it. c Create a new version at each start, too. open(unit=14,file='gce$delseq:delrecs.seq',recl=512, 1 form='formatted',carriagecontrol='list',status='new', 2 shared,err=9800) istart=1 end if ifid(1)=idwrk(1) ifid(2)=idwrk(2) c set up minimal FIBs to point at the file fibd1(1)=64 fibd2(1)=64 fibd1(2)=%loc(fib(1)) fibd2(2)=%loc(fib2(1)) fib(1)=1048576 !fib$m_nolock fib(2)=idwrk(1) fib(3)=idwrk(2) wkn4(1)=buf(26) wkn4(2)=buf(27) cw1=cwrkn(2:wknm(1)+1) ! nodename, 6 chars or less ccol=index(cw1,':') c strip any ":" from nodename if(ccol.gt.0.and.ccol.lt.8)cw1=cw1(:ccol-1) lcw1=ivlen(cw1,6) wkn4(1)=buf(3) wkn4(2)=buf(4) wkn4(3)=buf(5) wkn4(4)=buf(6) cw2=cwrkn(2:wknm(1)+1) ! device name lcw2=ivlen(cw2,22) if(buf(25).eq.0)write(dvcnm,100)cw1(:lcw1),cw2(:lcw2),buf(6) 100 format(a,'$',a,i3.3,':') if(buf(25).ne.0)write(dvcnm,101)buf(15),cw2(:lcw2),buf(6) 101 format('$',i3.3,'$',a,i3.3,':') if(buf(25).eq.0)write(sqdbn,102)cw1(:lcw1),cw2(:lcw2),buf(6) 102 format('gcy$cm:SD',a,'$',a,i3.3,'.GDB') if(buf(25).ne.0)write(sqdbn,103)buf(15),cw2(:lcw2),buf(6) 103 format('gcy$cm:SD','$',i3.3,'$',a,i3.3,'.GDB') ldbn=ivlen(dvcnm,256) c dvcnm(:ldbn) now contains the device name of the file. c use lib$fid_to_name to get the filename kk=lib$fid_to_name(dvcnm(:ldbn),idwrk,cfilsp,lfilsp, 1 ,iacps) c cfilsp(:lfilsp) is now the filename. Try callable convert to c copy it... c First see if this file should be matched though. If not, just c skip right on by. fexcl=' ' fincl=' ' kkk=lib$sys_trnlog('GCY$DELEXC',LEXCL,FEXCL) kkk=kkk.and.1 if(kkk.eq.0)then lexcl=1 fexcl=' ' endif kkk=lib$sys_trnlog('GCY$DELINC',lincl,fincl) kii=index(fincl,'GCY$DELINC') if(kii.ne.0)kkk=0 kkk=kkk.and.1 if(kkk.eq.0)then lincl=1 fincl='*' endif 10 continue c strip items off excl. list one at a time. ill=ivlen(fexcl,512) icomm=index(fexcl,',') if(icomm.eq.0.and.ill.gt.1)icomm=ill+1 if(icomm.le.0)goto 19 lll=str$match_wild(cfilsp(:lfilsp),fexcl(:icomm-1)) if(lll.eq.str$_match)then deldo=1 goto 9800 endif c Found the file in the exclusion list. Therefore just delete it now. fexcl=fexcl(icomm+1:) goto 10 19 continue if((mode.and.8).ne.0)goto 29 15 continue c strip items off excl. list one at a time. ill=ivlen(fincl,512) icomm=index(fincl,',') if(icomm.eq.0.and.ill.gt.1)icomm=ill+1 if(ill.eq.1.and.index(fincl,'*').eq.1)goto 29 if(icomm.le.1)goto 39 lll=str$match_wild(cfilsp(:lfilsp),fincl(:icomm-1)) if(lll.eq.str$_match)goto 29 c Found the file in the exclusion list. Therefore just delete it now. fincl=fincl(icomm+1:) goto 15 39 continue c here, we did not find the files in the INclude list and mode is set c so we specially treat only stuff that is. Thus let delete by. deldo=1 goto 9800 29 continue c c First see if we should bother; some logicals carry names to just c delete, some carry files to save. c c Keep a record of the original filespec and the file ID and build c an output filename based on file ID and time (time first) so we c can blow old files away real easily. ii=lib$cvt_from_internal_time(lib$k_julian_date,ijul,) ii=lib$cvt_from_internal_time(lib$k_second_of_day,isec,) c fill in filespec with time at high order, to the second c Use delete time since that's what we'll track with. write(ofilsp(1:9),1002)ijul 1002 format(i9.9) write(ofilsp(10:14),1003)isec 1003 format(i5.5) c now tack on original file ID so we stay unique diskwide. write(ofilsp(15:26),1004)ufid(1),ufid(2),ufid(3) 1004 format(3z4.4) c now tack on the device name ofilsp=ofilsp(:26) // dvcnm(:ldbn-1) // '.SAV' c now get overall length lofs=ivlen(ofilsp,128) c Now record this deletion if mode allows c c manage actual deletion operation c Destination filename may appear in variable data as D%filespec% so's not c to confuse anything... c c mode meanings: c Bit Meaning c 0-1 0 = use .COM file c 1 = use rename mode c 2 = use copy (callable cvt) mode c 3 = copy and add softlink. No database file genn'd c 2 If set don't delete ANYthing immediately c 3 If set don't include only included names c 4 If set, delete file if no room for rename/copy c If clear, leave file alone if copy area is full (return error though) c 5 If set, no timetag on deleted files (use if using softlink...) c c dbnm = name of database...use to get device name c idwrk = file id being deleted c buf is data passed to delfilt c in rename use lib$rename_file c for copy mode use callable convert majmod=mode.and.3 if(majmod.eq.2)then deldo=1 c 16 bit or 4 bit means no del on err if((mode.and.20).eq.0)deldo=3 ofilsp= 'delsav:' // ofilsp(:lofs) lofs=lofs+7 c now actually copy the original file to delsav: c Note transformed filename sorts by time so oldest files will be c first in the directory. That should be helpful. ii=conv$pass_files(cfilsp(:lfilsp),ofilsp(:lofs),,,) if(.not.ii)goto 9900 ii=conv$pass_options(convopts) if(.not.ii)goto 9900 ii=conv$convert(,) if(.not.ii)goto 9900 c looks ok, write the record and leave. c Use a sequential file. if((mode.and.32).eq.0)then write(14,1090)ofilsp(:lofs),dvcnm(:ldbn),cfilsp(:lfilsp) 1090 format(a,',',a,',',a) c Flush the record to disk in case of crash ii=for$rab(14) ii=sys$flush(%val(ii)) end if deldo=1 if((mode.and.4).ne.0)deldo=3 goto 9800 end if if (majmod.eq.1)then c rename mode. Use lib$rename_file ofilsp= 'delsav:' // ofilsp(:lofs) lofs=lofs+7 lofs=ivlen(ofilsp,510) c now actually copy the original file to delsav: c Note transformed filename sorts by time so oldest files will be c first in the directory. That should be helpful. ii=lib$rename_file(cfilsp(:lfilsp),ofilsp(:lofs),,,,,,,,,,) if(.not.ii)goto 9800 c looks ok, write the record and leave. c Use a sequential file. if((mode.and.32).eq.0)then write(14,1090)ofilsp(:lofs),dvcnm(:ldbn),cfilsp(:lfilsp) c Flush the record to disk in case of crash ii=for$rab(14) ii=sys$flush(%val(ii)) endif deldo=3 c fake deletion since we renamed here. goto 9800 end if if(majmod.eq.3)then c softlink mode. c copy file somewhere & softlink to it. deldo=1 c 16 bit or 4 bit means no del on err if((mode.and.20).eq.0)deldo=3 ofilsp= 'delsav:' // ofilsp(:lofs) lofs=lofs+7 c now actually copy the original file to delsav: c Note transformed filename sorts by time so oldest files will be c first in the directory. That should be helpful. ii=conv$pass_files(cfilsp(:lfilsp),ofilsp(:lofs),,,) if(.not.ii)goto 9900 ii=conv$convert(,) if(.not.ii)goto 9900 c No record of softlinks is needed. deldo=3 c Now truncate the file & tag softlink onto it. c Since FILE does this sort of thing, do it all in a DCL script for c the time being. Also allow a script for bulk conversions. write(workss,89)cfilsp(:lfilsp),ofilsp(:lofs), 1 ufid(1),ufid(2),ufid(3) 89 format('@gcy$cm:softlk ',a,' ',a,' ',3i8) lwrks=ivlen(workss,1023) c kkk=lib$spawn(workss(:lwrks),,,,,,istat) kkk=jtspawn(workss(:lwrks),1) goto 9800 end if c we handle cmd file mode outside this area. 9800 continue c check for mode bits that say don't delete. Here a code 1 means c delete, code 3 means fake it, code 2 or 4 means return error return 9900 continue c error occurred. Bug out. deldo=4 return end