* Dyn_Inp.For -- Dynamic Input routines & other miscellaneous routines * Pat Rankin, May'88 * i*4 Cli_Present ( label ) * i*4 Cli_Get_Value ( label, result, reslen ) * i*4 Cli_Parse_Command ( tables, verb, prompt ) * i*4 Get_Cli_Number ( key, result ) * i*4 Get_Inp_List ( qualif, list_size, list_adr, list_cnt ) * i*4 Get_Inp_Element ( size, list, indx, result, reslen ) * i*4 Add_Inp_Element ( size, list_adr, indx, string ) * i*4 Put_Inp_Element ( size, list, indx, string ) * i*4 Search_Inp_List ( size, list, target, wildcard ) * i*4 Expand_Inp_List ( list_size, list, new_adr ) * i*4 Output ( string ) * " Block_Output ( string ) * " Flush_Output ( ) * " Open_Output ( default_name, width ) * log Disable_Installed_Privs ( disabled_privs ) * i*4 PutMsg ( facility, sts, stv ) * i*4 Parse_Node ( infile, outfile, outlen ) * log Node_Available ( nodename ) * i*4 Parse_Keywords( qual_name, keywrd_count, keywords, synonyms, masks) * INTEGER *4 FUNCTION Cli_Present ( label ) ! Call CLI$PRESENT with signalling disabled. implicit none C input: CHARACTER *(*) label C functions: INTEGER *4 CLI$PRESENT EXTERNAL LIB$SIG_TO_RET CALL LIB$ESTABLISH( LIB$SIG_TO_RET) Cli_Present = CLI$PRESENT( label) RETURN END !of Cli_Present INTEGER *4 FUNCTION Cli_Get_Value ( label, result, reslen ) ! Call CLI$GET_VALUE with signalling disabled. implicit none C input: CHARACTER *(*) label C output: CHARACTER *(*) result INTEGER *2 reslen C functions: INTEGER *4 CLI$GET_VALUE EXTERNAL LIB$SIG_TO_RET CALL LIB$ESTABLISH( LIB$SIG_TO_RET) reslen = 0 Cli_Get_Value = CLI$GET_VALUE( label, result, reslen) RETURN END !of Cli_Get_Value INTEGER *4 FUNCTION Cli_Parse_Command ( tables, verb, prompt ) ! ! Fetch user's command line and parse it. If he used "RUN", ! there was no chance to supply one, so prompt for it now. ! implicit none C constant: INCLUDE '($FSCNdef)/nolist' !filescan defs INCLUDE '($CliVERBdef)/nolist' !cli verb defs *- INCLUDE '($CliSERVdef)/nolist' !cli service defs PARAMETER CLI$K_GETCMD = '00000001'x !get command line INCLUDE 'f_inc:Dsc.F' !descriptor defs STRUCTURE /clirq/ !cli request block BYTE rqtype/0/, rqindx/0/, rqflags/0/, rqstat /0/ INTEGER *4 %FILL(1) /0/ RECORD /dsc_z/ rdesc !descriptor initialized to 0's INTEGER *4 %FILL(3) /3*0/ END STRUCTURE !clirq STRUCTURE /fscn/ !short itemlist for $filescan INTEGER *2 len /0/, code /0/ INTEGER *4 adr /0/, end_of_list /0/ END STRUCTURE !fscn C input: EXTERNAL tables !command tables [set command/obj] CHARACTER *(*) verb, prompt !command verb and prompt strings C local: RECORD /dsc_d/ parse !descriptor for dynamic string RECORD /clirq/ cmd !command interface request block RECORD /fscn/ fscn !item list for $filescan INTEGER *4 sts !return status value C functions: INTEGER *4 SYS$CLI, CLI$DCL_PARSE EXTERNAL LIB$SIG_TO_RET, LIB$GET_INPUT CALL LIB$ESTABLISH( LIB$SIG_TO_RET) !suppress error signals C get command line cmd.rqtype = CLI$K_GETCMD !request is 'get command line' sts = SYS$CLI( cmd,,) IF ( sts ) THEN !ok => cli available & verb wasn't "RUN" C invoked via symbol => have command line (which might be empty) C [might also be invoked via mcr or dcl; that's ok] IF ( cmd.rqstat .EQ. CLI$K_VERB_MCR ) THEN !strip image name - fscn.code = FSCN$_FILESPEC !+ from MCR invocation CALL SYS$FILESCAN( cmd.rdesc, fscn,) cmd.rdesc.d_len = cmd.rdesc.d_len - fscn.len !shrink size cmd.rdesc.d_adr = cmd.rdesc.d_adr + fscn.len !advance ptr END IF C prepend verb and parse the command line CALL STR$CONCAT( parse, verb, ' ', cmd.rdesc) sts = CLI$DCL_PARSE( parse, tables) ELSE ! RUN (might be "no cli present" [CLI$_INVREQTYP]) C invoked via run => get a substitute command line from the user sts = CLI$DCL_PARSE(, tables, LIB$GET_INPUT, & LIB$GET_INPUT, prompt) END IF Cli_Parse_Command = sts RETURN END !of Cli_Parse_Command INTEGER *4 FUNCTION Get_Cli_Number ( key, result ) ! ! Use CLI routine to obtain a parameter or qualifier value ! and convert the resulting string into a binary integer. ! implicit none C input: CHARACTER *(*) key C output: INTEGER *4 result C local: CHARACTER *32 value INTEGER *2 ln INTEGER *4 sts C functions: INTEGER *4 Cli_Get_Value, OTS$CVT_TI_L result = 0 sts = Cli_Get_Value( key, value, ln) IF ( sts ) sts = OTS$CVT_TI_L( value(:ln), result) Get_Cli_Number = sts RETURN END !of Get_Cli_Number INTEGER *4 FUNCTION & Get_Inp_List ( qualif, list_size, list_adr, list_cnt ) ! ! Retreive a list that's been parsed via cli routines. ! If the first element is "-" then the item count will be ! negated. ! implicit none C input: CHARACTER *(*) qualif C input/output: INTEGER *4 list_size, & list_adr C output: INTEGER *4 list_cnt C local: CHARACTER *512 buffer INTEGER *2 buflen LOGICAL negate INTEGER *4 sts, clists C functions: INTEGER *4 Cli_Present, Cli_Get_Value, & Add_Inp_Element INTRINSIC LEN list_cnt = 0 sts = Cli_Present( qualif) IF ( sts ) THEN clists = Cli_Get_Value( qualif, buffer, buflen) negate = ( (clists .AND. 1) .EQ. 1 .AND. buflen .GT. 0 & .AND. buffer(:buflen) .EQ. '-' ) sts = clists !potential return status DO WHILE ( sts .AND. clists ) list_cnt = list_cnt + 1 sts = Add_Inp_Element( list_size, list_adr, & list_cnt, buffer(:buflen)) clists = Cli_Get_Value( qualif, buffer, buflen) END DO IF ( negate ) list_cnt = -list_cnt END IF Get_Inp_List = sts RETURN END !of Get_Inp_List INTEGER *4 FUNCTION & Get_Inp_Element ( size, list, indx, result, reslen ) ! ! Retreive a string from a dynamic array of descriptors. ! implicit none C constant: INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptors PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size RECORD /dsc/ list(*) INTEGER indx C output: CHARACTER *(*) result INTEGER *2 reslen C local: INTEGER *4 sts C functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS, LEN, MIN IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THEN sts = SS$_SUBRNG ELSE C result = list(indx) sts = STR$COPY_DX( result, %REF(list(indx))) reslen = MIN( list(indx).d_len, LEN(result)) END IF Get_Inp_Element = sts RETURN END !of Get_Inp_Element INTEGER *4 FUNCTION & Add_Inp_Element ( size, list_adr, indx, string ) ! ! Store a string in a dynamic array of descriptors, expanding ! it if necessary. ! implicit none C constant: PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size, list_adr INTEGER indx CHARACTER *(*) string C local: INTEGER *4 sts C functions: INTEGER *4 Expand_Inp_List, Put_Inp_Element INTRINSIC ABS sts = 1 IF ( ABS(indx) .GT. size ) THEN sts = Expand_Inp_List( size, list_adr) IF ( sts .AND. ABS(indx) .GT. size ) sts = SS$_SUBRNG END IF IF ( sts ) & sts = Put_Inp_Element( size, %VAL(list_adr), ABS(indx), string) Add_Inp_Element = sts RETURN END !of Add_Inp_Element INTEGER *4 FUNCTION Put_Inp_Element ( size, list, indx, string ) ! ! Store a string in a dynamic array of descriptors. ! implicit none C constant: INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptors PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size RECORD /dsc/ list(*) INTEGER indx CHARACTER *(*) string C local: INTEGER *4 sts C functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THEN sts = SS$_SUBRNG ELSE C list(indx) = string sts = STR$COPY_DX( %REF(list(indx)), string) END IF Put_Inp_Element = sts RETURN END !of Put_Inp_Element INTEGER FUNCTION Search_Inp_List ( size, list, target, wildcard ) ! ! Search an array of dyanamic string descriptors for a specified ! string; return its index if found, 0 otherwise. [If the list ! size is negative then return the negative of the index if found.] ! implicit none C constant: INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptors C input: INTEGER *4 size RECORD /dsc/ list(*) CHARACTER *(*) target LOGICAL wildcard C local: RECORD /dsc_d/ last_target !pre-initialized dynamic string descriptor INTEGER indx, abs_size LOGICAL found, reverse DATA indx /0/ SAVE indx !, last_target C functions: INTEGER *4 STR$MATCH_WILD INTEGER STR$COMPARE, STR$CASE_BLIND_COMPARE INTRINSIC ABS IF ( STR$COMPARE( target, last_target) .NE. 0 ) THEN found = .FALSE. reverse = ( size .LT. 0 ) abs_size = ABS(size) indx = 0 *(old) IF ( reverse ) indx = 1 !skip "-" DO WHILE ( indx .LT. abs_size .AND. .NOT. found ) indx = indx + 1 found = LEN(target) .NE. 0 !(require explicit match for null string) & .AND. STR$COMPARE( target, list(indx)) .EQ. 0 IF ( .NOT. found ) & found = STR$CASE_BLIND_COMPARE( target, list(indx)) .EQ.0 IF ( .NOT. found .AND. wildcard ) & found = STR$MATCH_WILD( target, list(indx)).AND.1 END DO IF ( .NOT. found ) indx = 0 IF ( reverse ) indx = -indx C save target (and result) for comparison next time CALL STR$COPY_DX( last_target, target) END IF Search_Inp_List = indx RETURN END !of Search_Inp_List INTEGER *4 FUNCTION Expand_Inp_List ( list_size, list ) ! ! Expand a dynamic array of string descriptors. ! implicit none C constant: INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptors PARAMETER eLEMENT_SIZE = 8, !size of descriptor & eXPANSION_INCREMENT = 10 C input: C input/output: INTEGER *4 list_size INTEGER *4 list C local: RECORD /dsc_d/ empty_dynamic !pre-initialized dynamic string descriptor INTEGER loop INTEGER *4 new_adr, new_size, old_size, & address, sts C functions: INTEGER *4 LIB$GET_VM, LIB$FREE_VM, & OTS$MOVE3 !MOVC3 but without 65535 byte limit INTRINSIC MIN new_size = list_size + eXPANSION_INCREMENT !increase by 10 slots sts = LIB$GET_VM( new_size * eLEMENT_SIZE, new_adr) IF ( sts ) THEN old_size = list_size IF ( old_size .GT. 0 ) THEN sts = OTS$MOVE3( %VAL(old_size * eLEMENT_SIZE), & %VAL(list), %VAL(new_adr)) IF ( sts ) & sts = LIB$FREE_VM( old_size * eLEMENT_SIZE, %VAL(list)) END IF C fill in empty (new) entries address = new_adr + old_size * eLEMENT_SIZE DO loop = 1, eXPANSION_INCREMENT ! old_size + 1, new_size CALL OTS$MOVE3( %VAL(eLEMENT_SIZE), %REF(empty_dynamic), & %VAL(address)) address = address + eLEMENT_SIZE END DO list_size = new_size list = new_adr END IF Expand_Inp_List = sts RETURN END !of Expand_Inp_List INTEGER *4 FUNCTION Output ( string ) ! ! Write out a string. ! implicit none C constant: INCLUDE '($SSdef)/nolist' !system service status codes INCLUDE '($RMSdef)/nolist' !RMS status codes INCLUDE '($FABdef)/nolist' !file-access-block defs INCLUDE '($RABdef)/nolist' !record-access-block defs INCLUDE '($NAMdef)/nolist' !file name block defs INCLUDE '($DEVdef)/nolist' !device defs INCLUDE '($DVIdef)/nolist' !device & volume info codes BYTE fAB_PROTOTYPE(2) / FAB$C_BID, FAB$C_BLN / BYTE rAB_PROTOTYPE(2) / RAB$C_BID, RAB$C_BLN / BYTE nAM_PROTOTYPE(2) / NAM$C_BID, NAM$C_BLN / PARAMETER rETRY_LIMIT = 10 C additional entries below: INTEGER *4 Block_Output, !use $write instead of $put & Flush_Output, !update output with $flush & Open_Output, !explicitly open an output file & Close_Output ! " close the " " C global input: COMMON /output_usropn/ usropn_routine, usropn_context INTEGER *4 usropn_routine /0/, !address of routine to process - & usropn_context /0/ !+ fab/rab/nam prior to $create. C input: CHARACTER *(*) string, !string to output & default_name !for Open_Output C output: INTEGER width !from Open_Output C local: RECORD /fabdef/ fab RECORD /rabdef/ rab RECORD /namdef/ nam CHARACTER *255 filename, buf *40 INTEGER *2 filnamlen, ln, retry_count INTEGER *4 len_tmp INTEGER *2 len_word BYTE len_byte EQUIVALENCE ( len_tmp, len_word, len_byte ) INTEGER *4 sts, clists, removed_privs(2), arglist(0:4) LOGICAL is_open /.FALSE./ SAVE is_open !, rab C functions: INTEGER *4 Cli_Present, Cli_Get_Value, & OTS$CVT_TI_L, & SYS$CREATE, SYS$CONNECT, & SYS$PUT, SYS$WRITE, SYS$FLUSH, & SYS$CLOSE, SYS$DISCONNECT, & LIB$PUT_OUTPUT INTRINSIC LEN, MIN, ICHAR IF ( is_open ) THEN C set up record buffer len_tmp = LEN(string) rab.rab$w_rsz = len_word rab.rab$l_rbf = %LOC(string) C write record & check results retry_count = 0 DO WHILE ( SYS$PUT( rab) .EQ. RMS$_RSA & .AND. retry_count .LT. rETRY_LIMIT ) CALL SYS$WAIT( rab) !if record stream active, wait & repeat retry_count = retry_count + 1 END DO sts = rab.rab$l_sts IF ( sts .EQ. RMS$_EXT !did we fail to extend? & .AND. rab.rab$l_stv .EQ. SS$_EXDISKQUOTA ) !due to quota? & sts = SYS$PUT( rab) !if so, try again ELSE C [ no explicit open was performed (or it was unsuccessful) ] sts = LIB$PUT_OUTPUT( string) END IF Output = sts RETURN ** ENTRY Block_Output ( string ) ! ! Use block i/o instead of record i/o; asynchronous contortions ! are not performed. Validity checks are left to RMS. ! C set up record buffer len_tmp = LEN(string) rab.rab$w_rsz = len_word rab.rab$l_rbf = %LOC(string) C write block & check results sts = SYS$WRITE( rab) IF ( sts .EQ. RMS$_EXT !did we fail to extend? & .AND. rab.rab$l_stv .EQ. SS$_EXDISKQUOTA ) !due to quota? & sts = SYS$WRITE( rab) !if so, try again Block_Output = sts Output = sts RETURN ** ENTRY Flush_Output ( ) ! ! Update output with $FLUSH. ! sts = SYS$FLUSH( rab) Flush_Output = sts RETURN ** ENTRY Open_Output ( default_name, width ) ! ! Open output file and determine desired line width. ! If the width has not been specified on the command line ! then use the default value: tty width for terminals, 80 for ! mailbox or network channels, 132 otherwise (ie, for disk files). ! ! Be sure not to risk compromising system security if this image ! has been installed with SYSPRV. (/output=sys$system:xxxx!) ! C retreive filename from command line: /output='filename' filnamlen = 0 IF ( Cli_Present( 'OUTPUT') ) THEN clists = Cli_Get_Value( 'OUTPUT', filename, filnamlen) END IF C initialize File Access Block CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0... fab.fab$l_fop = FAB$M_MXV .OR. FAB$M_SQO .OR. FAB$M_TEF !options fab.fab$b_fac = FAB$M_PUT !write access !-note: shr.shrget is incompatable with fop.tef !- fab.fab$b_shr = FAB$M_SHRGET !others can read !-!- & .OR. FAB$M_SHRPUT .OR. FAB$M_UPI .OR. FAB$M_MSE fab.fab$b_rat = FAB$M_CR !implied carriage return fab.fab$b_rfm = FAB$C_VAR !variable length IF ( filnamlen .GT. 0 ) THEN len_tmp = MIN( filnamlen, '00FF'x) !max length is 255 fab.fab$b_fns = len_byte !file name size fab.fab$l_fna = %LOC(filename) !file name address ELSE IF ( LEN(default_name) .EQ. 0 ) THEN fab.fab$b_fns = LEN('SYS$OUTPUT') fab.fab$l_fna = %LOC('SYS$OUTPUT') END IF fab.fab$b_dns = LEN(default_name) !default name size fab.fab$l_dna = %LOC(default_name) !default name address fab.fab$l_nam = %LOC(nam) !link NAM with FAB C initialize file NAMe block CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !NAM (for device name) * nam.nam$b_nop = NAM$M_PWD * len_tmp = MIN( LEN(realname), '00FF'x) * nam.nam$b_rss = len_byte * nam.nam$l_rsa = %LOC(realname) C initialize Record Access Block CALL LIB$MOVC5( 2, rAB_PROTOTYPE, 0, RAB$C_BLN, rab) !bid,bln,0... rab.rab$l_rop = 0 !no special record options rab.rab$l_fab = %LOC(fab) !link to FAB IF ( usropn_routine .NE. 0 ) THEN C kludge to transparently provide useropen-like functionality; C issue a call-back prior to $create (return status ignored): C call 'usropn_routine'( usropn_context, fab, rab, nam) arglist(0) = 4 !4 args in list arglist(1) = usropn_context arglist(2) = %LOC(fab) arglist(3) = %LOC(rab) arglist(4) = %LOC(nam) CALL LIB$CALLG( arglist, %VAL(usropn_routine)) END IF C disable any privileges that this image was installed with that the C user doesn't have in his/her own right CALL Disable_Installed_Privs( removed_privs) sts = SYS$CREATE( fab) IF ( sts ) THEN sts = SYS$CONNECT( rab) IF ( .NOT. sts ) CALL SYS$CLOSE( fab) * [ if ( sts ) define/user_mode sys$output 'realname' ] END IF is_open = ( (sts.AND.1) .EQ. 1 ) C if any privileges were removed, restore them now IF ( removed_privs(1) .NE. 0 .OR. removed_privs(2) .NE. 0 ) & CALL SYS$SETPRV( %VAL(1), removed_privs, %VAL(0),) width = 0 IF ( sts .AND. Cli_Present( 'WIDTH') ) THEN clists = Cli_Get_Value( 'WIDTH', buf, ln) IF ( clists .AND. ln .GT. 0 ) & clists = OTS$CVT_TI_L( buf(:ln), width) END IF IF ( sts .AND. width .LE. 0 ) THEN IF ( (fab.fab$l_dev .AND. DEV$M_TRM) .NE. 0 ) THEN ln = ICHAR(nam.nam$t_dvi(1:1)) CALL LIB$GETDVI( DVI$_DEVBUFSIZ,, nam.nam$t_dvi(2:1+ln), & width,,) IF ( width .LE. 0 ) width = 80 ELSE IF ( (fab.fab$l_dev .AND. (DEV$M_MBX .OR. DEV$M_NET)) & .NE. 0 ) THEN width = 80 ELSE width = 132 END IF END IF Open_Output = sts RETURN ** ENTRY Close_Output ( ) ! ! Close the file. ! sts = SYS$DISCONNECT( rab) CALL SYS$CLOSE( fab) if ( sts ) sts = fab.fab$l_sts if ( sts .eq. RMS$_NORMAL ) sts = 1 !SS$_NORMAL is_open = .false. Close_Output = sts RETURN END !of Output, Block_Output, Flush_Output, Open_Output & Close_Output LOGICAL FUNCTION Disable_Installed_Privs ( disabled_privs ) ! ! Disable any privileges that this image has been installed ! with that the user didn't already have. ! implicit none C constant: INCLUDE '($JPIdef)/nolist' !job & process info INCLUDE 'f_inc:Itm.F' !item list structure C output: INTEGER *4 disabled_privs(2) !privilege mask C local: RECORD /itmlst/ privs(3) !item list INTEGER *4 procpriv(2), imagpriv(2) LOGICAL disable privs(1).itm_length = ITM_S_QUADWORD privs(1).itm_code = JPI$_PROCPRIV privs(1).itm_bufadr = %LOC(procpriv) privs(2).itm_length = ITM_S_QUADWORD privs(2).itm_code = JPI$_IMAGPRIV privs(2).itm_bufadr = %LOC(imagpriv) privs(3).itm_code = ITM_K_END_OF_LIST imagpriv(1) = 0 imagpriv(2) = 0 CALL SYS$GETJPIW(,,, privs,,,) disabled_privs(1) = imagpriv(1) .AND. .NOT. procpriv(1) disabled_privs(2) = imagpriv(2) .AND. .NOT. procpriv(2) disable = ( disabled_privs(1) .NE. 0 & .OR. disabled_privs(2) .NE. 0 ) IF ( disable ) & CALL SYS$SETPRV( %VAL(0), disabled_privs, %VAL(0),) Disable_Installed_Privs = disable RETURN END !of Disable_Installed_Privs INTEGER *4 FUNCTION PutMsg ( facility, sts, stv ) ! ! Rudimentary message routine. ! implicit none C input: CHARACTER *(*) facility INTEGER *4 sts, stv C local INTEGER *4 msgvec(0:4) INTEGER *4 SYS$PUTMSG msgvec(0) = 1 !1 arg follows msgvec(1) = sts msgvec(2) = 0 IF ( %LOC(stv) .NE. 0 ) THEN msgvec(0) = 2 !make that two args msgvec(2) = stv END IF msgvec(3) = 0 msgvec(4) = 0 PutMsg = SYS$PUTMSG( msgvec,, facility,) RETURN END !of PutMsg INTEGER *4 FUNCTION Parse_Node ( in_name, outname, outlen ) ! ! Use RMS to extract a node name (let it handle any logical names). ! implicit none C constant: INCLUDE '($RMSdef)/nolist' INCLUDE '($FABdef)/nolist' INCLUDE '($NAMdef)/nolist' BYTE fAB_PROTOTYPE(2) / FAB$C_BID, FAB$C_BLN / BYTE nAM_PROTOTYPE(2) / NAM$C_BID, NAM$C_BLN / INTEGER *4 fILE_NAME_BITS PARAMETER ( fILE_NAME_BITS = NAM$M_NODE .OR. NAM$M_EXP_DEV & .OR. NAM$M_EXP_DIR .OR. NAM$M_EXP_NAME & .OR. NAM$M_EXP_TYPE .OR. NAM$M_EXP_VER ) C input: CHARACTER *(*) in_name C output: CHARACTER *(*) outname INTEGER *2 outlen C local: RECORD /fabdef/ fab RECORD /namdef/ nam CHARACTER *256 work_string INTEGER len_tmp, pos BYTE len_byte EQUIVALENCE ( len_tmp, len_byte ) INTEGER *4 sts C functions: INTEGER *4 SYS$PARSE INTRINSIC LEN, MIN, INDEX, ZEXT CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0... len_tmp = MIN( LEN(in_name), '00FF'x) !max length is 255 fab.fab$b_fns = len_byte !file name size fab.fab$l_fna = %LOC(in_name) !file name address fab.fab$l_nam = %LOC(nam) !pointer to NAM block CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !bid,bln,0... len_tmp = MIN( LEN(work_string), '00FF'x) !max length is 255 nam.nam$b_ess = len_byte !expanded string size nam.nam$l_esa = %LOC(work_string) !expanded string area nam.nam$b_nop = NAM$M_SYNCHK !options: syntax check only sts = SYS$PARSE( fab) IF ( sts ) THEN IF ( (nam.nam$l_fnb .AND. NAM$M_NODE) .NE. 0 ) THEN len_tmp = ZEXT(nam.nam$b_node) pos = INDEX( work_string(:len_tmp), '"') !find quote IF ( pos .GT. 0 ) THEN len_tmp = pos - 1 !drop access control string ELSE len_tmp = len_tmp - 2 !drop punctuation ("::") END IF ELSE IF ( (nam.nam$l_fnb .AND. fILE_NAME_BITS) & .EQ. NAM$M_EXP_NAME ) THEN C no punctuation present -- use name field as nodename len_tmp = ZEXT(nam.nam$b_name) CALL STR$COPY_R( work_string, len_tmp, & %VAL(nam.nam$l_name)) ELSE C missing node name: return "RMS-W-NOD, error in node name" sts = RMS$_NOD .AND. .NOT. '00000007'x !set severity to "W" len_tmp = ZEXT(nam.nam$b_esl) !return entire string anyway END IF outname = work_string(:len_tmp) outlen = len_tmp ELSE outname = in_name outlen = LEN(in_name) END IF outlen = MIN( outlen, LEN(outname)) Parse_Node = sts RETURN END !of Parse_Node LOGICAL FUNCTION Node_Avail ( nodename ) ! ! Determine whether the specified node is part of the cluster. ! Used by XSHOQUE to decide whether to display 'host unavailable' ! when it shows a stopped queue. ! implicit none C constant: INCLUDE '($SYIdef)/nolist' C input: CHARACTER *(*) nodename C local: LOGICAL avail INTEGER *4 sts, member INTEGER standalone /0/ SAVE standalone C functions: INTEGER *4 LIB$GETSYI IF ( standalone ) THEN C known to be non-clustered, so always return True avail = .TRUE. ELSE IF ( LEN(nodename) .EQ. 0 .OR. nodename .EQ. ' ' ) THEN C assumed non-cluster, so return True unless we're sure it's a cluster avail = (standalone .NE. 2) ELSE member = 0 sts = LIB$GETSYI( SYI$_CLUSTER_MEMBER, member,,, , & nodename) avail = ( (member .AND. 1).EQ. 1 ) C additional code added to support standalone system w/ SCSNODE defined IF ( standalone .EQ. 0 ) THEN IF ( avail ) THEN standalone = 2 !now known to be a cluster ELSE !check whether we're part of a cluster sts = LIB$GETSYI( SYI$_CLUSTER_MEMBER, member,,, ,) IF ( member ) THEN standalone = 2 ELSE standalone = 1 !not a cluster (Should compare nodename- avail = .TRUE. !assume ok (+ w/ our system's name.) END IF END IF END IF END IF Node_Avail = avail RETURN END !of Node_Avail INTEGER *4 FUNCTION Parse_Keywords( qual_name, keywrd_count, & keywords, synonyms, masks) ! ! Parse for a set of keywords and set up a mask longword ! based on their corresponding mask values. ! implicit none C constant: INCLUDE 'f_inc:Cli.F' !command interface defs C input: CHARACTER *(*) qual_name INTEGER keywrd_count CHARACTER *(*) keywords(0:*), synonyms(0:*) INTEGER *4 masks(0:*) C local: CHARACTER *32 qual_tmp INTEGER *2 ln INTEGER idx INTEGER *4 exp_incl, exp_excl, imp_excl, & result, sts, tmpsts C functions: INTEGER *4 Cli_Present INTEGER LIB$MATCH_COND result = 0 sts = Cli_Present( qual_name) IF ( sts ) THEN exp_incl = 0 !explicitly included exp_excl = 0 !explicitly excluded imp_excl = 0 !implicitly excluded DO idx = 0, keywrd_count CALL STR$TRIM( qual_tmp, keywords(idx), ln) sts = Cli_Present( qual_name//'.'//qual_tmp(:ln)) IF ( LIB$MATCH_COND( sts, CLI$_ABSENT, CLI$_DEFAULTED) & .GT. 0 ) THEN C check for synonym CALL STR$TRIM( qual_tmp, synonyms(idx), ln) IF ( ln .GT. 0 ) THEN tmpsts = Cli_Present( qual_name//'.'//qual_tmp(:ln)) IF ( LIB$MATCH_COND( tmpsts, CLI$_PRESENT, & CLI$_NEGATED, CLI$_DEFAULTED) & .GT. 0 ) sts = tmpsts END IF END IF IF ( sts ) THEN exp_incl = exp_incl .OR. masks(idx) exp_excl = exp_excl .AND. .NOT. masks(idx) !clear NOALL ELSE IF ( LIB$MATCH_COND( sts, CLI$_NEGATED) .GT. 0 ) THEN exp_excl = exp_excl .OR. masks(idx) ELSE IF ( idx .NE. 0 ) THEN imp_excl = imp_excl .OR. masks(idx) END IF END DO IF ( exp_incl .NE. 0 ) THEN result = exp_incl .AND. .NOT. exp_excl ELSE IF ( exp_excl .NE. 0 ) THEN result = .NOT. exp_excl ELSE result = .NOT. imp_excl END IF END IF Parse_Keywords = result RETURN END !of Parse_Keywords