Trailing-Edge
-
PDP-10 Archives
-
tops20-v7-ft-dist1-clock
-
7-sources/reaper.mac
There are 27 other files named reaper.mac in the archive. Click here to see a list.
; *** Edit 305 to REAPER.MAC by EVANS on 10-Apr-87, for SPR #21320
; Release JFNs when SCAN-only.
; *** Edit 304 to REAPER.MAC by EVANS on 10-Apr-87, for SPR #21435
; Prevent JFNS% error by getting JFN from right place if last file. Add ERJMP
; too.
; *** Edit 303 to REAPER.MAC by MAYO on 3-Jan-86, for SPR #21030
; Do not allow REAPER's internal mail buffer to overflow; notice when it gets
; filled and send what we have, restarting the buffer afterwards to allow for
; more mail. Also, make the buffer much bigger.
; *** Edit 302 to REAPER.MAC by MAYO on 20-Dec-85, for SPR #21031
; Check only those entries in DIRS that have meaningful values at CHKDI1.
TITLE REAPER
SEARCH MONSYM,MACSYM
.REQUIRE SYS:ARMAIL
EXTERN MLINIT,MLTOWN,MLTLST,MLDONE,.MLNFL,.MLOFL
.DIRECT FLBLST ;DON'T EXPAND TEXT
SALL ;KEEP LISTING READABLE
CPYRIG: ASCIZ +
REAPER - TOPS-20 Archival Utility
Copyright (C) 1984 by Digital Equipment Corporation, Maynard, Mass
THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
+
SUBTTL Version info and edit history
.MAJOR==6
.MINOR==0
.EDIT=^D305
.WHO=0 ;SM
COMMENT +
# who date Edit description, decreasing order
--- --- --------- ---------------------------------------------------
302 SM 24-Jul-85 Twofold bug in TRIM. FB%NOD should not be checked, as
it cannot prevent Migration, and make sure a file with
AR%NAR can be migrated if needed
301 SM 15-May-85 Have TAKE try connected directory first, then SYSTEM:
if it can't find the file.
300 SM 23-Jan-85 Add POLICY command, since TAKE<CR> no longer
takes SYSTEM:REAPER.CMD automatically. Fix
version number.
200 SM 14-Nov-84 Clean up code, fix SKIP to handle non-existant
directories, catch ill. inst. problems.
+
SUBTTL Definitions
; AC def's
F==0 ;FLAGS (F.????)
T1==1 ;THE USUAL SCRAP
T2==2
T3==3
T4==4
Q1==5
Q2==6
Q3==7
P1==10
P2==11
P3==12
P4==13
DIRPGS==14
ITMSTK==16 ;FOR DIRECTORY INFORMATION
P=17 ;STACK POINTER
; flags in AC F
F.PRIV==1B0 ;WHEEL
F.TRIM==1B1 ;TRIMMING OVER-ALLOCATION DIRECTORIES
F.TAPE==1B2 ;CHECK TAPES IN USE
F.FLSH==1B3 ;FLUSH OFFLINE FILES OLDER THAN (PERIOD)
F.PURG==1B5 ;PURGE EXPIRED FDBS
F.INVL==1B6 ;REQUIRE MIGRATION OF OLD FILES
F.SCAN==1B7 ;SCAN ONLY
F.NDIR==1B8 ;NEW DIRECTORY
F.TRES==1B9 ;TAKE RESISTED FILES
F.ORDR==1B11 ;HAVE A SYSTEM ORDER LIST
F.USOD==1B12 ;HAVE A USER ORDER LIST
F.CMMA==1B18 ;COMMA FOR OUTPUT FLAG
F.PEND==1B19 ;ARCHIVE PENDING ON THIS FILE
F.TMP==1B20 ;FOR TEMPORARY THINGS
F.GOTN==1B21
LS.TTY==1B0 ;FLAGS IN LSTFLG
LS.LST==1B1
;Useful symbols
FTONEX==0 ;-1 FOR ONLINE EXP. CODE
PERWRN==^D14 ;2 WEEKS WARNING
JFNSAL=1B2+1B5+1B8+1B11+1B14+JS%PAF+JS%TMP ;JFNS%, do all fields
JFNSNE=1B8+1B11+1B14+JS%PAF+JS%TMP ;JFNS%, name, ext, gen
JFNSNX=1B8+1B11+JS%PAF+JS%TMP ;JFNS%, name, ext
NFILMX==^D8000
;**; [303] At NFILMX+1, add 1 line SM 3-Jan-86
MSGSIZ=12000 ;[303] LOTS OF SPACE FOR MESSAGES
NTAPES==500
NDIRS==400
NJFNS==150
TAKLEN==10
TMPLEN==100
PAGLIN=56
BFRSIZ==1300 ;PARSE BUFFER SIZE (LARGE FOR LONG SKIP CMDS)
ATMSIZ==70 ;ATOM BUFFER SIZE
BFRLEN=BFRSIZ*5-1 ;CHARS ALLOWED IN CMD BUFFER
ATMLEN=ATMSIZ*5-1 ;CHARS ALLOWED IN ATOM BUFFER
PAGSIZ=1000 ;For DDT, mostly
PTAP==0 ;FOR THE TAPE STORE ROUTINES
TNAM==1
TCNT==2
IFNDEF VI%DEC,<VI%DEC==0>
;words for variables
%WRDAT==70000 ;Start of word assignments
;Allocate word macro
DEFINE W$(name,num<1>),<
name=%WRDAT
%WRDAT==%WRDAT+num>
W$ STACK,250
W$ DONEFL,NFILMX
W$ MSGPTR
;**; [303] At W$ MSGSPC, change number to symbol SM 3-Jan-86
W$ MSGSPC,MSGSIZ
W$ DIRCNT
W$ DIRPTR
;**; [302] At W$ DIRPTR+1 Add 1 line SM 20-Dec-85
W$ SKPCNT ;[302] for count of skippables
W$ FILPTR
W$ DIRS,NDIRS+1
W$ JFNSTP
W$ JFNPTR
W$ JFNLST,NJFNS+1
W$ RPSSTK
W$ RPSSTR,400
W$ PEOCNT
W$ COLTMP
W$ TMP
W$ INTTMP,2
W$ AGEIS
W$ LSTFLG
W$ FLGTMP
W$ STKSAV
W$ LSTTMP
W$ IFCTMP
W$ INPTMP
W$ TAKSTK
W$ TAKSTR,TAKLEN+1
W$ OUTMST
W$ OUTMSX
W$ TABTMP,6
W$ STRING,TMPLEN
W$ TEMP2,100
W$ DEFDEV,20
W$ DEFDIR,15
W$ DEFNAM,15
W$ DEFEXT,15
W$ DIRWLD,15
W$ FILPTH,50
W$ GOTNAM,50
W$ FDB,.FBLEN
W$ TAPBLK,.ARPSZ+1
W$ FINDSP
W$ LOCJFN
W$ ARCJFN
W$ MAILFL
W$ MLBLK,3
W$ LSTIS,25
W$ ATOM,ATMSIZ
W$ BFFR,BFRSIZ
;Things that get zeroed at start time
W$ CLRDAT,0
W$ CURDIR
W$ TODAY
W$ PERIOD
W$ LVPC3
W$ PREHIT
W$ EXPHIT
W$ LSTJFN
W$ CURCMD
W$ LSTLIN
W$ LSTPOS
W$ LSTPGN
;Keep the following in order
W$ NFILES
W$ TOTPGS
W$ NFLFIL
W$ FLPGS
W$ NTMFIL
W$ TMPGS
W$ NPURGE
W$ ZERO
;things above here get zero'd at start time
W$ CLREND
W$ TAPCNT,NTAPES*3
;Writables
GUIINB: <.CMNOI>B8
BLOCK 1
LISINB: <.CMOFI>B8+CM%SDH+CM%HPP+CM%DPP
0
-1,,[ASCIZ/LIST file specification/]
0 ;filled in at runtime
CMDBLK: 0,,TRAPRP
.PRIIN,,.PRIOU ;< FOR BALANCE
-1,,[ASCIZ/REAPER>/]
-1,,BFFR
-1,,BFFR
BFRLEN
BFRLEN
-1,,ATOM
ATMLEN
GTJBLK
GTJBLK: BLOCK 16
;TYPE addr types the string at that address. Literals are acceptable.
DEFINE TYPE(locstr),<
CALL [PUSH P,T1
HRROI T1,locstr
JRST OUTMSA] >
;TYPCHR "chr" types the character out.
DEFINE TYPCHR(chr),<
CALL [PUSH P,T1
MOVEI T1,<chr>
JRST OUTMSC] >
;TYPEAT addr is just like TYPE, but the addr contains a byte pointer to
; the text
DEFINE TYPEAT(locptr),<
CALL [PUSH P,T1
MOVE T1,locptr
JRST OUTMSG] >
;SELECT sets the output flags as listed, return flagword in the AC
DEFINE SELECT(flags,ac<T1>),<
MOVX ac,flags
MOVEM ac,LSTFLG >
;JSERRD for jsys errors that just shouldn't happen
DEFINE JSERRD(text, where<BAKOUT>, entri<ERJMP>),<
entri [CALL ANNERR ;;ANNOUNCE COMMAND IF TAKING
HRROI T1,[ASCIZ\?text\]
CALL LSTERR ;;REPORT WHAT ERROR WAS
JRST where] > ;;GO WHEREVER REQUESTED
;ERROR for general errors that just shouldn't happen.
DEFINE ERROR(text, where<BAKOUT>),<
JRST [CALL ANNERR
TYPE [ASCIZ\?text\]
JRST where] >
;WARN types a message with the approprate leadin character.
DEFINE WARN(locstr),<
CALL [CALL IFCRLF
TYPE [ASCIZ ~%'locstr~]
RET] >
;Command table macro
DEFINE CTB (addr,txt,fla<0>),<
IF1, < %%C==0>
IF2, < IFDEF addr, < %%C=addr>
IFNDEF addr, < %%C=NOCMD
PRINTX ?txt not in
>
>
XWD [ IFN fla,<EXP CM%FW!fla>
ASCIZ \txt\],%%C
>
;GUIDES does the GUIDE call and dispatches to NOCMD if it fails. Don't
; call this in a literal.
DEFINE GUIDES(text,whr<NOCMD>),<
JRST [HRROI T1,[ASCIZ ~text~]
CALL GUIDE
JRST whr
JRST .+1] >
;CONFIRM does a confirm. Dispatches to NOCMD on error, hurts no AC's.
DEFINE CONFIRM(whr<NOCMD>),<
CALL CONFRM
JRST whr >
SUBTTL Startup and Branching code
ENTVEC: JRST START
JRST START
BYTE (3).WHO (9).MAJOR (6).MINOR (18) <VI%DEC+.EDIT> ;VERSION
START: MOVEI P,STACK-1 ;SET STACK UP
MOVX T1,LS.TTY
MOVEM T1,LSTFLG ;OUTPUT TO TTY: ONLY FOR NOW
RESET% ;CLEAR THE UNIVERSE
SETZB F,CLRDAT ;AND THE FLAGS
MOVE T1,[CLRDAT,,CLRDAT+1]
BLT T1,CLREND
SETZM DIRS ;NO DIRECTORIES STORED YET
SETZM JFNLST ;NO JFNS EITHER
MOVSI T1,-NDIRS
MOVEM T1,DIRPTR
MOVE T1,[-NJFNS,,JFNLST]
MOVEM T1,JFNPTR
MOVEI T1,TAKSTR
MOVEM T1,TAKSTK ;SET UP TAKE STACK
MOVEI T1,.FHSLF ;Set up interrupts
MOVE T2,[LEVTAB,,CHNTAB]
SIR% ;DECLARE INTERRUPT TABLES
EIR%
MOVE T2,CHNMSK ;TURN ON THE CHANNELS
AIC% ;ACTIVATE CHANNELS
MOVE T1,[.TICCA,,CFCHN]
ATI% ;SETUP ^A
MOVX T1,.FHSLF
RPCAP%
TXNN T3,SC%WHL+SC%OPR ;WHEEL OR OPR PRIVS ON?
TXOA F,F.SCAN ;NO, ONLY SCANNING BY DEFAULT
TXOA F,F.PRIV ;YES, PRIVS!
JRST PEON ;NO, PEON TIME
HRROI T1,[ASCIZ/REAPER>/] ;INSURE NONPEON PROMPT
MOVEM T1,CMDBLK+.CMRTY
;Here after cleaning up after a bad error.
PANIC: MOVEI P,STACK-1 ;GET A CLEAN STACK
CALL GCMD ;DO A COMMAND
JRST .-1 ;DO ANOTHER COMMAND
GCMD: SETZM CURCMD ;NO COMMAND IN PROGRESS
GCMDP: DMOVE T1,[EXP CMDBLK,INIINB] ;DO THE COMMAND INIT
CALL PARSE ;PROMPT
JFCL ;SNH
MOVEM F,FLGTMP
MOVEM P,STKSAV ;SAVE STACK IN CASE REPARSE
MOVEI T1,RPSSTR
MOVEM T1,RPSSTK ;SAY NO REPARSE OPS NEED DOING YET
RPRS: TXNN F,F.PRIV ;PEON?
JRST [CALL WHERE ;YES, WHERE IS INPUT FROM?
JRST .+1 ;FROM FILE, FINE
JRST PENPAR] ;FROM TERMINAL, DO PEON PARSE
DMOVE T1,[EXP CMDBLK,CMDINB]
CALL PARSE ;PARSE A COMMAND
JRST UKCERR ;UNKNOWN COMMAND
MOVEM T2,CURCMD ;STORE THE COMMAND INFO
HRRZ T1,(T2)
JRST (T1)
;Routine should RET (if all OK), BAKOUT (if failing or ABORTed),
; or NOCMD (if the parse didn't work alright).
UKCERR: CALL ANNERR ;SOME SORT OF ERROR COMING UP
TYPE [ASCIZ/?Not a defined command/]
NOCMD: CALL UNDO ;GET THINGS LEFT BY PARSING
CALL WHERE ;IF INPUT FROM PRIMARY..
CALL UNTAKE ;DON'T UNDO TAKE FILES ON HIM
MOVE F,FLGTMP
JRST GCMDP
;Here if ^U or rubout
TRAPRP: CALL UNDO ;UNDO THE EFFECTS OF THE PARTIAL PARSE
GRPRS: MOVE F,FLGTMP ;RECOVER FLAGS BEFORE PARSE
MOVE P,STKSAV ;RESTORE THE STACK
JRST RPRS ;AND GO REPARSE
;Here if a command fails midstream or gets an ABORT.
BAKOUT: CALL WHERE ;IF INPUT FROM PRIMARY, DON'T HURT TAKES
CALL UNTAKE ;TOSS ANY COMMAND FILES
CALL UNDO ;GET ANYTHING LEFT BY PARSING
JRST PANIC ;AND SET UP ANEW
;Peon code, done if not an enables wheel at startup time. This forces a take
; on SYSTEM:REAPER.CMD if available, then forces the commands hardcoded in at
; PARTAB.
PEON: MOVX T1,GJ%SHT+GJ%OLD
HRROI T2,[ASCIZ/SYSTEM:REAPER.CMD/]
GTJFN%
JSERRD <Policy file not available>,DIENOW
TYPE [ASCIZ/ REAPER, reading policy file...
/]
CALL TAKE1 ;IF IT'S THERE, TAKE IT
PEON1: CALL GCMD
JRST PEON1 ;RUN UNTIL PAREOF GETS AN EOF
PEON2: TYPE CRLF ;PAREOF BRANCHES HERE FOR PEONS
SETOM PEOCNT ;SET UP FOR LIST OF IN-YOUR-BEHALF COMMANDS
PEOSET: AOS T3,PEOCNT ;GET OPERATION INDEX
SKIPN T3,PARTAB(T3) ;ANY SUCH OPERATION?
JRST DIENOW ;NO, DONE
HLRO T1,T3 ;GET THE PROMPT
MOVEM T1,CMDBLK+.CMRTY ;SET UP PROMPT
JRST GCMD ;STEAL INIT CODE AT GCMD FOR THIS
PENPAR: MOVE T3,PEOCNT ;GCMD BRANCHES HERE FOR US. GET INDEX
HRRZ T1,PARTAB(T3) ;DETERMINE WHERE TO ENTER ROUTINE
CALL (T1) ;ENTER IT
JRST PEOSET ;DONE. GO GET NEXT COMMAND
PARTAB: [ASCIZ/ Output to: /],,LIST1
[ASCIZ/ Check files: /],,ARCH1
0
SUBTTL Interrupt stuff
CFINT: SKIPN CURDIR ; Processing a BEGIN command?
DEBRK%
DMOVEM T1,INTTMP
MOVEI T1,.PRIOU
DOBE%
RFPOS%
HRROI T1,CRLF
TRNE T2,-1
PSOUT%
CFINT2: HRROI T1,[ASCIZ/ Working on /]
PSOUT%
MOVX T1,.PRIOU
MOVE T2,CURDIR
DIRST%
ERJMP .+1 ;DOESN'T FAIL
HRROI T1,CRLF
PSOUT%
DMOVE T1,INTTMP
DEBRK%
LEVTAB: BLOCK 2
LVPC3
CFCHN==1
CHNTAB: 0 ;0 Free
3,,CFINT ;1 ^A
0 ;2-5 free
0
0
0
0 ;6 Arith overflow
0 ;7 Float overflow
0 ;8 Reserved
0 ;9 PDL overflow
0 ;10 EOF
0 ;11 File Data error .ICDAE
0 ;12 Disk full
0 ;13 Reserved
0 ;14 Reserved
0 ;15 Ill Inst
0 ;16 Ill mem read
0 ;17 Ill mem write
0 ;18 Reserved
0 ;19 Inferior stopped
0 ;20 Sys res exhausted
0 ;21 Reserved
0 ;22 Non existant page
BLOCK ^D35-^D23+1 ;23 Free, 23-35
CHNMSK: 1B<CFCHN>
SUBTTL Quick commands
.FLUSH: GUIDES <Of old offline files>
MOVX T1,F.FLSH
JRST ONFLAG
.INVOL: GUIDES <Old files to offline storage>
MOVX T1,F.INVL
JRST ONFLAG
.TAPE: GUIDES <Check of tapes in use>
MOVX T1,F.TAPE
JRST ONFLAG
.TRIM: GUIDES <Directories over allocation>
MOVX T1,F.TRIM
JRST ONFLAG
.PURGE: GUIDES <Expired FDBs from disk>
MOVX T1,F.PURG
JRST ONFLAG
.REAPE: GUIDES <Everything possible>
MOVX T1,F.PURG!F.TRIM!F.INVL!F.FLSH
JRST ONFLAG
.SCAN: GUIDES <Only>
MOVX T1,F.SCAN
ONFLAG: CONFIRM
IOR F,T1
RET
.PERIO: GUIDES <For migration>
DMOVE T1,[EXP CMDBLK,PERINB]
CALL PARSE
ERROR <Bad Period>
GUIDES <Days>
CONFIRM
CAIGE T2,0
WARN <Negative PERIOD values are usually meaningless>
MOVEM T2,PERIOD
RET
.EXIT: GUIDES <To Monitor>
CONFIRM
HLLZ T1,TAKSTK
CAIE T1,0
WARN <EXIT command encountered in TAKE file>
HALTF%
RET
.SKIP: GUIDES <Directories>
MOVE ITMSTK,DIRPTR
SKIP1: DMOVE T1,[EXP CMDBLK,SKPINB]
CALL PARSE
JRST [HLLZ T1,TAKSTK ;IN A TAKE FILE?
CAIN T1,0 ;NONZERO IF YES
ERROR <Bad directory name in SKIP list> ;NO, DIE
WARN <Bad directory name "> ;YES, LET'S TRY TO IGNORE IT
MOVEI T1,[EXP ",", 0]
CALL SKIPTR ;SKIP UNTIL COMMA
TYPE ATOM ;SKIPTR LEAVES SKIPPED TEXT HERE
TYPE [ASCIZ/" ignored/]
JUMPE T3,SKIP2 ;THIS WOULD IMPLY CONFIRMED
JRST SKIP1] ;OTHERWISE, HIT A COMMA, GO ON
MOVE T3,T2
SKIP3: MOVEM T3,DIRS(ITMSTK) ; Save #
AOBJP ITMSTK,[WARN <SKIP space full>
JRST SKIP2]
MOVX T1,RC%STP+RC%AWL
HRROI T2,ATOM
RCDIR%
ERJMP SKIP4
TXNN T1,RC%NOM+RC%AMB+RC%NMD
JRST SKIP3
SKIP4: DMOVE T1,[EXP CMDBLK,CMCINB]
CALL PARSE
ERROR <Bad syntax in SKIP command>
CAIE T3,.CMCFM ;Confirm?
JRST SKIP1
SKIP2: SETZM DIRS(ITMSTK)
MOVEM ITMSTK,DIRPTR
;**; [302] At SKIP2:+2L Add 1 line SM 20-Dec-85
HRLZM ITMSTK,SKPCNT ; [302] Save count in LH of SKPCNT
RET
.ORDER: GUIDES <For trimming>
MOVE ITMSTK,JFNPTR ; Free space
ORDER1: SETO T1, ; Parse only pls
CALL GETFIL
ERROR <Bad filespec in ORDER list>
MOVEM T2,(ITMSTK) ; Save JFN
CALL RPSJFN
AOBJP ITMSTK,[
WARN <ORDER space is full>
JRST ORDER2]
DMOVE T1,[EXP CMDBLK, CMCINB]
CALL PARSE
ERROR <Bad syntax in ORDER command> ; Garbage
CAIE T3,.CMCFM
JRST ORDER1
ORDER2: SETZM (ITMSTK)
MOVEM ITMSTK,JFNPTR ; Cover stack
TXO F,F.ORDR ;SYSTEM ORDER LIST IN
RET
.LIST: GUIDES <Output to file>
HRROI T1,[ASCIZ/REAPER.LIST/]
TXNN F,F.PRIV
LIST1: HRROI T1,[ASCIZ/TTY:/]
MOVEM T1,LISINB+.CMDEF
DMOVE T1,[EXP CMDBLK,LISINB]
CALL PARSE
ERROR <Bad filespec in LIST Command>
CALL RPSJFN
CONFIRM
HRRZ T1,T2
MOVX T2,<FLD(7,OF%BSZ)+OF%WR>
OPENF%
JSERRD <Can't open LIST file>
EXCH T1,LSTJFN
CAIE T1,0
CLOSF%
JFCL
RET
SUBTTL BEGIN command
.ARCHI: TXNN F,F.PRIV ; Allowed?
RET ; Not really, just ignore the command
GUIDES <Processing files>
SETZ T1, ; Real JFNs
ARCH1: CALL GETFIL ; Get a file spec
ERROR <Bad file specification>
CONFIRM
MOVEM T2,ARCJFN ; Path to check
GTAD%
HLRZM T1,TODAY
SETZM DIRCNT
TXNE F,F.PRIV
TXNE F,F.TRIM
JRST NOPERW
SKIPN PERIOD
WARN <No period specified, continuing...>
; Get a directory number so we can step with RCDIR
NOPERW: HRROI T1,DIRWLD ; Area for string with wildcards
MOVX T3,<FLD(.JSAOF,JS%DEV)+FLD(.JSAOF,JS%DIR)+JS%PAF>
JFNS% ; Get STR:<DIR>
MOVX T1,RC%AWL ; Allow wildcards
HRROI T2,DIRWLD ; Point to directory string
SETZ T3, ; No previous dir #
RCDIR% ; Get a dir #
TXNE T1,RC%NOM ; No match???
ERROR <Failed to translate string to directory number>
MOVEM T3,CURDIR ; Save the result
HRROI T1,FILPTH ; Area for complete filespec
MOVE T2,ARCJFN
MOVX T3,JFNSAL
JFNS%
; Set up default strings for name and extension
HRROI T1,DEFNAM ; Area for name string
MOVX T3,<FLD(.JSAOF,JS%NAM)>
JFNS% ; Get the name specified
HRROI T1,DEFEXT ; Area for extension string
MOVX T3,<FLD(.JSAOF,JS%TYP)>
JFNS% ; Get the extension
MOVE T1,T2 ; JFN to T1
RLJFN% ; No longer need this
JFCL
CALL MLINIT ; Init stuff for sending mail
; Put in the listing file to describe what we were told to do
SKIPN T1,LSTJFN ; Have a listing file?
JRST [ MOVX T1,GJ%FOU+GJ%SHT
HRROI T2,[ASCIZ /REAPER.LIST/]
GTJFN%
JSERRD <Can't create list file>
MOVE T2,T1
CALL RPSJFN
HRRZ T1,T2
MOVX T2,<FLD(7,OF%BSZ)+OF%WR>
OPENF%
JSERRD <Can't create list file>
MOVEM T1,LSTJFN ; Save it
JRST .+1]
SELECT LS.LST
TYPE [ASCIZ /
REAPER run started at /]
CALL TADOUT
TYPE CRLF2
TYPE [ASCIZ / Specified file path: /]
TYPE FILPTH
TXNN F,F.PRIV
JRST [TYPE [ASCIZ /
The following would happen if the OPERATOR ran REAPER now:
/]
JRST STAT9]
TYPE CRLF
SKIPN T2,PERIOD ; Any period given to us?
JRST STAT0 ; No
TYPE [ASCIZ / Period is: /]
CALL DECOUT
TYPE [ASCIZ / days
/]
STAT0: TXNE F,F.SCAN
TYPE [ASCIZ / SCAN ONLY
/]
TXNE F,F.FLSH
TYPE [ASCIZ / Deleting disk contents of old offline files
/]
TXNE F,F.PURG
TYPE [ASCIZ / Purging expired offline files
/]
TXNN F,F.TRIM ; Triming directories?
JRST STAT1 ; No, skip that
TYPE [ASCIZ / Trimming directories over permanent allocation
Order during TRIM for taking files is: /]
TXNN F,F.ORDR
JRST [TYPE [ASCIZ/Not specified
/]
JRST STAT1]
MOVE ITMSTK,[-NJFNS,,JFNLST] ;Where things needing printing live
MOVEI T4,TYJFNF ;Routine to call to output an element
MOVX T3,JFNSNX
CALL PRTORD ; Print it
STAT1: TYPE [ASCIZ / Skipping directories: /]
SKIPN DIRS ; Any spec'd?
JRST [ TYPE [ASCIZ / None specified
/]
JRST STAT9]
MOVE ITMSTK,[-NDIRS,,DIRS]
MOVEI T4,TYDIRS
CALL PRTORD ; Listing is started, now start processing
STAT9: TXZ F,F.NDIR ; New directory
DODIR: CALL CHKDIR ; Make sure of good directory
JRST ENDARC ; That's the last of them
SETZ DIRPGS, ; No pages collected yet
SETO T1,
CALL SETGTD ; Set up the block
MOVE T1,[.NULIO,,.NULIO]
MOVEM T1,GTJBLK+.GJSRC
HRROI T1,STRING ; Scratch area
MOVE T2,CURDIR ; Dir we are working on
DIRST% ; Get the string
JSERRD <DIRST failure>
MOVE T1,[POINT 7,STRING]
MOVE T2,[POINT 7,DEFDEV] ; Make structure name
MOVEM T2,GTJBLK+.GJDEV
DODIR1: ILDB T3,T1
CAIN T3,":"
SETZ T3,
IDPB T3,T2
JUMPN T3,DODIR1
DODIR2: IBP T1 ; Flush "<"
MOVE T2,[POINT 7,DEFDIR] ; Make directory name
MOVEM T2,GTJBLK+.GJDIR
DODIR3: ILDB T3,T1
CAIN T3,">"
SETZ T3,
IDPB T3,T2
JUMPN T3,DODIR3
TXNE F,F.TRIM ;GOING TO TRIM BACK THE DIRECTORY?
CALL GETORD ;YES, GET ANY USER ORDER
HRROI T1,DEFNAM
MOVEM T1,GTJBLK+.GJNAM
HRROI T1,DEFEXT
MOVEM T1,GTJBLK+.GJEXT
DOFIL: SETZM FILPTR ; Reset count of entries in DONEFL
CALL DOKEEP ; Touch files WE want around
CALL DOPERI ; Migrate old files
CALL DOFLSH ; Delete contents of old archive files
CALL DOMISC ; Delete old temp files, etc.
CALL DOTRIM ; Trim directory back to quota
CALL DOTAPE ; Check tapes reference by this directory
AOS T1,DIRCNT
TRNE T1,17 ;CHECKPOINT EVERY 16 DIRECTORIES
JRST NXTDIR ;NOT YET
MOVE T1,LSTJFN
TXO T1,CO%NRJ
CLOSF% ;CLOSE LISTING FILE, BUT KEEP JFN
ERJMP .+2
CALL OPNLST
JRST [SELECT LS.TTY
WARN <List file didn't reopen>
JRST NXTDIR]
NXTDIR: CALL INCDIR
JRST ENDARC
JRST DODIR ; Loop
INCDIR: MOVX T1,RC%STP+RC%AWL ; Gotta go to next directory
HRROI T2,DIRWLD ; Point to wildcard string
MOVE T3,CURDIR ; Current dir #
RCDIR% ; Find next one
ERJMP CPOPJ
TXNE T1,RC%NMD ; No more dirs?
RET
MOVEM T3,CURDIR ; Remember new dir #
TXZ F,F.NDIR ; New directory
MOVE ITMSTK,JFNPTR
CALL RLJFNS ; Release any user ORDER JFNs
JRST CPOPJ1
; Check CURDIR to see if SKIPping this directory; if so, advance
; to one we aren't SKIPping
CHKDIR: SKIPN DIRS ; Skipping anything?
JRST CPOPJ1
MOVE T3,CURDIR ; Get current dir #
;**; [302] At CHKDIR:+3L Replace 1 line SM 20-Dec-85
MOVN T1,SKPCNT ;[302] Get -count,,0 of skippable directories
CHKDI1: CAME T3,DIRS(T1) ; Skip this guy?
AOBJN T1,CHKDI1 ; Loop
JUMPGE T1,CPOPJ1 ; Done, no match
CHKDI2: CALL INCDIR ; To next directory
RET ; No next
JRST CHKDIR ; Check this one too
ENDARC: TYPE CRLF2
SETZ Q2,
LSTTTL: HLRZ Q1,LSTTAB(Q2)
JUMPE Q1,ENDAR1
MOVE T2,(Q1)
TYPCHR " "
CALL DESOUT
HRRO T1,LSTTAB(Q2)
TYPEAT T1
MOVEI T2,^D40
CALL TABOUT
MOVE T2,1(Q1)
CALL DESOUT
TYPE [ASCIZ/ pages
/]
AOJA Q2,LSTTTL
ENDAR1: SKIPE EXPHIT ; Did any tapes get noted?
CALL DMPTAP ; Yes, dump out the info now
ENDAR2: MOVE T1,LSTJFN
CLOSF% ; Close the listing file
JFCL
SETZM LSTJFN ; No longer valid
CALL MLDONE ; Clean up mail stuff
MOVE ITMSTK,[-NJFNS,,JFNLST]
CALL RLJFNS
DIENOW: HALTF%
JRST START
DMPTAP: SETOM LSTLIN ; Start a new page
TYPE [ASCIZ/
Tape ID Count Tape ID Count Tape ID Count
/]
SETZM COLTMP ;Start in column 1, please
MOVEI T3,TAPCNT ; Beginning of the tree
CHASE: PUSH P,T1
CHASE1: MOVE T1,T3
HRRZ T3,PTAP(T3)
CAIE T3,0
CALL CHASE
CALL DOOP ;Do for each element in the tree
MOVE T3,T1
HLRZ T3,PTAP(T3)
CAIE T3,0
JRST CHASE1 ;TAIL RECURSION, JUST LIKE CALL CHASE
POP P,T1
RET
DOOP: PUSH P,T1
MOVE T2,TNAM(T1)
TLNE T2,-1 ;SIXBIT OT NUMERIC?
JRST [MOVE T3,T2
CALL SIXOUT
JRST DOOP1]
MOVE T3,[NO%OOV+NO%MAG+NO%LFL+7B17+^D10]
CALL NUMOUT
DOOP1: MOVE T2,COLTMP
MOVE T2,[DEC 10,34,58](T2)
CALL TABOUT ;..
MOVE T1,(P) ;POINTER TO BLOCK CONTAINING INFO
MOVE T2,TCNT(T1) ;GET THE COUNT
CALL DESOUT ;OUTPUT
AOS T2,COLTMP
SKIPN T2,[DEC 24,48,0]-1(T2)
JRST [SETZM COLTMP ;YES
TYPE CRLF
JRST DOOP2]
CALL TABOUT
DOOP2: POP P,T1 ;RESTORE T1
RET
;LH address of a pair of words, the first is typed before the RH text, the
; 2nd after it.
LSTTAB: NFILES,,[ASCIZ / files marked for migration/]
NFLFIL,,[ASCIZ / archive files deleted from disk/]
NTMFIL,,[ASCIZ / temporary files deleted/]
NPURGE,,[ASCIZ / expired files purged/]
0
; Period checker
DOPERI: TXNN F,F.INVL ; Switch for this turned on?
RET ; No
MOVX T1,GJ%IFG+GJ%XTN+.GJALL
MOVEM T1,GTJBLK+.GJGEN ; Fix up GTJFN bits
MOVEI T1,GTJBLK
SETZ T2, ; As if the user took default
GTJFN%
RET ; Done, none here
MOVEM T1,LOCJFN ; Save the JFN
DOPER1: CALL GTFDBF ;GET FDB INFORMATION
MOVE T1,FDB+.FBCTL
TXNE T1,FB%ARC!FB%OFF!FB%DIR!FB%NOD!FB%TMP!FB%PRM
JRST DOPER9 ; Go to next file
MOVE T1,FDB+.FBBBT
TXNE T1,AR%RAR!AR%RIV!AR%NAR!AR%EXM ; If requested or resist, skip it
JRST DOPER9
CALL HAVTAP ; See if we have tape ID's already
JRST DOPER9 ; We do, don't migrate the file again
; Check to see if online expiration has occured
IFN FTONEX,<
SKIPN T2,FDB+.FBNET ; Have on online expiration?
JRST DOPER3 ; No, file can't expire then
HLRZS T2 ; Want date portion of online exp
CAML T2,TODAY
JRST DOPER3 ; No (& does have exp. date)
JUMPN T2,DOPER5 ; Expired date if non-zero--take it
MOVE T1,FDB+.FBCRE ; Interval, find most recent date
CAMG T1,FDB+.FBCRV
MOVE T1,FDB+.FBCRV
CAMG T1,FDB+.FBWRT
MOVE T1,FDB+.FBWRT
CAMG T1,FDB+.FBREF
MOVE T1,FDB+.FBREF
HRRZ T2,FDB+.FBNET ; Get the interval
HLRZS T1
ADD T2,T1 ; Form expiration date
CAML T2,TODAY
JRST DOPER3 ; No, check for age
DOPER5: SETO T2, ; Flag file is expired
JRST DOPER2
> ; End IFN FTONEX
; Now check for too old a file
DOPER3: SKIPG PERIOD ; Have a real period?
JRST DOPER9 ; No, skip this then
CALL GTAGE ; Get age of file
CAMGE T2,PERIOD ; Old enough?
JRST DOPER9 ; No, skip it
DOPER2: CALL CKDNFL ; Has this one been done before?
JRST DOPER9 ; Yes, skip it this time
MOVEM T2,AGEIS
HRRZ T1,LOCJFN
MOVEI T2,.ARRIV ; Request file be migrated
MOVEI T3,.ARSET
TXNN F,F.SCAN ; Only a scan?
ARCF% ; No, real thing
ERJMP [HRROI T2,[ASCIZ / ARCF failed/]
CALL LSTFIL
JRST DOPER9]
HRRZ T1,FDB+.FBBYV
ADD DIRPGS,T1 ; Accum what we've taken
ADDM T1,TOTPGS ; Into running total
AOS NFILES ; Count files
HRROI T2,STRING
MOVE T1,AGEIS ;fetch age again
IFN FTONEX,<
JUMPL T1,[
HRROI T1,[ASCIZ /Online expiration reached/]
JRST DOPER4]
>; end IFN FTONEX
CALL NOUTB
HRROI T1,[ASCIZ / days old/]
DOPER4: CALL CSTR
HRROI T2,STRING
CALL LSTFIL ; Into listing
DOPER9: MOVE T1,LOCJFN
GNJFN%
JRST [ SETZM LOCJFN
RET]
JRST DOPER1
; Flush contents of OLD online files with tape backup
DOFLSH: TXNE F,F.FLSH
SKIPN PERIOD
RET
MOVX T1,GJ%IFG+GJ%XTN+.GJALL
MOVEM T1,GTJBLK+.GJGEN
MOVEI T1,GTJBLK
SETZ T2, ; Take default
GTJFN%
RET ; No files to do
MOVEM T1,LOCJFN ; Save the JFN
HRROI T1,[ASCIZ /Old file contents deleted from disk/]
MOVX T2,.MLOFL ; Use the offline msg file
CALL BEGUSR ; Start user message
DOFLS1: CALL GTFDBF
MOVE T1,FDB+.FBCTL
TXNE T1,FB%OFF ; Already off-line?
JRST DOFLS9 ; Yes, skip it
SKIPE TAPBLK+.ARTP1 ; First tape exist?
SKIPN TAPBLK+.ARTP2 ; AND 2nd? (HAVTAP is OR not AND)
JRST DOFLS9 ; Both tapes don't exist yet
CALL GTAGE ; Get its age
CAMGE T2,PERIOD ; Old enough?
JRST DOFLS9 ; No, skip the file
MOVEM T2,AGEIS ; Save the age
TXNE F,F.SCAN
JRST DOFLS2
MOVX T1,DF%CNO+DF%NRJ ; Disk contents only
HRR T1,LOCJFN
DELF% ; No, real thing
JRST [ HRROI T2,[ASCIZ / DELF failed/]
CALL LSTFIL
JRST DOFLS9]
DOFLS2: HRROI T1,[ASCIZ / - Disk contents deleted/]
CALL TOUSR ; Include in the message
AOS NFLFIL
HRRZ T1,FDB+.FBBYV ; Get # of pages
ADD DIRPGS,T1
ADDM T1,FLPGS ; To total
HRROI T1,[ASCIZ / Disk contents deleted, /]
HRROI T2,STRING
CALL CSTRB
MOVE T1,AGEIS
CALL NOUTB
HRROI T1,[ASCIZ / days old/]
CALL CSTR
HRROI T2,STRING
CALL LSTFIL
DOFLS9: MOVE T1,LOCJFN
GNJFN%
JRST [ SETZM LOCJFN ; Done JFN is garbage
JRST ENDUSR] ; End the message
JRST DOFLS1
; Here to touch various files that shouldn't get migrated...
DOKEEP: TXNE F,F.SCAN
RET ;SCANNING, IGNORE THIS
MOVX T1,GJ%OLD+GJ%XTN ; All files must exist
MOVEM T1,GTJBLK+.GJGEN
MOVX T1,G1%IIN
MOVEM T1,GTJBLK+.GJF2
HRROI T2,[ASCIZ /DIRECTORY.OWNER/]
CALL DOKEP1
HRROI T2,[ASCIZ /MAIL.TXT.1/]
CALL DOKEP1
HRROI T2,[ASCIZ /OFFLINE-FILE-MSGS.TXT/]
;JRST DOKEP1
DOKEP1: MOVE T1,[.NULIO,,.NULIO]
MOVEM T1,GTJBLK+.GJSRC
MOVEI T1,GTJBLK
GTJFN%
RET ; File doesn't exist
MOVEM T1,TMP ; Save the JFN
MOVE T2,[1,,.FBBBT] ;Get archival flags
MOVEI T3,T4 ;into T4
GTFDB%
TXNE T4,AR%EXM ;is it already migrate proof?
JRST DOKEP2 ;yes. It's safe. Go on.
MOVX T2,.AREXM ;Set prohibit migration
MOVX T3,.ARSET ; This disturbs the access date, but should
ARCF% ; only happen once.
ERJMP DOKEP2 ;shouldn't happen
DOKEP2: MOVE T1,TMP ;done, lose jfn
RLJFN%
JFCL
RET
; Trim directory back to size
DOTRIM: TXNN F,F.TRIM
RET ; We weren't told to do this
MOVX T1,GJ%IFG+GJ%XTN+.GJALL
MOVEM T1,GTJBLK+.GJGEN
MOVE T1,CURDIR ; Get current directory #
GTDAL%
SUB T2,T3 ; Pages they are over
SUB T2,DIRPGS ; And those already stolen
JUMPLE T2,CPOPJ ; Done if under allocation
TXON F,F.NDIR ; Need to print directory name?
CALL LSTDIR ; Yes, do that
MOVE DIRPGS,T2 ; Those required from user
TYPE [ASCIZ / Collecting /]
MOVE T2,DIRPGS
CALL DECOUT
TYPE [ASCIZ / pages
/]
MOVE ITMSTK,JFNSTP ; Get pointer to ORDER list
TXZ F,F.TRES ; Leave RESIST's (AR%NAR) if possible
DOTRI1: SKIPN T2,(ITMSTK) ; Anything?
JRST DOTRI2 ; No, go to next phase
CALL DOTRM ; Do the work
JRST DOTRIX ; Done
AOBJN ITMSTK,DOTRI1
DOTRI2: HRROI T2,[ASCIZ /*.*.*/]
CALL DOTRMS
JRST DOTRIX ; Done, enough collected
MOVE ITMSTK,JFNSTP ; Current ORDER list
TXO F,F.TRES ; Take RESIST's if necessary
DOTRI3: SKIPN T2,(ITMSTK) ; Any there?
JRST DOTRI4 ; No, done
CALL DOTRM
JRST DOTRIX ; Done, enough pages collected
AOBJN ITMSTK,DOTRI3
DOTRI4: HRROI T2,[ASCIZ /*.*.*/]
CALL DOTRMS
JRST DOTRIX ; Got all we needed
DOTRIX: JUMPLE DIRPGS,CPOPJ ; Leave
TXON F,F.NDIR ; Make sure we said what directory
CALL LSTDIR ; We didn't yet, do it now
TYPE [ASCIZ / Still over allocation by /]
MOVE T2,DIRPGS
CALL DECOUT
TYPE [ASCIZ / pages
/]
RET
; Do actual work; Expects T2 to have JFN of files to consider (ORDER)
DOTRM: HRROI T1,STRING
MOVX T3,<FLD(.JSAOF,JS%NAM)+FLD(.JSAOF,JS%TYP)+JS%PAF>
JFNS% ; Default name string
HRROI T2,STRING ; Point to default string
; Enter here with a string pointer in AC2 (also fallen into from DOTRM)
DOTRMS: MOVEI T1,GTJBLK ; Enter here with string
GTJFN%
JRST CPOPJ1 ; Done, none of correct flavor
MOVEM T1,LOCJFN ; Save the local JFN
DOTRM1: TXZ F,F.PEND ; No archive pending on this file
CALL GTFDBF ; Get FDB
TXNE F,F.TRES ; Interested in resisting files?
JRST DOTRM4 ; Yes - try to take it
MOVE T3,FDB+.FBBBT
TXNE T3,AR%NAR ; No. Is this a Resisting file?
JRST DOTRM9 ; Yes. Skip it this time
DOTRM4: CALL CKDNFL ; Check if file already done
JRST DOTRM9 ; Yes, don't do it again
MOVE T3,FDB+.FBBBT
TXNE T3,AR%RAR!AR%RIV ; Archive already pending?
JRST [ TXNE T3,AR%NDL ; Will we get any pages of it?
JRST DOTRM9 ; No, skip the file
TXO F,F.PEND ; Yes, flag archive already pending
JRST DOTRM8] ; And enter further down the line
MOVE T2,FDB+.FBCTL
TXNN T3,AR%EXM ; Not allowed to migrate it?
TXNE T2,FB%ARC!FB%OFF!FB%DIR!FB%TMP!FB%PRM
JRST DOTRM9 ; Skip it
CALL HAVTAP ; Already have tape backup?
JRST DOTRM9 ; Yes, skip the file
HRRZ T1,LOCJFN
MOVX T2,.ARRIV ; Migrate it
MOVEI T3,.ARSET
TXNN F,F.SCAN ; Only a scan?
ARCF% ; No, real
ERJMP [HRROI T2,[ASCIZ / ARCF failed/]
CALL LSTFIL
JRST DOTRM9]
DOTRM8: HRRZ T2,FDB+.FBBYV ; Get # of pages we got back
SUB DIRPGS,T2
TXNN F,F.PEND ; Actually mark it?
ADDM T2,TOTPGS ; Yes, add to total pages
AOS NFILES ; And count the files
MOVE T1,T2
HRROI T2,STRING
CALL NOUTB
HRROI T1,[ASCIZ / pages claimed/]
TXNE F,F.PEND ; Was archive already pending?
HRROI T1,[ASCIZ / migration already pending/]
CALL CSTR
HRROI T2,STRING
CALL LSTFIL ; Into listing
DOTRM9: JUMPLE DIRPGS,DOTRMD ; Done, end up things
MOVE T1,LOCJFN
GNJFN%
JRST CPOPJ1
JRST DOTRM1 ; Around for more
DOTRMD: HRRZ T1,LOCJFN
RLJFN%
JFCL
SETZM LOCJFN
RET ; Signal directory done
; Do miscellaneous operations -- delete old temp files,
; expunge FDBs which are past offline expiration.
DOMISC: TXNN F,F.PURG ;PURGING?
RET ;NO, NO MISC FUNCTIONS NEED DOING
MOVX T1,GJ%IFG+GJ%XTN+.GJALL
MOVEM T1,GTJBLK+.GJGEN
MOVEI T1,GTJBLK ; Get defaults
SETZ T2, ; Use them
GTJFN%
RET ; Nothing to do
MOVEM T1,LOCJFN ; Save local JFN
HRROI T1,[ASCIZ /Offline expired files/]
MOVX T2,.MLNFL ; Don't send to offline msg file
CALL BEGUSR ; Start a message
DOMSC1: CALL GTFDBF
MOVE T1,FDB+.FBCTL ; Get ctl bits
TXNE T1,FB%TMP ; Temp file?
JRST DOTMP ; Delete it if too old
JRST DOFET ; Yes, check offline expiration
DOADVA: MOVE T1,LOCJFN
GNJFN%
SETZM LOCJFN
ENDMSC: SKIPE LOCJFN
JRST DOMSC1
JRST ENDUSR ; Finish up and return
; Check offline file to see if it has reached offline expiration.
; If so, expunge it.
DOFET: TXNN F,F.PURG ; Purge expired FDBs?
JRST DOADVA ; No, done here
LDB T1,[POINT 7,FDB+.FBHDR,35]
CAIGE T1,.FBLXT ; Long enough?
JRST DOADVA ; No, skip this file
SKIPN FDB+.FBTP1 ; Have any tape info?
SKIPE FDB+.FBTP2
SKIPA T1,FDB+.FBFET
JRST DOADVA ; Has none, skip this file
TLNN T1,-1 ; Which is it?
JRST [ HRLZS T1 ; Make # days,,0
ADD T1,FDB+.FBTDT ; Date when will be expired
JRST .+1]
HLRZS T1
CAML T1,TODAY
JRST DOFET2
MOVE T1,FDB+.FBBBT
TXNN T1,AR%WRN ; User been warned about this?
JRST DOFET3 ; No, do so now
CALL JOJAR ; try to get (in T1) and advance jfn
MOVE T2,FDB+.FBCTL ;GET FLAGS ON THIS FILE
TXNN T2,FB%OFF ;OFFLINE?
JRST DOFETD ;YES. GO DISCARD TAPE BACKUP INFO
;**;[305] Change 1 line and add 5 at DOFET:+23L DEE 10-APR-87
TXNN F,F.SCAN ;[305] Just SCANning?
IFSKP. ;[305]
RLJFN% ;[305] Yes, release the JFN now
ERJMP .+1 ;[305]
JRST DOFETA ;[305] And don't DELF%
ENDIF. ;[305]
TXO T1,DF%EXP+DF%ARC
DELF%
JRST DELERR
DOFETA: AOS NPURGE
HRROI T2,[ASCIZ / Expunged, offline expiration reached/]
CALL LSTFIL
HRROI T1,[ASCIZ / - File deleted and expunged (expired)/]
CALL TOUSR
JRST ENDMSC
DOFET2: MOVE T3,FDB+.FBBBT
TXNE T3,AR%WRN ; Been warned?
JRST DOADVA ; Yes, don't do it again
SUBI T1,PERWRN ; Make it look later than it is
CAML T1,TODAY ; Now is it expired?
JRST DOADVA ; No, on to the next file
DOFET3: HRRZ T1,LOCJFN
HRLI T1,.FBBBT ; Set the warning flag
MOVX T2,AR%WRN
MOVE T3,T2
TXNN F,F.SCAN ; Don't if only a listing
CHFDB%
HRROI T1,[ASCIZ / - Offline expiration approaching/]
CALL TOUSR ; Put this in the msg
JRST DOADVA ; And go on
DOFETD: MOVX T2,.ARDIS ; Discard tape info
MOVX T3,AR%CR1+AR%CR2 ; Clear both sets of tape info
TXNN F,F.SCAN ; Don't if only a listing
ARCF%
ERJMP [HRROI T2,[ASCIZ/ ARCF discard failure/]
JRST OPERR]
HRROI T2,[ASCIZ / Tape backup information discarded/]
CALL LSTFIL
HRROI T1,[ASCIZ / - Tape backup information discarded (expired)/]
CALL TOUSR
MOVE T1,TMP
RLJFN% ; 2nd JFN no longer needed
JFCL
JRST ENDMSC
;JFN the file pointed to by LOCJFN, and advance LOCJFN. Returns GOTNAM
; containing the filename to operate on, T1/ jfn on that file, and
; F.GOTN on (for subsequent LSTFIL calls).
JOJAR: HRROI T1,GOTNAM
HRRZ T2,LOCJFN
MOVX T3,JFNSAL
JFNS%
;**;[304]Add 1 line at JOJAR:+4L DEE 10-APR-87
ERJMP OPERR ;[304] Some problem
TXO F,F.GOTN ;LSTFIL please use this name
MOVE T1,LOCJFN
GNJFN%
SETZM LOCJFN
MOVX T1,GJ%IFG+GJ%XTN+GJ%DEL
MOVEM T1,GTJBLK+.GJGEN
MOVEI T1,GTJBLK
HRROI T2,GOTNAM
GTJFN%
JSERRD <2nd JFN failure>,DIENOW
HRRZS T1
MOVEM T1,TMP
RET
;Release the JFN stored by JOJAR, and report a failed operation
DELERR: HRROI T2,[ASCIZ / DELF failed/]
OPERR: MOVE T1,TMP
RLJFN%
JFCL
CALL LSTFIL
JRST ENDMSC
BEGUSR: TXNE F,F.SCAN
RET ; Scan only, don't do message
MOVEM T2,MAILFL ; Save flag handed us
MOVEM T1,MLBLK+1 ; Remember the subject
CONUSR: MOVE T1,CURDIR ;[303] Add label
MOVEM T1,MLBLK+0 ; Save directory #
MOVE T1,[POINT 7,MSGSPC]
MOVEM T1,MSGPTR
MOVEM T1,MLBLK+2 ; Text field
RET ; All set up
ENDUSR: TXNE F,F.SCAN
RET ; Don't if scan only
MOVE T2,MSGPTR
CAMN T2,[POINT 7,MSGSPC] ; Have anything for the user?
RET ; No, don't bother sending then
EN2USR: HRROI T1,CRLF ;[303] Add label
CALL CSTR
MOVEI T1,MLBLK
MOVE T2,MAILFL ; Pick up flag type user wanted
JRST MLTOWN ; Mail to owner of the files
TOUSR: TXNE F,F.SCAN
RET ; Don't if scan only
PUSH P,T1 ; Save comment line
;**;[304] Add 2 lines and change 1 at TOUSR:+3L DEE 10-APR-87
SKIPN LOCJFN ;[304] No more files coming up?
SKIPA T2,TMP ;[304] Nope, use JFN from TMP for JFNS%
HRRZ T2,LOCJFN ;[304] Got more to come, use LOCJFN
MOVE T1,MSGPTR
MOVX T3,JFNSAL
JFNS%
;**;[304] Add 1 line at TOUSR:+9L DEE 10-APR-87
ERJMP OPERR ;[304] Some problem
MOVE T2,T1
POP P,T1 ; Comment line
TLNE T1,-1 ; Look like a string ptr?
CALL CSTRB
HRROI T1,CRLF
CALL CSTRB
MOVEM T2,MSGPTR
;**; [303] At DOTMP-4L, Replace 1 line with 5 SM 3-Jan-86
MOVEI T3,-MSGSPC(T2) ;[303] GET SIZE OF STRING
CAIGE T3,MSGSIZ-60 ;[303] GETTING NEAR THE END?
RET ;[303] NO, PLENTY ROOM, NOT TO WORRY
CALL EN2USR ;[303] FULL UP. DUMP WHAT WE HAVE..
JRST CONUSR ;[303] SET UP FOR MORE, AND THEN RETURN
; Delete temporary files PERIOD days old.
DOTMP: SKIPN PERIOD ; Period specified?
JRST DOADVA ; No, nothing to do
CALL GTAGE
CAMGE T2,PERIOD ; File old enough?
JRST DOADVA ; No, skip it
MOVEM T2,AGEIS
CALL JOJAR
;**;[305] Change 1 line and add 5 at DOTMP:+7L DEE 10-APR-87
TXNN F,F.SCAN ;[305]just scanning?
IFSKP. ;[305]
RLJFN% ;[305] Yup - better release the JFN now
ERJMP .+1 ;[305]
JRST DOTMP1 ;[305] And skip the DELF%
ENDIF. ;[305]
TXO T1,DF%EXP
DELF% ; No, do it for real
JRST DELERR
DOTMP1: HRRZ T1,FDB+.FBBYV ; Get pages claimed
ADD DIRPGS,T1 ; Accumulate dir total
ADDM T1,TOTPGS ; Account total pages in this directory
ADDM T1,TMPGS ; Accumulate temp file total
AOS NTMFIL ; Count temp files deleted
HRROI T2,STRING
MOVE T1,AGEIS
CALL NOUTB
HRROI T1,[ASCIZ / days old, deleted and expunged/]
CALL CSTR
HRROI T2,STRING
CALL LSTFIL
JRST ENDMSC
DOTAPE: TXNN F,F.TAPE
RET ;DON'T BOTHER IF NOT WANTED
MOVX T1,GJ%IFG+GJ%XTN+.GJALL
MOVEM T1,GTJBLK+.GJGEN
MOVEI T1,GTJBLK
SETZ T2,
GTJFN%
RET ; None to do
MOVEM T1,LOCJFN
DOTAP1: HRRZ T1,LOCJFN
MOVX T2,.ARGST
MOVEI T3,TAPBLK
ARCF% ; Get the tape info
ERJMP DOTAP2 ; Isn't any for that file
CALL STOTAP
DOTAP2: MOVE T1,LOCJFN
GNJFN%
RET ; All done
JRST DOTAP1
;Here with TAPBLK set up to store both tape names
STOTAP: SKIPE T2,TAPBLK+.ARTP1
CALL FIND
SKIPN T2,TAPBLK+.ARTP2
RET
;Here with tape name to match in T2. This routine is written to expect
; lots of calls with T2 alternating between FOO1 and FOO2 on entry. Ie,
; before it searches the tree, it checks to see if it is looking for
; what it was looking for 2 calls ago.
FIND: SKIPN PREHIT ;FIRST CALL?
JRST FFIND ;YES. GO SET UP AND ADD 1ST ENTRY.
SKIPN T1,EXPHIT ;MIGHT IT BE THE ONE WE EXPECT?
JRST FIND2 ;WE DON'T EXPECT ANYTHING, GO FIND PLACE
CAMN T2,TNAM(T1) ;MATCH EXPECTED ENTRY?
AOSA TCNT(T1) ;YES - UP THE COUNT AND GO HOME
JRST FIND2 ;NO, HAVE TO GO FIND OR ADD
RET
FFIND: MOVE T1,[-NTAPES,,TAPCNT] ;HERE TO ADD FIRST ENTRY. SET UP THE
MOVEM T1,FINDSP ;"LAST USED" POINTER, AND ADD ENTRY
JRST ADDIN2 ;..
NXTINT: SKIPA T1,T3 ;COPY POINTER
FIND2: MOVEI T1,TAPCNT ;HERE TO START AT THE BEGINNING
CAMN T2,TNAM(T1) ;MATCH THIS ENTRY?
JRST FOUND ;GOTCHA
HLRZ T3,PTAP(T1) ;NO, GUESS NAME IS GREATERTHAN
CAMG T2,TNAM(T1) ;IS IT?
HRRZ T3,PTAP(T1) ;NO, USE LESSTHAN POINTER
JUMPN T3,NXTINT ;ANYTHING THERE?
SKIPL T3,FINDSP ;NO - HAVE TO ADD AN ENTRY
RET ;LOSING ENTIRES, & ALREADY WARNED
ADD T3,[3,,3] ;SKIP OVER LAST ADDED
MOVEM T3,FINDSP ;YES, STORE FREESPACE POINTER BACK
JUMPG T3,[
WARN <Increase the size of NTAPES, entries being lost>
RET] ;IS THERE ROOM?
CAMG T2,TNAM(T1) ;LESS THAN OR GREATER?
JRST [HRRM T3,PTAP(T1) ;MAKE LESS POINTER POINT TO NEW ENTRY
JRST ADDIN]
HRLM T3,PTAP(T1) ;MAKE GREATER POINTER POINT HERE
ADDIN: MOVE T1,T3
ADDIN2: SETZM PTAP(T1) ;NEW ENTRY. NO POINTERS,..
SETZM TCNT(T1) ;AND NO COUNT
FOUND: MOVEM T2,TNAM(T1) ;STORE NAME
AOS TCNT(T1) ;AND INCR COUNT
EXCH T1,PREHIT ;GET LAST HIT IF ANY
HRRZM T1,EXPHIT ;MAKE IT THE EXPECTED HIT
RET
;This returns in T2 the age of the file looked at by GTFDBF in days.
GTAGE: MOVX T1,1B0+1B17
MOVSI T4,-NDATES
GTAGE1: HLRZ T2,@DATES(T4)
SUB T2,TODAY
CAMLE T2,T1
MOVE T1,T2
AOBJN T4,GTAGE1
MOVN T2,T1
CAIL T2,0 ;Make sure the value is 0 or greater
CAILE T2,^D365*14
SETZ T2,
RET
DATES: FDB+.FBCRV
FDB+.FBWRT
FDB+.FBREF
FDB+.FBTDT ; Last archive d&t
NDATES==.-DATES
; Here to see if a file has already been done once, & record if not
; Ret +1 if already done, +2 if not
CKDNFL: MOVE T1,FDB+.FBADR ; Assume caller has obtained the FDB
SKIPN T4,FILPTR ; Get current count
JRST CKFLD1 ; None, make 1st entry
HRLZS T4 ; Make an AOBJN ptr
CKFLD2: CAMN T1,DONEFL(T4) ; This match?
RET ; Yes, note we've seen the file before
AOBJN T4,CKFLD2 ; No match yet
CKFLD1: MOVEM T1,DONEFL(T4) ; Record new guy
SOS T1,FILPTR ; Update the count
MOVNS T1 ; Make positive count
CAIGE T1,NFILMX ; Over running the buffer?
JRST CPOPJ1 ; No
AOS FILPTR ; Yes, keep using last cell
WARN <File buffer full in CKDNFL - increase NFILMX>
JRST CPOPJ1
;Call with ITMSTK containing an AOBJN pointer, and T4 contaning the address
; of a routine to call to do the output of whetever is in T2.
PRTORD: TXZ F,F.CMMA
PRTO2: SKIPN T2,(ITMSTK)
JRST PROT3 ; Done
TXOE F,F.CMMA
TYPE [ASCIZ/, /]
CALL (T4) ;MUSTN'T HURT T3,T4
AOBJP ITMSTK,PROT3
MOVE T1,LSTPOS
CAIGE T1,^D57
JRST PRTO2
TYPE [ASCIZ/
/]
JRST PRTORD
PROT3: TYPE CRLF
RET
;Read user's MIGRATION.ORDER and set up JFNSTK approprately.
GETORD: TXNN F,F.TRIM ; Will the order be useful?
JRST GETOR4 ; Flag no user order & return
TXO F,F.USOD ; Assume the user will have one
MOVE ITMSTK,JFNPTR ; Where free space starts
PUSH P,GTJBLK+.GJGEN ; Save this, it's set up for someone
MOVX T1,GJ%OLD
MOVEM T1,GTJBLK+.GJGEN ; Set what we need
MOVEI T1,GTJBLK
HRROI T2,[ASCIZ /MIGRATION.ORDER/]
GTJFN%
JRST GETOR3 ; No order list for us
HRRZS T1 ; Probably got flags back
MOVEM T1,TMP ; Save the JFN
MOVX T2,<FLD(7,OF%BSZ)+OF%RD>
OPENF%
JRST [ MOVE T1,TMP ; JFN
RLJFN%
JFCL
JRST GETOR3]
MOVEM ITMSTK,JFNSTP ; Set for user ORDER list
GETOR1: MOVX T1,GJ%OFG+GJ%SHT+GJ%FNS+.GJALL
HRL T2,TMP ; Read from file
HRRI T2,.NULIO ; No output
GTJFN%
JRST GETOR2 ; Abort on error of any kind
MOVEM T1,(ITMSTK) ; Save it
AOBJN ITMSTK,GETOR1 ; Loop until...
WARN <User's ORDER list caused JFN storage to fill up>
GETOR2: SETZM (ITMSTK)
MOVE T1,TMP
CLOSF%
JFCL
GETOR3: POP P,GTJBLK+.GJGEN ; Restore GTJFN block
CAME ITMSTK,JFNPTR ; Get anything?
RET
MOVE T1,[-NJFNS,,JFNLST]
MOVEM T1,JFNSTP
GETOR4: TXZ F,F.USOD ; User didn't have an order list
RET
SUBTTL TAKE command
;TAKE and friends
.POLIC: GUIDES <does a TAKE on SYSTEM:REAPER.CMD>
CONFIRM
MOVX T1,GJ%SHT+GJ%OLD
HRROI T2,[ASCIZ/SYSTEM:REAPER.CMD/]
GTJFN%
JSERRD <Policy file not available>
JRST TAKE1
.TAKE: HLRZ T1,TAKSTK ;GET THE TAKE STACK COUNT
CAIL T1,TAKLEN ;ALL FULL UP?
ERROR <TAKEs nested too deeply, aborting.>
GUIDES <Commands from file>
MOVX T1,GJ%OLD ;JUST AN OLD FILE, PLEASE
MOVEM T1,GTJBLK+.GJGEN
SETZM GTJBLK+.GJDIR
SETZM GTJBLK+.GJDEV
HRROI T1,[ASCIZ/REAPER/]
MOVEM T1,GTJBLK+.GJNAM
HRROI T1,[ASCIZ/CMD/]
MOVEM T1,GTJBLK+.GJEXT
DMOVE T1,[EXP CMDBLK,FICINB] ;INPUT FILE OR CONFRM
CALL PARSE
TRNA
JRST TAKEOK
HRROI T1,[ASCIZ/SYSTEM/]
MOVEM T1,GTJBLK+.GJDEV
DMOVE T1,[EXP CMDBLK,FICINB]
CALL PARSE
ERROR <Not a Confirm or a File Specification>,NOCMD
TAKEOK: CAIN T3,.CMCFM ;CONFIRM OR FILE?
JRST TAKEND
CALL RPSJFN ;SAVE JFN FOR REPARSE
CONFIRM
HRRZ T1,T2 ;GET JFN IN T1
TAKE1: MOVX T2,7B5+OF%RD ;TRY TO OPEN
OPENF%
JSERRD <Can't OPEN file>,NOCMD ;IF AN ERROR OCCURS, SAY WHY AND DIE
HRLZS T1 ;JFN IN LH
HRRI T1,.NULIO ;OUTPUT (NOWHERE) IN RH
;JRST PUSTAK
;HERE WITH T1/ INJFN,,OUTJFN TO PUSH TO NEW INPUT & OUTPUT
PUSTAK: MOVE Q1,TAKSTK ;GET THE TAKE STACK
EXCH T1,CMDBLK+.CMIOJ;WHERE COMND LOOKS NOW
PUSH Q1,T1 ;SAVE OLD SOURCE ON TAKE JFN STACK
MOVEM Q1,TAKSTK ;SAVE STACK POINTER
RET
TAKEND: CALL TAKEOS
ERROR <No TAKE files active>,CPOPJ
RET
TAKEOS: TXOA F,F.TMP ;DON'T WANT ENDING MESSAGE
TAKEOF: TXZ F,F.TMP ;ALLOW END MESSAGE
MOVE Q1,TAKSTK ;GET TAKE STACK
TAKEO2: TLNN Q1,-1
RET ;NO OPERATION IF EMPTY STACK
POP Q1,T1 ;RESTORE PREVIOUS JFNS
MOVEM Q1,TAKSTK
EXCH T1,CMDBLK+.CMIOJ;GIVE BACK LAST JFNS
HLRZ T2,T1 ;GET COMMAND INPUT JFN IN T2
CAIN T2,.PRIIN ;IS IT MAIN INPUT?
JRST CPOPJ1 ;YEAH, DON'T ANNOUNCE OR CLOSE
TXZE F,F.TMP
JRST TAKEO3 ;NO ENDING MESSAGE
CALL IFCRLF ;ANNOUNCE WHAT'S ENDING
TYPE <[ASCIZ/[Ending /]>
CALL TYJFNS
TYPE CBCR ;CLOSE BRACKET CRLF
TAKEO3: MOVE T1,T2
CLOSF% ;CLOSE THE FILE OUT
JSERRD <>,CPOPJ1 ;FAILURE SEEMS UNLIKELY
JRST CPOPJ1 ;+2 RET
;Here to blow away all take files
UNTAKE: CALL TAKEOF ;END THE CURRENT TAKE FILES
RET ;DONE
JRST UNTAKE ;GO UNTIL NONE LEFT
SUBTTL Parsing
;To parse a wild filespec
GETFIL: PUSH P,T1 ; Save parse only param
SETO T1, ; Say we want *'s
CALL SETGTD ; Set the defaults for GTJFN
MOVX T1,GJ%OLD+GJ%IFG+GJ%DEL
IORM T1,GTJBLK+.GJGEN
POP P,T1
JUMPGE T1,GETFL2
MOVX T1,GJ%IFG+GJ%OLD
ANDCAM T1,GTJBLK+.GJGEN
MOVX T1,GJ%OFG
IORM T1,GTJBLK+.GJGEN
GETFL2: DMOVE T1,[EXP CMDBLK, FILINB]
;JRST PARSE
; Sucessful parse returns usual flags in T1, usual stuff in T2, the
; type of block in T3. Bad parse returns +1, good +2.
PARSE: COMND%
HITME: ERJMP PAREOF
TXNE T1,CM%NOP
RET ;DIDN'T PARSE
LDB T3,[POINT 9,(T3),8]
CPOPJ1: AOS (P)
RET
PAREOF: MOVX T1,.FHSLF ;WHAT WENT WRONG?
GETER% ;..
HRRZ T1,T2 ;ISOLATE ERROR CODE
CAIN T1,DESX3 ;DID WE LOSE THE JFN?
JRST [MOVEI T1,TAKSTR ;YES, ASSUME ^C/START
MOVEM T1,TAKSTK ;BLOW AWAY COMMAND STACK
MOVE T1,[.PRIIN,,.PRIOU] ;AND TALK TO TERMINAL
MOVEM T1,CMDBLK+.CMIOJ
JRST PANIC]
CAIE T1,IOX4 ;EOF?
JSERRD <Can't parse command>,PANIC,JRST ;NO, COMPLAIN
CALL TAKEOF ;ASSUME EOF, DROP A COMMAND LEVEL
JSERRD <Parse error>,PANIC,JRST ;IF THERE ISN'T A TAKE FILE, WEIRD
TXNE F,F.PRIV ;IS THIS A PEON?
JRST PANIC ;NO, RESTART
JRST PEON2 ;YES, SECOND STAGE PEON CODE PLEASE
;CALL to confirm. Skip ret if all OK.
CONFRM: DMOVEM T1,1(P)
MOVEM T3,3(P)
DMOVE T1,[EXP CMDBLK,CONINB]
COMND%
ERJMP PAREOF
TXNE T1,CM%NOP
ERROR <Not confirmed>,CPOPJ
MOVE T3,3(P)
DMOVE T1,1(P)
JRST CPOPJ1
;Here with a word address of a string to guide with in T1. Skip if OK.
GUIDE: HRROM T1,GUIINB+.CMDAT
DMOVEM T2,1(P)
DMOVE T1,[EXP CMDBLK,GUIINB]
COMND%
ERJMP PAREOF
TXNE T1,CM%NOP
ERROR <Illegal guide word>,CPOPJ
DMOVE T2,1(P)
JRST CPOPJ1
;Call with T1 pointing to a 0 terminated list of characters to stop on.
; This copies characters out of the COMND% buffer into the atom buffer,
; stopping on null or one of the characters listed. T3 is returned as the
; character matched, or 0 if noting did.
SKIPTR: MOVEM T1,TMP
MOVE T4,[POINT 7,ATOM]
SETZ T3,
JRST SKIPT3
SKIPT1: CAIE T2,.CHCRT
CAIN T2,.CHLFD
TRNA ;DON'T COPY THESE TO ATOM BUFFER
IDPB T2,T4
SKIPT3: SOS CMDBLK+.CMINC
ILDB T2,CMDBLK+.CMPTR
JUMPE T2,NFIND
MOVE T1,TMP
SKIPT2: SKIPN T3,(T1)
JRST SKIPT1
CAIE T2,(T3)
AOJA T1,SKIPT2
SETZ T2,
NFIND: IDPB T2,T4
RET
SETGTD: MOVE T2,[GTJBLK,,GTJBLK+1]
SETZM -1(T2)
BLT T2,GTJBLK+.GJBFP ; Clear it to start
MOVE T2,[.PRIIN,,.PRIOU]
MOVEM T2,GTJBLK+.GJSRC
MOVX T2,GJ%XTN
IORM T2,GTJBLK+.GJGEN
MOVX T2,G1%IIN
MOVEM T2,GTJBLK+.GJF2 ; Into extended blk
JUMPE T1,CPOPJ ; Done if doesn't want stars
HRROI T2,[ASCIZ /*/]
MOVEM T2,GTJBLK+.GJDIR ; For directory name
MOVEM T2,GTJBLK+.GJNAM ; For file name
MOVEM T2,GTJBLK+.GJEXT ; For extention
MOVX T2,GJ%IFG+.GJALL
IORM T2,GTJBLK+.GJGEN
RET
SUBTTL Error support
;ERROR and special output routines.
;ANNERR is good to call when you hit an error. If you are in a TAKE file,
; it <CRLF>s at need and types the failing command back to the user. It
; makes sure the next output starts at the margin and clears the input
; buffer.
ANNERR: DMOVEM T1,IFCTMP
MOVX T1,.CTTRM
RFMOD%
TXZE T2,TT%OSP ;CLEAR ^O
SFMOD%
CFIBF%
CALL WHERE
JRST .+2 ;FROM FILE
JRST IFCRL2 ;FROM TERMINAL
MOVEM T1,INPTMP
CALL IFCRL2
TYPE [ASCIZ/?In command /]
TYPE BFFR ;TYPE COMMAND
CALL IFCRL2
TYPE [ASCIZ/?In file /]
MOVE T2,INPTMP
CALL TYJFNS
JRST IFCRL2 ;DO IFCRLF, RESTORING CALLER'S AC'S
IFCRLF: DMOVEM T1,IFCTMP
IFCRL2: MOVEI T1,.PRIOU
DOBE%
RFPOS%
TRNE T2,-1
YSCRLF: TYPE CRLF
NOCRLF: DMOVE T1,IFCTMP
CPOPJ: RET
;WHERE skips if the commands are coming in from .PRIIN
; The current input JFN is returned in T1
WHERE: HLRZ T1,CMDBLK+.CMIOJ ;GET THE INPUT SOURCE
CAIN T1,.PRIIN ;PRIMARY INPUT?
AOS (P) ;YES, SKIP RET
RET
LSTERR: TLCE T1,-1 ;ANY LEADER STRING BEYOND "?"
TLCN T1,-1
HRLI T1,(POINT 7)
MOVEI T2,2 ;POINT TO 2ND CHARACTER
ADJBP T2,T1
LDB T2,T2 ;FETCH
TYPEAT T1
CAIE T2,0 ;JUST ONE CHAR (IE, "?") ?
LSTERD: TYPE [ASCIZ/ - /] ;IF YES, DON'T TYPE THIS
LSTERO: HRLOI T2,.FHSLF
LSTERC: HRROI T1,STRING
SETZ T3,
ERSTR%
JFCL
JFCL
TYPE STRING
RET
SUBTTL Terminal and List file output
;Terminal and list file, etc I/O subroutines
;Get text to proper places (Terminal, list file, etc). OUTMSG if the pointer
; passed could be anything, including null. OUTMSS if the pointer certainly
; contains some sort of pointer. OUTMSA if the pointer is PSOUT% legal.
; OUTMTT if the string is in TEMP2.
; TYPE and TYPEAT come here. Enter with T1 on the stack.
OUTMSG: JUMPE T1,OUTMS3 ;NULL POINTER OR CHARACTER? NOOP IF SO.
OUTMSS: TLNE T1,-1 ;POINTER OR CHARACTER?
JRST OUTMSA ;POINTER, GO USE
OUTMSC: HRLZM T1,OUTMSX ;CHARACTER. TUCK INTO STORAGE..
SKIPA T1,[POINT 7,OUTMSX,10] ;AND FETCH A POINTER TO IT
OUTMTT: HRROI T1,TEMP2 ;WHERE CALLER WROTE STRING
OUTMSA: MOVEM T1,OUTMST ;STORE THE POINTER TO THIS TEXT
PUSH P,T4 ;SAVE T4
MOVE T4,LSTFLG ;ARE WE WRITING THIS ANYWHERE?
TXNE T4,LS.TTY ;OUT TO PRIMARY OUTPUT?
PSOUT% ;YES
TXNE T4,LS.LST
SKIPN T1,LSTJFN ;FETCH LIST JFN
JRST OUTMSD ;NOT AVAILABLE, FINE
PUSH P,T2
PUSH P,T3
SKIPGE LSTLIN ;NEED A HEADER FIRST?
CALL FSTPGN ;YES, DO THAT
MOVE T2,OUTMST ;POINTER TO TEXT
SETZ T3, ;GO UNTIL NULL SEEN
SOUT% ;WRITE TO LIST FILE
ERJMP NOLSTF
SKIPGE T3,LSTPOS ;DID CALLER ALREADY FIGURE LSTPOS FOR US?
JRST [MOVNS T3 ;YES, JUST SET IT RIGHT
JRST CNTSP2]
MOVE T1,OUTMST
TLC T1,-1 ;UPDATE LSTPOS
TLCN T1,-1
HRLI T1,(POINT 7)
CNTSPC: ILDB T2,T1
JUMPE T2,CNTSP2
CAIN T2,.CHCRT
JRST [SETZ T3,
JRST CNTSPC]
CAIN T2,.CHLFD
JRST PAGTST ;<LF> DONE BELOW
CAIN T2,.CHTAB
JRST [TRO T3,7
AOJA T3,CNTSPC]
CAIGE T2," "
ADDI T3,1 ;ASSUME CTRL CHARS ARE 2 WIDE (^x)
AOJA T3,CNTSPC
PAGTST: AOS T4,LSTLIN
CAIL T4,PAGLIN ;LINES/PAGE
CALL FSTPGN ;NEED A PAGE HEADER
JRST CNTSPC ;NOT A NEW PAGE YET, GO ON
FSTPGN: PUSH P,T1
MOVE T1,LSTJFN ;SET UP TO OUT A ^L
MOVEI T2,.CHFFD
BOUT%
ERJMP .+1
SETZM LSTLIN
POP P,T1
RET
CNTSP2: MOVEM T3,LSTPOS
POP P,T3
POP P,T2
OUTMSD: POP P,T4
OUTMS3: POP P,T1
RET
;Error while writing list file - end the list file
NOLSTF: SKIPE T1,LSTJFN ;LIST FILE HERE?
CLOSF% ;YES, CLOSE IT
ERJMP .+1
SETZM LSTJFN
MOVX T4,LS.LST ;SAY NO MORE LIST FILE
ANDCAM T4,LSTFLG
CALL ANNERR ;ANNOUNCE ERROR
TYPE [ASCIZ/?Error writing LIST file, list file ended
/] ;RECURSION!
SETZ T3,
JRST CNTSP2
;TABOUT only works for the list file (because OUTMSG only follows the line
; position of the list file)
; Give it the column to get to in T2. This always outputs at least 1 space.
TABOUT: PUSH P,T1 ;BECAUSE OUTMSA WANTS THAT
MOVE T1,[POINT 7,TABTMP] ;A PLACE TO WRITE TO
MOVE T3,LSTPOS ;FIND OUT WHERE WE ARE
MOVEM T3,LSTTMP ;SAVE IT
MOVEI T4,.CHTAB ;PREPARE TO WRITE SOME TABS
TRZ T3,7 ;FIGURE THE EFFECT OF THE FIRST TAB
ADDI T3,8 ;..
TABITH: IDPB T4,T1 ;IN GOES THE TAB
CAIL T3,(T2) ;FAR ENOUGH?
JRST TTOFAR ;YES, MAYBE TOO FAR
MOVEM T3,LSTTMP ;TAB WAS OK, REMEMBER WHERE WE ARE
ADDI T3,8 ;SIMULATE THE NEXT TAB
JRST TABITH ;AND GO DO IT
TTOFAR: CAIG T3,(T2) ;DID WE GO TOO FAR?
JRST TOKOUT ;NO, JUST RIGHT, FINISH UP
MOVEI T4," " ;TOO FAR, OVERWRITE LAST TAB WITH SPACE
DPB T4,T1 ;..
AOS T3,LSTTMP ;ACCOUNT FOR SPACE
TSPOUT: CAIL T3,(T2) ;ENOUGH SPACES?
JRST TOKOUT ;YES, FINISH UP
IDPB T4,T1 ;NO, SPACE GOES IN
AOJA T3,TSPOUT ;ADVANCE THE COUNT AND GO ON
TOKOUT: MOVNM T3,LSTPOS ;TELL OUTMSA WE FIGURED THE LENGTH FOR IT
SETZ T4, ;NULL TO END
IDPB T4,T1 ;..
HRROI T1,TABTMP ;THE STRING WE WROTE
JRST OUTMSA ;GETS WRITTEN NOW
; Listing routines
;LSTFIL types out the current filename, either from the JFN in LOCJFN (if
; F.GOTN is off) or directly from the text at GOTNAM (if F.GOTN is on). It
; also clears F.GOTN when called.
LSTFIL: TXON F,F.NDIR ; New directory?
CALL LSTDIR ; Yes, spit it out
PUSH P,T2 ; Save note
TXZE F,F.GOTN ; Got name already?
JRST [TYPE GOTNAM
JRST LSTFI1]
HRRZ T2,LOCJFN
MOVX T3,JFNSNE ;Filnam, type, gen, and punctuation
CALL TYJFNF
LSTFI1: MOVEI T2,^D40
CALL TABOUT
POP P,T2 ; Note
CAIE T2,0 ; Any?
TYPEAT T2
TYPE CRLF
RET
LSTDIR: PUSH P,T2
TYPE [ASCIZ/
/]
CALL TYDIRC ;Type current directory name
TYPE CRLF
TXNN F,F.USOD ;HAVE A USER ORDERING?
JRST LSTDI1
TYPE [ASCIZ/ user ordering: /]
MOVEM ITMSTK,TMP
MOVE ITMSTK,JFNSTP
MOVX T3,JFNSNX
MOVEI T4,TYJFNF
CALL PRTORD
MOVE ITMSTK,TMP
LSTDI1: POP P,T2
RET
OPNLST: HRRZS T1
MOVE T2,[7B5+OF%APP]
OPENF%
ERJMP NOLISF
JRST CPOPJ1
NOLISF: HRRZS T1
RLJFN%
ERJMP .+1
RET
;Here to output time and date
TADOUT: PUSH P,T1
SETO T2,
MOVX T3,OT%NSC+OT%NCO+OT%SCL+OT%DAY
HRROI T1,TEMP2
ODTIM%
ERJMP .+1
JRST OUTMTT
;Here with a number in T2 to output. DECOUT loses T3. DECOUT & NUMOUT
; act identically to TYPE (it calls OUTMSG). NUMOUT can be treated
; exactly like NOUT% in terms of radixs and flags.
DESOUT: SKIPA T3,[NO%LFL+NO%OOV+5B17+^D10]
DECOUT: MOVEI T3,^D10 ;RADIX 10
NUMOUT: PUSH P,T1 ;MOSTLY BECAUSE OUTMSA WANTS IT
HRROI T1,TEMP2
NOUT%
ERJMP .+1
JRST OUTMTT
;Type JFN in T2
TYJFNS: MOVE T3,[JFNSAL]
TYJFNF: HRROI T1,TEMP2
JFNS%
ERJMP CPOPJ
PUSH P,T1
JRST OUTMTT ;TYPE STRING
;Type the directory name referenced by T2
TYDIRC: MOVE T2,CURDIR
TYDIRS: PUSH P,T1
HRROI T1,TEMP2
DIRST%
ERJMP .+1
JRST OUTMTT
;Acts like CSTRB, except T1/ number to output (decimal)
NOUTB: EXCH T1,T2
MOVEI T3,^D10
NOUT%
ERJMP .+1
EXCH T1,T2
RET
;Copy string and back up T2 on exit. Return last character in T3.
CSTRB: CALL CSTR
SETO T3,
ADJBP T3,T2
MOVE T2,T3
RET
;More string copy stuff. Takes T1 and T2 as the from and to, and returns
; T3 as 0.
CSTR: TLCE T1,-1
TLCN T1,-1
HRLI T1,(POINT 7)
TLCE T2,-1
TLCN T2,-1
HRLI T2,(POINT 7)
CSTRA: ILDB T3,T1
IDPB T3,T2
JUMPN T3,CSTRA
RET
;Output sixbit string in T3. Hurts T2 and T3
SIXOUT: PUSH P,T1
SETZ T2, ;PREPARE TO CONVERT TO ASCIZ
JUMPE T3,SIXOU1 ;IF NONE, ALREADY CONVERTED, SO TO SPEAK
JRST V6TO7B
V6TO7: LSH T2,1 ;ROOM FOR ASCII BIT (OR, MAKE LEFT JUSTIFIED)
TLNE T2,774K ;DONE? (ANYTHING IN 1ST BYTE?)
JRST V6TO7D ;YES, GO STORE
V6TO7B: LSHC T2,6 ;FETCH NEXT 6BIT BYTE INTO T2
TRNE T2,77 ;IS IT REAL?
ADDI T2," " ;YES, CONVERT TO ASCII
JRST V6TO7
V6TO7D: JUMPE T3,SIXOU1 ;IS 6TH BYTE NONEXISTANT?
LSH T3,-1 ;NO, NEEDS CONVERTING
ADD T3,[BYTE(7) " ",0]
SIXOU1: DMOVEM T2,TEMP2
JRST OUTMTT
;Here to push the JFN in T2 and the address of the "delete jfn" routine
; on the reparse stack.
RPSJFN: MOVEI T1,RPSJFD
HRL T1,T2
EXCH T1,RPSSTK ;SAVE DATA, GET STACK POINTER
PUSH T1,RPSSTK ;PUT DATA ON REPARSE STACK
EXCH T1,RPSSTK ;GET T1 BACK, PUT STACK POINTER AWAY AGAIN
RET
;Here to get something off the reparse stack. +1 ret with something in T1,
; +2 with nothing on stack anymore.
RPSGET: EXCH T2,RPSSTK
TLNN T2,-1 ;EMPTY STACK?
AOSA (P) ;YES, SKIP RETURN
POP T2,T1
EXCH T2,RPSSTK
RET
UNDO: CALL RPSGET
JRST GOUNDO ;RH OF T1 HAS THE ADDR OF A ROUTINE TO CALL
RET ;NOTHING LEFT TO UNDO
GOUNDO: CALL (T1) ;GO DO ROUTINE
JRST UNDO ;GO UNTIL REPARSE STACK EMPTY
JRST UNDO ;IN CASE OF A SKIP RETURN
RLJFNS: SKIPE T1,(ITMSTK) ; Anything?
RLJFN% ; Yes, release it
JFCL
SETZM (ITMSTK)
AOBJN ITMSTK,RLJFNS
RET
RPSJFD: HLRZS T1 ;DROP THE JFN IN THE LF OF T1
;Here to drop the JFN in T1 as though we never touched it
DRPJFN: JUMPE T1,CPOPJ ;IF NO JFN, FINE
GTSTS% ;IS THE JFN OPEN AT ALL?
JUMPL T2,DRPOFN ;IF SO, CLOSF%
RLJFN%
ERJMP .+1 ;IF NOT, RLJFN%, IF FAILS, CLOSF%
RET
DRPOFN: HRLI T1,(CZ%ABT+CZ%NUD)
CLOSF% ;THIS JFN NEVER HAPPENED
ERJMP .+1
RET
SUBTTL File information subroutines
; Here to determine if file has ANY tape info associated with it
HAVTAP: SKIPN TAPBLK+.ARTP1 ; Tape 1 ID there?
SKIPE TAPBLK+.ARTP2 ; No, how about tape 2 ID?
RET ; At least one is there
JRST CPOPJ1 ; Neither are there
GTFDBF: HRRZ T1,LOCJFN
MOVSI T2,.FBLEN
MOVEI T3,FDB
GTFDB%
ERJMP [HRLI T2,.FBLN0 ; Probably a short FDB
GTFDB%
JRST .+1]
LDB T2,[POINT 7,(T3),35]
CAIGE T2,.FBLXT ; Long enough for tape info?
JRST [ SETZM .FBTDT(T3) ; No, date is not valid then
SETZM TAPBLK+.ARTP1 ; No tape info
SETZM TAPBLK+.ARTP2 ; ...
RET]
HRRZS T1 ; JFN only
MOVX T2,.ARGST ; Get tape info
MOVEI T3,TAPBLK
ARCF%
ERJMP .+1
RET
CRLF: ASCIZ/
/
CRLF2: ASCIZ/
/
CBCR: ASCIZ/]
/
;Some parsing tokens
CMDINB: <.CMKEY>B8
CMDLST
CMDLST: CMDLEN,,CMDLEN
CTB .ARCHI, <BEGIN>
CTB .FLUSH, <DELETE-CONTENTS>
CTB .EXIT, <EXIT>
CTB .LIST, <LIST>
CTB .INVOL, <MIGRATE>
CTB .ORDER, <ORDER>
CTB .PERIO, <PERIOD>
CTB .POLIC, <POLICY>
CTB .PURGE, <PURGE>
; CTB .REAPE, <REAP>
CTB .SCAN, <SCAN>
CTB .SKIP, <SKIP>
CTB .TAKE, <TAKE>
CTB .TAPE, <TAPE>
CTB .TRIM, <TRIM>
CMDLEN=.-CMDLST-1
FICINB: <.CMCFM>B8+FILINB
FILINB: <.CMFIL>B8
PERINB: <.CMNUM>B8+CM%SDH+CM%HPP
^D10
-1,,[ASCIZ/Number of days/]
SKPINB: <.CMDIR>B8+CM%SDH+CM%HPP
CM%DWC
-1,,[ASCIZ/Name of directory to SKIP/]
CMCINB: <.CMCMA>B8+CONINB
INIINB: <.CMINI>B8
CONINB: <.CMCFM>B8
END <3,,ENTVEC>