RECORDFORMAT C
DIRF(STRING (30)SEC, BYTEINTEGER B, STRING (31)NAME,
INTEGER I1, I2, I3, I4)
OWNRECORD (DIRF)ARRAYFORMAT C
VDIRAF(-1 : 32768)
CONSTINTEGER TOP = 100
RECORDFORMAT C
HF(INTEGER END, START, SIZE, TYPE, SUM, DATETIME, ADR, RECS,
TOPFILE,
STRING (31)ARRAY FILE(1:TOP),
STRING (31)ARRAY TOPIC(1:TOP),
INTEGERARRAY KEY(1:TOP),
INTEGER KEYAREA)
RECORDFORMAT C
PDF(INTEGER START, STRING (11) NAME, INTEGER HOLE, S5, S6, S7)
RECORDFORMAT C
PDHF(INTEGER DATAEND, DATASTART, SIZE, FILETYPE, SUM,
DATETIME, ADIR, COUNT)
RECORDFORMAT C
RF(INTEGER CONAD, FILETYPE, DATASTART, DATAEND)
OWNRECORD (PDF)ARRAYFORMAT C
DIRAF(0:4095)
OWNSTRING (31)ARRAYFORMAT C
S31AF(1 : 100)
!
!
SYSTEMROUTINESPEC C
CONNECT(STRING (31) FILE, INTEGER MODE, HOLE, PROT,
RECORD (RF) NAME R, INTEGERNAME FLAG)
SYSTEMINTEGERFNSPEC C
DTWORD(INTEGER DT)
EXTERNALINTEGERFNSPEC C
DSFI(STRING (31)INDEX, INTEGER FSYS, TYPE, SET, ADR)
EXTERNALINTEGERFNSPEC C
EXIST(STRING (255)S)
EXTERNALROUTINESPEC C
NEWGEN(STRING (255)S)
EXTERNALROUTINESPEC C
PERMIT(STRING (255)S)
EXTERNALROUTINESPEC C
RENAME(STRING (255)S)
SYSTEMROUTINESPEC C
SETFNAME(STRING (63)S)
SYSTEMROUTINESPEC C
TRIM(STRING (31)FILE, INTEGERNAME FLAG)
SYSTEMROUTINESPEC C
CASTOUT(STRINGNAME S)
EXTERNALROUTINESPEC C
DESTROY(STRING (255) S)
EXTERNALROUTINESPEC C
DETACH(STRING (255) S)
EXTERNALROUTINESPEC C
DISCONNECT(STRING (255) S)
EXTERNALINTEGERFNSPEC C
DMESSAGE(STRING (6) USER, INTEGERNAME LEN, INTEGER ACT,FSYS,ADR)
SYSTEMSTRINGFNSPEC C
FAILUREMESSAGE(INTEGER FLAG)
SYSTEMSTRINGFNSPEC C
ITOS(INTEGER N)
SYSTEMROUTINESPEC C
MOVE(INTEGER LEN,FROM,TO)
SYSTEMROUTINESPEC C
OUTFILE(STRING (31)S, INTEGER SIZE,MAXBYTES,PROT, INTEGERNAME CONAD,FLAG)
SYSTEMINTEGERFNSPEC C
PSTOI(STRING (63)S)
EXTERNALINTEGERFNSPEC C
UINFI(INTEGER I)
EXTERNALSTRINGFNSPEC C
UINFS(INTEGER I)
!
!
!
INTEGERFN TEXTTOFILE(STRING (255)TEXT, FILE)
INTEGER CONAD, FLAG, L
OUTFILE(FILE,4096,4096,0,CONAD,FLAG)
IF FLAG = 0 START
L = LENGTH(TEXT)
MOVE(L,ADDR(TEXT)+1,CONAD+32)
INTEGER(CONAD)=L+32
INTEGER(CONAD+4)=32
FINISH
RESULT =FLAG
END ; ! TEXTTOFILE
!
!
!
INTEGERFN DAY NO
CONSTLONGINTEGER JMS = X'141DD76000'
*RRTC_0
*USH_-1
*SHS_1
*USH_1
*IDV_JMS
*STUH_B
*EXIT_-64
END
!
!
!
ROUTINE KDATE(INTEGERNAME D,M,Y,INTEGER K)
! K IS DAYS SINCE 1ST JAN 1900
! RETURNS D, M, Y 2 DIGIT Y ONLY
! %INTEGER W
! K=K+693902; ! days since Cleopatras birthday
! W=4*K-1
! Y=W//146097
! K=W-146097*Y
! D=K//4
! K=(4*D+3)//1461
! D=4*D+3-1461*K
! D=(D+4)//4
! M=(5*D-3)//153
! D=5*D-3-153*M
! D=(D+5)//5
! Y=K
*LSS_K; *IAD_693902
*IMY_4; *ISB_1; *IMDV_146097
*LSS_TOS ; *IDV_4; *IMY_4; *IAD_3
*IMDV_1461; *ST_(Y)
*LSS_TOS ; *IAD_4; *IDV_4
*IMY_5; *ISB_3; *IMDV_153
*ST_(M); *LSS_TOS
*IAD_5; *IDV_5; *ST_(D)
IF M<10 THEN M=M+3 ELSE START
M=M-9
IF Y=99 THEN Y = 0 ELSE Y=Y+1
FINISH
END ; ! OF KDATE
!
!
!
!%INTEGERFN KDAY(%INTEGER D,M,Y)
! %IF M>2 %THEN M=M-3 %ELSE M=M+9 %AND Y=Y-1
! %RESULT=1461*Y//4+(153*M+2)//5+D+58
!%END; ! OF KDAY
!
!
!
STRING (255)FN DATE(INTEGER K)
INTEGER D, M, Y, Q, R
STRING (2)TH
CONSTSTRING (6)ARRAY DAY(0:6) = "Mon", "Tues", "Wednes", "Thurs", C
"Fri", "Satur", "Sun"
CONSTSTRING (3)ARRAY MON(1:12) = "Jan", "Feb", "Mar", "Apr", C
"May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"
CONSTSTRING (2)ARRAY ORD(1:3) = "st", "nd", "rd"
KDATE(D, M, Y, K)
K = K - 7 * (K//7); ! day of week
Q = D//10
R = D - 10 * Q
TH = "th"
TH = ORD(R) IF Q # 1 AND 1 <= R <= 3
RESULT = DAY(K)."day ".ITOS(D).TH." ".MON(M).", 19".ITOS(Y)
END
!
!
!
STRINGFN S2(INTEGER I); ! returns a 2-digit string
INTEGER TENS
RESULT = "??" UNLESS 0 < I < 100
TENS = I // 10
I = I - 10 * TENS
RESULT = TOSTRING(TENS+'0').TOSTRING(I+'0')
END
!
!
!
STRING (8)FN NEXTDATE(INTEGER INTERVAL)
INTEGER D, M, Y
KDATE(D, M, Y, DAYNO+INTERVAL)
RESULT = S2(D)."/".S2(M)."/".S2(Y)
END ; ! NEXTDATE
!
!
!
ROUTINE AUTO(STRING (255) COMMANDS, INTEGER INTERVAL, TIME LIMIT,
INTEGERNAME FLAG)
!
!
!
INTEGER LEN
STRING (255) DETCOM
STRING (127) CONFIRM
STRING (8) NEWDATE
STRING (40) FAIL
CONSTSTRING (7) NJOB="T#AUTOJ"
CONSTSTRING (5) DETFILE="T#DTF"
!
!
!
NEWDATE = NEXTDATE(INTERVAL); ! get date 'interval' days from today
DETCOM = "AFTER=" . NEWDATE . "
.END
"
FLAG = TEXT TO FILE(DETCOM, DETFILE)
UNLESS FLAG = 0 START
FAIL= "AUTO fails to create ".DETFILE." - "
PRINTSTRING(FAIL.FAILUREMESSAGE(FLAG))
RETURN
FINISH
!
FLAG = TEXT TO FILE(COMMANDS, NJOB)
UNLESS FLAG = 0 START
FAIL = "AUTO fails to create ".NJOB." - "
PRINTSTRING(FAIL.FAILUREMESSAGE(FLAG))
RETURN
FINISH
!
DETACH(NJOB.",".ITOS(TIME LIMIT).",".DETFILE)
!
CONFIRM="Job detached to run on ".DATE(DAYNO+INTERVAL).TOSTRING(10)
IF UINFI(2) = 1 {foreground} C
THEN PRINTSTRING(CONFIRM) C
ELSE START
LEN=LENGTH(CONFIRM)
FLAG=DMESSAGE(UINFS(1),LEN,1,UINFI(1),ADDR(CONFIRM)+1)
FINISH
!
DISCONNECT(DETFILE)
DISCONNECT(NJOB)
DESTROY(DETFILE)
DESTROY(NJOB)
END ; ! AUTO
!
!
!
ROUTINE RUNAUTO(STRING (255)COMMAND)
INTEGER FLAG, INTERVAL, TIME LIMIT
STRING (255)W1, W2
CASTOUT(COMMAND)
W1 = "1" UNLESS COMMAND -> COMMAND . (",") . W1
W2 = "10" UNLESS W1 -> W1 . (",") . W2
INTERVAL = PSTOI(W1)
TIME LIMIT = PSTOI(W2)
AUTO(COMMAND.TOSTRING(10), INTERVAL, TIME LIMIT, FLAG)
PRINTSTRING("FLAG IS")
WRITE(FLAG, 1)
NEWLINE
END ; ! RUNAUTO
!
!
!***********************************************************************
!*
!* Service routines
!*
!***********************************************************************
!
CONSTINTEGER TOP STOP = 2
CONSTSTRING (31)ARRAY STOP FILE(1 : TOP STOP) = "BIR015.BIOL",
"HUR052.CATHEDRAL"
!
CONSTINTEGER NO = 0
CONSTINTEGER YES = 1
CONSTSTRINGNAME TIME = X'80C0004B'
OWNINTEGER SILENT = NO
OWNINTEGER OCP0
OWNINTEGER PTRNS0
!
ROUTINE Q(STRING (255)S)
INTEGER J, PTRNS, OCP
RETURNIF SILENT = YES
!
J = DSFI("", -1, 24, 0, ADDR(PTRNS))
J = DSFI("", -1, 28, 0, ADDR(OCP))
PRINTSTRING(TIME)
PRINTSTRING(" Ptrns"); WRITE(PTRNS-PTRNS0, 3)
PRINTSTRING(" OCP"); WRITE(OCP-OCP0, 3)
SPACE
PRINTSTRING(S)
NEWLINE
END ; ! Q
!
!-----------------------------------------------------------------------
!
ROUTINE CONNECT2(STRING (63)FILE, INTEGER MODE, HOLE, PROT,
RECORD (RF) NAME RR, INTEGERNAME FLAG)
! This is a generalised version of CONNECT.
INTEGER BASE, NEWBASE, I
STRING (31)MEM
STRING (255) FILEF, FULL, REM
RECORD (RF) R1
RECORD (PDHF) NAME H
RECORD (PDF) ARRAYNAME DIR
IF FILE = "" START
SETFNAME(FILE)
FLAG = 220; ! Invalid filename
RETURN
FINISH
!
!
FILEF = FILE."_"
FILEF -> FULL.("_").REM
CONNECT(FULL, MODE, HOLE, PROT, R1, FLAG)
RETURNIF FLAG # 0
!
BASE = R1_CONAD
!
CYCLE
H == RECORD(BASE)
EXITIF REM = ""
IF H_FILETYPE # 6 {SSPDFILETYPE} START
FULL <- FULL." is not a PD file"
IF LENGTH(FULL) > 40 START
FULL = SUBSTRING(FULL, LENGTH(FULL) - 36, LENGTH(FULL))
FULL = "...".FULL
FINISH
SETFNAME(FULL)
FLAG = 233; ! General flag
RETURN
FINISH
!
DIR == ARRAY(BASE + H_ADIR, DIRAF)
UNLESS REM - > MEM.("_").REM START
IF LENGTH(FILE) > 40 START
LENGTH(FILE) = 37
FILE = FILE."..."
FINISH
SETFNAME(FILE)
FLAG = 220; ! Invalid filename
RETURN
FINISH
!
NEWBASE = 0
FOR I = 0, 1, H_COUNT - 1 CYCLE
IF DIR(I)_NAME = MEM START
NEWBASE = BASE + DIR(I)_START
EXIT
FINISH
REPEAT
!
IF NEWBASE = 0 START
SETFNAME(MEM)
FLAG = 288; ! Member does not exist
RETURN
FINISH
!
BASE = NEWBASE
FULL = FULL."_".MEM
REPEAT
!
RR_CONAD = BASE
RR_FILETYPE = H_FILETYPE
RR_DATASTART = H_DATASTART
RR_DATAEND = H_DATAEND
END ; ! connect2
!
!------------------------------------------------------------
!
ROUTINE EXTRACT(STRING (255)S)
INTEGER J, K, HA, F, CFLAG, P, CH
INTEGER K1, N, L, DTEXTRACT, CHANGED
INTEGER DIRA, KEYA
RECORD (PDHF)NAME HDR
STRING (31)ARRAYNAME SUBFILE
RECORD (HF)NAME H
RECORD (RF)R, KR, VR
BYTEINTEGERARRAYNAME KEYS
BYTEINTEGERARRAYFORMAT KEYSF(0 : 1000000)
RECORD (DIRF)ARRAY NAME DIR
STRING (255)W, NAME
CHANGED = 0
DTEXTRACT = 1 << 31
CONNECT("EXTRACT", 1, 0, 0, R, J); ! connect current EXTRACT file
DTEXTRACT = DTWORD(INTEGER(R_CONAD+20)) IF J = 0
!
OUTFILE("T#OUT", 1<<17, 0, 0, HA, J)
RETURN UNLESS J = 0
!
H == RECORD(HA)
H_TYPE = 4; ! Data
H_ADR = 3; ! Structure not specified
K = ADDR(H_KEYAREA)
BYTEINTEGER(K) = 10
K = K + 1
!
H_TOPFILE = 2
S = "SUBSYS.VIEWBASE" IF S = ""
H_FILE(1) = "SUBSYS.VD_CMNDS"; ! get this first
H_FILE(2) = S
!
F = 1
WHILE F <= H_TOPFILE CYCLE
PRINTSTRING(H_FILE(F))
H_KEY(F) = K - HA
CONNECT2(H_FILE(F), 1, 0, 0, R, CFLAG)
IF CFLAG = 0 START
HDR == RECORD(R_CONAD)
IF DTWORD(HDR_DATETIME) > DTEXTRACT START
CHANGED = 1
PRINTSTRING(" changed")
FINISH
FINISH ELSE START
CHANGED = 1
-> NEXT
FINISH
!
IF HDR_FILETYPE = 3 START {character file}
PRINTSTRING(" is a character file")
IF HDR_COUNT = 2 START
DIRA = R_CONAD + 96
KEYA = DIRA + INTEGER(DIRA)
FINISH ELSE START
PRINTSTRING(" which hasn't been viewed")
-> NEXT
FINISH
FINISH ELSE START
CONNECT2(H_FILE(F) . "_VIEWKEYS", 1, 0, 0, KR, CFLAG)
-> NEXT UNLESS CFLAG = 0
!
CONNECT2(H_FILE(F) . "_VIEWDIR2", 1, 0, 0, VR, CFLAG)
-> NEXT UNLESS CFLAG = 0
DIRA = VR_CONAD
KEYA = KR_CONAD
FINISH
!
DIR == ARRAY(DIRA + 32, VDIRAF)
KEYS == ARRAY(KEYA + 32, KEYSF)
!
SUBFILE == ARRAY(ADDR(DIR(DIR(0)_I4)), S31AF)
P = 1
WHILE P <= DIR(-1)_I1 CYCLE
W = SUBFILE(P)
CYCLE J = 1, 1, H_TOPFILE
W = "" AND EXIT IF W = H_FILE(J); ! already have it
REPEAT
!
UNLESS W = "" START
J = 0
WHILE J < TOP STOP CYCLE
J = J + 1
W = "" AND EXIT IF W = STOP FILE(J); ! dont want it
REPEAT
FINISH
!
UNLESS W = "" START
H_TOPFILE = H_TOPFILE + 1
H_FILE(H_TOPFILE) = W
FINISH
P = P + 1
REPEAT
!
H_TOPIC(F) = DIR(-1)_SEC
K1 = INTEGER(KEYA) - 34; ! end of Viewkeys file
J = 0
LOOP:
-> NEXT IF J >= K1
J = J + 1 AND -> LOOP UNLESS KEYS(J) = NL
N = 0
WHILE '0' <= KEYS(J+1) <= '9' CYCLE
J = J + 1
N = N * 10 + KEYS(J) - '0'
REPEAT
!
IF LENGTH(DIR(N)_NAME) < 32 C
THEN NAME = DIR(N)_NAME C
ELSE START
LENGTH(NAME) = 31
MOVE(31, R_CONAD+INTEGER(ADDR(DIR(N)_NAME)+4)-X'40000', ADDR(NAME)+1)
FINISH
!
NAME = NAME . "¬" . DIR(N)_SEC
L = LENGTH(NAME)
MOVE(L, ADDR(NAME)+1, K)
K = K + L
!
CYCLE
J = J + 1
CH = KEYS(J)
BYTEINTEGER(K) = CH AND K = K + 1 UNLESS CH = ' '
REPEAT UNTIL KEYS(J) = NL
-> LOOP
NEXT:
PRINTSTRING(FAILUREMESSAGE(CFLAG)) UNLESS CFLAG = 0
NEXT1:
F = F + 1
NEWLINE
REPEAT
!
H_END = K - HA
TRIM("T#OUT", J)
!
PRINTSTRING("End: " . ITOS(H_END)); NEWLINE
PRINTSTRING(ITOS(H_TOPFILE) . " files"); NEWLINE
!
IF CHANGED = 1 START
IF EXIST("EXTRACT") = 0 C
THEN RENAME("T#OUT,EXTRACT") AND PERMIT("EXTRACT") C
ELSE NEWGEN("T#OUT,EXTRACT")
PRINTSTRING("Extract changed")
FINISH ELSE PRINTSTRING("No change")
END ; ! EXTRACT
!
!
!
EXTERNALROUTINE EXTRACTHELPDATA(STRING (255)S)
! RUNAUTO("EXTRACTHELPDATA")
PRINTSTRING("
EXTRACT:
")
EXTRACT("")
END ; ! EXTRACTHELPDATA
ENDOFFILE