.title SETUP - Set up VMS working environment .ident "V4.0" ; .library /mar:always/ ; ; Program: SETUP.MAR V4.0, VAX/VMS V5.1-1 ; ; Author: David G. North, CCP ; 1333 Maywood Ct ; Plano, Texas 75023-1914 ; (214) 902-3957 ; Additional ; Routines: Hunter Goatley - DCL key definition routines, ; original article February 1988 issue of ; Vax Professional ; ; Date: 90.11.20 ; ; Revisions: ; Who Date Description ; D.North 901120 DECUS release (Fall 90) ; D.North 911113 DECUS release (Fall 91) ; ; License: ; Ownership of and rights to these programs is retained by the author(s). ; Limited license to use and distribute the software in this library is ; hereby granted under the following conditions: ; 1. Any and all authorship, ownership, copyright or licensing ; information is preserved within any source copies at all times. ; 2. Under absolutely *NO* circumstances may any of this code be used ; in any form for commercial profit without a written licensing ; agreement from the author(s). This does not imply that such ; a written agreement could not be obtained. ; 3. Except by written agreement under condition 2, source shall ; be freely provided with all binaries. ; 4. Library contents may be transferred or copied in any form so ; long as conditions 1, 2, and 3 are met. Nominal charges may ; be assessed for media and transferral labor without such charges ; being considered 'commercial profit' thereby violating condition 2. ; ; Warranty: ; These programs are distributed in the hopes that they will be useful, but ; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY ; or FITNESS FOR A PARTICULAR PURPOSE. ; ; Description: See accompanying SETUP.RNO. ; The symbols MODE, $MODE, QUEUE_NAME, and ENTRY_NUMBER are ; defined for use by subsequent images or DCL. ; ; Revisions: When What ; 88.07.01 - Added Priority Boost and /NOSWAP ; 88.07.12 - Added rundown timer in case of program error ; 89.02.13 - Add DCL key definition routines (Goatley) ; 89.07.11 - Added REPLY/ENABLE capability ; 89.07.12 - Added SET MESSAGE capability (disabled) ; 89.07.12 - Added DISABLE_CMKRNL & DISABLE_CMEXEC ; 89.07.14 - Added unique macro library for SETUP (SETUPMLB) ; 89.07.14 - Added code for node specific items ; 89.07.17 - Changed error messages to use $PUTMSG service ; 90.11.19 - Cleaned up 'getopt_' test types & documentation ; 90.11.20 - Prompt, verify, exit command, internal restructure ; .library "setupmlb" .link "sys$system:sys.stb"/selective_search .link "sys$system:dcldef.stb"/selective_search $brkdef $chfdef $dvidef $iodef $jpidef $lnmdef $opcdef $prvdef $psldef $quidef $ssdef $ttdef $tt2def $uaidef _msgbitdef _prtdef _nodedef .PSECT $USRDATA,NOEXE,RD,WRT ; __ Customization section begins __ ; __ Customization section begins __ ; __ Customization section begins __ ; ;*** This program is designed to boost itself while running... uncomment ; the following to disable generation of boosting code ;DISABLE_BOOST = 1 ; comment this to enable boosting code ; ;*** This program can set the message flags for the process... unfortunately, ; they are protected URKW necessitating use of KERNEL mode code to set them. ; Since this may be unacceptable in a production environment, you must ; comment out the following line of code in order to allow generation of ; the $CMKRNL calls. Note that this is node-dependent and therefore may ; be enabled on a per-node basis... the DISABLE_CMKRNL flag is used to ; prevent *ANY* usage of kernel code for *ALL* nodes. ;DISABLE_CMKRNL = 1 ; comment to enable KERNEL code ; ;*** Similar flag for EXECUTIVE code (DCL keys) ;DISABLE_CMEXEC = 1 ; comment to enable EXEC code ; ;*** Similar flag for SUPERVISOR code (DCL prompt & verify) (via EXEC) ;DISABLE_CMSUPER = 1 ; comment to enable SUPERVISOR code ; ;* ;*** This is the lists of known nodes and classes ; Privilege classes DEFINE_CLASS CMSUPER ; May use supervisor code if generated DEFINE_CLASS CMEXEC ; May use exec code if generated DEFINE_CLASS CMKRNL ; May use kernel code if generated ; Operator/privilege classes DEFINE_CLASS OPER1 ; May enable self as operator (reply set 1) DEFINE_CLASS OPER2 ; May enable self as operator (reply set 2) ; Node/Cluster classes DEFINE_CLASS DWARVES ; Member of DWARVES cluster DEFINE_CLASS GIANTS ; Member of GIANTS cluster DEFINE_CLASS OTHER ; Member of OTHER cluster or NO cluster ; AltSyslib class - uses [1,3] instead of [1,2]... DEFINE_CLASS ALTSYSLIB ; Use alternate syslib (protection for PRD1-4) DEFINE_CLASS HOMEBASE ; Node is a home base... full environment ; Collection definitions DEFINE_COLLECTION PRIV_NODE,CMKRNL,CMEXEC,CMSUPER DEFINE_COLLECTION ALL_NODES,GIANTS,DWARVES,OTHER DEFINE_COLLECTION NON_GIANT,DWARVES,OTHER DEFINE_COLLECTION PRODUCTION,DWARVES,CMEXEC,CMSUPER,OPER1,ALTSYSLIB ; Node definitions DEFINE_NODE DEVEL,DWARVES,PRIV_NODE,HOMEBASE,,OPER1 DEFINE_NODE PRD1,PRODUCTION DEFINE_NODE PRD2,PRODUCTION DEFINE_NODE PRD3,PRODUCTION DEFINE_NODE PRD4,PRODUCTION DEFINE_NODE GIANT1,GIANTS DEFINE_NODE GIANT2,GIANTS DEFINE_NODE GIANT3,GIANTS DEFINE_NODE TSTBED,OTHER,PRIV_NODE,OPER2 ;* ;*** This list of symbols will be categorcally atomized with no errors ; (Usage is default...only class-mismatch not executed) hitlst: .ITM .ITM .ITM .ITM .ITM .EOLIST ;* ;*** This is the list of symbols to be defined ; (Usage is default...only class-mismatch not executed) symlst: .ITMVAL , .ITMVAL ,<$authorize> .ITMVAL , .ITMVAL ,<$$:cd.exe> .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL ,<@tools:debugoff> .ITMVAL ,<@tools:debugon> .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL ,<$$:prv> .ITMVAL ,<@tools:keptsda> .ITMVAL , .ITMVAL , .ITMVAL ,<1> .ITMVAL , .EOLIST ;* ;*** This is the list of logicals to be defined ;*** Note use of table names and how attributes are specified ; (Usage is default...only class-mismatch not executed) loglst: .ITM .ITMVAL <$>, .ITMVAL <$>,,COLL=ALTSYSLIB .ITMVAL ,<*>,OPTION=LNM$M_CONCEALED .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL , .ITMVAL ,<$2$DUA233:>,- OPTION=,COLL=DWARVES .EOLIST .EOLIST ;* ;*** This is the list of keys to be defined ;*** Note use of IFSTATE names and how attributes are specified ; (Usage is default...only class-mismatch not executed) ; (Note though, that 'keycls' collection {exact} membership req'd first!) keycls: .COLL CMEXEC keylst: .ITM .ITMVAL ,,- OPTION= .ITMVAL ,,- OPTION= .ITMVAL ,,- OPTION= .ITMVAL ,,- OPTION= .ITMVAL ,,- OPTION= .ITMVAL ,,- OPTION= .ITMVAL ,,- OPTION= .ITMVAL ,,- OPTION= .EOLIST .EOLIST ;* ;*** This is the list of processnames to be attempted 'til success ; (Usage is inhibited...class membership, or null<-->null match req'd) stdprc: .ITM .ITM .ITM .ITM .ITM .ITM .ITM .ITM .EOLIST ;Essentially not used...comment prclst: .ITM OPTION=stdprc .ITM OPTION=stdprc,COLL=ALL_NODES .EOLIST ;* ;*** This is the list of prompts ; (Usage is protected...class membership must exist) ; Items in the prompt list will be activated if *all* characteristics are ; matched. The first match of all characteristics will terminate the ; operation. wizset: .ascid <^x90>"1;16;1;0;0;2;0;0;{1???????????????/????????___ow}~//;"- <^x9c><^x90>"1;17;1;0;0;2;0;0;{1G[{{G_oPxwGa~d~/???@@HKNw~kNNNN//;"- <^x9c><^x90>"1;24;1;0;0;2;0;0;{1???????????????/lxba_o??????_{[//;"- <^x9c><^x90>"1;25;1;0;0;2;0;0;{1|NzyWWWKKKCs~N?/N}xnKG???o{NB??//;"- <^x9c> wizprm: .ascid <^x1b>"[1m"<^x1b>")1"<^x0e>"08"<^x1b>"[2D"<^x0a>"19"- <^x1b>")1"<^x0f><^x1b>"[m " dotprm: .ascid <^x1b>"[1m«»"<^x1b>"[m" stprmv: .address dotprm .long 0 ;no setup .long TT$_VT300_SERIES,0,TT2$M_REGIS .address wizprm .address wizset .long TT$_VT300_SERIES,0,0 .EOLIST prmlst: .ITM OPTION=stprmv,COLL=CMSUPER .EOLIST ;* ;*** This is the SET VERIFY flag ; (Usage is protected...class membership must exist) othver: batver: netver: falver: intver: .ITM OPTION=0,COLL=CMSUPER .EOLIST ;* ;*** This is the default protection ; (Usage is inhibited...class membership, or null<-->null match req'd) defpro: .ITM OPTION=<!!- !> .ITM OPTION=<!!- !>,- COLL=ALL_NODES .EOLIST ;* ;*** This is the default message flags .IF NDF,DISABLE_CMKRNL ; (Usage is inhibited...class membership, or null<-->null match req'd) ; (Note though, that 'msfcls' collection {exact} membership req'd first!) msfcls: .COLL CMKRNL defmsg: .ITM OPTION=MSGBIT_M_TEXT,COLL=CMKRNL .EOLIST .ENDC ;* ;*** These are the default privilege masks for the process ; (Usage is inhibited...class membership, or null<-->null match req'd) ; -- Default masks available...define new privilege combinations here stdmsk: .long ,<1@> minmsk: .long ,0 netmsk: .long ,0 allmsk: .long -1,-1 ; -- Mask lists by mode by classes...define new classes here to access masks batprv: othprv: intprv: .ITM OPTION=stdmsk .ITM OPTION=allmsk,COLL=NON_GIANT .ITM OPTION=minmsk,COLL=GIANTS .EOLIST falprv: .ITM OPTION=minmsk .ITM OPTION=minmsk,COLL=ALL_NODES .EOLIST netprv: .ITM OPTION=netmsk .ITM OPTION=netmsk,COLL=ALL_NODES .EOLIST ;* ;*** These define default directories by mode by node ; (Usage is inhibited...class membership, or null<-->null match req'd) ; -- Default dirs available...define new default dirs here dirpw: .ascid /[PRIVATE.WORK]/ dirpn: .ascid /[PRIVATE.NETWORK]/ ; -- Dir lists by mode by classes...define new classes here to access dirs faldir: ; failure batdir: ; batch othdir: ; other intdir: ; interactive .ITM OPTION=dirpw .ITM OPTION=dirpw,COLL=ALL_NODES .EOLIST netdir: ; network .ITM OPTION=dirpn .ITM OPTION=dirpn,COLL=ALL_NODES .EOLIST ; ;*** These define matching default drives by mode ; (Usage is inhibited...class membership, or null<-->null match req'd) ; -- Default drives available...define new default drives here drvpw: drvpn: .ascid /DSK:/ ; -- Drive lists by mode by classes...define new classes here to access drives faldrv: ; failure batdrv: ; batch othdrv: ; other intdrv: ; interactive netdrv: ; network .ITM OPTION=drvpn .ITM OPTION=drvpn,COLL=ALL_NODES .EOLIST ; ;*** This defines terminal broadcast states by node ; (Usage is inhibited...class membership, or null<-->null match req'd) ; -- Broadcast states available...define new broadcast states here stdbro: .long 0,<1@>!<1@>!- <1@> ; -- Broadcast states by classes...define new classes here for broadcast states ttbro: .ITM OPTION=stdbro .ITM OPTION=stdbro,COLL=ALL_NODES .EOLIST ; ;*** These define terminal characteristics by node ; (Usage is inhibited...class membership, or null<-->null match req'd) stdoff: .byte 0 ;class .byte 0 ;type .word 0 ;width .long TT$M_NOBRDCST!<0@24> ;0@24 is the page length position .long TT2$M_INSERT ;extended chars stdon: .long 0,0,0 ;same structure as above ; -- Broadcast states by classes...define new classes here for broadcast states ttoff: .ITM OPTION=stdoff .ITM OPTION=stdoff,COLL=ALL_NODES .EOLIST tton: .ITM OPTION=stdon .ITM OPTION=stdon,COLL=ALL_NODES .EOLIST ;* ;*** This is the list of exit DCL commands ; (Usage is protected...class membership must exist) stddo: .ascid /mytables/ ; -- Dir lists by mode by classes...define new classes here to access dirs batdo: ; batch intdo: ; interactive .ITM OPTION=stddo,COLL=ALL_NODES .EOLIST faldo: ; failure othdo: ; other netdo: ; network .EOLIST ; ;*** This defines the default classes for which the terminal will be enabled ; as an operator to receive messages from OPCOM ; (Usage is protected...node must be member of collection) opcmsk: .ITM COLL=OPER1,OPTION=<- OPC$M_NM_CENTRL!- OPC$M_NM_PRINT!- OPC$M_NM_TAPES!- OPC$M_NM_DISKS!- OPC$M_NM_DEVICE!- OPC$M_NM_CARDS!- OPC$M_NM_CLUSTER!- OPC$M_NM_SECURITY!- OPC$M_NM_LICENSE!- OPC$M_NM_OPER8!- OPC$M_NM_OPER12> .ITM COLL=OPER2,OPTION=<- OPC$M_NM_CENTRL!- OPC$M_NM_PRINT!- OPC$M_NM_TAPES!- OPC$M_NM_DISKS!- OPC$M_NM_DEVICE!- OPC$M_NM_CARDS!- OPC$M_NM_NTWORK!- OPC$M_NM_CLUSTER!- OPC$M_NM_SECURITY!- OPC$M_NM_LICENSE!- OPC$M_NM_OPER1!- OPC$M_NM_OPER2!- OPC$M_NM_OPER3!- OPC$M_NM_OPER4!- OPC$M_NM_OPER5!- OPC$M_NM_OPER6!- OPC$M_NM_OPER7!- OPC$M_NM_OPER8!- OPC$M_NM_OPER9!- OPC$M_NM_OPER10!- OPC$M_NM_OPER11!- OPC$M_NM_OPER12> .EOLIST ; ; __ No Customization modifications below this point __ ; __ No Customization modifications below this point __ ; __ No Customization modifications below this point __ .PSECT $SETUPDATA,NOEXE,RD,WRT ; ;*** Annunciate status of code generation .IIF NDF,DISABLE_CMKRNL, .PRINT 999 ; KERNEL code enabled .IIF DF,DISABLE_CMKRNL, .PRINT 999 ; KERNEL code disabled .IIF NDF,DISABLE_CMEXEC, .PRINT 998 ; EXEC code enabled .IIF DF,DISABLE_CMEXEC, .PRINT 998 ; EXEC code disabled .IIF NDF,DISABLE_CMSUPER, .PRINT 997 ; SUPERVISOR code enabled .IIF DF,DISABLE_CMSUPER, .PRINT 997 ; SUPERVISOR code disabled .IIF NDF,DISABLE_BOOST, .PRINT 996 ; BOOST code enabled .IIF DF,DISABLE_BOOST, .PRINT 996 ; BOOST code disabled ; ;*** These are internal work vars and constants extblk: .long 0,timout,1,extcnd ;exit handler description block extcnd: .long 0 ;place for exit handler condition code actprv: .quad 0 ;place to load active privs modepr: .long othprv,netprv,batprv,intprv,falprv actdrv: .long 0 ;place to load active drive actdir: .long 0 ;place to load active dir modecd: .long othdrv,othdir,netdrv,netdir,batdrv .long batdir,intdrv,intdir,faldrv,faldir modedo: .long othdo,netdo,batdo,intdo,faldo modevf: .long othver,netver,batver,intver,falver actbro: .long 0 ;address of active broadcast classes actoff: .long 0 ;address of terminal *OFF* chars acton: .long 0 ;address of terminal *ON* chars actprc: .long 0 ;address of active processname list actprm: .long 0 ;DCL prompt address verify: .long 0 ;contents: verify state +1 actdo: .long 0 ;address if LIB$DO command asctim: .ascid /0 0:0:5/ ;5s max boosted time bintim: .quad prctbl: .ascid /LNM$PROCESS_TABLE/ sysdsk: .ascid /SYS$DISK/ tblind: .long 2 ;annunciation to global table offmsk: .long -1 ;mask to ashcan all privileges .long -1 star: .asciz /*/ data1: .udesc 128 nodes: .ascid /NODE/ modes: .ascid /MODE/ mode0: .ascid /OTHER/ mode1: .ascid /NETWORK/ mode2: .ascid /BATCH/ mode3: .ascid /INTERACTIVE/ mode4: .ascid /JPI$_FAIL/ model: .long mode0 .long mode1 .long mode2 .long mode3 .long mode4 modev: .long 4 moden: .ascid /$MODE/ numctl: .ascid /%X!XL/ modval: .udesc 16 qnmsym: .ascid /QUEUE_NAME/ entsym: .ascid /ENTRY_NUMBER/ time: .blkl 2 cmeprv: .long ,0 cmkprv: .long ,0 booprv: .long ,0 boopri = 12 ; boosted priority norpri: .long 4 ; back down to normal usrnam: .udesc 32 usrlen: .long 32 ; for restore if needed uic: .long 0 jpilst: .long JPI$_MODE@16!4,modev,0 .long JPI$_AUTHPRI@16!4,norpri,0 .long JPI$_USERNAME@16!12,usrnam+8,usrnam .long JPI$_UIC@16!4,uic,0 .long 0 defdev: .blkb 16 defdir: .blkb 64 uailst: .long UAI$_DEFDEV@16!16,defdev,0 .long UAI$_DEFDIR@16!64,defdir,0 .long 0 quflgs: .long QUI$M_SEARCH_THIS_JOB entno: .long 0 entval: .udesc 16 quenam: .udesc 32 quiosb: .long 0,0 ;status quilst: .long QUI$_SEARCH_FLAGS@16!4,quflgs,0 .long QUI$_ENTRY_NUMBER@16!4,entno,0 .long 0 quils2: .long QUI$_SEARCH_FLAGS@16!4,quflgs,0 .long QUI$_SEARCH_NAME@16!1,star,0 .long QUI$_QUEUE_NAME@16!31,quenam+8,quenam .long 0 ; end of list lnmfdv: .ascid /LNM$FILE_DEV/ lnmjob: .ascid /LNM$JOB/ syslgi: .ascid /SYS$LOGIN/ atr: .long 0 trn: .udesc trnls1: .long LNM$_STRING@16!128,trn+8,trn,0 .long LNM$_ATTRIBUTES@16!4,atr,0 .long 0 curdir: .udesc device: .udesc exacmo: .byte PSL$C_EXEC ttchr: .blkb 12 ttchn: .long 0 ttnam: .ascid /TT:/ ; enbmsg: .byte OPC$_RQ_TERME,1,0,0 enbcls: .long 0 unit: .word 0 devnml: .byte 0 devnam: .blkb 64 enbdsc: .long <^x010e0000!<.-enbmsg-64>> .long enbmsg retlen: .long 0 retunt: .long 0 oprprv: .long PRV$M_OPER,0 secprv: .long 0,<1@> dvilst: .long DVI$_FULLDEVNAM@16!64,devnam,retlen .long DVI$_UNIT@16!4,retunt,0 .long 0 node: .long 0 ;no located nodename class: .long 0 ;default class of none nodeid: .udesc <^x20> syilst: .long !15,nodeid+8,nodeid .long 0 trnls2: .long LNM$_STRING@16!^x20,nodeid+8,nodeid,0 .long 0 sysnod: .ascid /SYS$NODE/ lnmsys: .ascid /LNM$SYSTEM/ ; .PSECT $SETUPCODE,PIC,USR,CON,REL,LCL,SHR,EXE,RD,NOWRT,NOVEC ; ;++ ; ** OOPS_CATCHER - exception handler ;-- .entry oops_catcher, ^m movpsl r0 extzv #PSL$V_CURMOD,#PSL$S_CURMOD,r0,r0 ;get current mode cmpl r0,#PSL$C_USER ; is it user mode??? bneq 10$ ; no...handle condition calls #0,timout ; shut things up right movl #SS$_RESIGNAL,r0 ; and pass it along.... brb 20$ ; normal return 10$: movl CHF$L_SIGARGLST(AP),r4 ; signal argument list cmpl CHF$L_SIG_NAME(r4),#SS$_UNWIND ; is this an unwind??? beql 20$ ; yep... keep on unwinding movl CHF$L_MCHARGLST(AP),r5 ; get mechanism list address movl CHF$L_SIG_NAME(r4),CHF$L_MCH_SAVR0(r5) ; copy signame $UNWIND_S ; Wipe out gracefully movl #SS$_CONTINUE,r0 ; Continue from exception 20$: ret ; return to caller ; ;++ ; ; HG$DEFINE_KEY - DEFINE/KEY ; 4(AP) - Key name descriptor ; 8(AP) - Key value descriptor ; 12(AP) - If_State string descriptor ; 16(AP) - Set_State string descriptor (null ok) ; 20(AP) - Flag address (SYM_M_* flags) ; ;-- .IF NDF,DISABLE_CMEXEC key_name = 4 equivalence = 8 if_state = 12 set_state = 16 flags = 20 work_bytes = 512 .entry hg$define_key, ^m cmpl #5,(AP) beql 5$ movl #LIB$_WRONUMARG,r0 ret 5$: subl2 #work_bytes,sp movl sp,r10 ; r10 --> template ; -- fill in template clrl SYM_L_FL(r10) ; Clear fwd link clrl SYM_L_BL(r10) ; Clear bck link clrl SYM_L_ORDERED(r10) ; ORDERED link (unused in 4.5) clrw SYM_W_FILELEVEL(r10) ; clear file level mnegw #1,SYM_W_PROCLEVEL(r10) ; Set no procedure level ??? clrw SYM_W_BLOCKLEVEL(r10) clrw SYM_L_BLOCKSEQ(r10) clrw SYM_W_SIZE(r10) ; clear size movb #SYM_K_KEYPAD,- SYM_B_TYPE(r10) ; this is a keypad symbol movl flags(AP),r0 ; get the flags movw (r0),SYM_W_FLAGS(r10) movab SYM_T_SYMBOL(r10),r3 ; template address of keyname movl key_name(ap),r0 ; address of keyname descrip movb (r0),(r3)+ ; copy length movc3 (r0),@4(r0),(r3) ; copy string to template movw @if_state(AP),r0 ; if state length addw2 @equivalence(AP),r0 ; add equivalence length tstl set_state(AP) ; is there a set_state? beql 10$ ; nope... don't add it in addw2 @set_state(AP),r0 ; add it in... 10$: addw2 #4,r0 ; +4 (number of length bytes) movw r0,(r3)+ ; put sum next 3 field lengths pushl r0 ; save length movl if_state(AP),r1 ; address of if_state movb (r1),(r3)+ ; copy length movc3 (r1),@4(r1),(r3) ; copy string to template movl equivalence(AP),r1 ; equivalence descriptor addr movw (r1),(r3)+ ; copy length movc3 (r1),@4(r1),(r3) ; copy string to template movl set_state(AP),r1 ; is there a set_state? beql 20$ ; nope... don't use it movb (r1),(r3)+ ; copy length movc3 (r1),@4(r1),(r3) ; copy string to template bisw2 #SYM_M_STATE,- ; set STATE bit for caller SYM_W_FLAGS(r10) 20$: clrb (r3)+ ; clear last byte of template addl3 (SP)+,#SYM_T_SYMBOL+1,r0 ; calc size of template addb2 SYM_T_SYMBOL(r10),r0 ; symbol name size addl2 #2,r0 ; include word sum of 3 lengths addl2 #7,r0 ; truncate to quad boundary bicl2 #7,r0 ; round to next quad boundary movw r0,SYM_W_SIZE(r10) ; set size of queue entry $CMEXEC_S - ; do rest of job in exec ROUTIN = exec_keydef ; (R10 is common data) addl2 #work_bytes,sp ; give back work space (no need) ret ; ; Exec routine to alloc and fill CLI memory ; .entry exec_keydef, ^m movaw oops_catcher,(FP) ;set a safety net moval G^CTL$AG_CLIDATA,r11 movl PPD$L_PRC(r11),r11 movab PRC_Q_ALLOCREG(r11),r3 ; get adddress of free memory movzwl SYM_W_SIZE(r10),r1 ; size of block to allocate jsb @#EXE$ALLOCATE ; alloc the memory movl #LIB$_INSCLIMEM,r0 ; assume not enough memory tstl r2 ; was space alloc'd? beql 20$ ; nope... crap out pushr #^m ; save movc5 trashed registers movc5 SYM_W_SIZE(r10),(r10),#0,- r1,(r2) ; suck over the template popr #^m ; restore trashed registers movw r1,SYM_W_SIZE(r10) ; set actual length alloc'd bsbw find_place ; find place to insert it insque SYM_L_FL(r2),@SYM_L_BL(r0) ; insert in que @r0 movl #SS$_NORMAL,r0 ; normal completion 20$: ret ; go home to user mode safety ; ; -- find place to stick in key definition ; find_place: pushr #^m movab SYM_T_SYMBOL+1(r10),r1 ; get address of key name movzbl -1(r1),r0 ; get key length addl2 r0,r1 ; r1 --> word length of rest incl r1 ; skip over word length incl r1 ; r1 --> if_state string movzbl (r1)+,r0 ; get the if_state length pushl r1 ; put addr onstack pushl r0 ; put len onstack movzbl SYM_T_SYMBOL(r10),r8 ; r8 = len of key name movab SYM_T_SYMBOL+1(r10),r9 ; r9 = addr of keyname movl PRC_Q_KEYPAD(r11),r6 ; r6 --> first entry in queue movab PRC_Q_KEYPAD(r11),r7 ; r7 --> beginning of queue 10$: cmpl r6,r7 ; EOQ yet? beql 20$ ; yep -- bug out movab SYM_T_SYMBOL+1(r6),r1 ; get address of keyname movzbl -1(r1),r0 ; get length addl2 r0,r1 ; r1 --> word length of rest incl r1 ; skip over word length incl r1 ; r1 --> if_state string movzbl (r1)+,r0 ; get the if_state length cmpc5 (sp),@4(sp),#^a/ /,r0,(r1) ; is this the same state? blssu 20$ ; no - try next entry bgtru 15$ ; if >, no ents for if_state movzbl SYM_T_SYMBOL(r6),r0 ; get len of keynam in que cmpc5 r8,(r9),#^a/ /,r0,SYM_T_SYMBOL+1(r6) ; comparem blssu 20$ ; found place if key rsb deletekey: pushl r3 ; save movab PRC_Q_ALLOCREG(r11),r3 ; allocation region listhead remque SYM_L_FL(r6),r0 ; unlink it movl SYM_L_FL(r0),r6 ; pick up 'new' current entry movzwl SYM_W_SIZE(r0),r1 ; size to unload jsb @#EXE$DEALLOCATE ; deallo the memory popl r3 ; restore register rsb ; backtocaller .ENDC ; ; PUTMSG ; Simpleton's interface to $PUTMSG ; .entry putmsg, ^m<> $PUTMSG_S - msgvec = (AP) ret ; ; GETNODE ; Get the nodename of the current node ; .entry getnode, ^m movc5 #0,#0,#^a/ /,nodeid,@nodeid+4 ;clear NODEID field $GETSYIW_S - ITMLST = syilst blbc r0,10$ tstw nodeid beql 10$ cmpb @nodeid+4,#^a/ / beql 10$ brw 30$ 10$: $TRNLNM_S - TABNAM = lnmsys,- LOGNAM = sysnod,- ITMLST = trnls2 blbc r0,30$ subw #2,nodeid ;scrape off the trailing colons brb 30$ 20$: movl #0,nodeid ;set no logical name 30$: ret ; ;SYSLOGIN ; Get rooted pathname for SYS$LOGIN ; .entry syslogin, ^m<> movab @curdir+4,r1 movb #^a/[/,0(r1) ;poke in a ']' movb #^a/]/,1(r1) ;poke in a ']' movw #2,curdir ;set length 2 movc3 syslgi,@syslgi+4,@device+4 movw syslgi,device ;start out with this device calls #0,inspth ;insert path ret inspth: .word ^m movw trn,r8 clrl atr clrl r9 ;indicate initial run clrb @trn+4 insrst: movw r8,trn bbs #LNM$V_TERMINAL,atr,10$ cmpb @trn+4,#^a/_/ bneq 20$ 10$: brw 60$ 20$: $TRNLNM_S - TABNAM = lnmfdv,- LOGNAM = device,- ITMLST = trnls1,- ACMODE = exacmo cmpl r0,#SS$_NOLOGNAM bneqw 70$ ;more tranlation needed $TRNLNM_S - TABNAM = lnmjob,- LOGNAM = device,- ITMLST = trnls1,- ACMODE = exacmo cmpl r0,#SS$_NOLOGNAM bneqw 70$ ;more tranlation needed tstl r9 ;see if we've been here before bneqw 60$ ;wasn't first NOLOGNAM 40$: $getuai_s - ;try the UAF for the login usrnam = usrnam,- itmlst = uailst blbs r0,50$ ;looks like we got it cmpl r9,#1 ;see if this is round #2 beql 60$ ;getouttahere... nothing worked movw usrlen,usrnam ;reset username length $idtoasc_s - id = uic,- namlen = usrnam,- nambuf = usrnam ;get username assoc. w/uic blbc r0,60$ ;that failed too...skipit incl r9 ;set getuai retry flag brb 40$ ;retry getuai w/new username 50$: movzbl defdev,r6 ;get len to stable reg movc3 r6,defdev+1,@trn+4 ;zip device into place addl3 trn+4,r6,r0 ;get address to put DIR movzbl defdir,r7 ;length of DIR to stable reg movc3 r7,defdir+1,(r0) ;stuffit addw3 r6,r7,trn ;calculate new length for trans brb 70$ ;try operation using UAF stuff 60$: brw pthext 70$: incl r9 ;flag successful translation locc #^a/:/,trn,@trn+4 ;find the resultant colon ; beql oops ;better be one there subl3 trn+4,r1,r6 ;length of device name in r2 movc3 r6,@trn+4,@device+4 ;copy for new device movw r6,device ;set length subw3 r6,trn,r7 ;set length of second part bicl #^x0ffff0000,r7 decl r7 ;yank the colon we found beql 99$ addl trn+4,r6 ;get source for next copy incl r6 ;skip the colon cmpb -1(r6)[r7],#^a/]/ ;strip a closing bracket bneq 80$ decl r7 ;remove it beql 99$ 80$: cmpb -1(r6)[r7],#^a/./ ;strip trailing '.' bneq 90$ decl r7 beql 99$ 90$: movb #^a/./,@curdir+4 ;stuff in a separator addl3 curdir+4,r7,r2 ;address of new stuff movc3 curdir,@curdir+4,(r2) ;make space for new stuff movc3 r7,(r6),@curdir+4 addw r7,curdir ;add in new space 99$: brw insrst pthext: movq device,r6 bicl #^x0ffff0000,r6 movb #^a/:/,(r7)[r6] incw device ;tack on a trailing colon incw r6 addl3 r6,curdir+4,r2 movc3 curdir,@curdir+4,(r2) ;insert device movc3 r6,@device+4,@curdir+4 addw r6,curdir movaq curdir,r1 movzwl #SS$_NORMAL,r0 ret ; ; SETDSK ; Set sysdisk to new disk for CD ; .entry setdsk, ^m<> pushl #0 ;no itmlist pushl #0 ;attribs pushaq prctbl ;here is the table name pushaq @4(AP) ;here is the value pushaq sysdsk ;here is the logical to assign value to calls #5,G^LIB$SET_LOGICAL ret ; ; SETDEFDIR ; Set sysdefdir for other half of CD operation ; .entry setdefdir, ^m<> pushl #0 ;optional prams not present pushl #0 ;optional parms not present pushaq @4(AP) ;incoming value calls #3,G^SYS$SETDDIR ret ; ; SETDEF ; Complete CD Operation ; .entry setdef, ^m<> pushaq @4(AP) ;push directory sent calls #1,setdefdir ;define it pushaq @8(AP) ;push disk sent calls #1,setdsk ;define that too ret ; ; TRVSL0: ; traverses an item list and executes routine w/parms ; ; inputs: pushab getopt_ ; pushal itemlist ; pushaw routine ; outputs: r0 contains eolist from input itemlist ; .entry trvsl0, ^m movl 4(AP),r4 ;get exec routine address movl 8(AP),r8 ;get data address 5$: movl r8,r0 ;save current address movl (r8)+,r6 ;load eoitem pointer beql 20$ ;eolist movzwl r6,r6 ;clear high word addl r0,r6 ;calculate next item address jsb @12(AP) ;check (r0) (r6)-n for class match bneq 10$ ;skip item if not class matched pushl r1 ;pass options/attributes pushl r8 ;item to be defined calls #2,(r4) ;do the function 10$: movl r6,r8 ;set next item address jmp 5$ ;back for another main item 20$: movl r8,r0 ;return eolist in R0 ret ; ; TRVSL1: ; traverses an item list and executes routine w/parms ; item list is multi-argument ; ; inputs: [pushaq lv2dsc] ;level 2 descriptor ; pushab getopt_ ; pushal itemlist ; pushaw routine ; outputs: r0 contains eolist from input itemlist ; .entry trvsl1, ^m movl 4(AP),r4 ;get exec routine address movl 8(AP),r8 ;get data address 10$: movl (r8)+,r7 ;get argcnt bneq 15$ ;nzero pointer is neolist brw 40$ ;zero pointer is eolist 15$: movl r8,r0 ;save current address movl (r8)+,r6 ;load eoitem pointer movzwl r6,r6 ;clear high word addl r0,r6 ;calculate next item address jsb @12(AP) ;check (r0) (r6)-n for class match beql 20$ ;process item if EQL movl r6,r8 ;jmp to item 17$: movl r8,r0 ;save current address movzwl (r8),r8 ;load eoitem pointer addl r0,r8 ;calculate next item address sobgtr r7,17$ ;keep it up, 'til eolist brw 10$ ;back for another main item 20$: movl #3,r5 ;initial item count movl r8,r9 ;save initial item name address 30$: movl r6,r8 ;jmp to item movl r8,r0 ;save current address movl (r8)+,r6 ;load eoitem pointer movzwl r6,r6 ;clear high word addl r0,r6 ;calculate next item address pushl r8 ;value descriptor incl r5 ;another item for the calls sobgtr r7,30$ ;keep it up, 'til eolist clrl -(SP) ;no level 2 descriptor yet cmpl (AP),#4 ;see if there's a level 2 descriptor bneq 35$ ;no level 2 descriptor movaq @16(AP),(SP) ;rewrite level 2 descriptor 35$: pushl r1 ;option longword pushl r9 ;item to be defined calls r5,(r4) ;do the function movl r6,r8 ;jmp to first item brw 10$ ;back for another main item 40$: movl r8,r0 ;return eolist in R0 ret ; ; TRVSL2: ; traverses list of itmlsts and executes routine w/parms ; using trvsl1 ; ; inputs: pushab getopt_ ; pushal itemlistlist ; pushaw routine ; outputs: r0 contains eolist from input itemlist ; .entry trvsl2, ^m movl 4(AP),r4 ;get exec routine address movl 8(AP),r0 ;get data address 10$: movl r0,r1 ;save current address movl (r0)+,r2 ;eotbl descriptor beql 20$ ;eolist movzwl r2,r2 ;clear high word addl r1,r2 ;calculate eoitem address pushl r0 ;level 2 descriptor pushl 12(AP) ;pass operation type pushl r2 ;item list list to be used pushl 4(AP) ;push routine address calls #4,trvsl1 ;do the function return new r0 brw 10$ ;back for another main item 20$: ret ;return eolist in r0 ; ; GETOPT_DEFAULT: ; -- get item options default execute ... note JSB entry ; input: (r0) item header ; (r6) end of item calculated ; output: EQL - class match - perform operation ; r1 = 0 or OPTION ; ; all 0-items executed by all ; all nz-items executed if match to class ; getopt_default: clrl r1 bbc #0,2(r0),10$ ;skip option load movl -4(r6),r1 ;load option 10$: bbs #1,2(r0),40$ ;must test further 20$: bispsw #^m ;set EQL condition (Z flag) (default) rsb ;return condition 30$: bicpsw #^m ;set NEQ condition (Z flag) rsb ;return condition 40$: bbs #0,2(r0),50$ ;code to skip option longword bitl -4(r6),class ;test mask against membership classes brb 60$ ;finish test 50$: bitl -8(r6),class ;test mask against membership classes 60$: beql 30$ ;no bits found...send NEQ return brb 20$ ;bits found...send EQL return ; ; GETOPT_MEMBERS: ; -- get item options member-only execute ... note JSB entry ; input: (r0) item header ; (r6) end of item calculated ; output: EQL - class match - perform operation ; r1 = 0 or OPTION ; ; 0-items executed by classed only ; nz-items executed if match to class ; getopt_members: clrl r1 bbc #0,2(r0),10$ ;skip option load movl -4(r6),r1 ;load option 10$: bbs #1,2(r0),40$ ;must test further tstl class ;is a class specified?? bneq 30$ ;member of classes...ok to default 20$: bicpsw #^m ;set NEQ condition (Z flag) rsb ;return condition 30$: bispsw #^m ;set EQL condition (Z flag) (default) rsb ;return condition 40$: bbs #0,2(r0),50$ ;code to skip option longword bitl -4(r6),class ;test mask against membership classes brb 60$ ;finish test 50$: bitl -8(r6),class ;test mask against membership classes 60$: beql 20$ ;no bits found...send NEQ return brb 30$ ;bits found...send EQL return ; ; GETOPT_INHIBIT: ; -- get item options inhibit default execute ... note JSB entry ; input: (r0) item header ; (r6) end of item calculated ; output: EQL - class match - perform operation ; r1 = 0 or OPTION ; ; 0-items executed by non-classed ; nz-items executed if match to class ; getopt_inhibit: clrl r1 bbc #0,2(r0),10$ ;skip option load movl -4(r6),r1 ;load option 10$: bbs #1,2(r0),40$ ;must test further tstl class ;is a class specified?? bneq 30$ ;member of classes...do not default 20$: bispsw #^m ;set EQL condition (Z flag) (default) rsb ;return condition 30$: bicpsw #^m ;set NEQ condition (Z flag) rsb ;return condition 40$: bbs #0,2(r0),50$ ;code to skip option longword bitl -4(r6),class ;test mask against membership classes brb 60$ ;finish test 50$: bitl -8(r6),class ;test mask against membership classes 60$: beql 30$ ;no bits found...send NEQ return brb 20$ ;bits found...send EQL return ; ; GETOPT_PROTECTED: ; -- get item options execute only if member... note JSB entry ; input: (r0) item header ; (r6) end of item calculated ; output: EQL - class match - perform operation ; r1 = 0 or OPTION ; ; 0-items never executed ; nz-items executed if match to class ; getopt_protected: clrl r1 bbc #0,2(r0),10$ ;skip option load movl -4(r6),r1 ;load option 10$: bbs #1,2(r0),40$ ;must test further 20$: bicpsw #^m ;set NEQ condition (Z flag) rsb ;return condition 30$: bispsw #^m ;set EQL condition (Z flag) (default) rsb ;return condition 40$: bbs #0,2(r0),50$ ;code to skip option longword bitl -4(r6),class ;test mask against membership classes brb 60$ ;finish test 50$: bitl -8(r6),class ;test mask against membership classes 60$: beql 20$ ;no bits found...send NEQ return brb 30$ ;bits found...send EQL return ; ; REPLYDEFINER ; Designed to be called from trvsl0 ; Sets operator class message flags ; .entry replydefiner, ^m<> movl 8(AP),enbcls ; set operator enable class ret ; ; SETMESSDEFINER ; Designed to be called from trvsl0 ; Sets message flags per DCL command $ SET MESSAGE/NOFACILITY... etc. ; Note: Uses $CMKRNL service. Use with caution on production equipment. ; .IF NDF,DISABLE_CMKRNL .entry setmessdefiner, ^m pushl 8(AP) ; incoming option is msg flags pushl #1 moval (SP),r2 $CMKRNL_S - ROUTIN = _setmess,- ARGLST = (r2) ret .entry _setmess, ^m<> movaw oops_catcher,(FP) ; set safety net movb 4(AP),@#CTL$GB_MSGMASK ; set new message value movzbl #SS$_NORMAL,r0 ; all is OK ret .ENDC ; ; DEFDIRDEFINER: ; designed to be called from trvsl0 ; defines default directory from OPTION(address) passed in ; .entry defdirdefiner,^m<> moval @8(AP),actdir ;set active default drive ret ; ; DEFDRVDEFINER: ; designed to be called from trvsl0 ; defines default drive from OPTION(address) passed in ; .entry defdrvdefiner,^m<> moval @8(AP),actdrv ;set active default drive ret ; ; DEFBRODEFINER: ; designed to be called from trvsl0 ; defines default broadcast from OPTION(address) passed in ; .entry defbrodefiner,^m<> moval @8(AP),actbro ;set active default broadcast ret ; ; DEFONDEFINER: ; designed to be called from trvsl0 ; defines default TTON from OPTION(address) passed in ; .entry defondefiner,^m<> moval @8(AP),acton ;set active default TTON chars ret ; ; DEFOFFDEFINER: ; designed to be called from trvsl0 ; defines default TTOFF from OPTION(address) passed in ; .entry defoffdefiner,^m<> moval @8(AP),actoff ;set active default TTOFF chars ret ; ; DEFPRVDEFINER: ; designed to be called from trvsl0 ; defines default privileges from OPTION(address) passed in ; .entry defprvdefiner,^m<> movq @8(AP),actprv ;move default privileges ret ; ; DEFPRODEFINER: ; designed to be called from trvsl0 ; defines default protection from OPTION passed in ; .entry defprodefiner,^m<> pushl 8(AP) moval (SP),r1 pushl #0 ;I couldn't care less what it was pushaw (r1) ;I want it set to this! calls #2,G^SYS$SETDFPROT ;Do the set prot xxx/def ret ; ; DEFPRCDEFINER: ; designed to be called from trvsl0 ; defines default processname list from OPTION(address) passed in ; .entry defprcdefiner,^m<> moval @8(AP),actprc ;move default processnames ret ; ; DEFPRMDEFINER: ; designed to be called from trvsl0 ; defines DCL prompt descriptor address from OPTION(address) passed in ; .entry defprmdefiner,^m<> moval @8(AP),actprm ;move prompt address ret ; ; VERDEFINER: ; designed to be called from trvsl0 ; defines verify status from OPTION(address) passed in ; .entry verdefiner,^m<> addl3 #1,8(AP),verify ;set verify state +1 ret ; ; DODEFINER: ; designed to be called from trvsl0 ; defines final 'do' command address from OPTION(address) passed in ; .entry dodefiner,^m<> movaq @8(AP),actdo ;insert address of 'do' list ret ; ; SYMKILLER: ; designed to be called from trvsl0 ; deletes symbols based on input parameters ; this routine expects EXACTLY ONE parameter ; .entry symkiller, ^m pushal tblind ;annunciate these to global table pushaq @4(AP) ;item pointer calls #2,G^LIB$DELETE_SYMBOL ret ;go home ; ; SYMDEFINER: ; designed to be called from trvsl1 ; assigns values to symbols based on input parameters ; this routine expects EXACTLY FOUR parameters ; Note that OPTION is ignored ; .entry symdefiner, ^m cmpl #4,(AP) ;see if multi-parms bneq 20$ ;deny invalid parameter count pushal tblind ;annunciate these to global table pushaq @16(AP) ;symbol value pushaq @4(AP) ;symbol name calls #3,G^LIB$SET_SYMBOL cmpl r0,#SS$_NORMAL ;is all ok? beql 10$ ;it's ok $EXIT_S CODE=r0 ;barf if I don't understand the error 10$: ret ;go home 20$: pushaq @4(AP) ;address of symbol being defined pushl #1 ;1 FAO parameter pushl #STP_SYMMES ;this message calls #3,putmsg ;dump it $EXIT_S ;bug out ; ; LOGDEFINER: ; designed to be called from trvsl1 ; assigns values to logicals based on input parameters ; this routine expects two or more parameters ; if there are three or more parameters, a list of values is defined ; lv2dsc (longword) is expected to contain a pointer to a table_name ; descriptor. ; .entry logdefiner, ^m movl (AP),r2 ;numargs cmpl #4,r2 ;see if multi-parms beql 5$ ;no...process single parm brw 40$ ;process list 5$: movl 8(AP),-(SP) ;save incoming attributes clrl -(SP) ;no itmlist pushal 4(SP) ;attribs pushaq @12(AP) ;here is the table name beql 30$ ;none specified...bomb movq @16(AP),r0 ;get value descriptor cmpw r0,#1 ;see if it's one byte long bneq 10$ ;not one byte long cmpb (r1),#^a/*/ ;test for '*' bneq 10$ ;Not a '*' pushaq curdir ;define this one as rooted logical brb 20$ ;skip valpush 10$: pushaq @16(AP) ;here is the value 20$: pushaq @4(AP) ;here is the logical to assign value to calls #5,G^LIB$SET_LOGICAL cmpl r0,#SS$_NORMAL ;see if ok beql lexit ;yep cmpl r0,#SS$_SUPERSEDE ;supersedes are allowed w/o error beql lexit ;yep $EXIT_S CODE=r0 ;leavus (i don't understand error) 30$: pushl #STP_NOTBL calls #1,putmsg $EXIT_S 40$: moval 16(AP),r3 ;addr of last val (first val arg) item movl 8(AP),-(SP) ;options moval (SP),r5 ;address of options longword pushl #0 ;list terminator subl #3,r2 ;rmv cnt for main item, option, &lv2dsc 50$: ;form ITEM_LIST_3 on stack pushl #0 ;ret ^ movl (r3)+,r1 ;get address of descriptor pushl 4(r1) ;push address of string movzwl (r1),r1 ;get length to r1 bisl #LNM$_STRING@16,r1 ;place code into high r1 pushl r1 ;this is the code/length of the item sobgtr r2,50$ ;place all items into list movl 8(AP),(r5) ;copy options/attributes pushal (SP) ;pointer to itemlist pushal (r5) ;attribs pushaq @12(AP) ;here is the table name beql 30$ ;none specified...bomb pushl #0 ;values are specified in itmlst pushaq @4(AP) ;logical name calls #5,G^LIB$SET_LOGICAL cmpl r0,#SS$_NORMAL ;see if ok beql lexit ;yep (restore stack) cmpl r0,#SS$_SUPERSEDE ;supersedes are allowed w/o error beql lexit ;yep (restore stack) $EXIT_S CODE=r0 ;leavus (I don't understand error) lexit: ret ;go home ; ; KEYDEFINER: ; designed to be called from trvsl1 ; assigns definitions to keys based on input parameters ; this routine expects two or three parameters ; if there are three or more parameters, program will error exit ; lv2dsc (longword) is expected to contain a pointer to an IF_STATE ; descriptor. ; .IF NDF,DISABLE_CMEXEC .entry keydefiner, ^m movl 8(AP),-(SP) ;save incoming attributes pushal (SP) ;flags address clrl -(SP) ;setstate pushaq @12(AP) ;ifstate beql 15$ ;no ifstate...bug it pushaq @16(AP) ;equivalence value pushaq @4(AP) ;keyname ... all args pushed now cmpl #4,(AP) ;see if setstate specified beql 10$ ;nope...issue call as-is cmpl #5,(AP) ;see if exactly & only setstate spec'd bneq 20$ ;nope...error...multidef movaq @20(AP),4(SP) ;rewrite equivalence value arg movaq @16(AP),12(SP) ;use first extra arg as setstate 10$: calls #5,hg$define_key ;do key definition ret 15$: pushl #STP_NOIFST ;use this message calls #1,putmsg ;output text $EXIT_S ;get lost 20$: pushaq @4(AP) ;pass keyname to putmsg pushl #1 ;1 FAO parameter pushl #STP_KYMMES ;use this message text calls #3,putmsg ;output message $EXIT_S ;barf out .ENDC ; ; REPLY_ENABLE ; Enables operator console if privilege exists to do so ; .entry reply_enable, ^m<> pushab getopt_protected;op squelched 'cept for members pushal opcmsk ;data address pushaw replydefiner ;define reply mask calls #3,trvsl0 ;traverse list, def reply mask tstl enbcls ;was something set??? bneq 5$ ;yes... try to do it ret ;nope... ignore rest 5$: $GETDVIW_S - ;get terminal name, unitno DEVNAM = ttnam,- ITMLST = dvilst blbcw r0,40$ ;retrieve terminal name/unitno movab devnam,r0 ;get name's address addl retlen,r0 ;jump 1 past end char decl r0 ;set address of last character cmpb (r0),#^a/:/ ;if it is not a colon bneq 10$ ;don't skip a character decl r0 ;else skip colon 10$: cmpb (r0),#^a/0/ ;backup over all numeric blssu 20$ ;oops... not numeric... keep cmpb (r0),#^a/9/ ;backup over all numeric bgtru 20$ ;oops... not numeric... keep decl r0 ;backup one character brb 10$ ;muck thru this stuff again 20$: subl3 #devnam-1,r0,retlen ;calculate remaining length movb retlen,devnml ;move to ascic len byte addw retlen,enbdsc ;add to message descriptor movw retunt,unit ;move in the unit number $SETPRV_S - ;try to get OPER privilege PRMFLG = #0,- ;try temporary privs ENBFLG = #1,- PRVADR = oprprv blbcw r0,40$ ;oops... error... bugout movl r0,r1 ;save status movl #SS$_NOOPER,r0 ;set NOOPER error cmpl r1,#SS$_NOTALLPRIV ;see if we didn't get OPER beql 40$ ;no OPER... return error $SETPRV_S - ;try to get SECURITY privilege PRMFLG = #0,- ;try temporary privs ENBFLG = #1,- PRVADR = secprv blbc r0,40$ ;oops... error... bugout cmpl r1,#SS$_NOTALLPRIV ;see if we didn't get SECURITY bneq 30$ ;SECURITY... default request bicl #OPC$M_NM_SECURITY,enbcls ;rmv SECURITY from OPCOM req. 30$: $SNDOPR_S - ;try to enable us as operator MSGBUF = enbdsc 40$: ret ;return all errors ; ; TIMOUT ; Timeout routine in case of high priority hangup ; .entry timout, ^m<> $SETPRV_S - ;attempt a priority boost ENBFLG = #1,- PRMFLG = #0,- PRVADR = booprv $SETPRI_S - PRI = norpri ;drop back down $SETSWM_S - SWPFLG = #0 ;release lock ret ; ; SETTMO ; Set timeout timer in case of programming error ; .IF NDF,DISABLE_BOOST settmo: $BINTIM_S - ;Convert time to binary TIMBUF = asctim,- TIMADR = bintim blbc r0,10$ $SETIMR_S - ;Set countdown killer DAYTIM = bintim,- ASTADR = timout blbc r0,10$ rsb 10$: $EXIT_S - CODE = r0 .ENDC ; ; functional routines ; each routine is called from mainline via JSB entry ; all registers may be scratched ; ; Attempt to identify the current node and set class mask accordingly setnode: calls #0,getnode ;get nodename clrl class ;set no classes movl #NODE_COUNT,r2 moval NODE_GL_LIST,r3 10$: movl (r3)+,r4 movaq 4(r4),r5 movl (r4),r4 cmpw nodeid,(r5) ;see if lengths match bneq 20$ pushr #^m cmpc3 nodeid,@nodeid+4,@4(r5) ;see if chars match popr #^m bneq 20$ movl r4,class ;set classes movl r5,node brb 30$ 20$: sobgtr r2,10$ pushaq nodeid pushl #2 pushl #STP_NODMES calls #3,putmsg 30$: rsb ; ; Define symbol NODE defnode: pushal tblind ;annunciate these to global table pushaq nodeid ;symbol value pushaq nodes ;symbol name calls #3,G^LIB$SET_SYMBOL rsb ; ; Define MODE symbol defmode: $GETJPIW_S - ITMLST = jpilst movl modev,r0 ;index value ashl #2,r0,r0 ;index table of longwords pushal tblind ;annunciate these to global table pushaq @model(r0) ;symbol value pushaq modes ;symbol name calls #3,G^LIB$SET_SYMBOL rsb ; ; Define $MODE numeric defmnum: $FAO_S - CTRSTR = numctl, - OUTLEN = modval, - OUTBUF = modval, - P1 = modev pushal tblind ;annunciate these to global table pushaq modval ;symbol value pushaq moden ;symbol name calls #3,G^LIB$SET_SYMBOL rsb ; ; Define QUEUE_NAME and ENTRY_NUMBER if in batch mode defqueue: cmpl #2,modev ;Are we in batch mode? beql isbat ;nope... skip the batch stuff brw nobat ;nope... skip the batch stuff isbat: $GETQUIW_S - FUNC = #qui$_display_job,- ITMLST = quilst,- IOSB = quiosb blbcw r0,nobat ;$QUI doesn't think all's well movl quiosb,r0 ;get $QUI iosb status blbcw r0,nobat ;$QUI doesn't think we're batch $GETQUIW_S - FUNC = #qui$_cancel_operation $GETQUIW_S - FUNC = #qui$_display_queue, - ITMLST = quils2, - IOSB = quiosb blbc r0,qunok blbs quiosb,quok movl quiosb,r0 qunok: ret quok: $GETQUIW_S - FUNC = #qui$_cancel_operation pushal tblind ;annunciate these to global table pushaq quenam ;symbol value pushaq qnmsym ;symbol name calls #3,G^LIB$SET_SYMBOL $FAO_S - CTRSTR = numctl, - OUTLEN = entval, - OUTBUF = entval, - P1 = entno pushal tblind ;annunciate these to global table pushaq entval ;symbol value pushaq entsym ;symbol name calls #3,G^LIB$SET_SYMBOL nobat: rsb ; ; Remove all unwanted symbols (ignore errors) remsym: pushab getopt_default ;operation performed by default pushal hitlst ;data address pushaw symkiller ;delete symbols calls #3,trvsl0 ;traverse list and kill symbols rsb ; ; Define symbols defsym: pushab getopt_default ;operation performed by default pushal symlst ;data address pushaw symdefiner ;define symbols calls #3,trvsl1 ;traverse list and define symbols rsb ; ; Define all logicals deflog: calls #0,syslogin ;setup rooted logical string pushab getopt_default ;operation performed by default pushal loglst ;list of logicals and tables pushaw logdefiner ;this is the routine for lvl1 lists calls #3,trvsl2 ;return nothing meaningful rsb ; ; Define all keys (if DISABLE_CMEXEC not defined) .IF NDF,DISABLE_CMEXEC defkeys: tstl keycls ;test required class mask beql 5$ ;no classes required mcoml keycls,r0 ;invert for BICL bicl3 r0,class,r0 ;leave only bits to test cmpl r0,keycls ;see if all requested bits present bneq 20$ ;class(es) do not permit operation 5$: cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE? bneq 20$ ;Nope, dont try key defs $SETPRV_S - ;get cme ENBFLG = #1,- PRMFLG = #0,- PRVADR = cmeprv cmpl r0,#SS$_NOTALLPRIV bneq 10$ pushl #STP_CMEMES calls #1,putmsg brb 20$ 10$: pushab getopt_default ;operation performed by default pushal keylst ;list of key definitionsh pushaw keydefiner ;this is the routine for lvl1 lists calls #3,trvsl2 ;return nothing meaningful $SETPRV_S - ;drop cme ENBFLG = #0,- PRMFLG = #0,- PRVADR = cmeprv 20$: rsb .ENDC ; ; Set message flag (if CMKRNL) .IF NDF,DISABLE_CMKRNL setmsg: tstl msfcls ;test required class mask beql 23$ ;no classes required mcoml msfcls,r0 ;invert for BICL bicl3 r0,class,r0 ;leave only bits to test cmpl r0,msfcls ;see if all requested bits present bneq 27$ ;class(es) do not permit operation 23$: $SETPRV_S - ;get cmk ENBFLG = #1,- PRMFLG = #0,- PRVADR = cmkprv cmpl r0,#SS$_NOTALLPRIV bneq 25$ pushl #STP_CMKMES calls #1,putmsg brb 27$ 25$: pushab getopt_inhibit ;operation performed only if mask match pushal defmsg ;data address pushaw setmessdefiner ;set message flags calls #3,trvsl0 ;traverse list and set flags $SETPRV_S - ;drop cmk ENBFLG = #0,- PRMFLG = #0,- PRVADR = cmkprv 27$: rsb .ENDC ; ; Set up terminal if interactive ttsetup: cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE? beql 10$ ;Nope, dont try tt setup brw 40$ 10$: clrl ttchn $ASSIGN_S - ;get a channel to the tt: DEVNAM = ttnam,- CHAN = ttchn blbs r0,15$ clrl ttchn ;make sure it's 0 for err's brw 40$ 15$: clrl actbro ;zap active broadcast to zeroes pushab getopt_inhibit ;operation performed only if mask match pushal ttbro ;data address pushaw defbrodefiner ;set default broadcast classes calls #3,trvsl0 ;traverse list and set flags tstl actbro ;see if actbro got set up beql 20$ ;leave 'em alone if not defined $qiow_s - ;force broadcast classes chan = ttchn,- func = #IO$_SETMODE!IO$M_BRDCST,- p1 = @actbro,- p2 = #8 blbs r0,20$ brw 40$ 20$: $qiow_s - ;read soft terminal chars chan = ttchn,- func = #IO$_SENSEMODE,- p1 = ttchr,- p2 = #12 clrl actoff ;no 'off' by default pushab getopt_inhibit ;operation performed only if mask match pushal ttoff ;data address pushaw defoffdefiner ;set default TTOFF calls #3,trvsl0 ;traverse list and set flags clrl acton ;no 'on' by default pushab getopt_inhibit ;operation performed only if mask match pushal tton ;data address pushaw defondefiner ;set default TTON calls #3,trvsl0 ;traverse list and set flags moval @actoff,r0 ;get address of TTOFF chars beql 25$ ;skip TTOFF actions bicl (r0),ttchr ;turn off these bicl 4(r0),ttchr+4 ;turn off these bicl 8(r0),ttchr+8 ;turn off these 25$: moval @acton,r0 ;get address of TTON chars beql 33$ ;skip TTON actions bisl (r0),ttchr ;turn on these bisl 4(r0),ttchr+4 ;turn on these bisl 8(r0),ttchr+8 ;turn on these 33$: $qiow_s - ;reset soft terminal chars chan = ttchn,- func = #IO$_SETMODE,- p1 = ttchr,- p2 = #12 40$: rsb ; ; Enable operator console enbopr: cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE? bneq 43$ ;Nope, dont try console calls #0,reply_enable 43$: rsb ; ; Set Default protection on files setpro: pushab getopt_inhibit ;op not performed by default pushal defpro ;data address pushaw defprodefiner ;define default protection calls #3,trvsl0 ;traverse list, def defpro rsb ; ; Set Default privs setprv: $SETPRV_S - ENBFLG = #0,- ;reset the named privs PRVADR = offmsk,- ;zap'em all PRMFLG = #1,- ;affect process privs PRVPRV = actprv ;use previous privs if none found movl modev,r0 ;index value ashl #2,r0,r0 ;index table of longwords pushab getopt_inhibit ;op not performed by default pushal @modepr(r0) ;data address pushaw defprvdefiner ;define default priv mask calls #3,trvsl0 ;traverse list, def defprv $SETPRV_S - ENBFLG = #1,- ;set the named privs PRVADR = actprv,-;set the new ones PRMFLG = #1 ;affect process privs rsb ; ; Set directory by mode setdir: movl modev,r2 ;index value ashl #3,r2,r2 ;index table of quadwords clrl actdrv ;set no active drive pushab getopt_inhibit ;op not performed by default pushal @modecd(r2) ;data address pushaw defdrvdefiner ;define drive mask calls #3,trvsl0 ;traverse list, def reply mask addl #4,r2 ;point second half of quadword clrl actdir ;set no active directory pushab getopt_inhibit ;op not performed by default pushal @modecd(r2) ;data address pushaw defdirdefiner ;define drive mask calls #3,trvsl0 ;traverse list, def reply mask tstl actdrv ;was one selected? beql 50$ pushaq @actdrv ;default drive tstl actdir ;was one selected? beql 50$ pushaq @actdir ;directory calls #2,setdef ;set defdir 50$: rsb $SETPRV_S - ;get cme ENBFLG = #1,- PRMFLG = #0,- PRVADR = cmeprv cmpl r0,#SS$_NOTALLPRIV bneq 10$ pushl #STP_CMEMES calls #1,putmsg brb 20$ 10$: pushab getopt_default ;operation performed by default pushal keylst ;list of key definitionsh pushaw keydefiner ;this is the routine for lvl1 lists calls #3,trvsl2 ;return nothing meaningful $SETPRV_S - ;drop cme ENBFLG = #0,- PRMFLG = #0,- PRVADR = cmeprv 20$: rsb ; ; Set DCL prompt if INTERACTIVE .IF NDF,DISABLE_CMSUPER setprm: cmpl modev,#JPI$K_INTERACTIVE ;Are we INTERACTIVE? bneq 10$ ;Nope, dont set prompt $SETPRV_S - ;get cme ENBFLG = #1,- PRMFLG = #0,- PRVADR = cmeprv cmpl r0,#SS$_NOTALLPRIV bneq 5$ pushl #STP_CMSMES calls #1,putmsg brb 10$ 5$: clrl actprm ;no active prompt pushab getopt_protected;op squelched 'cept for members pushal prmlst ;list of processname lists pushaw defprmdefiner ;define prompts calls #3,trvsl0 ;traverse list, def prcnam tstl actprm ;was one found? bneq 20$ 10$: $SETPRV_S - ;drop cme ENBFLG = #0,- PRMFLG = #0,- PRVADR = cmeprv rsb 20$: moval @actprm,r2 ;address of TTMATCH list brb 40$ ;start search 30$: addl #5*4,r2 ;jmpto next item 40$: tstl (r2) ;address of prompt descrip zero = eolist beql 10$ ;eolist reached tstl 8(r2) ;was a tt type spec'd beql 50$ ;nope... skipcheck cmpb 8(r2),ttchr+1 ;does spec'd type match? bneq 30$ ;nope... goto next item 50$: tstl 12(r2) ;were TT primary attribs spec'd? beql 60$ ;go test TT2$ attribs mcoml 12(r2),r1 ;prep test bicl3 r1,ttchr+4,r3 ;mask to only rqst'd chars mcoml r1,r1 ;re-invert mask cmpl r3,r1 ;are all rqst'd chars present? bneq 30$ ;nope... keep testing 60$: tstl 16(r2) ;were TT secondary attribs spec'd? beql 70$ ;accept as matched mcoml 16(r2),r1 ;prep test bicl3 r1,ttchr+8,r3 ;mask to only rqst'd chars mcoml r1,r1 ;re-invert mask cmpl r3,r1 ;are all rqst'd chars present? bneq 30$ ;nope... keep testing 70$: movaq @4(r2),r0 ;get setup descrip address beql 80$ ;jmp if no setup spec'd movq @4(r2),r0 ;get setup descrip to r0'r1 movzwl r0,r0 ;blast descriptor stuff $qiow_s - ;write setup for prompt chan = ttchn,- func = #IO$_WRITEVBLK,- p1 = (r1),- p2 = r0 80$: pushaq @(r2) ;push address of prompt string calls #1,90$ ;generate call frame rsb ;backto mainline 90$: .word 0 ;cmexec call w/arglst $cmexec_s - ;goto exec to vector to super routin = 100$,- arglst = (AP) ;CMEXEC using CALLS arglst ret ;return to subroutine 100$: .word 0 $dclast_s - ;vector to supervisor mode astadr = 110$,- astprm = AP,- ;use passed arglst as ASTPRM acmode = #PSL$C_SUPER ret ;back from cmexec fires super 110$: .word ^m ;MOVCx trashes these registers calls #0,@#EXE$CLRAST ;get out of AST mode moval g^CTL$AG_CLIDATA,r2 ;get cli data address movl PPD$L_PRC(r2),r2 ;get process region address movl 4(AP),AP ;recover $CMEXEC AP movaq @4(AP),r0 ;get address of prompt string addb3 #3,(r0),PRC_B_PROMPTLEN(r2) ;changeto DCL len req's (CRLF_) movc5 (r0),@4(r0),#0,#32,PRC_G_PROMPT(r2) ;prompt insert, max=32 char ret ;getlost .ENDC ; ; Set DCL verify if INTERACTIVE .IF NDF,DISABLE_CMSUPER setver: $SETPRV_S - ;get cme ENBFLG = #1,- PRMFLG = #0,- PRVADR = cmeprv cmpl r0,#SS$_NOTALLPRIV beql 10$ movl modev,r2 ;index value ashl #2,r2,r2 ;index table of longwords clrl verify ;no 'set verify' by default pushab getopt_protected;op squelched 'cept for members pushal @modevf(r2) ;data address pushaw verdefiner ;define verify calls #3,trvsl0 ;traverse list, def prcnam tstl verify ;was a state found? bneq 20$ ;yes... go do it 10$: $SETPRV_S - ;get cme ENBFLG = #0,- PRMFLG = #0,- PRVADR = cmeprv rsb 20$: subl3 #1,verify,-(SP) ;push new verify state calls #1,30$ ;generate call frame rsb ;backto mainline 30$: .word 0 ;cmexec call w/arglst $cmexec_s - ;goto exec to vector to super routin = 40$,- arglst = (AP) ;CMEXEC using CALLS arglst ret ;return to subroutine 40$: .word 0 $dclast_s - ;vector to supervisor mode astadr = 50$,- astprm = AP,- ;use passed arglst as ASTPRM acmode = #PSL$C_SUPER ret ;back from cmexec fires super 50$: .word ^m ;MOVCx trashes these registers calls #0,@#EXE$CLRAST ;get out of AST mode moval g^CTL$AG_CLIDATA,r2 ;get cli data address movl PPD$L_PRC(r2),r2 ;get process region address movl 4(AP),AP ;recover $CMEXEC AP tstl 4(AP) ;was verify rqst'd? bneq 60$ ;yes... setit bicw #PRC_M_VERIFY,PRC_W_FLAGS(r2) ;turn verify off ret ;getlost 60$: bisw #PRC_M_VERIFY,PRC_W_FLAGS(r2) ;turn verify on ret ;getlost .ENDC ; ; Set processname if possible setprc: clrl r4 ;maxtry counter $GETTIM_S - TIMADR = time ;read system time clrl actprc ;no active process name pushab getopt_inhibit ;op not performed by default pushal prclst ;list of processname lists pushaw defprcdefiner ;define processnames calls #3,trvsl0 ;traverse list, def prcnam rstspn: moval @actprc,r2 ;processnames beql eoprc ;none found... skipit extzv #5,#3,time,r3 ;mask low to 3 bits in r1 addl r4,r3 ;add in current index bicb #^xf8,r3 ;zapto 0..7 incl r3 ;start at 1 newprc: movl r2,r1 ;next address for forwardlink load movl r2,r0 ;save for nextitem calculation movzwl (r1),r2 ;pick up next item offset in r2 addl r0,r2 ;calculate nextitem sobgtr r3,newprc ;loop thru list 'til at desired item $SETPRN_S - PRCNAM = 4(r1) ;set processname blbs r0,eoprc ;branch on success aoblss #^x20,r4,rstspn ;try again until retries are burned up eoprc: rsb ; ; Do final command if applicable docmd: movl modev,r2 ;index value ashl #2,r2,r2 ;index table of longwords clrl actdo ;no 'do' by default pushab getopt_protected;op squelched 'cept for members pushal @modedo(r2) ;data address pushaw dodefiner ;define 'do' address calls #3,trvsl0 ;traverse list, def 'actdo' tstl actdo ;was one selected? bneq 10$ rsb 10$: pushaq @actdo ;address of command to do calls #1,g^LIB$DO_COMMAND $exit_s - ;we shouldn't ever get here! code = #SS$_BUGCHECK ; ; Initialization processing init_self: movaw oops_catcher,(FP) ;set trap (shut down boost code) .IF NDF,DISABLE_BOOST $SETPRV_S - ;attempt a priority boost ENBFLG = #1,- PRMFLG = #0,- PRVADR = booprv $DCLEXH_S - DESBLK = extblk ;set exit handler (shut down boost code) $SETSWM_S - SWPFLG = #1 ;lock us in memory temporarily $SETPRI_S - PRI = #boopri ;Temporary boost value bsbw settmo ;set timeout routine in case prog err. .ENDC rsb ; ; End processing endprc: $SETPRV_S - ;priority boost disable ENBFLG = #1,- PRMFLG = #0,- PRVADR = booprv $SETPRI_S - PRI = norpri ;drop back down $SETSWM_S - SWPFLG = #0 ;release lock $CANEXH_S - DESBLK = extblk ;No need to do this...already done movzwl #SS$_NORMAL,r0 rsb ; ; SETUP ; Main program entry point ; .entry setup, ^m<> ; Initialization processing bsbw init_self ; Attempt to identify the current node and set class mask accordingly bsbw setnode ; Define symbol NODE bsbw defnode ; Define MODE symbol bsbw defmode ; Define $MODE numeric bsbw defmnum ; Define QUEUE_NAME and ENTRY_NUMBER if in batch mode bsbw defqueue ; Remove all unwanted symbols (ignore errors) bsbw remsym ; Define symbols bsbw defsym ; Define all logicals bsbw deflog ; Define all keys (if DISABLE_CMEXEC not defined) .IIF NDF,DISABLE_CMEXEC, bsbw defkeys ; Set message flag (if CMKRNL) .IIF NDF,DISABLE_CMKRNL, bsbw setmsg ; Set up terminal if interactive bsbw ttsetup ; Enable operator console bsbw enbopr ; Set Default protection on files bsbw setpro ; Set Default privs bsbw setprv ; Set directory by mode bsbw setdir ; Set DCL prompt if INTERACTIVE .IIF NDF,DISABLE_CMSUPER, bsbw setprm ; Set DCL verify if INTERACTIVE .IIF NDF,DISABLE_CMSUPER, bsbw setver ; Set processname if possible bsbw setprc ; End processing bsbw endprc ; Final exit command (if applicable) pushl r0 bsbw docmd popl r0 ret .end SETUP