KVC@ENGVAX.SCG.HAC.COM (Kevin Carosso) (07/23/87)
$ show default $ check_sum = 1885746516 $ write sys$output "Creating FILESET.CLD" $ create FILESET.CLD $ DECK/DOLLARS="$*$*EOD*$*$" Define type ATTRS Keyword TYPE, value, nonnegatable Keyword ORGANIZATION, value, nonnegatable Keyword CARRIAGE_CONTROL, value, nonnegatable Keyword SPANNED, nonnegatable Keyword NOSPANNED, nonnegatable Keyword EOF_BLOCK, value, nonnegatable Keyword EOF_BYTE, value, nonnegatable Keyword RECORD_SIZE, value, nonnegatable Keyword MAX_RECORD_SIZE, value, nonnegatable Define verb FILESET Image PUB_ROOT:[SOURCE.FILESET]FILESET Parameter P1 Label = FILESPEC Prompt = "File(s)" Value (Required, list, type = $FILE) Qualifier CREATION_DATE Nonnegatable Placement = positional Value (Required, type = $DATETIME) Qualifier REVISION_DATE Placement = positional Value (Required, type = $DATETIME) Qualifier EXPIRATION_DATE Placement = positional Value (Required, type = $DATETIME) Qualifier NOREVISION_DATE Nonnegatable Placement = positional Qualifier NOEXPIRATION_DATE Nonnegatable Placement = positional Qualifier ATTRIBUTES Nonnegatable Placement = positional Value (Required, list, type = ATTRS) Disallow ATTRIBUTES.SPANNED and ATTRIBUTES.NOSPANNED $*$*EOD*$*$ $ checksum FILESET.CLD $ if checksum$checksum .ne. check_sum then - $ write sys$output "Checksum failed, file probably corrupted" $ check_sum = 1500609383 $ write sys$output "Creating FILESET.MAR" $ create FILESET.MAR $ DECK/DOLLARS="$*$*EOD*$*$" .Title Fileset - Set some file attributes. ;++ ; ; Written by Kevin Carosso, Hughes SCG|PWB, July 30, 1982. ; ; This program modifies file attributes. Command line ; qualifiers specify the attributes to be changed, parameter ; P1 is the file. ; ; Modified by Kevin Carosso, Hughes SCG|CTC, November 26, 1984. ; (For VMS V4.0) ; ; Removed /OWNER, since SET FILE has had that since V3. ; Added some more useful qualifiers: ; /ATTRIBUTES = (TYPE = {FIXED, VARIABLE, VFC, UNDEFINED, ; STREAM, STREAMLF, STREAMCR}, ; ORGANIZATION = {SEQUENTIAL, RELATIVE, ; INDEXED, DIRECT} ; EOF_BLOCK = nnn, EOF_BYTE = mmm ; RECORD_SIZE = nnn ; ) ; ;-- $CLIDEF ; CLI definitions. $DSCDEF ; Data descriptor definitions. $FIBDEF ; FID definitions. $ATRDEF ; Attribute Control Block definitions. $TPADEF ; TPARSE definitions. .Library /SYS$LIBRARY:LIB/ .Library /MACLIB/ ; Some useful macros. $FATDEF .Sbttl Data - Data definitions for Fileset .Psect Fildata, wrt, rd, noexe, long ; ; We need RMS data areas because we will use RMS to parse the file spec. ; modFAB: $FAB NAM = modNAM,- FNA = file_buff modNAM: $NAM ESS = NAM$c_maxrss,- ESA = expbuf expbuf: .blkb NAM$c_maxrss ; Buffer for resultant string . iosb: .quad 0 ; I/O status block. ; ; The FIB is used to communicate with the ACP. ; FIB_desc: .long FIB$c_extdata ; FIB descriptor. .address FIB FIB: .long FIB$m_write !- ; Allow write access for us, FIB$m_noread !- ; deny read and write for others. FIB$m_nowrite .blkb FIB$c_extdata - <.-FIB> ; Rest of the File Id Block (mbz). ; ; The Attribute Control Block determines what attributes to change. ; ACB: .blkl <14 * 2> + 1 ; Maximum size of the block. cre_date: .quad 0 ; System format date and time. rev_date: .quad 0 exp_date: .quad 0 attr_ACB: .word ATR$S_RECATTR ; Used to get old record attributes .word ATR$C_RECATTR .long attr_block .long 0 attr_type: .long 0 ; Holds attribute "TYPE" while parsing attr_org: .long 0 ; Holds attribute "ORG" while parsing attr_cc: .long 0 ; Record attributes (carriage-control) attr_spn: .long 0 ; Record attributes (span) attr_eof_block: .long 0 ; End of file block attr_eof_byte: .long 0 ; End of file byte attr_rsize: .long 0 ; record size attr_max_rsize: .long 0 ; maximum record size attr_block: .blkb ATR$S_RECATTR ; Record attr block itself attr_change: .long 0 ; Mask of attrs to change change_type = 0 change_org = 1 change_cc = 2 change_spn = 3 change_eof_block = 4 change_eof_byte = 5 change_rsize = 6 change_max_rsize = 7 ; ; We need to specify a channel and a device descriptor to talk to the ACP. ; channl: .word 0 ; Channel number desc: .quad 0 ; Device name descriptor. ; ; Here are some definitions for the interface to the CLI. ; cre_qual: .ascid /CREATION_DATE/ ; /CREATION_DATE cre_val: .ascid /dd-mmm-yyyy hh:mm:ss.tt/ rev_qual: .ascid /REVISION_DATE/ ; /REVISION_DATE rev_val: .ascid /dd-mmm-yyyy hh:mm:ss.tt/ norev_qual: .ascid /NOREVISION_DATE/ ; /NOREVISION_DATE exp_qual: .ascid /EXPIRATION_DATE/ ; /EXPIRATION_DATE exp_val: .ascid /dd-mmm-yyyy hh:mm:ss.tt/ noexp_qual: .ascid /NOEXPIRATION_DATE/ ; /NOEXPIRATION_DATE ; ; Data for parsing /ATTRIBUTES. We do this by looping through ; each possible value. The attr_table has the addresses of the ; information we need for each value on the attribute switch. ; attr_table: .address attr_type_qual ; qualifier .address attr_type_state ; TPARSE states .address attr_type_key ; TPARSE keys .address attr_org_qual .address attr_org_state .address attr_org_key .address attr_cc_qual .address attr_cc_state .address attr_cc_key .address attr_eof_block_qual .address attr_eof_block_state .address attr_eof_block_key .address attr_eof_byte_qual .address attr_eof_byte_state .address attr_eof_byte_key .address attr_rsize_qual .address attr_rsize_state .address attr_rsize_key .address attr_max_rsize_qual .address attr_max_rsize_state .address attr_max_rsize_key .long 0 ; end of table attr_qual: .ascid /ATTRIBUTES/ attr_type_qual: .ascid /ATTRIBUTES.TYPE/ attr_org_qual: .ascid /ATTRIBUTES.ORGANIZATION/ attr_cc_qual: .ascid /ATTRIBUTES.CARRIAGE_CONTROL/ attr_spn_qual: .ascid /ATTRIBUTES.SPANNED/ attr_nospn_qual: .ascid /ATTRIBUTES.NOSPANNED/ attr_eof_block_qual: .ascid /ATTRIBUTES.EOF_BLOCK/ attr_eof_byte_qual: .ascid /ATTRIBUTES.EOF_BYTE/ attr_rsize_qual: .ascid /ATTRIBUTES.RECORD_SIZE/ attr_max_rsize_qual: .ascid /ATTRIBUTES.MAX_RECORD_SIZE/ attr_val: ; Returned value of qualifier .word 100 .byte DSC$k_dtype_t .byte DSC$k_class_s .address . + 4 .blkb 100 file_param: .ascid /FILESPEC/ ; Filename file_val: .word 255 .byte DSC$k_dtype_t .byte DSC$k_class_s .address file_buff file_buff: .blkb 255 ; ;Table for lower to upper case translation: ; lcuc: .byte 00,01,02,03,04,05,06,07,08,09,10,11,12,13,14,15,- 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31 .ascii \ !"#$%&'()*+,-./0123456789:;<=>?@\ .ascii /ABCDEFGHIJKLMNOPQRSTUVWXYZ/ .ascii /[\]^_`/ .ascii /ABCDEFGHIJKLMNOPQRSTUVWXYZ/ .ascii /{|}~/ .byte 127 .Sbttl Tparse definitions. ; ; Use TPARSE to match keywords. ; ; First the TYPE: ; $INIT_STATE attr_type_state, attr_type_key $STATE $TRAN 'FIXED',,, FAT$C_FIXED, attr_type $TRAN 'VARIABLE',,, FAT$C_VARIABLE, attr_type $TRAN 'VFC',,, FAT$C_VFC, attr_type $TRAN 'UNDEFINED',,, FAT$C_UNDEFINED, attr_type $TRAN 'STREAM',,, FAT$C_STREAM, attr_type $TRAN 'STREAMLF',,, FAT$C_STREAMLF, attr_type $TRAN 'STREAMCR',,, FAT$C_STREAMCR, attr_type $STATE $TRAN TPA$_LAMBDA, TPA$_EXIT,, <1@change_type>, attr_change $END_STATE ; ; Now the ORGANIZATION: ; $INIT_STATE attr_org_state, attr_org_key $STATE $TRAN 'SEQUENTIAL',,, FAT$C_SEQUENTIAL, attr_org $TRAN 'RELATIVE',,, FAT$C_RELATIVE, attr_org $TRAN 'INDEXED',,, FAT$C_INDEXED, attr_org $TRAN 'DIRECT',,, FAT$C_DIRECT, attr_org $STATE $TRAN TPA$_LAMBDA, TPA$_EXIT,, <1@change_org>, attr_change $END_STATE ; ; Now the CARRIAGE_CONTROL: ; $INIT_STATE attr_cc_state, attr_cc_key $STATE $TRAN 'NONE',,,, $TRAN 'FORTRAN',,, FAT$M_FORTRANCC, attr_cc $TRAN 'IMPLIED',,, FAT$M_IMPLIEDCC, attr_cc $TRAN 'CR',,, FAT$M_IMPLIEDCC, attr_cc ; Synonym for IMPLIED $TRAN 'PRINT',,, FAT$M_PRINTCC, attr_cc $STATE $TRAN TPA$_LAMBDA, TPA$_EXIT,, <1@change_cc>, attr_change $END_STATE ; ; The EOF block ; $INIT_STATE attr_eof_block_state, attr_eof_block_key $STATE $TRAN TPA$_DECIMAL,,,, attr_eof_block $STATE $TRAN TPA$_LAMBDA, TPA$_EXIT,, <1@change_eof_block>, attr_change $END_STATE ; ; The EOF byte ; $INIT_STATE attr_eof_byte_state, attr_eof_byte_key $STATE $TRAN TPA$_DECIMAL,,,, attr_eof_byte $STATE $TRAN TPA$_LAMBDA, TPA$_EXIT,, <1@change_eof_byte>, attr_change $END_STATE ; ; The RECORD_SIZE block ; $INIT_STATE attr_rsize_state, attr_rsize_key $STATE $TRAN TPA$_DECIMAL,,,, attr_rsize $STATE $TRAN TPA$_LAMBDA, TPA$_EXIT,, <1@change_rsize>, attr_change $END_STATE ; ; The MAX_RECORD_SIZE block ; $INIT_STATE attr_max_rsize_state, attr_max_rsize_key $STATE $TRAN TPA$_DECIMAL,,,, attr_max_rsize $STATE $TRAN TPA$_LAMBDA, TPA$_EXIT,, <1@change_max_rsize>, attr_change $END_STATE ; ; TPARSE parameter block. ; TPARSE_block: .long TPA$K_count0 ; Block length. .long TPA$M_abbrev ; Allow abbreviations. .blkl TPA$K_length0 - 8 ; Room for the rest of the block. .Sbttl Fileset - Program proper. .Psect Code, exe, rd, nowrt, long .Entry Start, 0 ; ; First find out what qualifiers were specified. ; getfil: pushal file_val ; Get the file name pushal file_param calls #2, G^CLI$get_value blbs r0, parse ; Skip on if we got it. cmpl r0, #CLI$_absent ; If was just absent, bneq egress ; then exit normally. done: movzwl #SS$_normal, r0 egress: ret parse: movb file_val,- ; Set filename size. modFAB + FAB$b_fns moval ACB, r6 ; Get pointer to ACB credat: pushal cre_val pushal cre_qual ; See if we have /CREATION_DATE calls #2, G^CLI$get_value cmpl r0, #CLI$_absent ; If not present, then beql revdat ; go on. check ERR = egress ; Any other failure we die. movtc cre_val, @cre_val + 4,- #^A/ /, lcuc,- cre_val, @cre_val + 4 ;Convert to uppercase. $BINTIM_S TIMBUF = cre_val,- ; Convert to system date and time. TIMADR = cre_date check ERR = egress movw #ATR$s_credate,- ATR$w_size(r6) ; Set size field in ACB, movw #ATR$c_credate,- ATR$w_type(r6) ; type code, moval cre_date,- ATR$l_addr(r6) ; and pointer to new value. addl2 #8, r6 ; Index to next entry in block. revdat: pushal norev_qual ; See if we have /NOREVISION_DATE calls #1, G^CLI$present blbc r0, 10$ ; Go on if not. clrq rev_date ; If so, then clear revision date. brb 20$ 10$: pushal rev_val pushal rev_qual ; See if we have /REVISION_DATE calls #2, G^CLI$get_value cmpl r0, #CLI$_absent ; If not present, then beql expdat ; go on. check ERR = egress ; Any other failure we die. movtc rev_val, @rev_val + 4,- #^A/ /, lcuc,- rev_val, @rev_val + 4 ;Convert to uppercase. $BINTIM_S TIMBUF = rev_val,- ; Convert to system date and time. TIMADR = rev_date check ERR = egress 20$: movw #ATR$s_revdate,- ATR$w_size(r6) ; Set size field in ACB, movw #ATR$c_revdate,- ATR$w_type(r6) ; type code, moval rev_date,- ATR$l_addr(r6) ; and pointer to new value. addl2 #8, r6 ; Index to next entry in block. expdat: pushal noexp_qual ; See if we have /NOEXPIRATION_DATE calls #1, G^CLI$present blbc r0, 1$ ; Go on if not. clrq exp_date ; If so, then clear revision date. brb 2$ 1$: pushal exp_val pushal exp_qual ; See if we have /EXPIRATION_DATE calls #2, G^CLI$get_value cmpl r0, #CLI$_absent ; If not present, then beql attr ; go on. check ERR = egress ; Any other failure we die. movtc exp_val, @exp_val + 4,- #^A/ /, lcuc,- exp_val, @exp_val + 4 ;Convert to uppercase. $BINTIM_S TIMBUF = exp_val,- ; Convert to system date and time. TIMADR = exp_date check ERR = egress 2$: movw #ATR$s_expdate,- ATR$w_size(r6) ; Set size field in ACB, movw #ATR$c_expdate,- ATR$w_type(r6) ; type code, moval exp_date,- ATR$l_addr(r6) ; and pointer to new value. addl2 #8, r6 ; Index to next entry in block. ; ; See if he wants to do anything to the record attributes. ; attr: pushal attr_qual ; See if we have any /ATTRIBUTEs calls #2, G^CLI$PRESENT cmpl r0, #CLI$_ABSENT ; If not present, then bneq 10$ brw endACB ; go on. 10$: check ERR = egress ; Any other failure we die. ; ; Initialize things ; movw #ATR$S_RECATTR, - ; Set size field in the ACB, ATR$W_SIZE(r6) movw #ATR$C_RECATTR, - ; and type, ATR$W_TYPE(r6) moval attr_block, - ; and pointer to record attr block. ATR$L_ADDR(r6) addl2 #8, r6 ; Index to next entry in block. clrl attr_change ; Clear which ones to change ; ; First check keywords without values ; pushal attr_spn_qual ; See if we have SPANNED calls #1, G^CLI$present blbc r0, 20$ ; Go on if not. clrl attr_spn ; Clear indicator of NOSPANNED brb 30$ 20$: pushal attr_nospn_qual ; See if we have NOSPANNED calls #1, G^CLI$present blbc r0, 40$ ; Go on if not. movl #1, attr_spn ; Set indicator of NOSPANNED 30$: bisl2 #<1@change_spn>, - ; Say we have to diddle SPAN bit attr_change 40$: ; ; Loop over all keywords with values... R7 points into their table. ; moval attr_table, r7 ; Table for value information get_attr: tstl (r7) ; End of table? beql endACB ; if so, finish up the ACB pushal attr_val pushl (r7) ; Qualifier value calls #2, G^CLI$get_value cmpl r0, #CLI$_absent ; If present, then bneq 10$ ; process it. addl2 #12, r7 ; else bump table index brb get_attr ; try another one 10$: check ERR = egress ; Any other failure we die. ; ; Use TPARSE to find the record attribute he wanted. ; movq attr_val,- TPARSE_block + TPA$L_stringcnt pushl 8(r7) ; Address of keywords pushl 4(r7) ; Address of states pushal TPARSE_block calls #3, G^LIB$TPARSE ; Go parse it. check ERR = egress addl2 #12, r7 ; Bump table index brb get_attr ; and try another one ; ; Finish up by terminating ACB with a 0. ; endACB: moval ACB, r4 ; Get top of ACB cmpl r6, r4 ; Make sure at least something was bneq 20$ ; to be modified. brw getfil ; otherwise try another file. 20$: clrl (r6) ; End with a 0 ; ; First set up file and channel to the ACP. ; $PARSE FAB = modFAB ; Use RMS to parse it. check ERR = egress lookup: $SEARCH FAB = modFAB ; Look up the file. cmpl r0, #RMS$_nmf ; See if just no more files bneq 10$ brw getfil 10$: check ERR = egress movzbl modNAM + NAM$b_esl,- ; Make descriptor to resultant desc ; filename string. movl modNAM + NAM$l_esa,- desc + 4 $ASSIGN_S DEVNAM = desc,- ; Assign channel to ACP. CHAN = channl check ERR = egress ; ; Set the FID in the FIB ; movw modNAM + NAM$w_fid_num,- FIB + FIB$w_fid_num movw modNAM + NAM$w_fid_seq,- FIB + FIB$w_fid_seq movw modNAM + NAM$w_fid_rvn,- FIB + FIB$w_fid_rvn ; ; If he specified something having to do with a record attribute, then ; we have to get old RECATTR settings first. ; tstl attr_change bneq old_attr brw modify old_attr: $QIOW_S CHAN = channl, - ; Access to read old attributes FUNC = #<IO$_ACCESS!IO$M_ACCESS>, - IOSB = iosb, - P1 = FIB_desc, - P5 = #attr_ACB check ERR = egress check iosb, ERR = egress bbc #change_type, attr_change, 10$ ; Change the TYPE field? insv attr_type, #FAT$V_RTYPE, - ; Change old field #FAT$S_RTYPE, - attr_block + FAT$B_RTYPE 10$: bbc #change_org, attr_change, 20$ ; Change the ORG field? insv attr_org, #FAT$V_FILEORG, - ; Change old field #FAT$S_FILEORG, - attr_block + FAT$B_RTYPE 20$: bbc #change_cc, attr_change, 30$ ; Change the CC field? bicb2 #<FAT$M_FORTRANCC! - ; Clear any old CC FAT$M_IMPLIEDCC! - FAT$M_PRINTCC>, - attr_block + FAT$B_RATTRIB bisb2 attr_cc, - ; and set the new. attr_block + FAT$B_RATTRIB 30$: bbc #change_spn, attr_change, 40$ ; Change the SPN bit? tstl attr_spn ; Set or clear it? beql 31$ bisb2 #FAT$M_NOSPAN, - ; set it => NOSPAN attr_block + FAT$B_RATTRIB brb 40$ 31$: bicb2 #FAT$M_NOSPAN, - ; clear it => SPAN attr_block + FAT$B_RATTRIB 40$: bbc #change_eof_block, attr_change, 50$ ; Change EOF block #? movw attr_eof_block, - attr_block + FAT$W_EFBLKL ; Set low order movw attr_eof_block + 2, - attr_block + FAT$W_EFBLKH ; Set high order 50$: bbc #change_eof_byte, attr_change, 60$ ; Change EOF byte #? movw attr_eof_byte, - attr_block + FAT$W_FFBYTE ; Set it 60$: bbc #change_rsize, attr_change, 70$ ; Change RSIZE? movw attr_rsize, - attr_block + FAT$W_RSIZE ; Set it 70$: bbc #change_max_rsize, attr_change, 80$ ; Change max RSIZE? movw attr_max_rsize, - attr_block + FAT$W_MAXREC ; Set it 80$: ; ; Now modify the file attributes. ; modify: $QIOW_S CHAN = channl,- ; Issue QIO request. FUNC = #IO$_modify,- IOSB = iosb,- P1 = FIB_desc,- P5 = #ACB check ERR = egress check iosb, ERR = egress ; ; Deassign the channel and loop back for more files. ; $DASSGN_S CHAN = channl ; Deassign ACP. brw lookup ; Go on to next file. .End Start $*$*EOD*$*$ $ checksum FILESET.MAR $ if checksum$checksum .ne. check_sum then - $ write sys$output "Checksum failed, file probably corrupted" $ check_sum = 745828140 $ write sys$output "Creating MACLIB.MAR" $ create MACLIB.MAR $ DECK/DOLLARS="$*$*EOD*$*$" .Title Maclib - Useful macros. ;++ ; ; Written by Kevin Carosso @ Hughes S&CG PWB/ENG ; ; These macros are all placed in the macro library MATH$TOOLS:MACLIB. ; ;-- ;------------------------------------------------------------------------------ ; Check is used to test status returns from procedure calls ; and branch to the specified address on an error. As a side ; effect, R0 is loaded with the status if it was in fact an ; error code. ; ; CHECK ARG = r0, ERR ; ; ARG - Argument containing the status we are to check. ; If ommitted, this will default to R0. ; ERR - Address to branch to on an error status. ; .Macro check ARG = r0, ERR, ?L blbs ARG, L .if different ARG,r0 movzwl ARG, r0 .endc brw ERR L: .Endm ;------------------------------------------------------------------------------ ; ; This is a simple set of macros to allow local variables to be defined ; on the frame for VAX-11 procedures. This mimics local variables ; in some VAX/VMS languages such as Pascal. ; ; Usage: ; ; _VARBEG - To initialize the declaration. ; _VAR SYM, TYP, SIZ - Declares the variable SYM, ; of type TYP, and length SIZ. ; SIZ defaults to 1. ; Type must be one of: BYTE, WORD, ; LONG, QUAD, or OCTA ; _VAREND - To realign the stack and clean up. ; ;-- ; ; _VARBEG - initializes the environment. ; .Macro _VARBEG offset... = 0 .Endm _VARBEG ; ; _VAR - Declares SYM, with type TYP and length SIZ. ; .Macro _VAR, sym, typ, siz=1 .If BLANK, sym .Error ;Symbol required in _VAR declaration. .Mexit .Endc .If BLANK, typ .Error ;Type required in _VAR declaration. .Mexit .Endc typelen... = 0 .Iif IDENTICAL, typ,BYTE, typelen... = 1 .Iif IDENTICAL, typ,WORD, typelen... = 2 .Iif IDENTICAL, typ,LONG, typelen... = 4 .Iif IDENTICAL, typ,QUAD, typelen... = 8 .Iif IDENTICAL, typ,OCTA, typelen... = 16 .If EQUAL, typelen... .Error ;Invalid type in _VAR declaration. .Mexit .Endc offset... = offset... - <typelen... * siz> sym = offset... .Endm _VAR ; ; _VAREND - Knocks the stack down to make room on the frame. ; .Macro _VAREND subl2 #<-offset...>, sp .Endm _VAREND $*$*EOD*$*$ $ checksum MACLIB.MAR $ if checksum$checksum .ne. check_sum then - $ write sys$output "Checksum failed, file probably corrupted" $ exit