github.com/PDP-10.stacken
1
0
Fork 0
mirror of https://github.com/PDP-10/stacken.git synced 2026-02-02 23:01:01 +00:00
Code Issues Projects Releases Wiki Activity
Files
6e18f5ebefd9acb0d718ef31a08f33a60fc9fca2
PDP-10.stacken/files/stacken-tape-backup/dskb:10_7/acct/actlib.mac
Lars Brinkhoff 6e18f5ebef Extract files from tape images. 
Some tapes could not be extracted.
2021-01-29 10:47:33 +01:00

2565 lines
78 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
UNIVERSAL ACTPRM - PARAMETER FILE FOR THE ACCOUNTING SUBROUTINE PACKAGE
;COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1985,1986. ALL RIGHTS RESERVED.
;
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
;INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
;COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
;OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
;AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
; VERSION NUMBERS
APRVER==1 ;VERSION NUMBER
APRMIN==1 ;MINOR VERSION NUMBER
APREDT==11 ;EDIT NUMBER
APRWHO==0 ;WHO EDITED LAST
%%ACTP==:<BYTE(3)APRWHO(9)APRVER(6)APRMIN(18)APREDT>
SALL ;CLEAN LISTINGS
.DIREC FLBLST ;CLEANER LISTINGS
SUBTTL REVISION HISTORY
; 1 QAR ?????? DPM Date unknown
; Creation.
;
; 2 QAR ?????? DPM/RCB Date unknown
; A few buggers.
;
; 3 No SPR DPM 9-Jul-86
; Create edit history to satisfy Autopatch requirements.
; 4 No SPR DPM 18-Jul-86
; Change name of DEFAULT-LOG-FILE to LOG-FILE-DEFAULT to make
; the folks at TWINKY happy.
; 5 No SPR JAD 7-Aug-86
; Change TEMP in ACTRMS to be a block of length .AEMAX, otherwise
; updates of large records may fail unexpectedly.
;
; 6 No SPR DPM 18-Aug-86
; Correct undefined globals and parsing of filespecs in DLG routines.
;
; 7 No SPR RCB 2-Dec-86
; ERRMSG wasn't preserving S1 under 7.02.
;
; 10 10-35694 JJF 19-Feb-87
; (Incorrectly made as edit 151 to ACTDAE.)
; Fix the (unsupported) NCRYPT algorithm in ALGCUS so that it
; decrypts correctly (thus matching the original LOGIN routine).
;
; 11 10-35725 DPM 27-Aug-87
; Defend against updating a profile whose length has changed and the
; user name is being set to one which already exists. The code to
; handle profile length variations must detect this case before setting
; the sign bit of user name word zero to prevent record corruption.
SUBTTL MODULE INITIALIZATION MACRO
; MACRO TO SEARCH THE APPROPRIATE UNIVERSALS AND TO INITIALIZE ASSEMBLY
DEFINE MODULE (NAME),<
SALL ;;CLEAN LISTINGS
.DIREC FLBLST ;;CLEAN LISTINGS
SEARCH ACTSYM ;;ACCOUNTING DEFINITIONS
SEARCH GLXMAC ;;GALAXY DEFINITIONS
; SEARCH ORNMAC ;;PARSING DEFINITIONS
PROLOG ('NAME) ;;INIT GALACTIC STUFF
%%ACTP==:%%ACTP ;;FORCE ACTPRM VERSION INTO THE SYMBOL TABLE
TWOSEG 400K ;;MAKE US SHARABLE
RELOC 400K ;;START LOADING THE HIGH SEG BY DEFAULT
> ;END DEFINE MODULE
MODULE (ACTPRM)
SUBTTL ASSEMBLY PARAMETERS
; ASSEMBLY PARAMETERS
ND ACTFIL,<SIXBIT /ACTDAE/> ;ACCOUNTING FILE NAME
; SPECIAL AC ASSIGNMENTS USED BY REACT AND CUSREA
U==.A13 ;POINTER TO USER BLOCK
X==.A14 ;ALTERNATE POINTER TO USER BLOCK
SUBTTL ERROR MACROS
DEFINE FATAL (PFX,TXT,DAT,RET<MAIN>),<.ERR. ("?",PFX,<TXT>,DAT,RET)>
DEFINE WARN (PFX,TXT,DAT,RET<.+1>),<.ERR. ("%",PFX,<TXT>,DAT,RET)>
DEFINE INFO (PFX,TXT,DAT,RET<.+1>),<.ERR. ("[",PFX,<TXT>,DAT,RET)>
DEFINE .ERR. (CHR,PFX,TXT,DAT,RET),<
PUSHJ P,[PUSHJ P,A$ERRM##
XWD CHR,''PFX''
XWD RET,[ITEXT (<TXT>)]
IFB <DAT>,< EXP 0>
IFNB <DAT>,< EXP DAT>
]
> ;END DEFINE .ERR.
SUBTTL PROFILE DESCRIPTORS
; PROFILE DESCRIPTORS USED IN THE TABLE DRIVEN CHANGE AND
; SELECTION CODE
PD.RTN==1B0 ;CALL A ROUTINE
PD.NSL==1B1 ;NO SELECTION IS TO BE DONE
PD.UNP==1B2 ;UNPRIVILEGED FIELD
PD.MSK==1B3 ;MASKABLE WORD
PD.EXT==1B4 ;EXTENSIBLE QUANTITY
PD.NMD==1B5 ;NOT MODIFIABLE VIA UGCUP$
PD.CND==1B6 ;CAN NOT BE DEFAULTED
PD.NDI==1B7 ;CAN NOT BE DISPLAYED
PD.WRD==777B17 ;WORD (REPEAT) COUNT
;DEFINE SOME SYMBOLS FOR DEALING WITH .AEMAP
DEFINE AE (NAM,LEN,BITS,RTN),<
.DF'NAM==<.AE'NAM/^D36> ;;WORD OFFSET IN MAP
DF.'NAM==1B<.AE'NAM-.DF'NAM*^D36> ;;BIT IN WORD
DF$'NAM==.AEMAP+.DF'NAM ;;WORD IN PROFILE
>
AEPROF ;DEFINE THE SYMBOLS
PURGE AE ;DON'T KEEP THE MACRO AROUND
SUBTTL PROFILE ENTRY VECTOR DEFINITIONS USED BY REACT AND CUSREA
; OFFSETS INTO THE PROFILE ENTRY VECTOR
CG.FLG==:0 ;FLAGS
FL.NTY==:1B0 ;IGNORE THIS BLOCK ON TYPEOUT
FL.XCR==:1B1 ;OUTPUT AN EXTRA CRLF AFTER TYPEOUT
CG.IDX==:1 ;PROFILE ENTRY INDEX
CG.PRM==:2 ;PROMPT STRING
CG.GET==:3 ;ROUTINE TO GET VALUES FROM COMMAND BLOCK
CG.CMP==:4 ;ROUTINE TO COMPARE VALUES IN TWO BLOCKS
CG.CHG==:5 ;ROUTINE TO REQUEST CHANGES FROM ACTDAE
CG.RES==:6 ;ROUTINE TO RESTORE OLD VALUES
CG.PRT==:7 ;ROUTINE TO TYPE OUT VALUES IN PRETTY FORM
CG.HLP==:10 ;ADDRESS OF HELP TEXT
CG.PRS==:11 ;ADDRESS OF PARSE BLOCKS
CG.PFL==:12 ;PROFILE OFFSET FOR ENTRY
CG.DFL==:13 ;ROUTINE TO RESET TO DEFAULTS
ENTNUM==:700000 ;INITIALIZE PROFILE ENTRY INDEX
; MACRO TO GENERATE THE PROFILE ENTRY VECTORS
DEFINE .ENTRY (ABV,PFL,TEXT,FLAGS,%A),<
.XCREF %A
.ASSIGN %A,ENTNUM,1
ABV:: EXP FLAGS
XLIST
EXP <%A&7777>+1
IFIW [ASCIZ \TEXT\]
IFIW ABV'GET
IFIW ABV'CMP
IFIW ABV'CHG
IFIW ABV'RES
IFIW ABV'PRT
IFIW ABV'HLP
IFIW ABV'PRS
EXP PFL
IFIW ABV'DFL
LIST
> ;END DEFINE .ENTRY
PRGEND
TITLE ACTERR - SUPPORT FOR THE ERROR MESSAGE MACROS
SEARCH ACTPRM
MODULE (ACTERR)
ENTRY A$ERRI
; INITIALIZE
A$ERRI::HRLZM S1,PGMPFX ;SAVE PROGRAM PREFIX
MOVEM S2,PGMSUB ;SAVE EXIT SUBROUTINE ADDRESS
POPJ P, ;RETURN
; THIS CODE CAN ONLY BE INVOKED BY USING THE FATAL, WARN, AND INFO
; MACROS DEFINED IN ACTPRM
A$ERRM::DMOVEM T1,ERRACS ;SAVE T1 AND T2
DMOVEM T3,ERRACS+2 ;SAVE T3 AND T4
HRRZ T1,(P) ;GET ADDRESS OF ARGS FROM CALL
POP P,(P) ;GET EXTRA PUSHJ OFF THE STACK
MOVE T2,2(T1) ;GET DATA WORD
MOVEM T2,ERRDAT ;SAVE
SKIPE PGMSUB ;ERROR SUBROUTINE SUPPLIED?
JRST ERRM1 ;YES
HRROI T2,.GTWCH ;GETTAB TO
GETTAB T2, ; RETURN WATCH BITS
SETZ T2, ;STRANGE ...
TXNN T2,JW.WPR!JW.WFL ;HAVE PREFIX OR FIRST LINE SET?
ERRM1: TXO T2,JW.WPR!JW.WFL ;NO--DEFAULT TO THEM
MOVEI T3," " ;GET A SPACE
TXNE T2,JW.WPR ;PREFIX?
TXNN T2,JW.WFL ; AND FIRST LINE?
SETZ T3, ;NO
MOVEM T3,ERRSPC ;SAVE SPACE
HLRZ T3,0(T1) ;GET INITIAL CHARACTER
MOVEM T3,ERRICH ;SAVE
MOVEI T4,"]" ;INCASE INFORMATIONAL
CAIE T3,"[" ;CHECK
MOVEI T4,0 ;ISN'T
MOVEM T4,ERRFCH ;SAVE FINAL CHARACTER
MOVE T3,PGMPFX ;GET PROGRAM PREFIX
HRR T3,0(T1) ;INCLUDE ERROR PREFIX
TXNN T2,JW.WPR ;WANT PREFIX?
SETZ T3, ;NO
MOVEM T3,ERRPFX ;SAVE
HRRZ T3,1(T1) ;GET ITEXT BLOCK
TXNN T2,JW.WFL ;WANT FIRST LINE?
MOVEI T3,[ITEXT (<>)] ;NO
MOVEM T3,ERRTXT ;SAVE
HLRZ T3,1(T1) ;GET RETURN ADDRESS
HRRM T3,(P) ;SAVE ON STACK
SKIPE PGMSUB ;ERROR SUBROUTINE SUPPLIED?
JRST ERRM2 ;YES--DON'T TYPE ANYTHING
MOVE T1,[2,,T2] ;SET UP UUO AC
MOVEI T2,.TOFLM ;FUNCTION CODE
MOVNI T3,1 ;-1 FOR US
TRMOP. T1, ;FORCE LEFT MARGIN
$TEXT (T%TTY,<>) ;OLD MONITOR, DO IT THE HARD WAY
ERRM2: DMOVE T1,ERRACS ;RESTORE T1 AND T2
DMOVE T3,ERRACS+2 ;RESTORE T3 AND T4
SKIPE PGMSUB ;ERROR SUBROUTINE SUPPLIED?
PJRST @PGMSUB ;YES--GIVE CALLER CONTROL
$TEXT (T%TTY,<^7/ERRICH/^W/ERRPFX/^7/ERRSPC/^I/@ERRTXT/^7/ERRFCH/>)
POPJ P, ;RETURN
; ROUTINE TO PROCESS A QUEUE. UUO ERROR
; CALL: MOVE T1, UUO AC
; MOVE T2, ADDRESS OF QUEUE. UUO BLOCK
; MOVE T3, RETURN ADDRESS
; MOVE T4, EXTRA DATA
; PUSHJ P,A$QERR
A$QERR::DMOVEM T1,ERRACS ;SAVE T1 AND T2
DMOVEM T3,ERRACS+2 ;SAVE T3 AND T4
MOVE T1,[ERRBLK,,ERRBLK+1] ;SET UP BLT
SETZM ERRBLK ;CLEAR FIRST WORD
BLT T1,ERRBLK+4 ;ZAP ENTIRE BLOCK
MOVE T1,[PUSHJ P,A$ERRM] ;INSTRUCTION TO CALL ERROR HANDLER
MOVEM T1,ERRBLK+0
POP P,T1 ;PHASE STACK
SKIPN T3 ;HAVE A RETURN ADDRESS
MOVE T3,T1 ;NO--RETURN .+1
HRLZM T3,ERRBLK+2 ;SAVE
MOVEM T4,ERRBLK+3 ;SAVE EXTRA DATA
; CHECK FOR A RESPONSE BLOCK
QERR1: DMOVE T1,ERRACS ;GET T1 AND T2 BACK
TXNE T1,QU.RBT!QU.RBR;RESPONSE BLOCK RETURNED?
JUMPN T2,QERR2 ;YES
MOVE T2,T1 ;COPY ERROR CODE
MOVEM T2,ERRTMP ;SAVE INCASE UNKNOWN
CAIL T2,QUEELN ;KNOWN ERROR CODE?
MOVEI T2,0 ;NO
MOVS T3,QUEETB(T2) ;GET PREFIX,,ITEXT
HLRM T3,ERRBLK+2 ;SAVE ITEXT
HRLI T3,"?" ;FATAL ERROR
MOVEM T3,ERRBLK+1 ;SAVE PREFIX
JRST QERR4 ;FINISH UP
QERR2: MOVEI T1,[ITEXT(<^T/@ERRTMP/>)]
HRRM T1,ERRBLK+2 ;SAVE ITEXT BLOCK
HRRZ T2,.QURSP(T2) ;GET ADDRESS OF THE RESPONSE BLOCK
MOVE T1,(T2) ;GET PREFIX CHARACTER AND SIXBIT PREFIX
MOVEM T1,ERRBLK+1 ;SAVE
MOVEI T1,1(T2) ;POINT TO START OF STRING
MOVEM T1,ERRTMP ;SAVE ADDRESS FOR LATER
HRLI T1,(POINT 7,) ;MAKE A BYTE POINTER
QERR3: ILDB T3,T1 ;GET A CHARACTER
CAIE T3,.CHLFD ;LINE FEED?
CAIN T3,.CHCRT ;CARRIAGE RETURN?
MOVEI T3,.CHNUL ;YES--WE DON'T DO MULTI-LINE STUFF
IDPB T3,T1 ;PUT A CHARACTER
SKIPE T3 ;DONE?
JRST QERR3 ;NO
QERR4: DMOVE T1,ERRACS+0 ;RESTORE T1 AND T2
DMOVE T3,ERRACS+2 ;RESTORE T3 AND T4
PUSHJ P,ERRBLK ;GENERATE ERROR MESSAGE (NEVER RETURN)
QUEETB: XWD 'UUE',[ITEXT (<Unknown QUEUE. UUO error ^O/ERRTMP/>)]
XWD 'IAL',[ITEXT (<Illegal argument list>)]
XWD 'IFC',[ITEXT (<Illegal function code>)]
XWD 'NFC',[ITEXT (<No monitor free core>)]
XWD 'ADC',[ITEXT (<Address check>)]
XWD 'CNR',[ITEXT (<Component not running; no system pid>)]
XWD 'EFO',[ITEXT (<Fatal error returned from component>)]
XWD 'IMO',[ITEXT (<Invalid message from component>)]
XWD 'NPV',[ITEXT (<Not privileged>)]
XWD 'NRA',[ITEXT (<No response from component>)]
QUEELN==.-QUEETB
LIT
RELOC 0
PGMSUB: BLOCK 1 ;ERROR SUBROUTINE
PGMPFX: BLOCK 1 ;3-CHARACTER PROGRAM PREFIX
ERRBLK: BLOCK 5 ;DUMMY ERROR BLOCK
ERRTMP: BLOCK 1 ;TEMP STORAGE
ERRACS::BLOCK 4 ;ERROR ACS (T1-T4)
ERRDAT::BLOCK 1 ;DATA WORD
ERRPFX::BLOCK 1 ;ERROR PREFIX
ERRTXT::BLOCK 1 ;ERROR TEXT
ERRICH::BLOCK 1 ;INITIAL ERROR CHARACTER
ERRFCH::BLOCK 1 ;FINAL ERROR CHARACTER
ERRSPC::BLOCK 1 ;SPACE CHARACTER
PRGEND
TITLE ACTNAM - CHECK FOR RESERVED NAMES
SEARCH ACTPRM
MODULE (ACTNAM)
ENTRY A$CKNM, A$CKPP
; THIS ROUTINE WILL WEED OUT RESERVED NAMES SUCH AS "*-DEFAULT"
; AND "NNN-DEFAULT" WHERE NNN IS A VALID PROJECT NUMBER. THE
; RESERVED NAMES ARE USED FOR THE DEFAULT PROFILES. THIS ALSO
; CHECKS FOR "POSTMASTER", THE STANDARD NAME RESERVED FOR MAIL.
;
; NOTE THAT IN THE COMPARE LOOP BELOW, THE CHARACTER FROM OUR
; INTERNAL STRING IS CASE SHIFTED RATHER THAN MESSING AROUND
; WITH THE USER SUPPLIED STRING WHICH COULD CONTAIN UGLY 8-BIT
; CHARACTERS AND NECESSITATE THE USE OF ELABORATE CASE SHIFTING
; SCHEMES.
;
; RETURNS TRUE IF NAME IS OK FOR GENERAL USE. RETURNS FALSE IF THE NAME
; IS RESERVED TO THE ACCOUNTING SYSTEM. ON THE FALSE RETURN, S1 HOLDS
; THE PPN CORRESONDING TO THE RESERVED NAME.
A$CKNM::PUSHJ P,.SAVET ;SAVE T1-T4
PUSHJ P,.SAVE1 ;AND ANOTHER
MOVE T1,S1 ;COPY ADDRESS OF NAME
HRLI T1,(POINT 8,) ;8-BIT ASCIZ
MOVEI T2,^D39-1 ;LENGTH MINUS ONE
MOVEI T3,6 ;DIGIT COUNTER
MOVNI T4,1 ;ASSUME AN ASTERISK IS ON THE WAY
ILDB S1,T1 ;GET A CHARACTER
CAIE S1,"P" ;PERHAPS "POSTMASTER"
CAIN S1,"P"+40 ; IN EITHER CASE?
SOJA T3,CKNM4 ;GO CHECK IT OUT
SETO T4, ;PROJECT FOR "*-DEFAULT"
CAIN S1,"*" ;SPECIAL DEFAULT FOR ALL PPNS?
SOJA T3,CKNM2 ;YES--COUNT NEXT CHARACTER WE'RE ABOUT TO GET
TDZA T4,T4 ;CLEAR PROJECT NUMBER RESULT
CKNM1: ILDB S1,T1 ;GET A CHARACTER
CAIL S1,"0" ;RANGE
CAILE S1,"7" ; CHECK
JRST CKNM3 ;NOT A DIGIT
IMULI T4,10 ;PROJECT NUMBERS ARE OCTAL
ADDI T4,-"0"(S1) ;ADD IN DIGIT
SOSLE T2 ;COUNT NEXT CHARACTER WE'RE ABOUT TO GET
SOJG T3,CKNM1 ;LOOP BACK
SKIPA ;NOW CHECK FOR A DASH
CKNM2: ILDB S1,T1 ;GET NEXT CHARACTER
CKNM3: CAIE S1,"-" ;OCTAL STRING FOLLOWED BY A DASH?
$RETT ;NAME IS LEGAL
CAML T4,[-1] ;RANGE
CAILE T4,377777 ; CHECK
$RETT ;OK NAME IF PROJECT OUT OF RANGE
MOVE T3,[POINT 7,[ASCIZ /DEFAULT/]] ;POINT TO "DEFAULT"
MOVEI P1,7 ;CHARACTER COUNT
JRST CKNM5 ;ENTER LOOP
CKNM4: MOVE T3,[POINT 7,[ASCIZ /OSTMASTER/]] ;STANDARD RESERVED FOR MAIL
MOVEI P1,11 ;CHARACTER COUNT
MOVSI T4,'UPS' ;ERSATZ DEVICE RESERVED TO MAIL
DEVPPN T4,UU.PHY ;OBTAIN POSTMASTER'S PPN
MOVE T4,[5,,35] ;DEFAULT VALUE
CKNM5: ILDB S1,T1 ;GET CHARACTER FROM NAME
ILDB S2,T3 ;GET CHARACTER FROM SPECIAL STRING
MOVEI TF,40(S2) ;GET LOWER CASE EQUIVALENT TOO
CAIE S2,(S1) ;MATCH UPPER CASE?
CAIN TF,(S1) ;MATCH LOWER CASE?
SKIPA ;YES
$RETT ;NAME IS LEGAL
SOJLE T2,.RETT ;RETURN IF NAME RUNS OUT
SOJG P1,CKNM5 ;LOOP
TLNN T4,-1 ;HAVE A PPN OR A PROJECT?
HRLOS T4 ;PROJECT, MAKE IT A PPN
MOVE S1,T4 ;RETURN THE CORRESPONDING PPN
$RETF ;REQUESTED NAME IS RESERVED TO ACCT SYSTEM
; THIS ROUTINE CHECKS A PPN TO SEE IF IT IS ONE OF THOSE RESERVED TO THE
; ACCOUNTING SYSTEM.
;
; RETURNS TRUE IF THE PPN IS OK FOR GENERAL USE. RETURNS FALSE IF THE PPN
; IS RESERVED. BOTH RETURNS LEAVE S1 POINTING TO AN ASCIZ (7-BIT) TEXT
; STRING WHICH IS THE DEFAULT (OR RESERVED) NAME FOR THAT PPN.
A$CKPP::MOVE S2,S1 ;COPY THE PPN SUPPLIED
AOJE S2,CKPP.0 ;*-DEFAULT IF [%,%]
HLLO S2,S1 ;NO, GET PROJECT-DEFAULT FOR GIVEN VALUE
CAMN S2,S1 ;MATCH?
JRST CKPP.1 ;YES, GO DEAL WITH NNN-DEFAULT
MOVSI S2,'UPS' ;NO, GET MAILER'S ERSATZ DEVICE
DEVPPN S2,UU.PHY ;GET CORRESPONDING PPN
MOVE S2,[5,,35] ;DEFAULT
CAMN S2,S1 ;MATCH?
JRST CKPP.2 ;YES, GO RETURN POSTMASTER
$TEXT (<-1,,PPNNAM>,<^O/S1,LHMASK/,^O/S1,RHMASK/^0>)
MOVEI S1,PPNNAM ;POINT TO BLOCK FOR "P,PN" NAME
$RETT ;NON-RESERVED PPN
CKPP.0: MOVEI S1,[ASCIZ /*-DEFAULT/] ;POINT TO NAME FOR [%,%]
$RETF ;RESERVED PPN
CKPP.1: $TEXT (<-1,,PPNNAM>,<^O/S1,LHMASK/-DEFAULT^0>)
MOVEI S1,PPNNAM ;POINT TO BLOCK FOR NNN-DEFAULT
$RETF ;RESERVED PPN
CKPP.2: MOVEI S1,[ASCIZ /POSTMASTER/] ;NAME FOR MAILER'S PPN
$RETF ;RESERVED PPN
LIT
RELOC 0 ;LOWSEG
PPNNAM: BLOCK .AANLW ;SPACE TO MAKE A NAME
PRGEND
TITLE ACTPRS - PARSE AN OPTIONALLY WILDCARDED USER-ID
SEARCH ACTPRM
MODULE (ACTPRS)
ENTRY A$PWLD
; PARSE A USER-ID
; CALL: MOVE T1, WILDCARD BLOCK ADDRESS
; MOVE T2, BYTE POINTER TO USER-ID ACK BLOCK
; PUSHJ P,A$PWLD
;
; TRUE RETURN: WILDCARD AND ACK BLOCKS FILLED IN
; FALSE RETURN: NO PPN, NAME, OR QUOTED STRING TO BE PARSED
A$PWLD::PUSHJ P,.SAVE2 ;SAVE P1 AND P2
DMOVE P1,T1 ;COPY WILDCARD BLOCK, BYTE POINTER
MOVSI T1,0(P1) ;POINT TO START OF WILDCARD BLOCK
HRRI T1,1(P1) ;MAKE A BLT POINTER
SETZM (P1) ;CLEAR FIRST WORD
BLT T1,UW$SEL-1(P1) ;CLEAR ALL BUT SELECTION COUNT AND DATA
PUSHJ P,P$USER## ;TRY TO GET A PPN
JUMPT PRSPPN ;GOT IT
PUSHJ P,P$FLD## ;ELSE GO FOR A NAME
JUMPT PRSNAM ;GOT IT
PUSHJ P,P$QSTR## ;PERHAPS A QUOTED STRING?
JUMPT PRSQST ;YES
$RETF ;GIVE UP
; PARSE A PPN
PRSPPN: SETZM UW$WST(P1) ;SET WILDCARD SEARCH TYPE TO PPN
LOAD S1,ARG.HD(S2),AR.LEN ;GET RETURNED LENGTH
DMOVE T1,ARG.DA(S2) ;GET PPN AND POSSIBLE MASK
CAIE S1,3 ;WAS A MASK RETURNED?
MOVNI T2,1 ;NO--DEFAULT TO NON-WILD
ORCM T1,T2 ;MAKE SURE WILD FIELDS GET CAUGHT BELOW
MOVEM T1,UW$PPN(P1) ;SAVE PPN
MOVEM T2,UW$PPM(P1) ;SAVE MASK
PJRST PPNACK## ;GENERATE ACK TEXT AND RETURN
; PARSE A NAME
PRSNAM: MOVE T1,[POINT 8,1(S1)] ;POINT AT USERNAME
MOVEI T3,UW$NAM(P1) ;NAME FOR WILDCARDING
HRLI T3,(POINT 8,) ;8-BIT ASCIZ
PUSH P,[EXP 0] ;INIT WILD FLAG
MOVEI T2,1 ;INIT OTHER WILD FLAG
PRSNA1: ILDB S2,T1 ;GET A BYTE
IDPB S2,T3 ;STORE IN NAME FOR WILDCARDING
CAIE S2,"*" ;IS IT A WILDCARD?
CAIN S2,"?" ;OR A DIFFERENT WILDCARD?
ADDM T2,(P) ;MAYBE FLAG THE FACT
CAIN S2,.CHCNV ;IS THIS THE QUOTE CHARACTER?
TDZA T2,T2 ;YES, NEXT CHARACTER CAN'T LIGHT THE WILD FLAG
MOVEI T2,1 ;NO, NEXT CHARACTER GETS CHECKED NORMALLY
JUMPN S2,PRSNA1 ;LOOP
POP P,S1 ;GET FLAG BACK
MOVEI S2,1 ;ASSUME WILDCARDED NAME
SKIPN S1 ;TEST
MOVEI S2,2 ;NON-WILDCARDED NAME
MOVEM S2,UW$WST(P1) ;SAVE WILDCARD SEARCH TYPE
PJRST NAMACK## ;GENERATE ACK TEXT AND RETURN
; PARSE A QUOTED NAME
PRSQST: MOVE T1,[POINT 8,1(S1)] ;POINT AT USERNAME
MOVEI T2,UW$NAM(P1) ;NAME FOR WILDCARDING
HRLI T2,(POINT 8,) ;8-BIT ASCIZ
PRSQS1: ILDB S2,T1 ;GET A BYTE
IDPB S2,T2 ;STORE IN NAME FOR WILDCARDING
JUMPN S2,PRSQS1 ;LOOP
MOVEI S1,2 ;GET CODE
MOVEM S1,UW$WST(P1) ;SET WILDCARD SEARCH TYPE TO NON-WILD NAME
PJRST NAMACK## ;GENERATE ACK TEXT AND RETURN
LIT
PRGEND
TITLE ACTACK - ACK TEXT GENERATOR
SEARCH ACTPRM
MODULE (ACTACK)
ENTRY A$WACK, NAMACK, PPNACK
; GENERATE ACK TEXT BASED ON WILDCARD BLOCK
; CALL: MOVE T1, WILDCARD BLOCK ADDRESS
; MOVE T2, BYTE POINTER TO USER-ID ACK BLOCK
; PUSHJ P,A$GACK
A$WACK::PUSHJ P,.SAVE2 ;SAVE P1 AND P2
DMOVE P1,T1 ;COPY WILDCARD BLOCK, BYTE POINTER
SKIPN UW$WST(P1) ;SKIP IF SEARCHING BY NAME
JRST PPNACK ;IT'S PPN
NAMACK::MOVEI T2,UW$NAM(P1) ;POINT TO NAME
HRLI T2,(POINT 8,) ;8-BIT ASCIZ
NAMAC1: ILDB T1,T2 ;GET A BYTE
IDPB T1,P2 ;PUT A BYTE
JUMPN T1,NAMAC1 ;LOOP BACK
POPJ P, ;AND RETURN
PPNACK::MOVEI T1,"[" ;GET A BRACKET
IDPB T1,P2 ;STORE
HLLZ T1,UW$PPN(P1) ;GET PROJECT NUMBER
HLR T1,UW$PPM(P1) ;AND MASK
PUSHJ P,PPNAC1 ;TYPE MASKED OCTAL HALF WORD
MOVEI T1,"," ;GET A COMMA
IDPB T1,P2 ;STORE
HRLZ T1,UW$PPN(P1) ;GET PROGRAMMER NUMBER
HRR T1,UW$PPM(P1) ;AND MASK
PUSHJ P,PPNAC1 ;TYPE MASKED OCTAL HALF WORD
MOVEI T1,"]" ;GET A BRACKET
IDPB T1,P2 ;STORE
MOVEI T1,0 ;GET A NUL
IDPB T1,P2 ;TERMINATE STRING
POPJ P, ;AND RETURN
PPNAC1: TRCN T1,-1 ;MAKE MASK BIT 0 IF NOT WILD
JRST PPNAC5 ;TYPE * IF ALL WILD
HLRZ T2,T1 ;GET LH
CAIN T2,-2 ;FUNNY NUMBER?
JRST PPNAC6 ;YES
CAIN T2,-1 ;DEFAULT NUMBER?
JRST PPNAC7 ;YES
MOVE T2,T1 ;MOVE TO CONVENIENT PLACE
MOVEI T3,6 ;SET LOOP COUNT
PPNAC2: MOVEI T1,0 ;CLEAR ACCUMULATOR
LSHC T1,3 ;POSITION FIRST DIGIT
JUMPN T1,PPNAC4 ;GO IF NON-ZERO
SOJG T3,PPNAC2 ;LOOP UNTIL ALL DONE
PPNAC3: MOVEI T1,0 ;CLEAR ACCUMULATOR
LSHC T1,3 ;GET NEXT DIGIT
PPNAC4: ADDI T1,"0" ;CONVERT TO ASCII
TLNE T2,7 ;CHECK MASK
MOVEI T1,"?" ;CHANGE TO ? IF WILD
IDPB T1,P2 ;STORE CHARACTER
SOJG T3,PPNAC3 ;LOOP UNTIL DONE
POPJ P, ;RETURN
PPNAC5: MOVEI T1,"*" ;GET AN ASTERISK
IDPB T1,P2 ;STORE CHARACTER
POPJ P, ;RETURN
PPNAC6: SKIPA T1,["#"] ;FUNNY CHARACTER
PPNAC7: MOVEI T1,"%" ;DEFAULT CHARACTER
IDPB T1,P2 ;STORE CHARACTER
POPJ P, ;RETURN
LIT
PRGEND
TITLE ACTQUE - QUEUE UP A REQUEST FOR A PROFILE
SEARCH ACTPRM
MODULE (ACTQUE)
ENTRY A$QWLD
; QUEUE A REQUEST FOR A POSSIBLY WILDCARDED USER-ID TO [SYSTEM]ACCOUNTING
; CALL: MOVE T1, WILDCARD BLOCK ADDRESS
; MOVE T2, RESPONSE BLOCK ADDRESS
; MOVE T3, DEBUGGING PID ADDRESS,,MAXIMUM NUMBER OF SECONDS TO WAIT
; MOVE T4, PRIV-ENABLE FLAG (FALSE-OFF, TRUE-ON)
; PUSHJ P,A$QWLD
;
; TRUE RETURN: FIRST/NEXT PROFILE RETURNED IN SPECIFIED BLOCK
; FLASE RETURN: PROFILE NOT FOUND, S1 CONTAINS THE QUEUE. UUO ERROR CODE
ND .QUPID,.QUTIM+1 ;IN CASE NOT YET IN UUOSYM
A$QWLD::PUSHJ P,.SAVE1 ;SAVE P1
SKIPN DEBUGW ;ARE WE DEBUGGING IN GALACTIC STYLE?
ANDI T3,-1 ;NO, IGNORE THE PID ADDRESS
MOVEI P1,QUEBLK ;POINT TO ARG BLOCK
MOVE S1,[QF.RSP+.QUMAE] ;WANT RESPONSE BLOCK + ACCOUNTING FUNCTION
MOVEM S1,.QUFNC(P1) ;SAVE
SETZM .QUNOD(P1) ;CENTRAL STATION
MOVE S1,T2 ;GET RESPONSE BLOCK ADDRESS
HRLI S1,.AEMAX ;LENGTH OF A USER PROFILE
MOVEM S1,.QURSP(P1) ;SAVE
HRLI P1,.QUARG ;LENGTH OF BLOCK SO FAR
JUMPE T3,QWLD1 ;SKIP THIS STUFF IF NO TIME LIMIT
MOVE S1,[%CNDAE] ;GETTAB ARGUMENT
GETTAB S1, ;GET MONITOR VERSION
SETZ S1, ;ANCIENT MONITOR
HRRZS S1 ;STRIP OFF THE SIXBIT STUFF
CAIGE S1,703 ;CAN QUEUE. UUO TIMEOUT?
JRST QWLD1 ;NO
HRRZM T3,.QUTIM(P1) ;SAVE
ADD P1,[1,,0] ;UPDATE THE HEADER LENGTH
TLNN T3,-1 ;DO SOME MORE?
JRST QWLD1 ;NO, SKIP .QUPID
HLRZ S1,T3 ;YES, GET PID ADDRESS
MOVE S1,(S1) ;FETCH VALUE
JUMPE S1,QWLD1 ;IGNORE THIS IF WANT DEFAULT PID AFTER ALL
MOVEM S1,.QUPID(P1) ;SET FOR QUEUE. UUO
ADD P1,[1,,0] ;ANOTHER HEADER WORD
QWLD1: HLRZ S1,P1 ;GET WORD COUNT SO FAR
CAIE S1,.QUARG ;IF NOT THE DEFAULT,
DPB S1,[POINTR .QUFNC(P1),QF.HLN] ;STORE HEADER LENGTH
ADD P1,S1 ;POINT AT FIRST FREE WORD
DMOVE S1,[EXP <QA.IMM!1B17!.QBAFN>,UGWLD$] ;ACCOUNTING SUB-FUNCTION
SKIPE T4 ;WANT PRIVS?
TXO S2,AF.PRV ;YES, REQUEST THEM
DMOVEM S1,(P1) ;SAVE
ADD P1,[2,,2] ;ADVANCE POINTER
HLRZ S1,UW$TYP(T1) ;GET LENGTH OF MESSAGE
SKIPN S1 ;IS IT SET UP?
MOVEI S1,UW$MIN ;NO--DEFAULT TO MINIMUM LENGTH
CAIN S1,UW$MIN ;ANY SELECTION DATA?
SETZM UW$SEL(T1) ;NO--CLEAR OUT BLOCK COUNT
HRLZS S1 ;PUT LENGTH IN LH
HRRI S1,.QBAET ;INCLUDE BLOCK TYPE
MOVE S2,T1 ;POINT TO WILDCARD BLOCK
DMOVEM S1,(P1) ;SAVE
ADD P1,[2,,2] ;ADVANCE POINTER
HLRZ S1,P1 ;GET LENGTH OF BLOCK
SUBB P1,S1 ;SET UP UUO AC
QUEUE. S1, ;SEND REQUEST TO ACCOUNTING DAEMON
$RETF ;NO SUCH USER
QWLD2: MOVE S1,.AEPPN(T2) ;GET RESULT
MOVEM S1,UW$BRE(T1) ;SAVE
MOVSI S1,.AENAM(T2) ;POINT TO NAME
HRRI S1,UW$BRE(T1) ;AND DESTINATION
SKIPE UW$WST(T1) ;SKIP IF WILDCARDING BY PPN
BLT S1,UW$ERE(T1) ;COPY FOR NEXT CALL
AOS UW$FND(T1) ;COUNT THE PROFILE RETURNED
$RETT ;YES
LIT
RELOC 0
QUEBLK: BLOCK 11 ;QUEUE. UUO ARGUMENT BLOCK
PRGEND
TITLE ACTRMS - RMS-10 INTERFACE TO ACTDAE
SEARCH RMSINT,ACTPRM
MODULE (ACTRMS)
ENTRY INITIO
; SYMBOLS UNIQUE TO RMS THAT CALLERS MAY CARE ABOUT. SAVES THEM HAVING
; TO USE RMSINT
INTERN ER$RNF,ER$DUP,SU$DUP,ER$CHG,ER$COF,ER$EOF,ER$FNF,ER$PRV
INTERN ER$RSZ,ER$RTB
; SPECIAL AC DEFINITIONS
F==13 ;CURRENT FAB
R==14 ;CURRENT RAB
SUBTTL RMS-10 DATA STRUCTURES
; PROTOTYPE FAB
FAB: FAB$B ;INITIALIZE A FAB
F$BSZ ^D9 ;FILE BYTE SIZE
F$BKS ^D5 ;BUCKET SIZE FOR FILE
F$FOP FB$CIF ;CREATE IF NOT FOUND
F$MRS <<<<<.AEMAX>*4>>>> ;MAX RECORD (PROFILE) SIZE
F$ORG FB$IDX ;INDEXED MODE
F$RFM FB$VAR ;VARIABLE LENGTH RECORDS
F$SHR FB$NIL ;NO SHARING
FAB$E ;END OF FAB
; PROTOTYPE RAB
RAB: RAB$B ;INITIALIZE THE RAB
R$KRF 0 ;DEFAULT KEY OF REF IS PRI INDEX
R$MBF ^D8 ;ALLOW SOME REASONABLE # OF BUFFERS
R$PAD 0 ;PAD CHAR
RAB$E ;END OF RAB
; PROTOTYPE XAB FOR AREA 1 (PPN)
XABA1: XAB$B ALL ;ALLOCATION
X$AID 1 ;PPN INDEX
X$BKZ 1 ;BUCKET SIZE
XAB$E ;END OF XAB
; PROTOTYPE XAB FOR AREA 2 (NAME SECONDARY DATA BUCKETS)
XABA2: XAB$B ALL ;ALLOCATION
X$AID 2 ;NAME SIDRS
X$BKZ 1 ;BUCKET SIZE
XAB$E ;END OF XAB
; PROTOTYPE XAB FOR AREA 3 (NAME INDEX)
XABA3: XAB$B ALL ;ALLOCATION
X$AID 3 ;NAME INDEX
X$BKZ 1 ;BUCKET SIZE
XAB$E ;END OF XAB
; PROTOTYPE XAB FOR KEY 0
XABK0: XAB$B KEY ;KEY
X$REF 0 ;THIS IS THE PRIMARY KEY
X$DTP XB$EBC ;EBCDIC (9 BIT BYTES)
X$DAN 0 ;IT LIVES IN THIS DATA AREA
X$DFL 1 ;FILL 1/2 FULL
X$IAN 1 ;IT LIVES IN THIS INDEX AREA
X$IFL 1 ;FILL 1/2 FULL
X$POS <<<<<.AEPPN>*4>>>> ;OFFSET TO PPN
X$SIZ ^D4 ;SIZE OF PPN (BYTES)
XAB$E ;END OF XAB
; PROTOTYPE XAB FOR KEY 1
XABK1: XAB$B KEY ;KEY
X$REF 1 ;THIS IS THE SECOND KEY
X$DTP XB$EBC ;EBCDIC (9 BIT BYTES)
X$DAN 2 ;IT LIVES IN THIS DATA AREA
X$DFL 1 ;FILL 1/2 FULL
X$IAN 3 ;IT LIVES IN THIS INDEX AREA
X$IFL 1 ;FILL 1/2 FULL
X$POS <<<<.AENAM*4>>>> ;OFFSET TO NAME
X$SIZ .AANLC ;SIZE OF NAME (BYTES)
X$FLG XB$CHG ;VALUE OF KEY MAY CHANGE
XAB$E ;END OF XAB
SUBTTL RMS-10 INTERFACE INITIALIZATION
; INITIALIZE RMS-10 INTERFACE
; CALL: PUSHJ P,INITIO
INITIO::SETOM SAVFLG ;INIT AC SAVE ROUTINES
PUSHJ P,ENTX ;SWITCH CONTEXTS
JRST .POPJ1 ;RETURN FOR NOW
SUBTTL OPEN A FILE
; CALL: MOVE AC1, ADDRESS OF ASCIZ FILESPEC
; MOVE AC2, READ/WRITE FLAG (0 = READ, 1 = WRITE)
; PUSHJ P,OPNA/OPNB/OPNC
OPNA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
XMOVEI T1,A.ZBEG ;POINT TO START OF STORAGE
XMOVEI T2,A.ZEND ;POINT TO END OF STORAGE
XMOVEI T3,A.WXA1 ;WORKING XAB FOR AREA 1
MOVEM T3,X.WXA1 ;SAVE
XMOVEI T3,A.WXA2 ;WORKING XAB FOR AREA 2
MOVEM T3,X.WXA2 ;SAVE
XMOVEI T3,A.WXA3 ;WORKING XAB FOR AREA 3
MOVEM T3,X.WXA3 ;SAVE
XMOVEI T3,A.WXK0 ;WORKING XAB FOR KEY 0
MOVEM T3,X.WXK0 ;SAVE
XMOVEI T3,A.WXK1 ;WORKING XAB FOR KEY 1
MOVEM T3,X.WXK1 ;SAVE
PUSHJ P,OPNCOM ;OPEN THE FILE
POPJ P, ;FAILED
PUSHJ P,CLSCOM ;NOW CLOSE THE FILE
POPJ P, ;SHOULDN'T FAIL
PUSHJ P,OPNFIX ;FIX UP FILE PROTECTION AND STATUS WORD
XMOVEI T1,A.ZBEG ;POINT TO START OF STORAGE
XMOVEI T2,A.ZEND ;POINT TO END OF STORAGE
PJRST OPNCOM ;ENTER COMMON CODE
OPNB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
XMOVEI T1,B.ZBEG ;POINT TO START OF STORAGE
XMOVEI T2,B.ZEND ;POINT TO END OF STORAGE
XMOVEI T3,B.WXA1 ;WORKING XAB FOR AREA 1
MOVEM T3,X.WXA1 ;SAVE
XMOVEI T3,B.WXA2 ;WORKING XAB FOR AREA 2
MOVEM T3,X.WXA2 ;SAVE
XMOVEI T3,B.WXA3 ;WORKING XAB FOR AREA 3
MOVEM T3,X.WXA3 ;SAVE
XMOVEI T3,B.WXK0 ;WORKING XAB FOR KEY 0
MOVEM T3,X.WXK0 ;SAVE
XMOVEI T3,B.WXK1 ;WORKING XAB FOR KEY 1
MOVEM T3,X.WXK1 ;SAVE
PUSHJ P,OPNCOM ;OPEN THE FILE
POPJ P, ;FAILED
PUSHJ P,CLSCOM ;NOW CLOSE THE FILE
POPJ P, ;SHOULDN'T FAIL
PUSHJ P,OPNFIX ;FIX UP FILE PROTECTION AND STATUS WORD
XMOVEI T1,B.ZBEG ;POINT TO START OF STORAGE
XMOVEI T2,B.ZEND ;POINT TO END OF STORAGE
PJRST OPNCOM ;ENTER COMMON CODE
OPNC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
XMOVEI T1,C.ZBEG ;POINT TO START OF STORAGE
XMOVEI T2,C.ZEND ;POINT TO END OF STORAGE
XMOVEI T3,C.WXA1 ;WORKING XAB FOR AREA 1
MOVEM T3,X.WXA1 ;SAVE
XMOVEI T3,C.WXA2 ;WORKING XAB FOR AREA 2
MOVEM T3,X.WXA2 ;SAVE
XMOVEI T3,C.WXA3 ;WORKING XAB FOR AREA 3
MOVEM T3,X.WXA3 ;SAVE
XMOVEI T3,C.WXK0 ;WORKING XAB FOR KEY 0
MOVEM T3,X.WXK0 ;SAVE
XMOVEI T3,C.WXK1 ;WORKING XAB FOR KEY 1
MOVEM T3,X.WXK1 ;SAVE
PUSHJ P,OPNCOM ;OPEN THE FILE
POPJ P, ;FAILED
PUSHJ P,CLSCOM ;NOW CLOSE THE FILE
POPJ P, ;SHOULDN'T FAIL
PUSHJ P,OPNFIX ;FIX UP FILE PROTECTION AND STATUS WORD
XMOVEI T1,C.ZBEG ;POINT TO START OF STORAGE
XMOVEI T2,C.ZEND ;POINT TO END OF STORAGE
PJRST OPNCOM ;ENTER COMMON CODE
; COMMON OPEN CODE
OPNCOM: PUSHJ P,OPNINI ;INIT STORAGE, FETCH ARGS, SETUP FAB/RAB
POPJ P, ;FAILED
$FETCH T1,FAC,0(F) ;GET THE DESIRED ACCESS MODE
TXNN T1,FB$PUT ;DID WE ASK FOR WRITE ACCESS?
JRST OPNCO1 ;NO, CAN'T DO $CREATE
$CREATE 0(F) ;OPEN THE FILE. AS THIS IS THE FIRST
; RMS CALL, ACS 1 TO 4 MAY HAVE BEEN TRASHED
JRST OPNCO2 ;CONTINUE
OPNCO1: $OPEN 0(F) ;READ ONLY, CAN'T DO $CREATE EVEN THOUGH
; IT'S A CREATE-IF THAT WOULDN'T
OPNCO2: PUSHJ P,ERRCKF ;CHECK FOR ERRORS
POPJ P, ;FAILED
PUSHJ P,OPNBLK ;INIT FILOP, L/E/R, AND PATH BLOCKS
$CONNEC 0(R) ;SET UP AN IO STREAM
PUSHJ P,ERRCKR ;CHECK FOR ERRORS
POPJ P, ;FAILED
PUSHJ P,DOLOA ;SET LOAD MODE IF REQUESTED
JFCL ;IGNORE ERRORS
PUSHJ P,UPDFIX ;SEE IF PREVIOUS UPDATE NEEDS FIXING UP
POPJ P, ;IT DID AND IT FAILED
JRST .POPJ1 ;RETURN
; INITIALIZE FILE PROCESSING
; THIS ROUTINE WILL DO THE FOLLOWING:
; 1. ZERO STORAGE FOR THIS FILE
; 2. FETCH OPEN ARGUMENTS
; 3. SET UP FAB
; 4. SET UP RAB
;
; CALL: MOVE T1, START ADDRESS OF STORAGE
; MOVE T2, ENDING ADDRESS OF STORAGE
; MOVE F, ADDRESS OF THE WORKING FAB
; MOVE R, ADDRESS OF THE WORKING RAB
; PUSHJ P,OPNINI
OPNINI: SETZM 0(T1) ;CLEAR FIRST WORD
HRLS T1 ;COPY START ADDRESS TO LH
HRRI T1,1(T1) ;MAKE A BLT POINTER
BLT T1,-1(T2) ;CLEAR STORAGE
; FETCH ARGUMENTS
MOVE T1,SAVACS+1 ;GET ADDRESS OF ASCIZ FILESPEC
SKIPN T2,SAVACS+2 ;GET READ/WRITE FLAG
SKIPA T2,[FB$GET] ;READ-ONLY
MOVX T2,FB$PUT!FB$GET!FB$DEL!FB$UPD ;WRITE
; SET UP FAB
MOVSI T3,FAB ;POINT TO PROTOTYPE FAB
HRRI T3,(F) ;MAKE A BLT POINTER TO WORKING FAB
BLT T3,FA$LNG-1(F) ;COPY INTO FAB
$STORE T1,FNA,0(F) ;SET THE FILE NAME ADDRESS
$STORE T2,FAC,0(F) ;SET THE DESIRED ACCESS MODE
; SET UP RAB
MOVSI T4,RAB ;POINT TO PROTOTYPE RAB
HRRI T4,(R) ;MAKE A BLT POINTER TO WORKING RAB
BLT T4,RA$LNG-1(R) ;COPY INTO RAB
$STORE F,FAB,0(R) ;STORE THE FAB ADDRESS IN THE RAB
; XAB FOR AREA 1
SETZ T1, ;NO PREVIOUS XAB
XMOVEI T2,XABA1 ;XAB ADDRESS
MOVE T3,X.WXA1 ;WORKING STORAGE
PUSHJ P,OPNXAL ;SETUP
; XAB FOR AREA 2
XMOVEI T2,XABA2 ;XAB ADDRESS
MOVE T3,X.WXA2 ;WORKING STORAGE
PUSHJ P,OPNXAL ;SETUP
; XAB FOR AREA 3
XMOVEI T2,XABA3 ;XAB ADDRESS
MOVE T3,X.WXA3 ;WORKING STORAGE
PUSHJ P,OPNXAL ;SETUP
; XAB FOR KEY 0
XMOVEI T2,XABK0 ;XAB ADDRESS
MOVE T3,X.WXK0 ;WORKING STORAGE
PUSHJ P,OPNXKY ;SETUP
; XAB FOR KEY 1
XMOVEI T2,XABK1 ;XAB ADDRESS
MOVE T3,X.WXK1 ;WORKING STORAGE
PUSHJ P,OPNXKY ;SETUP
JRST .POPJ1 ;RETURN
; INITIALIZE XAB FOR ALLOCATION
; CALL: MOVE T1, PREVIOUS XAB
; MOVE T2, PROTOTYPE XAB
; MOVE T3, WORKING XAB
; MOVE F, FAB
; MOVE R, RAB
; PUSHJ P,OPNXAL
OPNXAL: SKIPN T1 ;SKIP IF A PREVIOUS XAB
$STORE T3,XAB,(F) ;LINK CURRENT XAB TO FAB
SKIPE T1 ;SKIP IF NO PREVIOUS XAB
$STORE T3,NXT,(T1) ;LINK CURRENT XAB TO PREVIOUS XAB
MOVSI T4,(T2) ;POINT TO PROTOTYPE
HRRI T4,(T3) ;MAKE A BLT POINTER
BLT T4,XA$SXA-1(T3) ;COPY
MOVE T1,T3 ;CURRENT XAB IS NOW THE PREVIOUS XAB
POPJ P, ;RETURN
; INITIALIZE XAB FOR ALLOCATION
; CALL: MOVE T1, PREVIOUS XAB
; MOVE T2, PROTOTYPE XAB
; MOVE T3, WORKING XAB
; MOVE F, FAB
; MOVE R, RAB
; PUSHJ P,OPNXKY
OPNXKY: $STORE T3,NXT,(T1) ;LINK CURRENT XAB TO PREVIOUS XAB
MOVSI T4,(T2) ;POINT TO PROTOTYPE
HRRI T4,(T3) ;MAKE A BLT POINTER
BLT T4,XA$SXK-1(T3) ;COPY
MOVE T1,T3 ;CURRENT XAB IS NOW THE PREVIOUS XAB
POPJ P, ;RETURN
; INITIALIZE FILOP, LOOKUP/ENTER/RENAME, AND PATH BLOCKS
; MUST BE CALLED AFTER A SUCCESSFUL $CREATE OR $OPEN
OPNBLK: MOVE T1,[FFZBEG,,FFZBEG+1] ;SET UP BLT
SETZM FFZBEG ;CLEAR FIRST WORD
BLT T1,FFZEND-1 ;CLEAR STORAGE
; NOW GET FILESPEC ON OPENED CHANNEL
OPNBL1: MOVE T1,[2,,T2] ;SET UP UUO AC
$FETCH T2,JFN,0(F) ;GET TOPS-10 I/O CHANNEL NUMBER FROM FAB
HRLZS T2 ;PUT IN LH
HRRI T2,.FOFIL ;FILOP. UUO FUNCTION CODE
MOVE T3,[.FOFMX,,FFFIL] ;POINT TO DATA BLOCK
FILOP. T1, ;READ FILESPEC
POPJ P, ;RETURN
; LOAD FILOP BLOCK
OPNBL2: MOVEI T1,FFFOP ;POINT TO BLOCK
MOVE T2,[FO.PRV!FO.ASC+.FORED] ;PRIV'ED, ASSIGN CHANNEL, READ
MOVEM T2,.FOFNC(T1)
MOVE T2,[UU.PHS+.IODMP] ;PHYSICAL DUMP MODE I/O
MOVEM T2,.FOIOS(T1)
MOVE T2,FFFIL+.FOFDV ;DEVICE NAME
MOVEM T2,.FODEV(T1)
MOVEI T2,FFLKP ;LOOKUP/ENTER/RENAME BLOCK
MOVEM T2,.FOLEB(T1)
; LOAD LOOKUP/ENTER/BLOCK
OPNBL3: MOVEI T1,FFLKP ;POINT TO BLOCK
MOVEI T2,.RBMAX ;LENGTH
MOVEM T2,.RBCNT(T1)
MOVEI T2,FFPTH ;PATH BLOCK
MOVEM T2,.RBPPN(T1)
MOVE T2,FFFIL+.FOFFN ;FILE NAME
MOVEM T2,.RBNAM(T1)
MOVE T2,FFFIL+.FOFEX ;EXTENSION
MOVEM T2,.RBEXT(T1)
; LOAD PATH BLOCK
OPNBL4: MOVE T1,[-<.PTMAX-.PTPPN>,,FFPTH+.PTPPN] ;POINT TO BLOCK
MOVEI T2,FFFIL+.FOFPP ;POINT TO RETURNED FILESPEC
OPNBL5: MOVE T3,(T2) ;GET A WORD
MOVEM T3,(T1) ;PUT A WORD
AOS T2 ;ADVANCE POINTER
AOBJN T1,OPNBL5 ;LOOP
SETOM FFFLG ;INDICATE GOODNESS
POPJ P, ;RETURN
; FIX UP THE FILE PROTECTION AND STATUS WORD
; MUST BE CALLED AFTER OPNBLK/CLOSE SEQUENCE
OPNFIX: $FETCH T1,FAC,0(F) ;GET THE DESIRED ACCESS MODE
TXNE T1,FB$PUT ;DID WE ASK FOR WRITE ACCESS?
SKIPN FFFLG ;YES--WAS CALL TO OPNBLK SUCCESSFUL?
POPJ P, ;NOPE
MOVE T1,[.FOMAX,,FFFOP] ;SET UP UUO AC
FILOP. T1, ;LOOKUP THE FILE
POPJ P, ;SHOULDN'T FAIL
MOVE T1,FFFOP+.FOFNC ;GET FUNCTION WORD
TDZ T1,[-1-FO.CHN] ;KEEP ONLY THE CHANNEL
TDO T1,[FO.PRV+FO.UOC+.FORNM] ;USE ALREADY OPENED CHANNEL FOR RENAME
MOVEM T1,FFFOP+.FOFNC ;UPDATE FUNCTION WORD
MOVEI T1,FFREN ;POINT TO RENAME BLOCK
HRLM T1,FFFOP+.FOLEB
MOVE T1,[FFLKP,,FFREN] ;SET UP BLT
BLT T1,FFREN+.RBMAX-1 ;COPY
MOVE T1,[%LDSSP] ;ASK MONITOR FOR SYS:*.SYS CODE
GETTAB T1, ;SO
MOVSI T1,(157B8) ;DEFAULT
LSH T1,-33 ;POSITION
DPB T1,[POINTR (FFREN+.RBPRV,RB.PRV)] ;STORE
MOVEI T1,RP.ABU ;CAUSE FILE TO ALWAYS BE BACKED UP
IORM T1,FFREN+.RBSTS ; TO TAPE REGARDLESS OF ACCESS DATE
MOVE T1,[.FOMAX,,FFFOP] ;SET UP UUO AC
FILOP. T1, ;RENAME THE FILE
JFCL ;IGNORE ERRORS HERE
MOVE T1,[1,,T2] ;SET UP UUO AC
MOVE T2,FFFOP+.FOFNC ;GET FUNCTION WORD
TDZ T2,[-1-FO.CHN] ;KEEP ONLY THE CHANNEL
HRRI T2,.FOREL ;NEW FUNCTION
FILOP. T1, ;RELEASE THE CHANNEL
JFCL ;???
POPJ P, ;DONE
SUBTTL CLOSE A FILE
; CLOSE FILE "A"
CLSA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
JRST CLSCOM ;ENTER COMMON CODE
; CLOSE FILE "B"
CLSB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
JRST CLSCOM ;ENTER COMMON CODE
; CLOSE FILE "C"
CLSC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
; JRST CLSCOM ;ENTER COMMON CODE
; COMMON CLOSE CODE
CLSCOM: $CLOSE 0(F) ;CLOSE THE FILE
PUSHJ P,ERRCKF ;CHECK UP ON IT
POPJ P, ;FAILED
JRST .POPJ1 ;RETURN GOODNESS
SUBTTL ERASE (DELETE) A FILE
; ERASE FILE "A"
ERSA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
JRST ERSCOM ;ENTER COMMON CODE
; ERASE FILE "B"
ERSB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
JRST ERSCOM ;ENTER COMMON CODE
; ERASE FILE "C"
ERSC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
; JRST ERSCOM ;ENTER COMMON CODE
; COMMON ERASE CODE
ERSCOM: $ERASE 0(F) ;DELETE THE FILE
PUSHJ P,ERRCKF ;CHECK UP ON IT
POPJ P, ;FAILED
JRST .POPJ1 ;RETURN GOODNESS
SUBTTL DELETE A RECORD
; CALL: MOVE AC1, FLAG (0 = PPN, -1 = NAME)
; MOVE AC2, PPN OR ADDRESS OF NAME
; PUSHJ P,DELA/DELB/DELC
DELA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
JRST DELCOM ;ENTER COMMON CODE
DELB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
JRST DELCOM ;ENTER COMMON CODE
DELC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
; JRST DELCOM ;ENTER COMMON CODE
; COMMON DELETE CODE
DELCOM: SKIPE ACTLCK ;LOCKED OUT?
POPJ P, ;YES--GO AWAY
DMOVE T1,ARGS ;GET CALLER'S ARGUMENTS
JUMPGE T1,DELCO1 ;JUMP IF BY PPN
MOVE T2,T2 ;COPY ADDRESS OF NAME
HRLI T2,(POINT 8,0) ;MAKE A SOURCE POINTER
MOVE T3,[POINT 9,TMPNAM] ;POINT TO A SCRATCH BUFFER
PUSHJ P,CVTNM1 ;COPY THE STRING
MOVEI T1,1 ;SECONDARY KEY
MOVEI T2,.AANLC ;EXACT MATCH
JRST DELCO2 ;READY TO FIND
DELCO1: MOVEM T2,TMPNAM ;SAVE PPN AS SEARCH STRING
MOVX T1,0 ;PRIMARY KEY
MOVX T2,^D4 ;BYTES IN A PPN
DELCO2: PUSHJ P,SETFND ;SET UP FIND
$FIND 0(R) ;NOW POSITION TO THAT RECORD
PUSHJ P,ERRCKR ;SEE IF WE FOUND IT
POPJ P, ;FAILED
$DELETE 0(R) ;TOSS THE RECORD
PUSHJ P,ERRCKR ;SEE IF WE DELETED IT
POPJ P, ;FAILED
; JRST .POPJ1 ;RETURN
$FLUSH 0(R) ;*** FORCE BUFFERS OUT
PUSHJ P,ERRCKR ;*** CHECK FOR ERRORS
POPJ P, ;*** FAILED
JRST .POPJ1 ;RETURN
SUBTTL GET A RECORD FROM A FILE
; HERE TO SET UP THE RMS CALL FOR A POSSIBLY WILDCARDED SEARCH
; CALL: MOVE AC1, ADDRESS OF BUFFER
; MOVE AC2, ADDRESS OF WILDCARD MESSAGE BLOCK
; PUSHJ P,GETA/GETB/GETC
GETA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
JRST GETCOM ;ENTER COMMON CODE
GETB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
JRST GETCOM ;ENTER COMMON CODE
GETC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
; JRST GETCOM ;ENTER COMMON CODE
GETCOM: MOVE P1,ARGS+1 ;COPY WILDCARD MESSAGE BLOCK ADDRESS
SETOM WLDNXT ;INIT NEXT PROFILE FLAG
PUSHJ P,FIXNAM ;FIX UP POSSIBLY WILD NAME
GETCO1: MOVEI T1,.AEMAX ;GET MAXIMUM LENGTH OF PROFILE
$STORE T1,USZ,0(R) ;STORE SIZE IN RAB
MOVE T1,ARGS ;GET BUFFER ADDRESS
$STORE T1,UBF,0(R) ;STORE ADDRESS IN RAB
PUSHJ P,SRHSET ;SET UP SEARCH
POPJ P, ;RETURN IF DONE
PUSHJ P,SETFND ;SET UP FIND
$FETCH T1,ROP,0(R) ;FETCH THE CURRENT OPTIONS
SKIPN WLDNXT ;FETCH NEXT PROFILE?
TXO T1,RB$KGT ;YES
$STORE T1,ROP,0(R) ;SAVE FLAGS AND BYTE COUNT
$GET 0(R) ;READ SPECIFIED RECORD
PUSHJ P,ERRCKR ;SEE IF WE FOUND IT
JRST GETCO3 ;FAILED
MOVE T1,ARGS ;FETCH BUFFER ADDRESS
PUSHJ P,NAME8 ;CONVERT 9-BIT NAME TO 8-BIT
PUSHJ P,MATCH ;COMPARE PPNS/NAMES
JRST GETCO2 ;NO MATCH
PUSHJ P,SELANL ;PERFORM SELECTION ANALYSIS
JRST GETCO1 ;FAILED, CHECK NEXT
JRST .POPJ1 ;RETURN
GETCO2: JUMPN T1,GETCO1 ;TRY AGAIN IF MORE POSSIBLE
JRST SRHRNF ;NO--MAKE IT LOOK LIKE "NO SUCH RECORD"
GETCO3: SKIPN T1,UW$WST(P1) ;GET WILDCARD SEARCH TYPE
JRST GETCO4 ;TEST IS DIFFERENT FOR PPN
CAIE T1,2 ;MUST BE WILD
AOSE WLDNXT ;MAYBE FETCH NEXT PROFILE
POPJ P, ;NO--GIVE UP
JRST GETCO1 ;LOOP BACK
GETCO4: SETO T1, ;GET A MASK
CAME T1,UW$PPM(P1) ;IF NON-WILD MASK,
AOSE WLDNXT ;OR ALREADY TRIED THIS,
POPJ P, ;THEN GIVE UP
JRST GETCO1 ;LOOP BACK TO TRY FOR NEXT PPN
; FIX UP PREVIOUS NAME FOR WILD NAME SEARCHES
FIXNAM: SKIPN UW$WST(P1) ;SEARCHING BY PPNS?
POPJ P, ;NOTHING TO DO
MOVE T1,[BASNAM,,BASNAM+1] ;SET UP BLT
SETZM BASNAM ;CLEAR FIRST WORD
BLT T1,BASNAM+11 ;NO--CLEAR BASE NAME STORAGE
MOVEI T2,UW$NAM(P1) ;POINT TO TARGET NAME
HRLI T2,(POINT 8,) ;8-BIT ASCIZ
SKIPE UW$BRE(P1) ;A PREVIOUS RESULT?
SKIPA T3,T2 ;YES--JUST CONVERT TARGET NAME
MOVE T3,[POINT 8,BASNAM] ;POINT TO BASE NAME STORAGE
MOVE T4,UW$WST(P1) ;GET WILDCARD SEARCH TYPE
SUBI T4,1 ;MAKE WILD NAME CODE = 0
FIXNA1: ILDB T1,T2 ;GET A BYTE
SKIPE UW$BRE(P1) ;A PREVIOUS RESULT?
JRST FIXNA2 ;YES--JUST DO CASE CONVERSION
CAIN T1,.CHCNV ;MAGIC QUOTE CHARACTER?
JRST FIXNA4 ;YES, DO QUOTING
JUMPN T4,FIXNA2 ;JUMP IF NON-WILD NAME
CAIE T1,"*" ;IS IT A WILDCARD?
CAIN T1,"?" ;OR A DIFFERENT WILDCARD?
JRST FIXNA3 ;YES--ALMOST DONE
FIXNA2: PUSHJ P,CVTCAS ;DO CASE CONVERSION
IDPB T1,T3 ;STORE IN BASE FOR WILDCARDING
JUMPN T1,FIXNA1 ;LOOP
FIXNA3: SKIPE UW$BRE(P1) ;A PREVIOUS RESULT?
POPJ P, ;YES--ALL DONE
MOVEI T2,UW$NAM(P1) ;POINT TO TARGET NAME
HRLI T2,(POINT 8,) ;8-BIT ASCIZ
MOVE T3,T2 ;SOURCE AND DESTINATION ARE SAME
PJRST CVTNM1 ;CONVERT TO UPPER CASE
FIXNA4: ILDB T1,T2 ;GET QUOTED CHARACTER
JRST FIXNA2 ;COPY IT WITH NO WILDCARD CHECKING
; SEARCH SET UP
; CALL: PUSHJ P,SRHSET
;
; ON RETURN, T1 HAS KEY NUMBER AND T2 LENGTH OF KEY IN BYTES
SRHSET: MOVE T1,UW$SEL(P1) ;GET COUNT OF SELECTION BLOCKS
MOVEM T1,SELBLK ;SAVE
SKIPN UW$WST(P1) ;SKIP IF SEARCHING BY NAME
JRST SRHSE2 ;GO SEARCH BY PPN
; SEARCH BY NAME
SRHSE1: MOVEI T2,UW$BRE(P1) ;POINT TO PREVIOUS RESULT
MOVE T3,UW$WST(P1) ;GET WILDCARD SEARCH TYPE
SKIPE (T2) ;BEEN HERE BEFORE?
SOJG T3,SRHRNF ;YES
SKIPN (T2) ;BEEN HERE BEFORE?
MOVEI T2,BASNAM ;FIRST TIME--POINT TO BASE NAME
HRLI T2,(POINT 8,0) ;MAKE A SOURCE POINTER
MOVE T3,[POINT 9,TMPNAM] ;POINT TO A SCRATCH BUFFER
PUSHJ P,CVTNM1 ;COPY THE STRING
MOVE T1,UW$WST(P1) ;GET SEARCH TYPE
CAIE T1,2 ;NON-WILD NAME?
SKIPN UW$BRE(P1) ;A PREVIOUS RESULT?
SKIPA ;DON'T ASK FOR NEXT PROFILE
SETZM WLDNXT ;YES--ASK FOR NEXT PROFILE
MOVEI T1,1 ;SECONDARY KEY
MOVEI T2,.AANLC ;EXACT MATCH
JRST .POPJ1 ;READY TO FIND
; SEARCH BY PPN
SRHSE2: MOVE T1,UW$PPM(P1) ;GET MASK
SKIPE UW$BRE(P1) ;A PREVIOUS RESULT?
AOJE T1,SRHRNF ;YES
MOVE T1,UW$PPN(P1) ;GET PPN
MOVE T2,UW$PPM(P1) ;GET MASK
AND T1,T2 ;MASK DOWN PPN
SKIPE T2,UW$BRE(P1) ;A PREVIOUS RESULT?
MOVE T1,T2 ;YES--USE IT INSTEAD
MOVEM T1,TMPNAM ;SAVE PPN AS SEARCH STRING
SKIPE UW$BRE(P1) ;HAVE A PREVIOUS VALUE?
SETZM WLDNXT ;YES--FETCH NEXT PROFILE
MOVEI T1,0 ;PRIMARY KEY
MOVEI T2,^D4 ;BYTES IN A PPN
JRST .POPJ1 ;READY TO FIND
; HERE IF NO SEARCH WILL BE DONE. MAKE IT LOOK LIKE A STANDARD
; RMS "RECORD NOT FOUND" ERROR.
SRHRNF: MOVEI T1,ER$RNF ;CODE FOR RECORD NOT FOUND
MOVEI T2,0 ;STATUS
$STORE T1,STS,0(R) ;SET STATUS
$STORE T2,STV,0(R) ;AND STATUS VALUE
POPJ P, ;RETURN
; CHECK FOR A MATCH
MATCH: SKIPN T1,UW$WST(P1) ;SKIP IF SEARCHING BY PPN
PJRST MATPPN ;COMPARE PPNS
SOJG T1,.POPJ1 ;RETURN GOODNESS IF NON-WILD NAME
PUSH P,P2 ;SAVE P2
PUSH P,P3 ;SAVE P3
PUSHJ P,MATNAM ;COMPARE NAMES
SKIPA ;FAILED
AOS -2(P) ;SKIP
POP P,P3 ;RESTORE P3
POP P,P2 ;RESTORE P2
POPJ P, ;RETURN
; CHECK FOR A PPN MATCH
MATPPN: MOVE T2,ARGS ;FETCH BUFFER ADDRESS
MOVE T2,.AEPPN(T2) ;AND THE PPN RETURNED
MOVEM T2,UW$BRE(P1) ;SAVE
SETZ T1, ;SET RETURN CODE TO "NO MORE PROFILES"
HLRZ T2,UW$PPN(P1) ;GET PROJECT NUMBER
JUMPE T2,MATPP1 ;ALL PROJECTS?
HLRZ T3,UW$BRE(P1) ;AND THE ONE FROM PROFILE
CAILE T3,(T2) ;GONE BEYOND THIS PROJECT NUMBER YET?
POPJ P, ;YES--STOP NOW
HRRZ T2,UW$PPN(P1) ;GET PROGRAMMER NUMBER
JUMPE T2,MATPP1 ;ALL PROGRAMMERS?
HRRZ T3,UW$BRE(P1) ;AND THE ONE FROM PROFILE
CAIG T3,(T2) ;GONE BEYOND PROGRAMMER NUMBER YET?
JRST MATPP1 ;NO
MOVE T3,UW$PPM(P1) ;GET MASK
AOJE T3,.POPJ ;RETURN IF NOT WILD
HLLOS UW$BRE(P1) ;MAKE IT [PROJECT,777777]
JRST MATPP2 ;NO MATCH BUT MAYBE MORE TO COME
MATPP1: MOVE T2,UW$BRE(P1) ;GET PPN
AND T2,UW$PPM(P1) ;MASK
MOVE T3,UW$PPN(P1) ;GET REQUESTED PPN
AND T3,UW$PPM(P1) ;MASK
CAMN T2,T3 ;MATCH?
JRST .POPJ1 ;YES
MATPP2: MOVNI T1,1 ;MAYBE MORE PROFILES AVAILABLE
POPJ P, ;SAY NO MORE
; CHECK FOR A NAME MATCH
MATNAM: MOVE T1,ARGS ;FETCH BUFFER ADDRESS
MOVE T3,T1 ;COPY FOR LATER
MOVSI T1,.AENAM(T1) ;POINT TO RETURNED NAME
HRRI T1,UW$BRE(P1) ;AND TO RESULT NAME
BLT T1,UW$ERE(P1) ;COPY
MOVEI T1,UW$NAM(P1) ;POINT TO SOURCE NAME
HRLI T1,(POINT 8,) ;8-BIT ASCIZ STRING
MOVEI T2,.AANLC ;LENGTH IN CHARACTERS
MOVEI T3,.AENAM(T3) ;POINT TO NAME
HRLI T3,(POINT 8,) ;8-BIT ASCIZ STRING
MOVEI T4,.AANLC ;LENGTH IN CHARACTERS
SETZM WLDCNT ;NO ITERATIONS YET
MATNA1: SOJL T2,MATNA6 ;MAYBE AT END
ILDB P2,T1 ;GET CHARACTER FROM PROTOTYPE
JUMPE P2,MATNA6 ;TEST FOR END MATCH IF NUL
CAIN P2,.CHCNV ;MAGIC QUOTE CHARACTER?
JRST MATNA8 ;YES, SKIP WILDCARDING
CAIN P2,"*" ;FOUND THE SPECIAL CASE?
JRST MATNA2 ;YES, RECURSE
SOJL T4,MATNA7 ;NO, CHECK FOR ANOTHER CHARACTER HERE
ILDB P3,T3 ;FETCH IT
JUMPE P3,MATNA7 ;NO MATCH IF AT END
CAIN P2,"?" ;IF WILD,
AOS WLDCNT ;FLAG IT
CAIE P2,"?" ;IF WILD,
CAMN P2,P3 ;OR IF THEY MATCH,
JRST MATNA1 ;KEEP LOOKING
JRST MATNA7 ;FAIL IF THEY DON'T MATCH
MATNA2: AOS WLDCNT ;ABOUT TO ITERATE
ADJSP P,4 ;MAKE ROOM
DMOVEM T1,-3(P) ;SAVE PROTOTYPE POINTER
MATNA3: DMOVEM T3,-1(P) ;AND ENTRY POINTER
PUSHJ P,MATNA1 ;CHECK FOR A MATCH
SKIPA ;FAILED
JRST MATNA5 ;FINISH UP
DMOVE T1,-3(P) ;RETRIEVE WILDCARD POINTER
DMOVE T3,-1(P) ;RETRIEVE ENTRY POINTER
SOJL T4,MATNA4 ;NO MATCH IF AT END
ILDB P3,T3 ;GET NEXT CHARACTER
JUMPN P3,MATNA3 ;TRY AGAIN IF NOT YET AT END
MATNA4: ADJSP P,-4 ;TRIM STACK
JRST MATNA7 ;ANOTHER SEARCH NEEDED
MATNA5: ADJSP P,-4 ;TRIM STACK
JRST .POPJ1 ;RETURN IF MATCH
MATNA6: SOJL T4,.POPJ1 ;IF END HERE, THEY MATCH
ILDB P3,T3 ;GET NEXT CHARACTER
JUMPE P3,.POPJ1 ;MATCH
MATNA7: SETZ T1, ;SET RETURN CODE TO "NO MORE PROFILES"
SKIPE WLDCNT ;ANY CHARACTER MATCHES?
MOVNI T1,1 ;YES--ANOTHER SEARCH IS NEEDED
POPJ P, ;RETURN NO MATCH ON THIS NAME
MATNA8: SOJL T2,MATNA7 ;QUOTE REQUIRES A FOLLOWING CHARACTER
ILDB P2,T1 ;FETCH IT
JUMPE P2,MATNA7 ;REQUIRED TO BE PRESENT
SOJL T4,MATNA7 ;CAN'T MATCH IF NO MORE CHARACTERS
ILDB P3,T3 ;GET NEXT FROM PROFILE
CAMN P2,P3 ;IF THE SAME,
JRST MATNA1 ;THIS CHARACTER MATCHES
JRST MATNA7 ;ELSE NO MATCH HERE
; HERE TO PERFORM SELECTION ANALYSIS
SELANL: SKIPN SELBLK ;ANY BLOCKS SPECIFIED?
JRST .POPJ1 ;NO--SAY THIS PROFILE MATCHES
MOVSI T1,[REPEAT 4,<JRST .POPJ1>] ;SOME FRIENDLY INSTRUCTIONS
HRRI T1,CMPINS ;POINT TO STORAGE
BLT T1,CMPINS+3 ;COPY
HLRZ P2,UW$TYP(P1) ;GET LENGTH OF MESSAGE
SUBI P2,UW$DAT ;KEEP ONLY COUNT OF SELECTION DATA WORDS
MOVNS P2 ;NEGATE
HRLZS P2 ;PUT IN LH
HRRI P2,UW$DAT(P1) ;POINT TO START OF SELECTION DATA
MOVEM P2,SELPTR ;SAVE
SETOM SELFLG ;FLAG SELECTION IN PROGRESS
SELAN1: LOAD T4,(P2),AF.SEL ;GET FUNCTION CODE
CAIL T4,1 ;RANGE
CAILE T4,SELMAX ; CHECK
POPJ P, ;GIVE UP
SELAN2: MOVE T4,SELTAB-1(T4) ;POINT TO INSTUCTIONS
DMOVE T1,0(T4) ;FETCH
DMOVE T3,2(T4) ; AND
DMOVEM T1,CMPINS ; INSTRUCTIONS
DMOVEM T3,CMPINS+2 ; ...
PUSHJ P,SELCMP ;COMPARE PROFILE DATA WITH THAT IN MSG
JRST SELAN3 ;PROFILE DOESN'T SATISFY CRITERIA
PUSHJ P,ADVBLK ;ADVANCE TO NEXT SELECTION SUB-BLOCK
JRST .POPJ1 ;RETURN IF NO MORE SUB-BLOCKS
LOAD T4,(P2),AF.SEL ;GET TYPE OF NEXT BLOCK
CAIE T4,.AFOR ;IS THIS AN "OR" BLOCK?
JRST SELAN1 ;NO, JUST TRY IT
JRST .POPJ1 ;YES, WE FOUND A WINNING SET OF CONSTRAINTS
SELAN3: PUSHJ P,ADVBLK ;LOST THIS TIME, LOOK FOR AN "OR" BLOCK
POPJ P, ;ALL OUT OF POSSIBILITIES
LOAD T4,(P2),AF.SEL ;MAYBE, GET BLOCK TYPE
CAIE T4,.AFOR ;IS IT TIME TO START OVER?
JRST SELAN3 ;NO, KEEP LOOKING
JRST SELAN2 ;YES, TRY A NEW STRING OF CONSTRAINTS
; SELECTION FUNCTION TABLE
SELTAB: IFIW SELAND ;"AND"
IFIW SELOR ;"OR"
IFIW SELNOT ;"NOT"
IFIW SELGEQ ;".GE."
IFIW SELLEQ ;".LE."
SELMAX==.-SELTAB ;LENGTH OF TABLE
; "OR"
SELOR:!
; "AND"
SELAND: CAMN T1,T2 ;COMPARE
AOS (P) ;SAME
POPJ P, ;RETURN
; "NOT"
SELNOT: CAME T1,T2 ;COMPARE
AOS (P) ;DIFFERENT
POPJ P, ;RETURN
; "GEQ"
SELGEQ: CAML T1,T2 ;PROFILE .GE. USER VALUE?
AOS (P) ;YES, SUCCEED
POPJ P, ;NO, FAIL
; "LEQ"
SELLEQ: CAMG T1,T2 ;PROFILE .LE. USER VALUE?
AOS (P) ;YES, SUCCEED
POPJ P, ;NO, FAIL
; ADVANCE TO THE NEXT SELECTION SUB-BLOCK
ADVBLK: SOSG T1,SELBLK ;COUNT SELECTION BLOCKS
POPJ P, ;NO MORE
LDB T1,[POINT 9,(P2),17] ;GET LENGTH
HRLS T1 ;PUT IN BOTH HALVES
ADD P2,T1 ;ADVANCE
MOVEM P2,SELPTR ;UPDATE
JUMPGE P2,.POPJ ;JUMP IF POINTER RAN OUT
JRST .POPJ1 ;ELSE RETURN OK
; COMPARE VALUES
SELCMP: LOAD T1,(P2),AF.OFS ;GET BLOCK TYPE
CAIL T1,.AEMIN ;RANGE CHECK
POPJ P, ;ILLEGAL
MOVX T2,AF.DEF ;DEFAULTING BIT
TDNE T2,(P2) ;WANTING TO CHECK FOR DEFAULTED FIELD?
JRST SELCM6 ;YES, DO SO
MOVE T2,CHGTAB##(T1) ;NO, GET BITS FOR THIS BLOCK TYPE
TXNE T2,PD.NSL ;INVALID FOR SELECTION?
POPJ P, ;YES, FAIL
MOVE P3,ARGS ;POINT TO PROFILE BUFFER FOR CALLED ROUTINE
IFE 1B0-PD.RTN,<JUMPL T2,(T2)> ;CALL ROUTINE IF ONE IS PROVIDED
IFN 1B0-PD.RTN,<
HRRZ T3,T2 ;GET POSSIBLE ROUTINE ADDRESS
TXNE T2,PD.RTN ;WAS IT PROVIDED?
PJRST (T3) ;YES, USE IT
>
SELCM1: TXNE T2,PD.EXT ;EXTENSIBLE BLOCK?
JRST SELCM2 ;YES, HANDLE
TXNN T2,PD.MSK ;MASKABLE WORD?
JRST SELCM3 ;NO, SIMPLE WORD COMPARES
LDB T3,[POINT 9,(P2),17] ;YES, GET SUPPLIED BLOCK LENGTH
CAILE T3,2 ;WAS A MASK SUPPLIED?
SKIPA T2,2(P2) ;YES, USE IT
SETO T2, ;NO, USE FULLWORD
CAIL T3,2 ;WAS A VALUE GIVEN?
CAILE T3,3 ;OR MORE THAN VALUE & MASK?
POPJ P, ;YES, IT DOESN'T MATCH
HRRZ T3,ARGS+0 ;OK, GET PROFILE BUFFER ADDRESS
ADD T3,T1 ;GET BLOCK OFFSET
MOVE T1,1(P2) ;GET VALUE FROM THE SELECTION SUB-BLOCK
AND T1,T2 ;KEEP ONLY PORTION TO COMPARE
AND T2,(T3) ;FETCH & MASK FROM PROFILE
PJRST CMPINS ;GO COMPARE AND RETURN TRUE/FALSE
; EXTENSIBLE BLOCK PROCESSING
SELCM2: ADD T1,P3 ;GET ADDRESS TO FETCH
MOVE T1,(T1) ;DO SO
ADD T1,P3 ;UN-RELATIVIZE THE AOBJN POINTER
JRST SELCM4 ;JOIN COMMON CODE FOR WORD COMPARES
; REGULAR BLOCK PROCESSING
SELCM3: LOAD T2,CHGTAB##(T1),PD.WRD ;GET BLOCK LENGTH
ADD T1,P3 ;GET ADDRESS OF BLOCK TO TEST
MOVNS T2 ;GET MINUS BLOCK LENGTH
HRL T1,T2 ;MAKE AOBJN POINTER TO BLOCK
;HERE FOR COMMON WORD-MODE COMPARISON CODE
SELCM4: LDB T2,[POINT 9,(P2),17] ;GET SUPPLIED BLOCK LENGTH
SUBI T2,1 ;ONLY WANT DATA LENGTH
MOVNS T2 ;USE NEGATIVE FOR AOBJN
MOVSS T2 ;AOBJN CHECKS LH
HRRI T2,1(P2) ;POINT TO DATA
DMOVE T3,T1 ;MOVE POINTERS TO SAFER ACS
SELCM5: SKIPL T3 ;ANY MORE TO FETCH HERE?
TDZA T1,T1 ;NOPE
MOVE T1,(T3) ;YES, GET IT
SKIPL T4 ;SIMILARLY FOR USER DATA
TDZA T2,T2
MOVE T2,(T4)
PUSHJ P,CMPINS ;TEST IT
POPJ P, ;FAILS THE CRITERIA
AOBJP T3,.+1 ;ADVANCE POINTER
AOBJN T4,SELCM5 ;LOOP OVER DATA
JUMPL T3,SELCM5 ;AS LONG AS EITHER POINTER HOLDS OUT
JRST .POPJ1 ;MEETS SELECTION CRITERIA
; DEFAULTED FIELD CHECKING
SELCM6: IDIVI T1,^D36 ;GET MAP OFFSET & BIT NUMBER
MOVN T4,T2 ;SHIFT VALUE
MOVX T2,1B0 ;BIT TO SHIFT
LSH T2,(T4) ;GET BIT TO TEST
ADDI T1,.AEMAP ;OFFSET TO MAP
HRRZ T3,ARGS+0 ;GET PROFILE ADDRESS
ADD T1,T3 ;GET ADDRESS TO FETCH
MOVE T1,(T1) ;FETCH WORD FROM PROFILE MAP
AND T1,T2 ;MAKE THINGS EASY
PJRST CMPINS ;TEST AND RETURN TRUE/FALSE
;SETFND - SET UP A $FIND
;
;T1/ KEY OF REFERENCE
;T2/ # OF BYTES
;TMPNAM/KEY TO MATCH
SETFND: $STORE T1,KRF,0(R) ;STORE WHICH KEY TO USE
MOVEI T1,TMPNAM ;BUFFER ADDRESS
$STORE T1,KBF,0(R) ;STORE KEY BUFFER ADDRESS
$STORE T2,KSZ,0(R) ;STORE KEY SIZE
MOVEI T1,RB$KEY ;KEYED ACCESS
$STORE T1,RAC,0(R) ;SET
$FETCH T1,ROP,0(R) ;FETCH THE CURRENT OPTIONS
TXZ T1,RB$KGE!RB$KGT ;MATCH SHOULD BE EQUAL
$STORE T1,ROP,0(R) ;PUT THEM BACK (AND RETURN TO CALLER)
POPJ P, ;DONE
; SETHDR - SETS UP THE RMS RECORD HEADER AND RAB GIVEN THE USER ARGS
; CALL: MOVE T1, BUFFER ADDRESS
; PUSHJ P,SETHDR
SETHDR: $SAVE P1 ;FOR LOOPING
MOVSI T2,(T1) ;POINT TO USER ARGUMENT
HRRI T2,PROFIL ;POINT TO INTERNAL PROFILE BLOCK
HRRZ T3,.AEVRS(T1) ;GET LENGTH OF THIS PROFILE
BLT T2,PROFIL-1(T3) ;COPY
MOVEI T2,PROFIL ;FROM NOW ON, WE'LL USE INTERNAL BLOCK
$STORE T2,RBF,0(R) ;STORE BUFFER ADDRESS
HRRZ T2,.AEVRS(T2) ;GET BUFFER SIZE
IMULI T2,^D4 ;MAKE SIZE INTO BYTES
$STORE T2,RSZ,0(R) ;TELL RMS HOW MUCH TO WRITE
MOVEI T2,RB$KEY ;KEYED ACCESS
$STORE T2,RAC,0(R) ;TELL RMS
CAIN T1,PROFIL ;INTERNAL BUFFER?
POPJ P, ;YES--ALREADY IN 9-BIT FORMAT
MOVEI T2,.AENAM(T1) ;POINT TO NAME
HRLI T2,(POINT 8,) ;8-BIT BYTES
MOVE T3,[POINT 9,PROFIL+.AENAM] ;POINTER TO STORAGE
MOVEI T4,.AANLC ;LENGTH IN CHARACTERS
SETHD1: ILDB T1,T2 ;GET 8-BIT CHARACTER
PUSHJ P,CVTCAS ;DO CASE CONVERSION IF NECESSARY
IDPB T1,T3 ;PUT 9-BIT CHARACTER
SOJG T4,SETHD1 ;LOOP THROUGH NAME
MOVEI P1,.AEMIN ;OFF-THE-END INDEX FOR CHGTAB
SETHD2: SOJL P1,SETHD4 ;LOOP OVER CHGTAB ENTRIES
MOVE T4,CHGTAB##(P1) ;GET CONTROL BITS
TXNE T4,PD.EXT ;MUST BE EXTENSIBLE
TXNE T4,PD.NMD!PD.CND ;MUST BE MODIFIABLE AND DEFAULTABLE
JRST SETHD2 ;ELSE JUST TRUST THE CALLER
HRRZ T2,P1 ;GET OFFSET
SETO T3, ;WANT TO TEST
MOVEI T1,PROFIL ;OUR COPY OF THE BLOCK
PUSHJ P,A$BMAP## ;SEE IF IT WAS DEFAULTED
JUMPF SETHD2 ;NO, DON'T GRIND IT DOWN
MOVE T4,CHGTAB##(P1) ;YES, GET BITS AGAIN
TXNN T4,PD.EXT ;EXTENSIBLE?
JRST SETHD3 ;NO, DON'T MESS WITH THE BLOCK
SETO T4, ;YES, DON'T WANT TO CHANGE THE DEFAULT BIT
SETZ T3, ;WE WANT TO DELETE THE BLOCK
HRROI T2,(P1) ;INDEX TO THE ENTRY
; MOVEI T1,PROFIL ;STILL SETUP
SKIPE PROFIL(T2) ;IF BLOCK IS IN USE,
PUSHJ P,A$EBLK## ;DELETE IT
JRST SETHD2 ;KEEP CLEANING UP THE BLOCK
SETHD3: LOAD S1,T4,PD.WRD ;GET BLOCK SIZE
MOVEI S2,PROFIL(P1) ;AND ITS ADDRESS
$CALL .ZCHNK ;CLEAR IT OUT
JRST SETHD2 ;KEEP CLEANING UP THE BLOCK
SETHD4: HRRZ T2,PROFIL+.AEVRS ;GET BUFFER SIZE
IMULI T2,^D4 ;MAKE SIZE INTO BYTES
$STORE T2,RSZ,0(R) ;TELL RMS HOW MUCH TO WRITE
POPJ P, ;RETURN
; CONVERT 9-BIT INTERNAL ACCOUNTING USER NAME TO 8-BIT
; CALL: MOVE T1, PROFILE ADDRESS
; PUSHJ P,NAME8
NAME8: MOVSI T2,.AENAM(T1) ;POINT TO NAME
HRRI T2,TMPNAM ;TEMP STORAGE
BLT T2,TMPNAM+.AANLW-1 ;COPY
SETZM .AENAM(T1) ;WANT TO CLEAR LOW-ORDER BITS
MOVEI T2,.AENAM+1(T1) ;OF ENTIRE BLOCK
HRLI T2,.AENAM(T1) ;MAKE TRANSFER WORD
BLT T2,.AENAM+.AANLW-1(T1) ;CLEAR THE BLOCK
MOVE T2,[POINT 9,TMPNAM] ;POINT TO 9-BIT NAME
MOVEI T3,.AENAM(T1) ;WHERE TO RETURN THE CONVERTED NAME
HRLI T3,(POINT 8,) ;8-BIT ASCIZ
MOVEI T4,.AANLC ;LENGTH IN CHARACTERS
NAME81: ILDB T1,T2 ;GET A CHARACTER
IDPB T1,T3 ;PUT A CHARACTER
SOJG T4,NAME81 ;LOOP
POPJ P, ;RETURN
CVTNM1: MOVEI T4,.AANLC ;MAX LENGTH OF USER NAME
CVNLUP: SKIPE T1,T2 ;IF NOT OFF END,
ILDB T1,T2 ;FETCH GIVEN NAME
SKIPN T1 ;DONE?
SETZ T2, ;YES, MAKE SURE FILLED WITH ZEROS
PUSHJ P,CVTCAS ;DO CASE CONVERSION
IDPB T1,T3 ;COPY INTO KEY
SOJGE T4,CVNLUP ;LOOP IF NOT (1 EXTRA FOR NULL @END)
POPJ P, ;RETURN
; CASE CONVERSION
; "UPCASE" ANY 8 BIT CHARS TOO. SCNSER SHOULD BE WORRYING IF
; 7-BIT TTY TYPES 8-BIT NAME. I WON'T.
CVTCAS: CAIL T1,"A"+40 ;CONVERT
CAILE T1,"Z"+40 ; LOWER
CAIL T1,"A"+240 ; CASE TO
CAILE T1,"Z"+240 ; UPPER CASE
POPJ P, ;NOTHING TO CONVERT
SUBI T1," " ;OK, DO THE CONVERSION
POPJ P, ;RETURN
SUBTTL PUT A RECORD INTO A FILE
; CALL: MOVE AC1, ADDRESS OF USER BUFFER
; PUSHJ P,PUTA/PUTB/PUTC
PUTA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
JRST PUTCOM ;ENTER COMMON CODE
PUTB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
JRST PUTCOM ;ENTER COMMON CODE
PUTC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
; JRST PUTCOM ;ENTER COMMON CODE
; COMMON PUT CODE
PUTCOM: SKIPE ACTLCK ;LOCKED OUT?
POPJ P, ;DON'T BOTHER RMS
MOVE T1,ARGS ;GET CALLER'S ARGUMENT
PUSHJ P,SETHDR ;SET UP THE RECORD HEADER
PUTCO1: $PUT 0(R) ;PUT THE RECORD IN THE FILE
PUSHJ P,ERRCKR ;CHECK FOR ERRORS
POPJ P, ;FAILED
; JRST .POPJ1 ;RETURN
$FLUSH 0(R) ;*** FORCE BUFFERS OUT
PUSHJ P,ERRCKR ;*** CHECK FOR ERRORS
POPJ P, ;*** FAILED
JRST .POPJ1 ;RETURN
SUBTTL UPDATE A FILE
; UPDATE THE LAST RECORD READ
; CALL: MOVE AC1, ADDRESS OF USER BUFFER
; PUSHJ P,UPDA/UPDB/UPDC
UPDA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
JRST UPDCOM ;ENTER COMMON CODE
UPDB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
JRST UPDCOM ;ENTER COMMON CODE
UPDC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
; JRST UPDCOM ;ENTER COMMON CODE
; COMMON UPDATE CODE
UPDCOM: SKIPE ACTLCK ;LOCKED OUT?
POPJ P, ;DON'T BOTHER RMS
MOVEI T1,.AEMIN+$AEFLT ;GET LENGTH OF PROFILE
$STORE T1,USZ,0(R) ;STORE SIZE IN RAB
MOVEI T1,TEMP ;POINT TO TEMP PROFILE STORAGE
$STORE T1,UBF,0(R) ;STORE ADDRESS IN RAB
MOVE T1,ARGS ;GET CALLER'S ARGUMENT
MOVE T2,.AEPPN(T1) ;AND TARGET PPN FROM PROFILE
MOVEM T2,TMPNAM ;SAVE PPN AS SEARCH STRING
MOVEI T1,0 ;PRIMARY KEY
MOVEI T2,4 ;BYTES IN A PPN
PUSHJ P,SETFND ;SET UP FIND
$GET 0(R) ;READ SPECIFIED RECORD
PUSHJ P,ERRCKR ;SEE IF WE FOUND IT
POPJ P, ;MUST BE THERE
MOVE T1,ARGS ;GET CALLER'S ARGUMENT
PUSHJ P,SETHDR ;SET UP HEADERS
HRRZ T1,TEMP+.AEVRS ;GET LENGTH OF PROFILE TO UPDATE
HRRZ T2,PROFIL+.AEVRS ;GET LENGTH OF PROFILE ON DISK
CAIN T1,(T2) ;UPDATE OF SAME SIZE?
JRST UPDCO3 ;YES--THAT'S EASY
PUSHJ P,UPDVAL ;VALIDATE A POSSIBLE NAME CHANGE
POPJ P, ;PROBABLY DUPLICATE NAME
UPDCO1: MOVE T1,TEMP+.AEPPN ;TARGET PPN
MOVEM T1,PROFIL+.AEACS ;SAVE
SETZM PROFIL+.AEPPN ;ZAP PPN (KEY)
MOVSI T1,400000 ;HIGH BIT OF FIRST CHARACTER IN USER NAME
IORM T1,PROFIL+.AENAM ;TURN IT ON
PUSHJ P,PUTCO1 ;STORE TEMP PROFILE WITH PPN [0,0]
POPJ P, ;FAILED
MOVE T1,ARGS ;GET CALLER'S ARGUMENT
MOVE T2,.AEPPN(T1) ;AND TARGET PPN
PUSHJ P,DELCO1 ;DELETE ORIGINAL PROFILE
JRST UPDCO2 ;UNWIND AS BEST WE CAN
MOVE T1,ARGS ;GET CALLER'S ARGUMENT
PUSHJ P,SETHDR ;SET UP THE RECORD HEADER
MOVE T1,PROFIL+.AEPPN ;GET THE PPN
MOVEM T1,PROFIL+.AEACS ;SAVE AS THE UPDATE ACTIVE PPN
PUSHJ P,PUTCO1 ;INSERT NEW PROFILE FOR ORIGINAL PPN
POPJ P, ;FAILED
SETZ T2, ;GET [0,0]
PUSHJ P,DELCO1 ;DELETE THAT PROFILE
POPJ P, ;FAILED
MOVE T1,PROFIL+.AEACS ;GET TARGET PPN
MOVEM T1,TMPNAM ;SAVE AS KEY
MOVEI T1,0 ;KEY OF REFERENCE
MOVEI T2,4 ;KEY LENGTH
PUSHJ P,SETFND ;SET UP FIND
$FIND 0(R) ;FIND THE RECORD
PUSHJ P,ERRCKR ;CHECK FOR ERRORS
POPJ P, ;FAILED
MOVEI T1,PROFIL ;POINT TO INTERNAL PROFIL BUFFER
JRST UPDCO4 ;GO FINISH UP
UPDCO2: SETZ T2, ;[0,0]
PUSHJ P,DELCO1 ;TRY TO DELETE THE PPN
JFCL ;WHO CARES AT THIS POINT
POPJ P ;RETURN
UPDCO3: MOVE T1,ARGS ;GET CALLER'S ARGUMENT
UPDCO4: PUSHJ P,SETHDR ;SET UP THE RECORD HEADER
SETZM PROFIL+.AEACS ;MAKE SURE UPDATE ACTIVE PPN IS ZEROED
$UPDATE 0(R) ;REPLACE THE RECORD IN THE FILE
PUSHJ P,ERRCKR ;CHECK FOR ERRORS
POPJ P, ;FAILED
; JRST .POPJ1 ;RETURN
$FLUSH 0(R) ;*** FORCE BUFFERS OUT
PUSHJ P,ERRCKR ;*** CHECK FOR ERRORS
POPJ P, ;*** FAILED
JRST .POPJ1 ;RETURN
UPDFIX: PUSHJ P,.SAVE1 ;SAVE P1
MOVEI T1,.AEMAX ;GET MAXIMUM LENGTH OF PROFILE
$STORE T1,USZ,0(R) ;STORE SIZE IN RAB
MOVEI T1,PROFIL ;POINT TO TEMP PROFILE STORAGE
$STORE T1,UBF,0(R) ;STORE ADDRESS IN RAB
SETZB T1,TMPNAM ;KEY OF REFERENCE, PPN IS [0,0]
MOVEI T2,4 ;KEY LENGTH
PUSHJ P,SETFND ;SET UP FIND
$GET 0(R) ;FETCH TEMPORARY PROFILE
PUSHJ P,ERRCKR ;SEE IF FOUND
JRST .POPJ1 ;NOT THERE SO NO UPDATE WAS IN PROGRESS
SKIPN P1,PROFIL+.AEACS ;GET ACTIVE UPDATE PPN
POPJ P, ;MUST BE ONE
MOVEM P1,TMPNAM ;SAVE PPN AS KEY
SETZ T1, ;PRIMARY KEY
MOVEI T2,4 ;KEY LENGTH
PUSHJ P,SETFND ;SET UP FIND
$GET 0(R) ;FETCH PROFILE
PUSHJ P,ERRCKR ;CHECK FOR ERRORS
JRST UPDFI2 ;NOT THERE
UPDFI1: MOVE T2,PROFIL+.AEPPN ;GET ORIGINAL PPN
PUSHJ P,DELCO1 ;DELETE ITS PROFILE
POPJ P, ;FAILED
UPDFI2: SETZB T1,TMPNAM ;KEY OF REFERENCE, PPN IS [0,0]
MOVEI T2,4 ;KEY LENGTH
PUSHJ P,SETFND ;SET UP FIND
$GET 0(R) ;FETCH TEMPORARY PROFILE AGAIN
PUSHJ P,ERRCKR ;SEE IF FOUND
POPJ P, ;SHOULD NOT FAIL
MOVE T1,PROFIL+.AEACS ;GET ACTIVE UPDATE PPN
MOVEM T1,PROFIL+.AEPPN ;SAVE AS REAL PPN NOW
MOVSI T1,400000 ;HIGH BIT OF FIRST WORD IN USER NAME
ANDCAM T1,PROFIL+.AENAM ;CLEAR IT
MOVEI T1,PROFIL ;POINT TO BUFFER
PUSHJ P,SETHDR ;SET UP THE RECORD HEADER
PUSHJ P,PUTCO1 ;INSERT PROFILE WITH ORIGINAL PPN
POPJ P, ;FAILED
SETZ T2, ;[0,0]
PUSHJ P,DELCO1 ;DELETE TEMPORARY PROFILE
POPJ P, ;FAILED
MOVEM P1,TMPNAM ;TARGET IS ORIGINAL PPN AGAIN
MOVEI T1,0 ;KEY OF REFERENCE
MOVEI T2,4 ;KEY LENGTH
PUSHJ P,SETFND ;SET UP FIND
$GET 0(R) ;FETCH TEMPORARY PROFILE AGAIN
PUSHJ P,ERRCKR ;SEE IF FOUND
POPJ P, ;SHOULD NOT FAIL
MOVEI T1,PROFIL ;POINT TO INTERNAL PROFILE BUFFER
PJRST UPDCO4 ;GO CLEAR UPDATE ACTIVE PPN AND RETURN
;VALIDATE USER NAME ON AN UPDATE WHEN PROFILE LENGTH DIFFERS
UPDVAL: PUSHJ P,.SAVE2 ;SAVE P1 AND P2
MOVEI P1,TEMP+.AENAM ;TEMP PROFILE USER NAME
MOVEI P2,PROFIL+.AENAM ;NAME ON DISK
MOVSI T1,-.AANLW ;AOBJN POINTER
UPDVA1: MOVE T2,(P1) ;GET A WORD
CAME T2,(P2) ;MATCH?
JRST UPDVA2 ;NO
ADDI P1,1 ;ADVANCE POINTER
ADDI P2,1 ;...
AOBJN T1,UPDVA1 ;LOOP THROUGH ENTIRE NAME
JRST .POPJ1 ;RETURN IF NO NAME CHANGE
UPDVA2: MOVE T1,ARGS ;GET CALLER'S BUFFER
MOVSI T1,.AENAM(T1) ;NEW NAME
HRRI T1,TEMP+.AENAM ;STORAGE
BLT T1,TEMP+.AENAM+.AANLW-1 ;COPY IN NEW NAME
MOVEI T1,TEMP ;POINT TO PROFILE
PUSHJ P,UPDCO4 ;FIRST CHANGE JUST THE NAME
POPJ P, ;FAILED
JRST .POPJ1 ;NOW COMPLETE THE UPDATE
SUBTTL SET RMS-SPECIFIC OPTIONS
; BIT FIDDLER'S DELIGHT
; CALL: MOVE AC1, OPTION-NUMBER
; MOVE AC2, VALUE
; PUSHJ P,OPTA/OPTB/OPTC
OPTA:: PUSHJ P,ENTA ;SWITCH TO FILE "A" CONTEXT
JRST OPTCOM ;ENTER COMMON CODE
OPTB:: PUSHJ P,ENTB ;SWITCH TO FILE "B" CONTEXT
JRST OPTCOM ;ENTER COMMON CODE
OPTC:: PUSHJ P,ENTC ;SWITCH TO FILE "C" CONTEXT
; JRST OPTCOM ;ENTER COMMON CODE
; COMMON OPTION CODE
OPTCOM: DMOVE T1,ARGS ;GET CALLER'S ARGUMENTS
SKIPL T1 ;RANGE
CAILE T1,OPTMAX ; CHECK
POPJ P, ;NO
PJRST @OPTTAB(T1) ;CALL FUNCTION-SPECIFIC PROCESSOR
OPTTAB: IFIW .POPJ ;(0) CATCH RANDOM CALLERS
IFIW SETLOA ;(1) SET/CLEAR THE RMS "LOAD" MODE BIT
IFIW GETFBE ;(2) GET LAST FAB ERROR
IFIW GETRBE ;(3) GET LAST RAB ERROR
IFIW GETFIL ;(4) GET ADDRESS OF RETURNED FILESPEC BLOCK
OPTMAX==<.-OPTTAB>-1 ;MAX LEGAL OPTION
; FUNCTION 1 - SET/CLEAR LOAD FLAG
;
; T2/ 0 - SET NORMAL MODE, RECORDS WILL BE PLACED REGARDLESS OF FILL FACTORS
; 1 - SET LOAD MODE, FILL FACTOR WILL DETERMINE RECORD PLACEMENT
; MAY BE CALLED ANY TIME, REMAINS AS SET UNTIL CHANGED.
; SHOULD BE SET TO 1 WHEN MASS INSERTIONS ARE BEING DONE. SUCH INSERTIONS
; SHOULD BE SORTED BY PPN TO MAXIMIZE BENEFIT.
SETLOA: MOVEM T2,LOAFLG ;SAVE THE REQUESTED STATUS
DOLOA: JUMPE R,.POPJ ;JUMP IF NO STREAM OPEN
$FETCH T1,ROP,0(R) ;GET CURRENT ROP FIELD
SKIPN LOAFLG ;LOAD MODE?
TXZA T1,RB$LOA ;NO, TELL RMS
TXO T1,RB$LOA ;YES, TELL RMS
$STORE T1,ROP,0(R) ;RETURN RESULT
JUMPE F,.POPJ ;JUMP IF NO FAB
$FETCH T1,FOP,0(F) ;GET CURRENT FOP FIELD
SKIPN LOAFLG ;LOAD MODE?
TXZA T1,FB$DFW ;NO, TELL RMS
TXO T1,FB$DFW ;YES, TELL RMS
$STORE T1,FOP,0(F) ;RETURN RESULT
JRST .POPJ1 ;OK
; FUNCTION 2 - GET FAB ERROR STATUS
GETFBE: JUMPE F,.POPJ ;ERROR IF NO FAB
$FETCH T1,STS,0(F) ;GET STATUS
$FETCH T2,STV,0(F) ;AND STATUS VALUE
DMOVEM T1,ARGS ;SAVE RESULTS
JRST .POPJ1 ;SUCCESS
; FUNCTION 3 - GET RAB STATUS
GETRBE: JUMPE R,.POPJ ;ERROR IF NO RAB
$FETCH T1,STS,0(R) ;GET STATUS
$FETCH T2,STV,0(R) ;AND STATUS VALUE
DMOVEM T1,ARGS ;SAVE RESULTS
JRST .POPJ1 ;SUCCESS
; FUNCTION 4 - GET ADDRESS OF RETURNED FILESPEC BLOCK
GETFIL: MOVE T1,[2,,T2] ;SET UP UUO AC
$FETCH T2,JFN,0(F) ;GET TOPS-10 I/O CHANNEL NUMBER FROM FAB
HRLZS T2 ;PUT IN LH
HRRI T2,.FOFIL ;FILOP. UUO FUNCTION CODE
MOVE T3,[.FOFMX,,FFFIL] ;POINT TO DATA BLOCK
FILOP. T1, ;READ FILESPEC
POPJ P, ;RETURN
MOVEI T1,.FOFMX ;LENGTH OF BLOCK
MOVEI T2,FFFIL ;POINT TO BLOCK
DMOVEM T1,ARGS ;SAVE RESULTS
JRST .POPJ1 ;RETURN
;HERE AFTER EACH RMS OPERATION TO SEE IF THERE WAS AN ERROR
;RETURNS CPOPJ/CPOPJ1, IN EITHER CASE THE STS IS IN T1, THE STV IN T2.
ERRCKF: SKIPA T1,F ;POINT TO FAB AGAIN
ERRCKR: MOVE T1,R ;OR THE RAB
$FETCH T2,STV,0(T1) ;GET STATUS VALUE
$FETCH T1,STS,0(T1) ;AND ACTUAL STATUS
CAIGE T1,ER$MIN ;AN ERROR?
AOS (P) ;NO
POPJ P, ;RETURN
; CONTEXT SWITCH TO THE APPROPRIATE FILE
; THIS IS A CO-ROUTINE THAT MAY NOT BE CALLED RECURSIVELY
; TO SAVE 'N' SETS OF ACS.
; CALL: PUSHJ P,ENTA/ENTB/ENTC
; ALL
ENTX: AOSE SAVFLG ;ALREADY CONTEXT SWITCHED?
POPJ P, ;YES--THEN DO NOTHING
MOVEM 0,SAVACS+0 ;SAVE AC 0
MOVE 0,[1,,SAVACS+1] ;SET UP BLT
BLT 0,SAVACS+17 ;SAVE ACS 1 - 17
SETZB F,R ;NO FAB OR RAB
JRST ENTCOM ;ENTER COMMON CODE
; FILE "A"
ENTA: AOSE SAVFLG ;ALREADY CONTEXT SWITCHED?
POPJ P, ;YES--THEN DO NOTHING
MOVEM 0,SAVACS+0 ;SAVE AC 0
MOVE 0,[1,,SAVACS+1] ;SET UP BLT
BLT 0,SAVACS+17 ;SAVE ACS 1 - 17
MOVEI F,A.WFAB ;POINT TO FAB
MOVEI R,A.WRAB ;POINT TO RAB
JRST ENTCOM ;ENTER COMMON CODE
; FILE "B"
ENTB: AOSE SAVFLG ;ALREADY CONTEXT SWITCHED?
POPJ P, ;YES--THEN DO NOTHING
MOVEM 0,SAVACS+0 ;SAVE AC 0
MOVE 0,[1,,SAVACS+1] ;SET UP BLT
BLT 0,SAVACS+17 ;SAVE ACS 1 - 17
MOVEI F,B.WFAB ;POINT TO FAB
MOVEI R,B.WRAB ;POINT TO RAB
JRST ENTCOM ;ENTER COMMON CODE
; FILE "C"
ENTC: AOSE SAVFLG ;ALREADY CONTEXT SWITCHED?
POPJ P, ;YES--THEN DO NOTHING
MOVEM 0,SAVACS+0 ;SAVE AC 0
MOVE 0,[1,,SAVACS+1] ;SET UP BLT
BLT 0,SAVACS+17 ;SAVE ACS 1 - 17
MOVEI F,C.WFAB ;POINT TO FAB
MOVEI R,C.WRAB ;POINT TO RAB
; JRST ENTCOM ;ENTER COMMON CODE
; COMMON ENTRY/EXIT CODE
ENTCOM: DMOVE T1,SAVACS+1 ;GET CALLER'S ARGUMENTS
DMOVEM T1,ARGS ;SAVE
MOVE T1,SAVACS+P ;GET OLD PDL POINTER
XMOVEI T1,@0(T1) ;GET CALLER'S ADDRESS
MOVE 0,T1 ;COPY ADDRESS
MOVE T1,SAVACS+T1 ;RELOAD T1
PUSHJ P,@0 ;CALL THE CALLER
TDZA T1,T1 ;INDICATE FALSE RETURN
HRROI T1,-1 ;INDICATE TRUE RETURN
MOVEM T1,SAVACS+0 ;SAVE IN AC 0
DMOVE T1,ARGS ;GET RESULTS
DMOVEM T1,SAVACS+1 ;STORE FOR CALLER
MOVE 0,[SAVACS+1,,1] ;SET UP BLT
BLT 0,17 ;RESTORE THE ACS
MOVE 0,SAVACS+0 ;RELOAD AC 0
POP P,(P) ;PRUNE STACK
SETOM SAVFLG ;RESET CONTEXT FLAG
POPJ P, ;RETURN
LIT
RELOC 0
SAVACS: BLOCK 20 ;AC STORAGE
SAVFLG: BLOCK 1 ;NON-ZERO IF ACS SAVED
ACTLCK::0 ;ACCT FILE IS LOCKED FLAG
ARGS: BLOCK 2 ;CALLER'S ARGUMENTS
WLDNXT: BLOCK 1 ;ZERO IF SEARCHING FOR NEXT PROFILE
WLDCNT: BLOCK 1 ;COUNT OF RECURSIONS AND/OR CHARACTER MATCHES
SELBLK: BLOCK 1 ;COUNT OF SELECTION BLOCKS IN MESSAGE
SELPTR: BLOCK 1 ;AOBJN POINTER TO SELECTION DATA
SELFLG::BLOCK 1 ;NON-ZERO IF SELECTION ANALYSIS IN PROGRESS
CMPINS::BLOCK 4 ;COMPARE INSTRUCTIONS
BASNAM: BLOCK 12 ;BASE NAME FOR WILDCARD SEARCHES
TMPNAM: BLOCK .AANLW ;TEMP STG FOR UP-CASED USER NAME STRING(ASCIZ)
UPDNAM: BLOCK .AANLW ;TEMP STORAGE FOR USER NAME DURING UPDATE
LOAFLG: BLOCK 1 ;"LOAD MODE" FLAG
PROFIL: BLOCK .AEMAX ;INTERNAL PROFILE BLOCK
TEMP: BLOCK .AEMAX ;ANOTHER INTERNAL PROFILE FOR UPDATES
; FILE "A" STORAGE
A.ZBEG:! ;START OF BLOCK TO ZERO
A.WFAB: BLOCK FA$LNG ;WORKING FAB
A.WRAB: BLOCK RA$LNG ;WORKING RAB
A.WXA1: BLOCK XA$SXA ;WORKING XAB FOR AREA 1
A.WXA2: BLOCK XA$SXA ;WORKING XAB FOR AREA 2
A.WXA3: BLOCK XA$SXA ;WORKING XAB FOR AREA 3
A.WXK0: BLOCK XA$SXK ;WORKING XAB FOR KEY 0
A.WXK1: BLOCK XA$SXK ;WORKING XAB FOR KEY 1
A.ZEND:! ;END OF BLOCK TO ZERO
; FILE "B" STORAGE
B.ZBEG:! ;START OF BLOCK TO ZERO
B.WFAB: BLOCK FA$LNG ;WORKING FAB
B.WRAB: BLOCK RA$LNG ;WORKING RAB
B.WXA1: BLOCK XA$SXA ;WORKING XAB FOR AREA 1
B.WXA2: BLOCK XA$SXA ;WORKING XAB FOR AREA 2
B.WXA3: BLOCK XA$SXA ;WORKING XAB FOR AREA 3
B.WXK0: BLOCK XA$SXK ;WORKING XAB FOR KEY 0
B.WXK1: BLOCK XA$SXK ;WORKING XAB FOR KEY 1
B.ZEND:! ;END OF BLOCK TO ZERO
; FILE "C" STORAGE
C.ZBEG:! ;START OF BLOCK TO ZERO
C.WFAB: BLOCK FA$LNG ;WORKING FAB
C.WRAB: BLOCK RA$LNG ;WORKING RAB
C.WXA1: BLOCK XA$SXA ;WORKING XAB FOR AREA 1
C.WXA2: BLOCK XA$SXA ;WORKING XAB FOR AREA 2
C.WXA3: BLOCK XA$SXA ;WORKING XAB FOR AREA 3
C.WXK0: BLOCK XA$SXK ;WORKING XAB FOR KEY 0
C.WXK1: BLOCK XA$SXK ;WORKING XAB FOR KEY 1
C.ZEND:! ;END OF BLOCK TO ZERO
; XAB ADDRESS STORAGE FOR OPNINI
X.WXA1: BLOCK 1 ;ADDRESS OF WORKING XAB FOR AREA 1
X.WXA2: BLOCK 1 ;ADDRESS OF WORKING XAB FOR AREA 2
X.WXA3: BLOCK 1 ;ADDRESS OF WORKING XAB FOR AREA 3
X.WXK0: BLOCK 1 ;ADDRESS OF WORKING XAB FOR KEY 0
X.WXK1: BLOCK 1 ;ADDRESS OF WORKING XAB FOR KEY 1
; FILE FIXUP STORAGE
FFZBEG:! ;START OF BLOCK TO ZERO
FFFLG: BLOCK 1 ;NON-ZERO IF CALL TO OPNBLK SUCCESSFUL
FFFIL: BLOCK .FOFMX ;RETURNED FILESPEC BLOCK
FFFOP: BLOCK .FOMAX ;FILOP BLOCK
FFPTH: BLOCK .PTMAX ;PATH BLOCK
FFLKP: BLOCK .RBMAX+1 ;LOOKUP BLOCK
FFREN: BLOCK .RBMAX+1 ;RENAME BLOCK
FFZEND:! ;END OF BLOCK TO ZERO
RMS$$G::BLOCK 3K ;3 PAGES FOR RMS GLOBAL DATA
PRGEND
TITLE ACTPDF - PROFILE DEFAUTLING
SEARCH ACTPRM
MODULE (ACTPDF)
ENTRY A$PDEF
; THIS ROUTINE WILL CAUSE A USER PROFILE TO HAVE ITS DEFAULTED FIELDS
; FILLED IN FROM THE ALTERNATE PROFILE PROVIDED. IT IS EXPECTED THAT
; THE CALLER RESERVED .AEMAX WORDS FOR THE USER PROFILE BLOCK.
; CALL: MOVE T1, USER PROFILE ADDRESS
; MOVE T2, DEFAULT PROFILE ADDRESS
; PUSHJ P,A$PDEF
;
; TRUE RETURN, PROFILE'S DEFAULT FIELDS COPIED.
; FALSE RETURN, SOMETHING WENT WRONG (NO ROOM FOR EXTENSIBLE BLOCK?).
;
; CLOBBERS ONLY S1 & S2.
A$PDEF::PUSHJ P,.SAVE4 ;PRESERVE SOME ACS
$SAVE <T1,T2,T3,T4> ;AND SOME MORE
DMOVE P1,T1 ;SAVE THE ARGUMENTS
MOVE P3,[POINT 1,.AEMAP(P1)] ;EXAMINE THE USER'S DEFAULT MAP
MOVSI P4,-CHGLEN## ;FOR EXAMINING CHGTAB
PDEF.1: MOVE T4,CHGTAB##(P4) ;GET BITS FOR NEXT ENTRY
ILDB T3,P3 ;AND USER'S PROFILE BIT
JUMPE T3,PDEF.5 ;DON'T BOTHER IF NO DEFAULTING WANTED
TXNE T4,PD.CND ;CAN IT BE DEFAULTED?
JRST PDEF.4 ;NO, CLEAR THE BIT
TXNE T4,PD.EXT ;IS THIS AN EXTENSIBLE BLOCK?
JRST PDEF.3 ;YES, HANDLE DIFFERENTLY
LOAD T1,T4,PD.WRD ;NO, GET LENGTH OF SUB-BLOCK
JUMPE T1,PDEF.4 ;SKIP THIS WORD IF IT'S NOT FOR REAL
DMOVE S1,P1 ;COPY BLOCK ADDRESSES
ADDI S1,(P4) ;FORM OFFSET
ADDI S2,(P4) ;INTO EACH BLOCK
PDEF.2: MOVE T2,(S2) ;GET DEFAULT VALUE
MOVEM T2,(S1) ;STORE IN USER PROFILE
SOJLE T1,PDEF.5 ;DIFFERENT OVERHEAD AT END OF BLOCK
AOJ S1, ;ADVANCE PROFILE POINTER
AOJ S2, ;BOTH PROFILES
IDPB T3,P3 ;MAKE SURE DEFAULT BITS ARE CONSISTENT
AOBJN P4,PDEF.2 ;ADVANCE CHGTAB POINTER AND LOOP
$RETF ;SOMETHING'S WRONG IF IT WON'T FIT
PDEF.3: DMOVE T1,P1 ;COPY PROFILE ADDRESSES
ADDI T2,(P4) ;POINT TO ENTRY IN DEFAULT BLOCK
MOVE T2,(T2) ;GET THE RELATIVE BLOCK POINTER
HRRZ T3,T2 ;COPY THE OFFSET
SKIPE T3 ;IF THERE'S REALLY A SUB-BLOCK,
ADDI T3,(P2) ;GET ITS ADDRESS (NOT OFFSET)
HRRI T2,(P4) ;HERE'S THE PROFILE OFFSET WE'RE AFTER
SETO T4, ;DEFAULT BIT IS ALREADY ON, LEAVE IT
PUSHJ P,A$EBLK## ;DIDDLE THE EXTENSIBLE BLOCK
JUMPT PDEF.5 ;KEEP GOING IF ITS SUCCEEDS
$RET ;PROPAGATE FAILURE
PDEF.4: SETZ T3, ;GET A ZERO BIT
DPB T3,P3 ;THIS IS NOT EITHER A DEFAULTED FIELD
PDEF.5: AOBJN P4,PDEF.1 ;LOOP OVER ALL OF CHGTAB
$RETT ;IT WORKED!
LIT
PRGEND
TITLE ACTBLK - PROFILE MEMORY MANAGEMENT
SEARCH ACTPRM
MODULE (ACTBLK)
ENTRY A$EBLK
; THIS ROUTINE WILL ALLOCATE, DEALLOCATE, AND SHUFFLE EXTENSIBLE
; DATA BLOCKS WITHIN A PROFILE. IT IS EXPECTED THE CALLER HAS
; RESERVED .AEMAX WORDS FOR A PROFILE.
; CALL: MOVE T1, PROFILE ADDRESS
; MOVE T2, -LENGTH,,PROFILE OFFSET
; MOVE T3, ADDRESS OF BLOCK TO INSERT OR ZERO
; MOVE T4, FLAG
; PUSHJ P,A$EBLK
;
; FLAG: -1 = DO NOT UPDATE .AEMAP
; 0 = CLEAR .AEMAP BIT
; 1 = SET .AEMAP BIT
;
; TRUE RETURN: BLOCK INSERTED IF T3 NON-ZERO OR DELETED IF ZERO
; FALSE RETURN: NO ROOM TO INSERT BLOCK
A$EBLK::PUSHJ P,.SAVE4 ;SAVE SOME ACS
DMOVE P1,T1 ;COPY
DMOVE P3,T3 ; ARGS
HRRZ T1,P2 ;GET OFFSET
MOVX T2,PD.EXT ;BIT DENOTING EXTENSIBLE BLOCKS
CAIGE T1,.AEMIN ;IS IT IN THE RANGE OF VALID BLOCK TYPES?
TDNN T2,CHGTAB##(T1) ;AND IS IT EXTENSIBLE?
$RETF ;NO, FAIL BEFORE WE DO DAMAGE
JUMPE P3,DELBLF ;GO DELETE IF NO BLOCK GIVEN
ADDBLK: HRRZ T1,P2 ;GET OFFSET
ADDI T1,(P1) ;INDEX INTO PROFILE
SKIPN (T1) ;BETTER NOT BE IN USE
JRST ADDBL1 ;IT'S NOT
PUSHJ P,DELBLK ;FIRST DELETE WHAT'S THERE
HRRZ T1,P2 ;GET OFFSET AGAIN
ADDI T1,(P1) ;RESET INDEX INTO PROFILE
ADDBL1: HRRZ T3,P2 ;GET OFFSET AGAIN
LOAD T3,CHGTAB##(T3),PD.WRD ;GET MAX. BLOCK SIZE
MOVNS T3 ;NEGATE IT FOR COMPARISONS
HLRE T2,P2 ;GET -LENGTH
CAMGE T2,T3 ;BLOCK TOO LONG?
MOVE T2,T3 ;YES, ONLY USE OUR MAX. LENGTH
HRL P2,T2 ;UPDATE LENGTH
MOVMS T2 ;MAKE POSITIVE
HRRZ T3,.AEVRS(P1) ;GET LENGTH OF PROFILE SO FAR
ADDI T2,(T3) ;COMPUTE LAST WORD IN PROFILE
CAILE T2,.AEMAX ;WILL NEW BLOCK FIT?
$RETF ;NOPE
HRRM T2,.AEVRS(P1) ;UPDATE NEW PROFILE LENGTH
HLLM P2,(T1) ;STORE -WORD COUNT OF EXTENSIBLE BLOCK
HRRM T3,(T1) ;AND THE RELATIVE OFFSET IN PROFILE
ADDI T3,(P1) ;POINT TO END OF THE PROFILE NOW
HRLI T3,(P3) ;MAKE A BLT POINTER
ADDI T2,(P1) ;COMPUTE END OF BLT
BLT T3,-1(T2) ;COPY INTO THE PROFILE
EBLKRT: JUMPL P4,.RETT ;RETURN IF NO UPDATES TO .AEMAP WANTED
MOVE T1,P1 ;GET PROFILE ADDRESS
HRRZ T2,P2 ;GET PROFILE OFFSET FOR AOBJN POINTER
MOVE T3,P4 ;GET SET/CLEAR BIT
PJRST A$BMAP## ;GO TOGGLE BIT AND RETURN
DELBLF: PUSHJ P,DELBLK ;DELETE THE BLOCK
PJRST EBLKRT ;DO COMMON RETURN CODE
DELBLK: PUSHJ P,.SAVE4 ;PRESERVE ARGUMENTS
MOVSI T1,(P1) ;POINT TO PROFILE
HRRI T1,TEMP ;AND TO TEMP STORAGE
BLT T1,TEMP+.AEMAX-1 ;COPY PROFILE
MOVEI T1,.AEMIN ;MINIMUM LENGTH
HRRM T1,.AEVRS(P1) ;TRUNCATE ORIGINAL PROFILE
MOVSI T1,.AEMIN(P1) ;POINT TO END OF STATIC PROFILE
HRRI T1,.AEMIN+1(P1) ;MAKE A BLT POINTER
SETZM .AEMIN(P1) ;CLEAR FIRST WORD
BLT T1,.AEMAX-1(P1) ;ZERO OUT EXTENSIBLE DATA STORAGE
MOVSI P4,-EXTSIZ ;AOBJN POINTER
DELBL1: MOVE T1,EXTTBL(P4) ;GET PROFILE OFFSET
ADDI T1,(P1) ;INDEX INTO ORIGINAL PROFILE
SETZM (T1) ;ZERO EXTENSIBLE POINTER
AOBJN P4,DELBL1 ;LOOP FOR ALL POINTERS
MOVSI P4,-EXTSIZ ;AOBJN POINTER
HRRZ T1,P2 ;GET OFFSET OF POINTER TO BLOCK FOR DELETION
PUSH P,T1 ;SAVE
DELBL2: MOVE T1,EXTTBL(P4) ;GET AN OFFSET
CAME T1,(P) ;FOUND BLOCK TO DELETE?
SKIPN P2,TEMP(T1) ;NO--GET OFFSET TO EXTENSIBLE DATA
JRST DELBL3 ;THERE IS NONE
HRRZ P3,P2 ;GET RELATIVE INDEX INTO PROFILE
ADDI P3,TEMP ;POINT DIRECTLY TO IT
HRR P2,T1 ;WHERE TO STUFF NEW AOBJN POINTER
PUSH P,P4 ;SAVE AOBJN POINTER
MOVNI P4,1 ;IGNORE .AEMAP
PUSHJ P,ADDBLK ;RE-INSERT THE BLOCK
POP P,P4 ;RESTORE AOBJN POINTER
DELBL3: AOBJN P4,DELBL2 ;LOOP FOR ALL POSSIBLE DATA POINTERS
POP P,(P) ;PHASE STACK
POPJ P, ;RETURN
EXTTBL: EXTDAT ;TABLE OF EXTENSIBLE DATA BLOCK OFFSETS
EXTSIZ==.-EXTTBL ;NUMBER OF ACTUAL ENTRIES IN TABLE
LIT
RELOC 0
TEMP: BLOCK .AEMAX ;TEMPORARY PROFILE
PRGEND
TITLE ACTBIT - SET/CLEAR BITS IN .AEMAP
SEARCH ACTPRM
MODULE (ACTBIT)
ENTRY A$BMAP
; ROUTINE TO TOGGLE BITS IN .AEMAP BIT MAP
; CALL: MOVE T1, PROFILE ADDRESS
; MOVE T2, PROFILE OFFSET
; MOVE T3, FLAG (-1 = CHECK, 0 = CLEAR, 1 = SET)
; PUSHJ P,A$BMAP##
;
; TRUE RETURN: 1. FUNCTION = CHECK AND BIT IS SET
; 2. FUNCTION = SET/CLEAR AND OFFSET IS LEGAL
; FALSE RETURN: 1. FUNCTION = CHECK AND BIT IS CLEAR
; 2. FUNCTION = SET/CLEAR AND OFFSET IS ILLEGAL
;
; ON EITHER RETURN, T1 AND T2 REMAIN UNCHANGED AND T3 HAS THE POSSIBLY
; UPDATED STATUS OF THE BIT BEING CHECKED/SET/CLEARED. THIS IS SO THE
; CALLER MAY TURN AROUND AND IMMEDIATELY CHANGE THE STATUS OF THE BIT
; WITHOUT HAVING TO SETUP THE ACS AGAIN.
; THIS CODE WILL HAVE TO CHANGE IF EVER THERE IS A STATIC BLOCK WHICH IS
; DEFAULTABLE.
A$BMAP::CAIL T2,.AEMIN ;WITHIN RANGE OF BLOCK OFFSETS?
JUMPGE T3,.RETF ;NO, AND CHANGING, FAIL NOW
CAIL T2,.AEMIN ;CHECK AGAIN
JRST BMAP1 ;YES, AND CHECKING, IT'S DEFAULTED (FOR NOW)
PUSH P,T1 ;SAVE T1
PUSH P,T2 ;SAVE T2
MOVE T4,T3 ;COPY CHECK/CLEAR/SET FLAG
IDIVI T2,^D36 ;COMPUTE WORD OFFSET IN .AEMAP
ADDI T2,.AEMAP(T1) ;INDEX INTO BIT MAP
MOVN T1,T3 ;NEGATE BIT POSITION
MOVSI T3,400000 ;INITIAL BIT
LSH T3,(T1) ;POSITION
JUMPGE T4,BMAP2 ;JUMP IF CHANGING STATUS
MOVE T4,T2 ;COPY BIT MAP ADDRESS
POP P,T2 ;RESTORE T2
POP P,T1 ;RESTORE T1
TDNN T3,(T4) ;CHECK BIT
BMAP0: TDZA T3,T3 ;BIT IS CLEAR
BMAP1: SKIPA T3,[EXP 1] ;BIT IT SET
$RETF ;RETURN
$RETT ;RETURN
BMAP2: ANDI T4,1 ;AVOID ILL MEM REFS
XCT [ANDCAM T3,(T2)
IORM T3,(T2)](T4)
MOVEI T3,(T4) ;GET STATE OF BIT
POP P,T2 ;RESTORE T2
POP P,T1 ;RESTORE T1
$RETT ;RETURN
PRGEND
TITLE ACTCHG - SELECTION/CHANGE TABLE
SEARCH ACTPRM
MODULE (ACTCHG)
ENTRY CHGTAB
CHGTAB::
DEFINE AE(NAM,LEN,BTS,RTN),<
BITS==0!<BTS>
IFE <LEN>+1,<BITS==BITS!PD.MSK>
IFL <LEN>+1,<BITS==BITS!PD.EXT>
IFL <LEN>,<BITS==BITS!FLD(<-<LEN>>,PD.WRD)>
IFG <LEN>,<BITS==BITS!FLD(<LEN>,PD.WRD)>
IFNB<RTN>,<BITS==BITS!PD.RTN>
IF2,< IFNB<RTN>,< .IF RTN,NEEDED,<EXTERN RTN> > >
IFN <LEN>,< EXP BITS!RTN >
BITS==<BITS&PD.CND>!PD.NMD!PD.NSL
IFG <LEN>-1,< REPEAT <LEN>-1,< EXP BITS > >
>
AEPROF
CHGLEN==:.-CHGTAB ;LENGTH OF THIS TABLE
IF1,< IFN CHGLEN-.AEMIN,<
PRINTX ? CHGTAB is wrong
>>
PRGEND
TITLE ACTSCD - SCDMAP.SYS ROUTINES
SEARCH ACTPRM
MODULE (ACTSCD)
ENTRY A$DSCD, A$FSCD, A$ISCD
ND SCDSIZ,^D128*2 ;SIZE OF SCDMAP.SYS DATA
; OPEN SCDMAP.SYS AND READ IN THE MAPS
; CALL: PUSHJ P,A$ISCD
;
; TRUE RETURN: SCDMAP.SYS IN CORE, S1 CONTAINS THE ADDRESS OF THE MAP
; FALSE RETURN: FAILED
A$ISCD::SKIPE SCDTBL ;POINTER THERE?
$RETT ;YES, JUST RETURN
PUSHJ P,.SAVE2 ;SAVE P1 AND P2
MOVEI S1,FOB.MZ ;FOB SIZE
MOVEI S2,SCDFOB ;FOB ADDRESS
PUSHJ P,F%IOPN ;OPEN FOR INPUT
$RETIF ;CHECK FOR ERRORS
MOVE P1,S1 ;SAVE IFN
MOVEI S1,SCDSIZ ;SIZE OF SCDMAP FILE
PUSHJ P,M%GMEM ;GET CORE
MOVEM S2,SCDTBL ;POINT TO THE CORE WE GOT
HRLI S2,-SCDSIZ ;MAKE AN AOBJN POINTER
MOVE P2,S2 ;COPY IT
MOVE S1,P1 ;GET IFN BACK
ISCD1: PUSHJ P,F%IBYT ;GET A WORD
JUMPF ISCD2 ;CHECK FOR ERRORS
MOVEM S2,(P2) ;PUT A WORD
AOBJN P2,ISCD1 ;LOOP THROUGH FILE
PUSHJ P,ISCD3 ;RELEASE THE CHANNEL
$RETT ;RETURN
ISCD2: PUSHJ P,A$DSCD ;DELETE MAP
ISCD3: MOVE S1,P1 ;GET IFN
PUSHJ P,F%RREL ;RELEASE THE CHANNEL
$RETF ;RETURN
; DELETE SCDMAP.SYS DATA
; CALL: PUSHJ P,A$CSCD
A$DSCD::MOVEI S1,SCDSIZ ;SIZE OF SCDMAP FILE
MOVE S2,SCDTBL ;ADDRESS OF MAP
PUSHJ P,M%RMEM ;RELEASE CORE
SETZM SCDTBL ;CLEAR POINTER
$RETT ;RETURN
; GET SCHEDULER TYPE AND CLASS
; CALL: MOVE S1, PROFILE BLOCK ADDRESS
; PUSHJ P,A$FSCD
A$FSCD::PUSHJ P,.SAVE3 ;SAVE SOME ACS
MOVE P1,S1 ;POINT TO ENTRY
SKIPN P2,SCDTBL ;FIND OUT IF WE HAVE SCHEDULAR DATA
JRST FSCD1 ;NOPE, JUST GIVE THE RAW FILE DATA
LDB P2,[POINTR .AESCD(P1),AE.SCD] ;GET SCHEDULAR TYPE
IDIVI P2,4 ;GET INDEX INTO TABLE
ADD P2,SCDTBL ;ADD TABLE BASE ADDRESS
LDB S1,BYTTAB(P3) ;GET TIMESHARING CLASS
ADDI P2,SCDSIZ/2 ;POINT INTO BATCH END
LDB P2,BYTTAB(P3) ;GET BATCH CLASS
DPB S1,[POINTR P2,AE.SCT] ;TIMESHARING INFO
FSCD1: HRRM P2,.AESCD(P1) ;GET SCHEDULAR TYPE AND ENQ QUOTA
$RETT
BYTTAB: POINT 9,(P2),8 ;BYTE PTR FOR REMAINDER=0
POINT 9,(P2),17 ;REMAINDER=1
POINT 9,(P2),26 ;REMAINDER=2
POINT 9,(P2),35 ;REMAINDER=3
SCDFOB: $BUILD (FOB.MZ) ;BLOCK SIZE
$SET (FOB.FD,,SCDFD) ;FILE DESCRIPTOR
$SET (FOB.CW,FB.PHY,1) ;PHYSICAL I/O
$SET (FOB.CW,FB.BSZ,44);36-BIT BYTES
$EOB ;END OF BLOCK
SCDFD: $BUILD (FDXSIZ) ;BLOCK SIZE
$SET (.FDLEN,FD.LEN,FDXSIZ) ;BLOCK LENGTH
$SET (.FDLEN,FD.TYP,.FDNAT) ;NATIVE TOPS-10 FILE
$SET (.FDSTR,,'SYS ');DEVICE
$SET (.FDNAM,,'SCDMAP');FILE NAME
$SET (.FDEXT,,'SYS ');EXTENSION
$EOB ;END OF BLOCK
LIT
RELOC 0
SCDTBL: BLOCK 1 ;POINTER TO SCDMAP DATA
PRGEND
TITLE ACTSUM - GENERATE SUMMARY TEXT
SEARCH ACTPRM
MODULE (ACTSUM)
ENTRY A$SWLD
; GENERATE SUMMARY TEXT FOLLOWING CALLS TO FETCH A PROFILE
; CALL: MOVE T1, WILDCARD MESSAGE BLOCK
; MOVE T2, BYTE POINTER TO ACK TEXT
; MOVE T3, TEXT
; MOVE T4, SUCCESS-COUNT,,FAILURE-COUNT
; PUSHJ P,A$SWLD
;
; TRUE RETURN: AT LEAST ON PROFILE FOUND
; FALSE RETURN: NO PROFILES FOUND
;
; ON EITHER RETURN, S1 CONTAINS THE ADDRESS OF THE GENERATED TEXT
A$SWLD::PUSHJ P,.SAVE1 ;SAVE P1
MOVE P1,S1 ;COPY TEXT TO INSERT
SKIPG UW$FND(T1) ;FOUND ANY MATCHES?
JRST SWLD1 ;NO
HLRZ TF,T4 ;GET SUCCESS COUNT
MOVEI S1,[ITEXT (<^D/T4,LHMASK/ users>)]
CAIN TF,0
MOVEI S1,[ITEXT (<no users>)]
CAIN TF,1
MOVEI S1,[ITEXT (<one user>)]
HRRZ TF,T4 ;GET FAILURE COUNT
MOVEI S2,[ITEXT (<; there were ^D/T4,RHMASK/ failures>)]
CAIN TF,0
MOVEI S2,[ITEXT (<>)]
CAIN TF,1
MOVEI S2,[ITEXT (<; there was one failure>)]
$TEXT (<-1,,SUMTXT>,<A total of ^I/(S1)/ ^T/(P1)/^I/(S2)/^0>)
MOVEI S1,SUMTXT ;POINT TO TEXT
$RETT ;RETURN
SWLD1: MOVE S1,UW$WST(T1) ;GET SEARCH TYPE
CAIN S1,1 ;WILD NAME?
JRST SWLD2 ;YES
CAIN S1,2 ;NON-WILD NAME?
JRST SWLD3 ;YES
CAIG S1,1 ;WILD PPN OR NAM?
MOVE S1,UW$PPM(T1) ;GET PPN MASK
AOJE S1,SWLD3 ;JUMP IF NOT WILD
SWLD2: MOVEI S2,[ITEXT (<No users matching ^Q/T2/>)]
SKIPE UW$SEL(T1) ;ANY SELECTION BLOCKS?
MOVEI S2,[ITEXT (<Users ^Q/T2/ rejected by constraints>)]
JRST SWLD4 ;FINISH UP
SWLD3: MOVEI S2,[ITEXT (<No such user ^Q/T2/>)]
SKIPE UW$SEL(T1) ;ANY SELECTION BLOCKS?
MOVEI S2,[ITEXT (<User ^Q/T2/ rejected by constraints>)]
SWLD4: $TEXT (<-1,,SUMTXT>,<^I/(S2)/^0>)
MOVEI S1,SUMTXT ;POINT TO TEXT
$RETF ;RETURN
LIT
RELOC 0
SUMTXT: BLOCK ^D30 ;ROOM FOR A LONG NAME + LOTS OF CRUFT
END
Reference in New Issue View Git Blame Copy Permalink