% VAX-11 Librarian V04-00D`w1OӒ!9ef  ("CLI.F|DSC.F9 DYNAMIC.FOR& EXTRACT.CLD d EXTRACT.DOC EXTRACT.Fg EXTRACT.FOR EXTRACT.HLPL EXTRACT.MAKN0 EXTR_BUF.FOR EXTR_COL.FOR EXTR_EDIT.FOR2 EXTR_INP.FOReEXTR_TODO.LIST FINDFILE.FORxITM.FXABS.F DO* Cli.F -- Status codes returned by CLI$PRESENT, CLI$GET_VALUE, CLI$DCL_PARSE*. parameter CLI$_NOCOMD = '000380B0'x. parameter CLI$_ABSENT = '000381F0'x. parameter CLI$_NEGATED = '000381F8'xA parameter CLI$_LOCNEG = '00038230'x !locally negated. parameter CLI$_PRESENT = '0003FD19'x. parameter CLI$_DEFAULTED = '0003FD21'xD parameter CLI$_CONCAT = '0003FD29'x !terminated by plusA parameter CLI$_LOCPRES = '0003FD31'x !locally presentE parameter CLI$_COMMA = '0003FD39'x !terminated by comma. parameter CLI$_NORMAL = '00030001'xB parameter CLI$_INVREQTYP = '00038822'x !(no CLI present)7 parameter CLI$_SYNTAX = '000310FC'x !fatalH parameter CLI$_VALREQ = '00038150'x !missing required valueww D?* Dsc.F -- Substitute include file for Descriptor definitions* INCLUDE '($DSCdef)/nolist'F parameter dSC_S_DSC = 8 !descriptor size (standard quad type)M! alternate definition of generic descriptor structure (all fields should,! be treated as unsigned quantities) STRUCTURE /dsc/ UNION MAP% INTEGER *2 d_len !length# BYTE d_typ !type$ BYTE d_cls !class8 INTEGER *4 d_adr !address (pointer to data) END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNION END STRUCTURE !dsc STRUCTURE /dsc_s/ UNION MAP INTEGER *2 d_len /0/5 BYTE d_typ /DSC$K_DTYPE_T/ !ascii text1 BYTE d_cls /DSC$K_CLASS_S/ !static INTEGER *4 d_adr /0/ END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNION END STRUCTURE !dsc_s STRUCTURE /dsc_d/ UNION MAP INTEGER *2 d_len /0/5 BYTE d_typ /DSC$K_DTYPE_T/ !ascii text2 BYTE d_cls /DSC$K_CLASS_D/ !dynamic INTEGER *4 d_adr /0/ END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNION END STRUCTURE !dsc_d STRUCTURE /dsc_z/ UNION MAP INTEGER *2 d_len /0/6 BYTE d_typ /0/ !unspecified6 BYTE d_cls /0/ !unspecified INTEGER *4 d_adr /0/ END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNI ON END STRUCTURE !dsc_zww/D0! Extract.Cld -- command defintion for ExtractJ! Pat Rankin, Oct'88J! revised, Apr'89!& module Extract_Cmd !@.obj versiondefine verb extract&!$image Extract !$ dcl version&!@routine Extract_Cmd !@.obj version4 parameter p1, value(required,list,type=$infile),# label=Input_Extr, prompt="File": qualifier blocks, value(list,type=blk_rcrd_keywords)< qualifier columns, value(required,list) !,type=$number)? qualifier edit, value(required,list,type=edit_keywords)$ qualifier expand_tabs, negatable6 qualifier head, value(type=$number,default=22)! qualifier identify, negatableJ qualifier output, value(type=$outfile,default="SYS$OUTPUT"), default: qualifier records, value(list,type=blk_rcrd_keywords)6 qualifier tail, value(type=$number,default=22)< qualif ier translate, value(required,type=xlate_keywords) ! qualifier truncate= qualifier vfc_header, value(type=vfc_keywords), negatable ! qualifier width ! qualifier wrap, disallow ANY2(head,tail,records,blocks)E or blocks and (columns or expand_tabs or translate or vfc_header)3 or neg records and not (blocks or head or tail)= disallow records.end and records.count and records.start3 or blocks.end and blocks.count and blocks.startdefine type blk_rcrd_keywords5 keyword start, value(type=$number,default=1)6 keyword end, value(type=$number,default=-1)4 keyword count, value(type=$number,required)define type edit_keywords! keyword collapse, negatable! keyword compress, negatable! keyword lowercase, negatable! keyword trim, negatable! keyword uncomment, negatable! keyword upcase, negatable% keyword strip_trailing, negatable% keyword ignore_quotes, negatable2 keyword format , negatable !, default! keyword fallback, negatabledefine type vfc_keywords keyword data keyword ignore keyword keep, defaultdefine type xlate_keywords keyword ascii_to_ebcdic keyword ebcdic_to_ascii!***!!define verb EXIT!! synonym EX*!! cliroutine EXIT, cliflags(immediate)ww A#3DN+ Extract.Doc +J Pat Rankin, May'89 Description:H EXTRACT is a utility for retreiving records out of files. OneH may extract--in order to copy or display--a set of records from theH start [/HEAD], middle [/RECORD=(START and/or END and/or COUNT)], orH end [/TAIL] of one or more files. In addition, various conversionsH may be performed on the extracted records--such as tab expansion,H column range selection, and simple edits like case conversion, blank) compression, and parity-bit stripping. Usage:H EXTRACT can be defined as a native DCL command, eitherH system-wide or for the current process, or it can be used as aH 'foreign' command by using a symbol for it or by invoking it via MCR.= $ EXTRACT 'options' file[,file...] 'other_options'3 The file-specification(s) may contain wildcards. Options:! Record selection options:: /HEAD='k' !extract the first 'k' records7 /TAIL='k' ! " " last 'k' "F /RECORD=(START='m',END='m',COUNT='k') !analogous to DUMPH A negative value can be used to refer to positions relative to theH end of the file for HEAD, TAIL, START, and END. The last record ofH the file is considered to be #-1, the one before that #-2, and so on.A /HEAD='-k' !extract all but the last 'k' records> /TAIL='-k' ! " " " " first 'k' "F /BLOCK=(START='m',END='m',COUNT='k') !analogous to DUMPH Block-mode is only partially implemented and not thoroughly tested.H The record selection options (and the block option) are mutuallyH exclusive. When no record option is specified, the default behaviorH depends upon the use of record modification options (see below): theH whole file is extracted if any of the modification options areH specified, otherwise just the first record is extracted (ie,H /record=count=1 is the d efault). If the block option is used, none2 of the record modification options are allowed.$ Record modification options:< /COLUMNS=([-,]p:q,...) !select specific columnsE /[NO]EXPAND_TABS ![don't] convert tabs into spacesE /EDIT=(COLLAPSE,COMPRESS,LOWERCASE,TRIM,UNCOMMENT,UPCASE,-? STRIP_TRAILING,IGNORE_QUOTES,FALLBACK,FORMAT); /TRANSLATE={ ASCII_TO_EBCDIC | EBCDIC_TO_ASCII }H Selection by columns involves specifying one or more ranges of columnH positions; each range is a single number or a low and high pairH separated by colon (":") or dash ("-"); if the first range is just aH dash, then the rest of the list is interpreted as columns to rejectH instead of ones to select. Tab expansion is done by default ifH column selection or translation into EBCDIC is performed, otherwiseH tabs are left as is unless the expand option is requested. The editH options are basica lly the same as those provided by the DCL lexical2 function F$EDIT(), with a few extensions added. Miscellanous options:C /[NO]IDENTIFY ![don't] identify input file(s)E /OUTPUT=file !default is SYS$OUTPUT (terminal)H /VFC_HEADER={ IGNORE | DATA | KEEP } !special rms handlingH Identification consists of displaying the name of each input fileH prior to extraction; it is done by default if wildcards are presentH o r if a list of input files is specified or if the input file isH located via an RMS searchlist. All output--including input fileH identification--is written to the specified output file (analogous toH TYPE/OUTPUT rather than COPY or CONVERT). Files having variable-H with-fixed-control-area record format can receive special handling toH preserve their format or to bring the control area (which is normally, hidden) into the record as ordinary data. Installation:H  To define EXTRACT as a 'foreign' command simply create a DCL" symbol that points to the image1 $ EXTRACT :== $disk:[directory]EXTRACTH where 'disk' and 'directory' depend on the location of EXTRACT.EXEH and the dollar sign ("$") preceding 'disk' is required. To define itH as a native command, define a logical name that points to the .EXE9 and .CLD files and then use SET COMMAND to install it.3 $ DEFINE EXTRACT disk:[directory]EXTRACT  $ SET COMMAND EXTRACTH An entry for the system's online help is included and can be, installed using the LIBRARY/HELP command. Author: Pat Rankin- California State Legislature c/oK Assembly Elections, Reapportionment, Environmental Quality LaboratoryM & Constitutional Amendments Committee California Institute of Technology7 Los Angeles, CA Pasadena, CA. Internet: rankin @ eql.Caltech.EDU1 Bit net: rankin%eql @ CITiago.bitnet. SPAN/HEPnet: EQL::RANKIN (EQL==5.970)N+ [pr] +ww`D)* Extract.F -- include file for ExtractJ* Pat Rankin, Oct'88*%C miscellaneous global parameters common /extract_params/@ & block_mode, start_val, end_val, count_val,C & detab, xlate, buffer_required, direct_ access,F & non_span, lrecl, last_record, identify, use_vfc, & edit$ logical block_mode, detab,B & buffer_required, direct_access, non_span< integer identify, xlate, use_vfc !(0,1,or 2)1 integer *4 start_val, end_val, count_val,2 & lrecl, last_record, edit5C dynamic arrays for command line list processing common /dyn_list/1 & inp_list, inp_siz, inp_cnt,0 & col_list, col_siz, col_cnt. integer *4 inp_list, inp_siz, inp_cnt,4 & col_list, col_siz, col_cntww 4D program ExtractC ! Pat Rankin, Oct'88C ! revised, Apr'89 != ! Extract (and copy or display) a set of records or blocks: ! from the start, middle, or end of a file. Optionally> ! perform various conversions ~8* Extr_Col.For -- column oriented routines for Extract2* [also command line processing]J* Pat Rankin, Oct'88J* modified, Jul'89;* log Expand_Tabs ( col_cnt, col_list, record$, rec_len )d+* sub Select_Substring ( range, rec_dsc )L>* log Select_Columns ( col_cnt, col_list, record$, rec_len )0* i*4 Process_Column_List( size, list, first )%*  i*4 Param_Init ( outfile, o_len )s0* sub Give_Signal ( condition, param, status )*a logical function= & Expand_Tabs ( col_cnt, col_list, record$, rec_len )* != ! Replace tab characters with the proper number of spaces.@ ! We're constrained by expanding in place (which makes things ! absurdly over-complicated). !E ! Tab stops are defined to be every 8th column: 1, 9, 17, 25, ...e ! implicit noneC called by:&* subroutine Process_Record C constant5 character *1 tAB !ascii tab character D byte CR, BS, rUB !carriage return, backspace, rubout? parameter ( tAB = CHAR(9), CR = 13, BS = 8, rUB = 127 ) 4 parameter tAB_SIZE = 8, tAB_CACHE_SIZE = 256 C input:B integer *4 col_cnt, !number of elements in col_list[]G & col_list(2,*) !list of column ranges (sorted)%C input/output:m2 character *(*) record$ !one line of data> integer *2  rec_len !functional length of record$ C local: logical results2 integer *4 length, pos, old_pos, end_col,7 & added_len, chunk_len, log_pos . integer *2 len_word, pos_word, spaces,2 & cache_ptr, tab_cnt, idx,3 & pos_cache(2,tAB_CACHE_SIZE)7 equivalence ( length, len_word ), ( pos, pos_word )u character *1 c$, byte c< equivalence ( c$, c ) !simplify charact er testingC functions:/ intrinsic INDEX, ZEXT, MOD, MIN, LENt@ result = .false. !(*not really implemented yet*)6 length = ZEXT(rec_len) ! i*2 -> unsigned i*4B if ( length .eq. 0 ) return !nothing to do if record is empty 11 continueG if ( col_cnt .gt. 0 ) then !got column range(s) [limits interest] F end_col = MIN( col_list(2,col_cnt), LEN(record$)) !final column else ? end_col = LEN(record$) !need to process entire recor do end if - if ( end_col .lt. length ) length = end_colm0C find first tab; if none, we can return now$ pos = INDEX( record$(:length), tAB)E if ( pos .eq. 0 .or. pos .gt. end_col ) return !leave as is C GC first pass: identify tab positions and determine ultimate lengtheCM/ old_pos = 0 !previous tab locationNF log_pos = 0 !logical column position after last characterG added_len = 0 !number of additional characters due to spaces_: c "ache_ptr = 0 !index into list of tab locations tab_cnt = 0 do while ( pos .gt. 0 ) pos = old_pos + posOC figure out our logical position (determines # of spaces for this tab) " do idx = old_pos + 1, pos - 1 c$ = record$(idx:idx)i> if ( (c .and. '7F'x) .ge. ' ' !printable character7 & .and. (c .and. '7F'x) .ne. rUB ) thenf log_pos = log_pos + 1 : else if ( c .eq. CR ) then !carriage return log_pos = 0n@ else": integer *4 function Process_File ( rab, condition ) !* ! Process an (already open) input file. !A ! Note: the input file's fixed-header size (for vfc) is passedA ! in the rab's context field. If there are multiple input@ ! files processed, this might have a different value fromB ! call to call (so it won't necessarily match output file's6 ! vfc size if we're preserving the vfc header). ! implicit noneC called by:&* program Ex # if ( c .eq. BS .and. log_pos .gt. 0 ) then !backspace log_pos = log_pos - 1d* elseK* non-printable character does not advance logical columnt end if end dod0 spaces = tAB_SIZE - MOD( log_pos, tAB_SIZE) log_pos = log_pos + spacesl5 if ( pos + added_len - 1 + spaces .gt. end_col )i< & spaces = end_col - (pos + added_len - 1)' added_len = added_len + spaces - 1 C store tab's position tab_cnt = t$ab_cnt + 1 cache_ptr = cache_ptr + 1F if ( cache_ptr .gt. tAB_CACHE_SIZE ) cache_ptr = 1 !wrap& pos_cache(1,cache_ptr) = pos_word$ pos_cache(2,cache_ptr) = spacesC look for next tabr old_pos = pos pos = 0@ if ( old_pos .lt. length ) !ok to look for new pos@ & pos = INDEX( record$(old_pos+1:length), tAB)N if ( pos + old_pos + added_len .gt. end_col ) pos = 0 !past last column end do !while more tabsC<C % second pass: replace tabs with spaces (right to left)C 7 pos = length + 1 !just past end of input string , if ( length + added_len .lt. end_col ) then! end_col = length + added_len elsen" pos = end_col - added_len + 1 end iff& length = end_col !save end_col. do idx = MIN( tab_cnt, tAB_CACHE_SIZE), 1, -1 old_pos = pos& pos_word = pos_cache(1,cache_ptr)$ spaces = pos_cache(2,cache_ptr)" chunk_len = old_pos - pos - 1 if ( chunk_len .gt. 0 ) &H & record$(end_col-chunk_len+1:end_col) = record$(pos+1:old_pos-1)+ end_col = end_col - chunk_len - spacesf, record$(end_col+1:end_col+spaces) = ' ' cache_ptr = cache_ptr - 1F if ( cache_ptr .eq. 0 ) cache_ptr = tAB_CACHE_SIZE !wrap end do !next cached positionrC DC if we couldn't handle them all this time, start all over again(C ******** NOT TESTED ********C_( if ( tab_cnt .gt. tAB_CACHE_SIZE ) then( record$(pos:) = record$(end_col+1:)'( length = length - (end_col+1 - pos) rec_len = len_wordb7 length = pos !optimization to limit index()F goto 11 !**** !LOOP end if C done: set output parameter rec_len = len_word! Expand_Tabs = resultf return  end !of Expand_Tabso5 subroutine Select_Substring ( range, rec_dsc )  !9 ! Modify a string descriptor to reference a substring. > ! [Optimization used when selecting a single (column range.] ! implicit noneC called by:&* subroutine Process_RecordC constant: @ include 'f_inc:Dsc.F' !descriptor definitions C input:< integer *4 range(2) !start & end valuesC input/output: ? record /dsc/ rec_dsc !descriptor for record, C local: integer *4 lengthe integer *2 length_word& equivalence ( length, length_word )C functions: intrinsic MIN, ZEXTf< len)gth = MIN( range(2), ZEXT(rec_dsc.d_len)) - range(1) + 1 if ( range(1) .gt. 1 )e< & rec_dsc.d_adr = rec_dsc.d_adr + range(1) - 1 rec_dsc.d_len = length_word return end !of Select_Substring logical functionH & Select_Columns ( col_cnt, col_list, in_rec$, outrec$, rec_len ) !< ! Replace record with specific columns. ['col_cnt' >= 1]B ! Returns true if data copied into output record, false if it's? ! left in input record (due to selecting co*lumns 1..n only)._ ! implicit noneC called by:&* subroutine Process_Record C input:I integer *4 col_cnt, !number of entries in 'col_list' K & col_list(2,*) !sorted list of range pairsr6 character *(*) in_rec$ !input string C output:.F character *(*) outrec$ !output string (len >= input)C input/output: H integer *2 rec_len !record length (before & after) +C local:G logical result !true=>outrec$, false=>in_rec$ 5 integer indx !array index # integer *4 next, last, ltmp3 integer *2 last_word" equivalence ( last, last_word )C functions: intrinsic LEN, MIN, MAX6 result = .false. !data not copied into outrec$D if ( col_cnt .le. 0 ) return ![this should never happen]NC check whether first column range includes left-most part of input string ,B if ( col_list(1,1) .gt. 1 ) then !skipping start of string6 indx = 0 !start with first column pair. last = 0 !end of string so far7 else !beginning of string is being includedr4 indx = 1 !skip to second column pair? last = MIN( col_list(2,1), LEN(in_rec$)) !end of 1st rangea end ifsC if ( indx .eq. 0 .or. col_cnt .gt. 1 ) then !need to copy datao= result = .true. !data is being copied into 'outrec$'(J if ( -indx .eq. 1 ) outrec$(:last) = in_rec$(:last) !copy 1st segment end if C loop through column ranges do while ( indx .lt. col_cnt )i+ indx = indx + 1 !next column rangeeD next = col_list(1,indx) !start of substring' if ( next .le. LEN(in_rec$) ) theneA ltmp = MIN( col_list(2,indx), LEN(in_rec$)) - next + 1 !lengthR7 outrec$(last+1:last+ltmp) = in_rec$(next:next+ltmp-1)p last = last + ltmp< else !request column(s) past end of input .record* indx = col_cnt + 1 !force loop exit end ifb! end do !loop: next column rangeA- rec_len = last_word !store return length Select_Columns = result returnl end !of Select_Columns= integer *4 function Process_Column_List ( size, list )r !; ! Convert strings into integers. Overwrite the originalc? ! string descriptors with the values. Each string is either.B ! a single number or a pair of numbers separated by '-' or ':'. !> ! The lis /t of ranges are sorted into ascending sequence andA ! then overlapping ranges are consolidated. Also, if the size D ! of the list is negative then first element of the list was "-",& ! so the ranges are to be inverted:1 ! ("-","5-10","15-20") -> (1-4,11-14,21-*)_ ! implicit noneC called by:"* function Param_InitC constant:n> include '($SHRdef)/nolist' !shared message codes? include 'f_inc:Dsc.F' !($DSCdef) descriptors @ s0tructure /dsc_or_range/ !custom structure for this task union map; record /dsc/ descrip !string descriptor end map map9 integer *4 low, high !pair of numbers end map end union end structure !dsc_or_range7 parameter mAX_COLUMN = '0000FFFF'x !65535tC input/output:eC integer *4 size !number of elements (might change) E record /dsc_or_range/ list(*) !raw input strings -> numeric range1ss C local: record /dsc_or_range/ work. integer indx, pos, len_tmp, offset! integer *4 sts, low, highrC functions:( integer STR$COMPARE, LIB$INDEX integer *4 STR$FREE1_DX,M & OTS$CVT_TI_L !convert text integer to long  intrinsic ABS, MINC)/C first pass: convert strings into numbersCdA work.descrip.d_quad(1) = 0 !dsc: type & class unspecified (Z,Z). sts = 1I if ( size .eq. -1 ) sts = SHR$_VAL 2ERR !what columns are we discarding?c indx = 0d+ do while ( sts .and. indx .LT. ABS(size) )eC get next stringc7 indx = indx + 1 !increment array indexrG work.descrip.d_len = list(indx).descrip.d_len !string length G work.descrip.d_adr = list(indx).descrip.d_adr ! " addressw low = 0C high = 0d6C check for range (by looking for punctuation)D pos = LIB$INDEX( work.descrip, ':') !find colon or dash; if ( pos .e 3q. 0 ) pos = LIB$INDEX( work.descrip, '-')e if ( pos .eq. 0 ) thene8C single number (treat as a range of "n:n")< sts = OTS$CVT_TI_L( work.descrip, low) !convert to binary6 high = low !'range' covers single value elsep<C range (note special handling for leading '-')7 len_tmp = work.descrip.d_len !save original length B work.descrip.d_len = pos - 1 !reduce length: start thru punct if ( pos .eq. 1u! & .or. pos .eq. 2r 4H & .and. STR$COMPARE( work.descrip, '*') .eq. 0 ) then:C (negative => nogood unless special case); if ( indx .eq. 1 !first element: implied column 1r? & .or. indx .eq. 2 .and. size .lt. 0 ) thenf6 low = 1 !starting column of '1' was implied else sts = SHR$_VALERR end if% else !convert string into numbera, sts = OTS$CVT_TI_L( work.descrip, low) end if$ if ( sts ) then !ok so farDC 5 adjust descriptor to point to right part of string( work.descrip.d_len = len_tmp - pos3 work.descrip.d_adr = work.descrip.d_adr + post$ if ( work.descrip.d_len .eq. 06 & .or. work.descrip.d_len .eq. 1H & .and. STR$COMPARE( work.descrip, '*') .eq. 0H & ) then !only ok for last element (or inversion '-')4 high = mAX_COLUMN !guaranteed end of record if ( indx .lt. ABS(size)mB & 6 .and. ( indx .gt. 1 .or. size .gt. 0 ) )1 & sts = SHR$_VALERR ) else !convert string into numberu* sts = OTS$CVT_TI_L( work.descrip, high) end if end if !low value converted ok% end if !punctuation pos => rangee@ if ( sts !if ok so far, check for invalid range value(s)F & .and. ( high .lt. low .or. low .lt. 1 .or. high .lt. 1 ) & ) then& sts = SHR$_VALERR !value error elset:C re7place descriptor data with pair of numbers$ work.low = MIN( low, mAX_COLUMN)$ work.high = MIN( high, mAX_COLUMN)4 if ( list(indx).descrip.d_cls .eq. DSC$K_CLASS_D )O & call STR$FREE1_DX( list(indx).descrip) !release memoryb list(indx).low = work.low list(indx).high = work.high end ifb end do !next indx if ( sts ) thenCn(C second pass: clean up the numbersCt5 do indx = 2, ABS(size) !sort the short list  low = list(indx).8lowy, if ( low .lt. list(indx - 1).low ) then high = list(indx).high pos = indx - 16 do while ( pos .gt. 0 .and. low .lt. list(pos).low )( list(pos + 1).low = list(pos).low) list(pos + 1).high = list(pos).high= pos = pos - 1  end do !sort loopn list(pos + 1).low = low list(pos + 1).high = highf end ifa end do !next indxC) if ( size .lt. 0 ) then4C convert exclusion list into inclusion list size = ABS(size).B list(1).low = 1  !(element '1' had been used only for "-") offset = 1oH if ( list(2).low .le. 1 ) then !excluding left-most part (1:x)A list(1).low = list(2).high + 1 !so include beyond that (x+1:?)r offset = 2 end if  do indx = offset + 1, size B list(indx - offset).high = list(indx).low - 1 !copy next 'low' if ( list(indx - offset).highE & .lt. list(indx - offset).low ) offset = offset + 1  if ( offset .eq. 1F & .or. list(indx).high .ge. l :`w1OӒH* Dyn_Inp.For -- Dynamic Input routines & other miscellaneous routinesJ* Pat Rankin, May'88* i*4 Cli_Present ( label )/* i*4 Cli_Get_Value ( label, result, reslen ) 2* 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 )8* i*4 Add_Inp_Element ( size, list ;_adr, indx, string )4* i*4 Put_Inp_Element ( size, list, indx, string )8* i*4 Search_Inp_List ( size, list, target, wildcard )4* i*4 Expand_Inp_List ( list_size, list, new_adr )* i*4 Output ( string )e* " Block_Output ( string ) * " Flush_Output ( )+* " Open_Output ( default_name, width )i2* log Disable_Installed_Privs ( disabled_privs )%* i*4 PutMsg ( facility, sts, stv )N.* i*4 Parse_Node ( infile, outfile, outlen )#* log Node_Available ( nodename ) K* i*4< Parse_Keywords( qual_name, keywrd_count, keywords, synonyms, masks) *p0 INTEGER *4 FUNCTION Cli_Present ( label )/ ! Call CLI$PRESENT with signalling disabled. implicit none C input: CHARACTER *(*) labelC functions: INTEGER *4 CLI$PRESENT EXTERNAL LIB$SIG_TO_RETe$ CALL LIB$ESTABLISH( LIB$SIG_TO_RET)" Cli_Present = CLI$PRESENT( label) RETURN; END !of Cli_PresenteB INTEGER *4 FUNCTION Cli_Get_Value ( label, result, reslen )1= ! Call CLI$GET_VALUE with signalling disabled.  implicit none C input: CHARACTER *(*) label C output:  CHARACTER *(*) resultt INTEGER *2 reslensC functions: INTEGER *4 CLI$GET_VALUE EXTERNAL LIB$SIG_TO_RETg$ CALL LIB$ESTABLISH( LIB$SIG_TO_RET) reslen = 0 6 Cli_Get_Value = CLI$GET_VALUE( label, result, reslen) RETURNl END !of Cli_Get_Value E INTEGER *4 FUNCTION Cli_Parse_Command ( tables, verb, prompt )f !? ! Fetch use >r's command line and parse it. If he used "RUN",n= ! there was no chance to supply one, so prompt for it now.C ! implicit noneC constant:S7 INCLUDE '($FSCNdef)/nolist' !filescan defs/7 INCLUDE '($CliVERBdef)/nolist' !cli verb defs/A*- INCLUDE '($CliSERVdef)/nolist' !cli service defss> PARAMETER CLI$K_GETCMD = '00000001'x !get command line9 INCLUDE 'f_inc:Dsc.F' !descriptor defsr3 STRUCTURE /clirq/ !cli reques ?t block A BYTE rqtype/0/, rqindx/0/, rqflags/0/, rqstat /0/s INTEGER *4 %FILL(1) /0/G RECORD /dsc_z/ rdesc !descriptor initialized to 0'ss" 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:B EXTERNAL tables !command tables [set command/obj]A C @HARACTER *(*) verb, prompt !command verb and prompt strings, C local:? RECORD /dsc_d/ parse !descriptor for dynamic stringA RECORD /clirq/ cmd !command interface request blockm9 RECORD /fscn/ fscn !item list for $filescano5 INTEGER *4 sts !return status valuelC functions:( INTEGER *4 SYS$CLI, CLI$DCL_PARSE/ EXTERNAL LIB$SIG_TO_RET, LIB$GET_INPUTR@ CALL LIB$ESTABLISH( LIB$SIG_TO_RET) !suppress error signals AC get command line? cmd.rqtype = CLI$K_GETCMD !request is 'get command line'n sts = SYS$CLI( cmd,,)A IF ( sts ) THEN !ok => cli available & verb wasn't "RUN"HC invoked via symbol => have command line (which might be empty)?C [might also be invoked via mcr or dcl; that's ok] D 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,)< cm Bd.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)1C prepend verb and parse the command linec2 CALL STR$CONCAT( parse, verb, ' ', cmd.rdesc)( sts = CLI$DCL_PARSE( parse, tables)? ELSE ! RUN (might be "no cli present" [CLI$_INVREQTYP])vHC invoked via run => get a substitute command line from the user1 sts = CLI$DCL_PARSE(, tables, LIB$GET_INPUT, 6 & LICB$GET_INPUT, prompt) END IFO Cli_Parse_Command = sts RETURN] END !of Cli_Parse_Commandt9 INTEGER *4 FUNCTION Get_Cli_Number ( key, result )  != ! Use CLI routine to obtain a parameter or qualifier valuei< ! and convert the resulting string into a binary integer. ! implicit none C input: CHARACTER *(*) key C output:i INTEGER *4 resulte C local: CHARACTER *32 value INTEGER *2 lnr INTEGER *4 stsC functions:- INTEGDER *4 Cli_Get_Value, OTS$CVT_TI_L result = 0% sts = Cli_Get_Value( key, value, ln)e4 IF ( sts ) sts = OTS$CVT_TI_L( value(:ln), result) Get_Cli_Number = stsp RETURNt END !of Get_Cli_Number INTEGER *4 FUNCTIONr@ & Get_Inp_List ( qualif, list_size, list_adr, list_cnt ) !9 ! Retreive a list that's been parsed via cli routines.i< ! If the first element is "-" then the item count will be ! negated.i ! implicit none C input: CHARACTERE *(*) qualiflC input/output:c INTEGER *4 list_size,i & list_adr C output:w INTEGER *4 list_cntm C local: CHARACTER *512 buffers INTEGER *2 buflen  LOGICAL negatei INTEGER *4 sts, clists C functions:- INTEGER *4 Cli_Present, Cli_Get_Value, ' & Add_Inp_Elemente INTRINSIC LEN list_cnt = 0t sts = Cli_Present( qualif)l IF ( sts ) THEN4 clists = Cli_Get_Value( qualif, bFuffer, buflen); negate = ( (clists .AND. 1) .EQ. 1 .AND. buflen .GT. 0 6 & .AND. buffer(:buflen) .EQ. '-' )9 sts = clists !potential return status" DO WHILE ( sts .AND. clists ) list_cnt = list_cnt + 1f- sts = Add_Inp_Element( list_size, list_adr,g@ & list_cnt, buffer(:buflen))1 clists = Cli_Get_Value( qualif, buffer, buflen)B END DO ( IF ( negate ) list_cnt = -list_cnt END IFe Get_Inp_List G= stsh RETURN. END !of Get_Inp_List INTEGER *4 FUNCTIONn@ & Get_Inp_Element ( size, list, indx, result, reslen ) !; ! Retreive a string from a dynamic array of descriptors.t ! implicit noneC constant: ? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptorsBD PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 sizet RECORD /dsc/ list(*) INTEGER indxa C output:r CHARACTER *(*H) resulti INTEGER *2 reslen C local: INTEGER *4 stsC functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS, LEN, MIN1 IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THEN  sts = SS$_SUBRNGd ELSE C result = list(indx) 1 sts = STR$COPY_DX( result, %REF(list(indx)))i1 reslen = MIN( list(indx).d_len, LEN(result))A END IF  Get_Inp_Element = sts RETURNe END !of Get_Inp_ElementH INTEGER *4 FUNCTIONA: & Add_IInp_Element ( size, list_adr, indx, string ) !@ ! Store a string in a dynamic array of descriptors, expanding ! it if necessary. ! implicit noneC constant: D PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size, list_adr INTEGER indxi CHARACTER *(*) stringt C local: INTEGER *4 stsC functions:2 INTEGER *4 Expand_Inp_List, Put_Inp_Element INTRINSIC ABS sts = 1 IF ( ABS(indx) .GT.J size ) THEN+ sts = Expand_Inp_List( size, list_adr) ; IF ( sts .AND. ABS(indx) .GT. size ) sts = SS$_SUBRNGd END IFo IF ( sts )iG & sts = Put_Inp_Element( size, %VAL(list_adr), ABS(indx), string) Add_Inp_Element = sts RETURNl END !of Add_Inp_Element G INTEGER *4 FUNCTION Put_Inp_Element ( size, list, indx, string )  !6 ! Store a string in a dynamic array of descriptors. ! implicit noneC constant:(? INCLUDE 'f_inc:Dsc.F' K !($DSCdef) descriptorstD PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size  RECORD /dsc/ list(*) INTEGER indx  CHARACTER *(*) stringb C local: INTEGER *4 stsC functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS1 IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THENk sts = SS$_SUBRNGP ELSErC list(indx) = stringu1 sts = STR$COPY_DX( %REF(list(indx)), string)t END IFK Put_Inp_Element = sts RETURNs END !of Put_Inp_ElementOH INTEGER FUNCTION Search_Inp_List ( size, list, target, wildcard ) !C ! Search an array of dyanamic string descriptors for a specifiedtB ! string; return its index if found, 0 otherwise. [If the listF ! size is negative then return the negative of the index if found.] ! implicit noneC constant:/? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptorsl C input: INTEGER *4 size  RECORD Mt@ $ EXTRACT Test.Dat/RECORDS=(START=11,END=-11) /OUTPUT=Test.Mid, !Get specific columns out of several files: $ EXTRACT/COLUMNS=(1:10,18:19,25,41:*) Test.*,[...]*.Tmp!#eof#wwy?D# Makefile for ExtractJ# Pat Rankin, Oct'88J# revised, Apr'89#Iextract.exe : extract.obj extr_inp.obj extr_col.obj extr_buf.obj \; extr_edit.obj extr_cmd.obj findf Nile.obj \ [-.xshow]dynamic.obj* write sys$$output " Linking ""Extract"" "> link Extract,Extr_Inp,Extr_Col,Extr_Buf,Extr_Cmd,Extr_Edit, -/ FindFile,[-.xshow]Dynamic,sys$$input:/optionsB identification="v1.3" $extr_cmd.obj : extract.cld- write sys$$output " Compiling ""Extr_Cmd"" "( set command/object=Extr_Cmd Extract.Cld *.obj : *.for' write sys$$output " Compiling ""$*"" " fortran $*/obj>extract.obj extr_inp.obj extr_col.Oobj extr_buf.obj : extract.f#eof#wwOD/* Extr_Buf.For -- Buffer routines for ExtractJ* Pat Rankin, Oct'883* i*4 Buffer_File ( rab, nxt_rec, start, finish )%* i*4 Fetch_Record ( rec_num, rab )$* sub Alloc_Buf_Dsc ( size, list )#* sub Init_Buf_Dsc ( size, list )* i*4 Buf_LPeek ( l )* i*2 Buf_WPeek ( w )* byt Buf_BPeek ( b )*F integer *4 function Buffer_File ( rab, nxt_rec, start P, finish ) !% ! Read an entire file into memory. !@ ! Note: if we're treating fixed-header portion of vfc record= ! as data, then the size is in the rab's context field@ ! and the header's buffer immediately precedes the recordB ! buffer--they can be concatenated without moving any data. !A ! NB: retaining vfc header as a vfc header is not implementedA ! here because it's never buffered if it's on disk (assume> ! that only disk files ever have vf Qc format). Treating> ! vfc header as data is also not necessary to implement3 ! but it's done anyway since it's so simple. ! implicit noneC called by:$* function Process_FileC constant:: include '($RMSdef)/nolist' !rms status codesF include '($RABdef)/nolist' !rms Record Access Block defsF parameter mAX_RECORD = '7FFFFFFF'x !largest positive i*4/ parameter wORD = 2, lONG = 4, qUAD = 8< parameter d RSC_S_SIZE = qUAD !size of descriptorK parameter cHUNK_SIZE = 256 !arbitrary amount (of descriptors) C global: include 'Extract.F' common /buffers/4 & buf_list, buf_indx, buf_limit,: & buf_rec_start, buf_rec_end, buf_wrap: integer *4 buf_list(2) /2*0/, buf_indx, buf_limit,B & buf_rec_start, buf_rec_end /0/, buf_wrap C input:F record /rabdef/ rab !input file's rms record access block S C output:H integer *4 nxt_rec, !next fetch will retreive this record #L & start, finish !initial & final records of interest C local:$ integer *4 rec_cnt, buf_size,6 & buf_start, buf_end, buf_ptr, & sts integer vfc_offsetC functions:, integer Buf_WPeek *2, Buf_LPeek *4 integer *4 Alloc_Buf_Dsc,+ & SYS$FIND, SYS$GET,& & TLIB$SCOPY_R_DX! intrinsic ZEXT, MAX, MIN sts = 1 buf_rec_start = 0 buf_rec_end = 0 start = 1 !temp finish = 0 !temp if ( start_val .gt. 0 ) then5C skip until we reach desired starting record/ nxt_rec = 0 !($find needs 1 extra) start = start_val. do while ( nxt_rec .lt. start .and. sts ). if ( SYS$FIND( rab) ) nxt_rec = nxt_rec + 1 sts = rab.rab$l_sts end do if ( .not. sts ) goto 88 else nxt_rec = 1U end if*C determine how many records to bufferD if ( start_val .gt. 0 .and. end_val .gt. 0 ) then !(won't happen)( buf_limit = end_val - start_val + 1" else if ( start_val .lt. 0 ) then@ buf_limit = -start_val !buffer -start thru eof else buf_limit = mAX_RECORD end if$C initialize buffer if necessary if ( buf_list(1) .eq. 0 ) then buf_size = cHUNK_SIZE0 sts = Alloc_Buf_Dsc( buf_size, buf_list(2))3 buf_list(1) = buf_size V !save size end if buf_indx = 0 buf_rec_start = nxt_rec buf_wrap = 0OC prepare for vfc manipulation (easy--the hard stuff has already been done) vfc_offset = 0+ if ( use_vfc ) vfc_offset = rab.rab$l_ctxCC loop through the rest of the input stream, retreiving records&C and copying them into memory rec_cnt = nxt_rec - 1 do while ( sts )' if ( SYS$GET( rab) .eq. RMS$_RTB )M & rab.rab$l_sts = rab.rab$l_sts .or. 3 !****W sts = rab.rab$l_sts if ( sts ) then9 rec_cnt = rec_cnt + 1 !increment record count buf_indx = buf_indx + 1: if ( buf_indx .eq. 1 .or. buf_indx .gt. buf_limit ) then buf_size = buf_list(1) buf_start = buf_list(2)1 buf_end = buf_start + buf_size * dSC_S_SIZE buf_ptr = buf_start buf_rec_start = rec_cnt buf_wrap = rec_cnt - 1 buf_indx = 1 end if= buf_ptr = buf_ptr + dSC_S_SIZE !advance to next descriptor" if ( bufX_ptr .gt. buf_end ) then0 buf_ptr = Buf_LPeek( %VAL(buf_start+lONG)) if ( buf_ptr .ne. 0 ) then buf_start = buf_ptr/ buf_size = ZEXT(Buf_WPeek( %VAL(buf_start))) else buf_size = cHUNK_SIZE! sts = Alloc_Buf_Dsc( buf_size,A & %VAL(buf_start+lONG)) if ( sts )H & buf_start = Buf_LPeek( %VAL(buf_start+lONG)) end if buf_end = buf_startA & + buf_size * cHUNK_YSIZE * dSC_S_SIZE> buf_ptr = buf_start + dSC_S_SIZE !advance to position end if if ( sts )G & sts = LIB$SCOPY_R_DX( ZEXT(rab.rab$w_rsz) + vfc_offset,F & %VAL(rab.rab$l_rbf - vfc_offset),3 & %VAL(buf_ptr)) end if end do !while sts buf_rec_end = rec_cnt?C we can now determine proper values for for start & finish if ( start_val .le. 0 ) then/ start = MAX( (rec_cnt + 1) + start_Zval, 1) * else#* start already set above end if if ( end_val .le. 0 ) then. finish = MAX( (rec_cnt + 1) + end_val, 0) else$ finish = MIN( end_val, rec_cnt) end if2 nxt_rec = start !setup for Process_File() 88 continue4 if ( sts .eq. RMS$_EOF ) sts = 1 !SS$_NORMAL Buffer_File = sts return end !of Buffer_FileF integer *4 function Fetch_Record ( rec_num, rcrd, copy_string ) !6 ! Retreive a record that's [been buffered in memory. !? ! Note: if the caller intends to expand tabs, 'copy_string'A ! will direct us to copy the record contents into caller's? ! large buffer instead of just filling in the descriptor@ ! with a pointer to the buffered record. [Eventually tabA ! processing will be revised to eliminate this necessity.] ! implicit noneC called by:$* function Process_FileC constant:: include '($RMSdef)/nolist' !rms st \atus codes9 include 'f_inc:Dsc.F' !descriptor defs$ parameter lONG = 4, qUAD = 8" parameter dSC_S_SIZE = qUAD C global:* include 'Extract.F' common /buffers/4 & buf_list, buf_indx, buf_limit,: & buf_rec_start, buf_rec_end, buf_wrap: integer *4 buf_list(2) /2*0/, buf_indx, buf_limit,B & buf_rec_start, buf_rec_end /0/, buf_wrap C input:/ integer *4 rec_num !reco ]rd numberE logical copy_string !flag to force string copy instead -NC input/output: !+ of simply filling in the descriptorE record /dsc/ rcrd !string descriptor to receive record C local: record /dsc_z/ temp/ integer *4 buf_ptr, buf_start, buf_end,/ & buf_size, target_indx,1 & prev_rec, prev_ptr, sts data prev_rec /-1/3 save prev_rec, prev_ptr, buf_start, buf_end^C functions:, integer Buf_WPeek *2, Buf_LPeek *4 integer *4 STR$COPY_DX sts = 1% if ( rec_num .gt. buf_rec_end ) then sts = RMS$_EOF+ else if ( rec_num .ne. prev_rec + 1 ) then buf_start = buf_list(2) buf_size = buf_list(1). target_indx = rec_num - buf_rec_start + 1D if ( rec_num .lt. buf_rec_start ) !buffer has wrapped9 & target_indx = target_indx + buf_limitA do while ( target_indx .gt. buf_size .and. buf__start .ne.0 )& target_indx = target_indx - buf_size. buf_start = Buf_LPeek( %VAL(buf_start+lONG)) if ( buf_start .ne. 0 )E & buf_size = ZEXT( Buf_WPeek( %VAL(buf_start))) end do0 buf_end = buf_start + buf_size * dSC_S_SIZE3 buf_ptr = buf_start + target_indx * dSC_S_SIZE else* if ( rec_num .eq. buf_wrap + 1 ) then buf_start = %LOC(buf_list)+ prev_ptr = buf_end !force 'if' below end if$ buf_ptr = prev_ptr + dSC_S_SIZE% ` if ( buf_ptr .gt. buf_end ) then. buf_start = Buf_LPeek( %VAL(buf_start+lONG)) if ( buf_start .ne. 0 )E & buf_size = ZEXT( Buf_WPeek( %VAL(buf_start)))- buf_end = buf_start + buf_size * dSC_S_SIZE" buf_ptr = buf_start + dSC_S_SIZE end if end if if ( .not. sts ) then* do nothing" else if ( buf_start .eq. 0 ) thenF sts = 0 !internal error !**** else+ temp.d_len = Buf_WPeek( %VAL(buf_ptr))0 a temp.d_adr = Buf_LPeek( %VAL(buf_ptr+lONG)) if ( copy_string ) then sts = STR$COPY_DX( rcrd, temp) else rcrd.d_adr = temp.d_adr end if rcrd.d_len = temp.d_len prev_rec = rec_num prev_ptr = buf_ptr end if Fetch_Record = sts return end !of Fetch_Record7 integer *4 function Alloc_Buf_Dsc ( size, list ) !4 ! Allocate an array of dynamic string descriptors* ! and initiailize them to null strings. ! implicit nonebC callend by:#* function Buffer_FileC constant: integer *4 dSC_S_SIZE! parameter ( dSC_S_SIZE = 8 ) C input: integer size C output: integer *4 list C local: integer *4 stsC functions: integer *4 LIB$GET_VM+ sts = LIB$GET_VM( size * dSC_S_SIZE, list)1 if ( sts ) call Init_Buf_Dsc( size, %VAL(list)) Alloc_Buf_Dsc = sts return end !of Alloc_Buf_Dsc- subroutine Init_Buf_Dcsc ( size, list ) !< ! Initialize array of dynamic string descriptors to null.> ! The first element of the array is not a string descriptor; ! but is rather part of a linked list (or soon will be). ! implicit noneC callend by:%* function Alloc_Buf_DscC constant: include 'f_inc:Dsc.F'C input/output: integer size C output: record /dsc/ list(0:*) C local:D record /dsc_d/ null !pre-initialized dynamic descriptord integer idx#C first element is not a string= size = size - 1 !don't count initial element list(0).d_len = size list(0).d_typ = 0 list(0).d_cls = 0# list(0).d_adr = 0 !next list do idx = 1, sizeE list(idx).d_quad(1) = null.d_quad(1) !length (0), type, class7 list(idx).d_quad(2) = 0 !(address) end do return end !of Init_Buf_Dsc* integer *4 function Buf_LPeek ( l )3 integer *4 l e !%val(i*4) Buf_LPeek = l return end !of Buf_LPeek* integer *2 function Buf_WPeek ( w )3 integer *2 w !%val(i*2) Buf_WPeek = w return end !of Buf_WPeek$ byte function Buf_BPeek ( b )4 byte b !%val(byte) Buf_BPeek = b return end !of Buf_BPeekww XSD8* Extr_Col.For -- column oriented routines for Extract2* [also command line fV?'ϒExtract utility, to be done... 1) implement /loga. 2) add /number[ed] option, similar to searchL 3) finish implementing 'common' qualifiers (/exclude, /confirm, /by_owner,F /before, /since, /created, /modified, /backup [/backedup?], /expired)K 4) option to specify or propagate more rms settings for output file (at at' minimum, allow sort's /format=fixed=#)J 5) adjust rms input options to allow access to an open .log file (and/or? implement /override_locked=(file,record) or something similar)e0 0) clean up source code & update documentationww! absurdly over-complicated). !E ! Tab stops are defined to be every 8th column: 1, 9, 17, 25, ... ! implicit noneC called by:&* subroutine Process_RecordC constant5 character *1 tAB !ascii tab characterD byte CR, BS, rUB !carriage return, backspace, rubout? parameter ( tAB = CHAR(9), CR = 13, BS = 8, rUB = 127 )4 parameter tAB_SIZE = h }'ϒ program ExtractC ! Pat Rankin, Oct'88 C ! revised, Apr'89C ! " Jul'89aC ! " Oct'89 = ! Extract (and copy or display) a set of records or blocks : ! from the start, middle, or end of a file. Optionally> ! perform various conversions such as tab expansion, coilumn' ! range selection, and simple edits., !A ! Note: Block-mode implementation is incomplete and what there1 ! is of it has not been thoroughly tested.r ! implicit noneC constant: = include '($RMSdef)/nolist' !rms condition codestE include '($SHRdef)/nolist' !shared message status codesEI character *(*) fACILITY !also in Param_Init, Give_Signaln6 parameter ( fACILITY = 'EXTRACT' ) ! who are we? C global:  include 'Exjtract.F' C local:! character *128 infile, outfile # integer *2 inf_len, outf_lenn integer width: logical show_name, ldummy, was_bad, need_input$ integer *4 rabadr, sts, condC functions: integer *4 Param_Init,& & Get_Next_File,( & Open_Input_File,$ & Open_Output,% & Close_Output, $ & Process_File% sts = Param_Init( outfile, outf_len)i k if ( .not. sts ) then3C report probelm (and subsequently give up)s& call Give_Signal( SHR$_PARSEFAIL,? & %DESCR(fACILITY//' command'), sts)a else !init okPC get first input file spec and open its file before opening output file need_input = .true.& do while ( sts .and. need_input )2 sts = Get_Next_File( infile, inf_len, show_name) if ( sts )@ & sts = Open_Input_File( infile(:inf_len), rabadr)A if ( .not. sts ) then l !give message, possibly reset 'sts'a: call Give_Signal( SHR$_OPENIN, infile(:inf_len), sts) was_bad = .true. else need_input = .false. end if end dol if ( sts ) then& call Customize_Output( %VAL(rabadr))/ sts = Open_Output( outfile(:outf_len), width)  if ( .not. sts )H & call Give_Signal( SHR$_OPENOUT, outfile(:outf_len), sts) end ifr end if !init okC loop through input files do while ( sts )d#C identify the curmrent file_) if ( show_name .and. .not. was_bad )a9 & call Identify_File( infile(:inf_len))C C perform the real worklC( if ( .not. was_bad ) then) sts = Process_File( %VAL(rabadr), cond)t elseo- was_bad = .false. !clear problem flagp end ifr if ( sts ) then"C open next input file/ sts = Get_Next_File( infile, inf_len, ldummy)o if ( sts )@ & sts = Open_Input_File( infile(:inf_len), rabadr)/ if ( .nnot. sts .and. sts .ne. RMS$_NMF ) thenl: call Give_Signal( SHR$_OPENIN, infile(:inf_len), sts) was_bad = .true. end if else !.not. sts'C report processing problemc% if ( cond .eq. SHR$_WRITEERR ) thend6 call Give_Signal( cond, outfile(:outf_len), sts) else4 call Give_Signal( cond, infile(:inf_len), sts) end if end if !sts? end do !next fileC clean up if ( sts .eq. RMS$_NMF ) then sts = Close_Output()p if ( .not. sts o)n4 & call Give_Signal( SHR$_CLOSEOUT,= & outfile(:outf_len), sts)= end if C done, if ( .not. sts ) call SYS$EXIT( %VAL(sts)) end !of Extract(main)=, subroutine Identify_File ( filename ) != ! Write out a line identifying the file that's about to be) ! processed. [/IDENTIFY] !C ! Note: the line-feeds won't translate into ebcdic (who cares?).e ! implicit noneC constant:_9 character *1 LF p !ascii line feedd parameter ( LF = CHAR(10) )4 character *(*) sEPARATOR_PREFIX, sEPARATOR_SUFFIX1 parameter ( sEPARATOR_PREFIX = LF//'***** ',*9 & sEPARATOR_SUFFIX = ' *****'//LF )rC global input:d' include 'Extract.F' !xlate+ C input: character *(*) filenamel C local: character *144 bufferi integer *2 ln  call STR$TRIM( buffer, H & sEPARATOR_PREFIX // filename // sEPARATOR_SUFFIX, lqn)MC since the header ends up with the output, translate it if necessaryaB if ( xlate .eq. 1 ) !translate from ASCII into EBCDIC? & call LIB$TRA_ASC_EBC( buffer(:ln), buffer(:ln))r call Output( buffer(:ln)) return> end !of Identify_Filet: integer *4 function Process_File ( rab, condition ) !* ! Process an (already open) input file. !A ! Note: the input file's fixed-header size (for vfc) is passedA ! in the rab's contex rt field. If there are multiple inputn@ ! files processed, this might have a different value fromB ! call to call (so it won't necessarily match output file's6 ! vfc size if we're preserving the vfc header). ! implicit noneC called by:&* program Extract (main)C constant:c: include '($RMSdef)/list' !rms status codesF include '($RABdef)/list' !rms Record Access Block defs> include '($SHRdef)/list' !shareds message codes9 include 'f_inc:Dsc.F' !descriptor defssC global input:e include 'Extract.F'D common /vfc/ vfc_size, vfc_header !output file's fixed-header/ byte vfc_size /0/, vfc_header(255)_ C input: record /rabdef/ rab C output:h integer *4 condition C local: record /dsc/ rcrd, work* integer *4 start, finish, nxt_rec,/ & problem, sts, tmpsts,d & tmp_long integer *2 t tmp_word % equivalence ( tmp_long, tmp_word ) " logical manipulate_record integer vfc_offset  character record$ *65535 C functions:< integer *4 Rfa_Position, Direct_Position, Block_Pos,3 & Buffer_File, Fetch_Record,e= & Output, Block_Output, Flush_Output,d6 & SYS$FIND, SYS$GET, SYS$READ,2 & SYS$DISCONNECT, SYS$CLOSE! intrinsic LEN, MIN, ZEXT  conditi uon = 0 sts = 1C set up record buffer(s)tH rcrd.d_adr = %LOC(record$) !(useful iff detab or columns [of vfc])L rcrd.d_quad(1) = MIN(LEN(record$),'0000FFFF'x) !(type & class unspecified)D if ( block_mode ) rcrd.d_quad(1) = rab.rab$l_ctx !block size= rab.rab$w_usz = rcrd.d_len !size of user buffer @ rab.rab$l_ubf = rcrd.d_adr !address of user bufferB if ( use_vfc .eq. 2 ) then !want to keep fixed-header portionMC note: if 'buffer_requi vred' then header won't exist [don't care] I rab.rab$l_rhb = %LOC(vfc_header) !address of record header buffern< else if ( use_vfc ) then !treat fixed-header as dataC vfc_offset = rab.rab$l_ctx !size of fixed-header arear" rab.rab$l_rhb = rab.rab$l_ubf/ rab.rab$l_ubf = rab.rab$l_ubf + vfc_offset 0 tmp_long = ZEXT(rab.rab$w_usz) - vfc_offset rab.rab$w_usz = tmp_worde end ifd@ work = rcrd !copy string descriptorI call LIB$ wMOVC5( 0, %VAL(0), 0, ZEXT(vfc_size), vfc_header) !init to 0's! C flag for record processing8 manipulate_record = ( detab .or. edit .or. xlate .ne. 02 & .or. col_cnt .gt. 0 )F problem = SHR$_READERR !if we encounter trouble, this will be reason6C perform preliminary file processing if necessary if ( block_mode ) theneEC position so that $read will get the first block of interest 2 sts = Block_Pos( rab, nxt_rec, start, finish)! else if ( buffe xr_required ) then>C read entire file and hold it in memory (last resort)4 sts = Buffer_File( rab, nxt_rec, start, finish) else if ( direct_access ) thenr=C calculate start and/or finish and position at startp8 sts = Direct_Position( rab, nxt_rec, start, finish)6 else if ( start_val .lt. 0 .or. end_val .lt. 0 ) then*C read entire file and cache rfa's5 sts = Rfa_Position( rab, nxt_rec, start, finish), else !scan sequentiallytC nxt_rec = 0 !ynumber of next record (need 1 extra find)R start = start_valt finish = end_valD end if&C process the file if ( sts ) then/C skip intervening records if necessaryS. do while ( nxt_rec .lt. start .and. sts ). if ( SYS$FIND( rab) ) nxt_rec = nxt_rec + 1 sts = rab.rab$l_stsp end do%C extract the desired recordsH/ do while ( nxt_rec .le. finish .and. sts )d3 work = rcrd !reset working descriptor- problem = SHR$_READERR !i zn case of trouble1#C get next input record  if ( block_mode ) then sts = SYS$READ( rab)< rab.rab$l_bkt = 0 !subsequent access will sequential" else if ( buffer_required ) thenM*- if ( detab ) work.d_len = rcrd.d_len !reset length)/ sts = Fetch_Record( nxt_rec, work, detab)  else: if ( SYS$GET( rab) .eq. RMS$_RTB ) !record too big?M & rab.rab$l_sts = rab.rab$l_sts .or. 3 !****a sts = rab. {rab$l_stst9 work.d_len = rab.rab$w_rsz !size of record : work.d_adr = rab.rab$l_rbf !address of data= if ( use_vfc ) then !treat fixed-header as data-NC fixed-header buffer immediately precedes the data bufferNC (because we've set it up that way); concatenate them' work.d_adr = work.d_adr - vfc_offset + tmp_long = ZEXT(work.d_len) + vfc_offsetq work.d_len = tmp_word end if end if !input mode|3C process input record and write it outp if ( sts ) then  if ( manipulate_record )? & call Process_Record( work, record$) 5 problem = SHR$_WRITEERR !in case of trouble  if ( block_mode ) then7 sts = Block_Output( work) !write out the blockr else8 sts = Output( work) !write out the current record end if9 nxt_rec = nxt_rec + 1 !increment record countr end if !stst end do !while more reco}rdsr0 if ( sts .eq. RMS$_EOF ) sts = RMS$_NORMAL9C update the output file (not strictly necessary)_( if ( sts ) problem = SHR$_WRITEERR tmpsts = Flush_Output() if ( sts ) sts = tmpsts  end if !sts okkC close the input file# if ( sts ) problem = SHR$_CLOSEINu call SYS$DISCONNECT( rab) if ( sts ) sts = rab.rab$l_sts) tmpsts = SYS$CLOSE( %VAL(rab.rab$l_fab))s if ( sts ) sts = tmpsts : if ( .not. sts ) condition = problem !auxiliary output4 i~f ( sts .eq. RMS$_NORMAL ) sts = 1 !SS$_NORMAL Process_File = sts  return  end !of Process_File2 subroutine Process_Record ( work, record$ ) ! ! Process the current record.= ! If we're translating from ascii into ebcdic, perform taboB ! expansion and requested edits first; but if we're translating? ! from ebcdic into ascii, ignore tab expansion (can't accessp: ! them) and perform edits *after* the data is in ascii. ! implicit noneC called by:$* function Process_FileC constant: 1 include 'f_inc:Dsc.F' !descriptor defsiC global input: include 'Extract.F'C input/output:h< record /dsc/ work !descriptor for data recordI character *(*) record$ !large string buffer for manipulation(s)= C local:6 record /dsc/ temp !temporary descriptor logical resultsC functions:- logical Expand_Tabs, Select_Columns1$ if ( xlate .ne. 0 .or. detab ) thenQC build temporary string descriptor; leave type & class unspecified [0,0]h temp.d_adr = %LOC(record$)o" temp.d_quad(1) = LEN(record$)) if ( xlate .eq. 2 ) detab = .false.= end if C if ( detab ) then !possibly increase length (within record$) 3 result = Expand_Tabs( col_cnt, %VAL(col_list), 2 & temp, work.d_len). if ( result ) work.d_adr = %LOC(record$) end if  if ( col_cnt .eq. 1 ) then 1 call Select_Substri ng( %VAL(col_list), work)iB else if ( col_cnt .gt. 1 ) then !possibly decrease length6 result = Select_Columns( col_cnt, %VAL(col_list),> & work, record$, work.d_len). if ( result ) work.d_adr = %LOC(record$) end if 1 if ( xlate .eq. 2 .and. work.d_len .gt. 0 ) thene temp.d_len = work.d_len& call LIB$TRA_EBC_ASC( work, temp) work.d_adr = %LOC(record$)s end if(/ if ( edit ) then !might decrease length1 call Edit_Record( work, record$, work.d_len)i work.d_adr = %LOC(record$)  end ife1 if ( xlate .eq. 1 .and. work.d_len .gt. 0 ) then) temp.d_len = work.d_len& call LIB$TRA_ASC_EBC( work, temp) work.d_adr = %LOC(record$)n end ife return end !of Process_Record, subroutine Customize_Output ( inrab ) !C ! Set up a callback from Open_Output() to set up special optionsiA ! for the output file. Callback handles RMS output-file-parsef? ! option for filling in fields of output name based on firstiA ! input file's name and also handles block-mode and vfc-header( ! contortions.i ! implicit noneC called by:&* program Extract (main)C constant: A include '($RABdef)/nolist' !RMS Record Access Block external Outfile_OptionsC global output:6 common /output_usropn/ usropn_routine, usropn_context0 integer *4 usropn_routine, usropn_context C input: record /rabdef/ inrab' usropn_routine = %LOC(Outfile_Options) usropn_context = %LOC(inrab)P return  end !of Customize_Output; subroutine Outfile_Options ( in_rab, fab, rab, nam )m != ! Set additional RMS options before Open_Output() $CREATEsh? ! the output file. RMS blocks have already been initializedy' ! for standard text file attributes.  !A ! Note: the input file's fixed-header size (for vfc) is passedoA ! in the rab's context field. If there are multiple input ? ! files, their header sizes may differ; the first one is 4 ! used to set the outfile file's header size. ! implicit noneC called by:#* function Open_OutputCC constant:  include '($FABdef)/nolist' include '($RABdef)/nolist'E include '($NAMdef)/nolist'tC global input:B include 'Extract.F'C global output:" common /vfc/ vfc_size, vfc_header+ byte vfc_size, vfc_header(255)E C input:8 record /rabdef/ in_rab !rab of open input fileC input/output:c5 record /fabdef/ fab !fab for output file 3 record /rabdef/ rab !rab " " " 5 record /namdef/ nam !nam for output file C local: integer offset + integer *4 fabadr, namadr, tmp_long  integer *2 tmp_word  byte tmp_byteg/ equivalence ( tmp_long, tmp_word, tmp_byte ) C functions: byte Buf_BPeek integer *4 Buf_LPeekE fabadr = in_rab.rab$l_fab !get address of input file's fabOC additional filename options (use input file's name fields in output name) G fab.fab$l_fop = fab.fab$l_fop .or. FAB$M_OFP !output file parse C offset = %LOC(fab.fab$l_nam) - %LOC(fab) !FAB$L_NAM G nam.nam$l_rlf = Buf_LPeek( %VAL(fabadr + offset)) !input's nam blockz if ( block_mode ) then *C block mode is fairly restrictiveC fab.fab$b_fac = fab.fab$b_fac .or. FAB$M_BIO !use block i/o H fab.fab$b_shr = fab.fab$b_shr .or. FAB$M_UPI !(ignore interlock) if ( lrecl .eq. 0 ) thena fab.fab$b_rfm = FAB$C_UDFnA tmp_long = in_rab.rab$l_ctx !context field contains rec len"( else !retain original format< offset = %LOC(fab.fab$b_rfm) - %LOC(fab) !FAB$B_RFM= fab.fab$b_rfm = Buf_BPeek( %VAL(fabadr + offset)) !formatn< offset = %LOC(fab.fab$b_rat) - %LOC(fab) !FAB$B_RATA fab.fab$b_rat = Buf_BPeek( %VAL(fabadr + offset)) !attributesC tmp_long = lrecl end ifo fab.fab$w_mrs = tmp_wordDH use_vfc = 0 !force this to guarantee freedom from conflicts else if ( use_vfc .ne. 0 ) thenLC need to retreive vfc info from input file (which is already open);@C first get fixed-header-size from RAB context field tmp_long = in_rab.rab$l_ctx vfc_size = tmp_byte5 if ( use_vfc .eq. 2 .and. vfc_size .ne. 0 ) thentNC want to retain vfc format [the first input file is already open]2 fab.fab$b_fsz = vfc_size !set header size7 fab.fab$b_rfm = FAB$C_VFC !file format is "vfc")< offset = %LOC(fab.fab$b_rat) - %LOC(fab) !FAB$B_RATA fab.fab$b_rat = Buf_BPeek( %VAL(fabadr + offset)) !attributes -C set up buffer for record headerl" rab.rab$l_rhb = %LOC(vfc_header) end if  end if  returni end !of Outfile_Optionsewwf ( Cli_Present( 'TRANSLATE.EBCDIC_TO_ASCII') ) then1 xlate = 2 !ebcdic -> ascii (before /edit) end if end ifI if ( iden/'ϒ ! Extract.Hlp J! Pat Rankin, Apr'89! Online help for EXTRACT.!e 1 EXTRACT D General purpose file extraction utility. Selects records from theH beginning, middle, or end of one or more files and optionally performs0 various modifications before writing them out. format:  EXTRACT 'options' file,...6 EXTRACT /RECORD=([START=m,END=n,COUNT=k]) file,... EXTRACT /HEAD=k file,... EXTRACT /TAIL=k file,... 2 Parameterd7 file[,...] input file(s); wildcards are supported.gE All output is written to a single file (default is SYS$OUTPUT) even ( if multiple input files are specified. 2 Qualifiers/BLOCKSl /BLOCKS[=(option,...)]kH Similar to DUMP/BLOCKS; extracts blocks from the input file(s) without& interpreting their record structure.G Up to two of the following options may be specified; if more than onelJ is used, separate them with a comma and enclose the list in parent heses.D START=m starting block number; the first block in the file is 1.B A negative value specifies a number of blocks relativeD to the end of the file: -1 is the last block, -2 is the! one before that, etc.e> END=n ending block number; the last block of the file is- considered to be block number -1.D COUNT=k number of blocks to extract. If START is specified, ENDD is derived by adding COUNT-1 to it; if END is specifie d,F START is derived by subracting COUNT-1 from it; if neither= is specified, START is 1 and END is set to COUNT.B Incompatable with /RECORDS, /HEAD, and /TAIL. Also incompatable; with /COLUMNS, /EXPAND_TABS, /TRANSLATE, and /VFC_HEADER.r/COLUMNS /COLUMNS=([-,]column_range,...)B Select or reject certain columns within extracted records beforeE writing them to the output file. 'column_range' is either a singlevC column number or a low and high pair separat ed by "-" or ":". If G more than one range is desired, separate them with commas and enclose)D the list in parentheses. If the first element of the list is "-",D then the rest of the list represents columns to reject rather than ones to select.CA If the first range begins with ":" (ie, ":20") then column 1 istC implied; if the last range ends with ":" (ie, "41:") or ":*" then)# the end of the record is implied. D Note: the output record consists of the selected columns in their C original relative positions, not in the order listed in /COLUMNS. E That is, /COLUMNS=(25:30,5:10) produces the same output as the list. (5:10,25:30). /EDITu /EDIT=(option,...)lC Perform one or more of various modifications to extracted recordssB before writing them to the output file. The available functions? include all options of the DCL F$EDIT() lexical function plus  several extensions: > COLLAPSE, COMPRESS, LOWERCASE, TRIM, UNCOMMENT, UPCASE,7 STRIP_TRAILING, IGNORE_QUOTES, FALLBACK, FORMAT.HE If more than one option is specified, separate them with commas andt& enclose the list within parentheses.* See "edit_options" for more information. /EXPAND_TABS /[NO]EXPAND_TABS E Convert ASCII tab characters into spaces. Tab stops are considereda7 to be positioned at every 8th column: 9, 17, 25, ...iG By default, tabs are expanded if extraction by columns (/COLUMNS=xxx) G or translation into EBCDIC (/TRANSLATE=ASCII_TO_EBCDIC) is requested,o and left as tabs otherwise.vH Tab expansion is never performed if translation from EBCDIC into ASCII, (/TRANSLATE=EBCDIC_TO_ASCII) is requested./HEADu /HEAD[=count]D Extract records from the beginning of the file(s). 'count' is theH number of records to extract; if not present, the default value is 22.F A negative 'count' value designates the number records at the end ofG the file to omit. That is, /HEAD=-5 will extract every record in thei file except for the last 5.=1 Incompatable with /BLOCKS, /RECORDS, and /TAIL. /IDENTIFYe /[NO]IDENTIFYE Determines whether to display the input file name before performingcD extraction upon its contents. By default, the file identificationB is performed if the input file specification is a list of files,F contains any wildcards, or includes a search list. /IDENTIFY forces6 identification; /NOIDENTIFY suppresses identication.F Note: the file identification is written to the same destination asE the extracted data, so it should normally be suppressed if the datao= is being translated into EBCDIC or if vfc-headers are kept. /OUTPUTO /OUTPUT[=file]CI Specifies the output file. Output is written to SYS$OUTPUT by default.tE File format is variable length records with implied carriage returnE (ie, standard text file format), unless whole records are extractedeI from a file having fixed length records. /VFC_HEADER=KEEP will produce G a VFC format output file (but only i f the input file has VFC format).t/RECORDS /RECORDS[=(option,...)]G Similar to DUMP/RECORDS but with more flexibility in indicating whichp> records. Extracts specified records from the input file(s).G Up to two of the following options may be specified; if more than oneiJ is used, separate them with a comma and enclose the list in parentheses.F START=m starting record number; the first record in the file is 1.C A negative value specifies a number of records relativ elE to the end of the file: -1 is the last record, -2 is ther! one before that, etc.2@ END=n ending record number; the last record of the file is. considered to be record number -1.E COUNT=k number of records to extract. If START is specified, END D is derived by adding COUNT-1 to it; if END is specified,F START is derived by subracting COUNT-1 from it; if neither= is specified, START is 1 and END is set to COUNT.L. Incompatable with /BLOCKS, /HEAD, and /TAIL./TAIL  /TAIL[=count]E Extract records from the end of the file(s). 'count' is the numberA of records to extract; if not present, the default value is 22.eE A negative 'count' value designates the number records at the startoF of the file to omit. That is, /TAIL=-5 will extract the entire file! except for the first 5 records.e1 Incompatable with /BLOCKS, /RECORDS, and /HEAD.) /TRANSLATE1 /TRANSLATE={ ASCII_TO_EBCDIC | EBCD IC_TO_ASCII }F Translate data (which is assumed to represent simple character text)E from ASCII into EBCDIC or vice versa. One of the two keywords mustiF be specified. If ASCII_TO_EBCDIC is used then tab expansion is doneE unless /NOEXPAND_TABS is specified. If the reverse is used, no tab_9 expansion will be attempted regardless of /expand_tabs.OE Translation from EBCDIC into ASCII is done before any modifications F from /EDIT are performed; translation from ASCII into EBCDIC is o 'warning'* call SYS$PUTMSG( msgvec,, fACILITY_NAME,)B if ( ok ) status = status .or. 1 !transform into 'success'6 status = status .or. '10000000'x !message seen return end !of Give_Signalww^D.* Extr_Edit.For -- Edit routines for ExtractJ* Pat Rankin, Apr'89(* sub Edit_Record ( record$, rec_len )$* sub Parse_Edit_Options ( flags )#* sub Alpha_Init ( atype, acase )*; subroutine Edit_Record ( in_rec$, outrec$, rec_len ) !1 ! Perform requested edits on the input record.= ! Provides the same alternatives as DCL's lexical function$ ! F$EDIT(), with some extensions. !: ! Note: fallback mode might distort quote or space/tabC ! recognition but it's not important enought to worry about. !*M* COLLAPSE Remove all spaces and tabs (overrides 'compress' & 'trim')G* COMPRESS Replace multiple spaces and tabs with a single spac e"* LOWERCASE Make lower case>* TRIM Remove leading and trailing spaces and tabsI* UNCOMMENT Remove comments (delimited by 'explanation' point "!")D* UPCASE Make upper case (has precedence over 'lowercase')7* STRIP_TRAILING Remove trailing spaces and tabs=* IGNORE_QUOTES Ignore quotes when making other editsF* FALLBACK Strips 8th bit to translate into 7-bit 'equivalent'M* FORMAT Convert non-visible characters into "." (ala $FAO's "!AF")* implicit noneC called by:&* subroutine Process_RecordC constant:+ parameter eDIT_NO_OP = '0001'x,2 & eDIT_COLLAPSE = '0002'x,2 & eDIT_COMPRESS = '0004'x,2 & eDIT_LOWERCASE = '0008'x,2 & eDIT_TRIM = '0010'x,2 & eDIT_UNCOMMENT = '0020'x,2 & eDIT_UPCASE = '0040'x,6 & eDIT_STRIP_TRAILING = '0080'x,6 & eDIT_IGNORE_QUOTES = '0100'x,2 & eDIT_FALLBACK = '0200'x,1 & eDIT_FORMAT = '0400'x4 byte sPACE, tAB, rUB, cOMMENT, qUOTE3 parameter ( sPACE = ' ', tAB = 9, rUB = 127,5 & cOMMENT = '!', qUOTE = '"' ), byte aTYPE(0:255), aCASE(0:255) C global: include 'Extract.F' C input: character *(*) in_rec$ C output: character *(*) outrec$C input/output: integer *2 rec_len C local:& integer *4 ip, op, last, reclH integer *2 last_word !i*2 for final return length assignment; equivalence ( last, last_word ) !overlay i*2 & i*4- logical init_done, keep, in_quote,9 & collpse, comprss, lower, trim,: & uncomnt, upper, strip, ignor_q,$ & falbk, frmt character *1 c$ byte c, t integer  c_# equivalence ( c$, c ), ( c_, c ) data init_done /.false./ save init_doneC functions: intrinsic ZEXT"C set up character case tables if ( .not. init_done ) then# call Alpha_Init( aTYPE, aCASE) init_done = .true. end if=C set up individual flags for quicker testing within loop/ collpse = ( (edit .and. eDIT_COLLAPSE).ne. 0 )/ comprss = ( (edit .and. eDIT_COMPRESS).ne. 0 )) trim = ( (edit .and. eDIT_TRIM).ne. 0 )> str ip = ( (edit .and. eDIT_STRIP_TRAILING).ne. 0 .or. trim )+ upper = ( (edit .and. eDIT_UPCASE).ne. 0 )@ lower = ( (edit .and. eDIT_LOWERCASE).ne. 0 .and. .not. upper )0 uncomnt = ( (edit .and. eDIT_UNCOMMENT).ne. 0 )4 ignor_q = ( (edit .and. eDIT_IGNORE_QUOTES).ne. 0 )- falbk = ( (edit .and. eDIT_FALLBACK).ne. 0 )+ frmt = ( (edit .and. eDIT_FORMAT).ne. 0 )+ c_ = 0 !clear upper bytes8 recl = ZEXT(rec_len) !(unsigned) input record lengthE in_quote = .false. !flag indicating whether we're within quotesG last = 0 !index of last non-blank char in output stringC op = 0 !index of last char put into output string? ip = 0 !index of current char in input stringC loop through input string do while ( ip .lt. recl )6 ip = ip + 1 !advance to next charA c$ = in_rec$(ip:ip) !get next char into 'c' and 'c_'; if ( falbk ) c = c .and. '7F'x !strip 8th bitE t = aTYPE(c_) ! -1 => upper-case, +1 => lower-case6 keep = .true. !retain it by default if ( in_quote ) then> if ( c .eq. qUOTE ) in_quote = .false. !close quote" else if ( c .eq. qUOTE ) then= if ( .not. ignor_q ) in_quote = .true. !open quote> else if ( t .lt. 0 ) then !negative => uppercase letter1 if ( lower ) c = aCASE(c_) !make lowercaseE else if ( t ) then !odd (but non-negative) => lowercase1 if ( upper ) c = aCASE(c_) !make uppercase2 else if ( c .eq. sPACE .or. c .eq. tAB ) then**- if ( .not. in_quote ) then: if ( collpse !drop all blanksN & .or. comprss .and. last .ne. op !drop successive blankK & .or. trim .and. op .eq. 0 !drop leading blank & ) then keep = .false. else if ( comprss ) then0 c = sPACE !convert tab to space end if*- end if$ else if ( c .eq. cOMMENT ) then$ keep = in_quote .or. .not. uncomnt4 if ( .not. keep ) ip = recl !break out of loop else** do nothing (except 'keep') end if if ( keep ) then3 op = op + 1 !increment output pointer4 if ( in_quote .or. c .ne. sPACE .and. c .ne. tAB )J & last = op !keep track of last non-blank char. if ( frmt .and. ( (c .and. '7F'x) .lt. sPACEH &  .or. (c .and. '7F'x) .eq. rUB ) ) c$ = '.'+*- if ( op .lt. LEN(outrec$) )+ outrec$(op:op) = c$ !retain character end if end do !loop (next input char)F if ( .not. strip ) last = op !don't care if last+1..op were blanks rec_len = last_word return end !of Edit_Record. subroutine Parse_Edit_Options ( flags ) !; ! Parse the keywords supplied by /EDIT=(keyword,...) and> ! put the result into a simple bitmask. We are only called/ ! when /EDIT is present on the command line. !E ! Note: combinations like UPCASE+LOWERCASE are handled elsewhere. !/ ! NB: negation information is not retained;= ! should possibly check for some workable combinations7 ! like TRIM+NOSTRIP (remove leading blanks only)A ! or COMPRESS+NOTRIM[+STRIP] (compress within line but not& ! leading or trailing portion). ! implicit noneC called by:"* function Param_InitC constant:' parameter eDIT_OPTION_COUNT = 105 character *16 eDIT_OPTION_NAMES(eDIT_OPTION_COUNT)A & / 'COLLAPSE', 'COMPRESS', 'LOWERCASE',> & 'TRIM', 'UNCOMMENT', 'UPCASE',? & 'STRIP_TRAILING', 'IGNORE_QUOTES',4 & 'FALLBACK', 'FORMAT' / C output: integer *4 flags C local: character *16 keyword integer *2 ln integer idxC functions: integer *4  Cli_Present intrinsic IBSET7 flags = 1 !first bit means that /edit is present do idx = 1, eDIT_OPTION_COUNT8 call STR$TRIM( keyword, eDIT_OPTION_NAMES(idx), ln)/ if ( Cli_Present( 'EDIT.'//keyword(:ln)) )O & flags = IBSET( flags, idx) !=> IOR( flags, 2**idx) end doF if ( flags .eq. 1 ) flags = 0 !clear it if no options found return end !of Parse_Edit_Options- subroutine Alpha_Init ( atype, acase )C ! Pat Rankin, May'89? ! Create upper- <-> lower-case identification and conversionA ! tables. Character-set independent (assuming that STR$UPCASEC ! supports the character-set in use; don't know if/how alternateB ! sets can be specified). The 'atype' array will contain three? ! values, indexed by character's byte code: -1 if characterA ! has a lower-case equivalent (implies that it is upper case);= ! +1 [odd but non-negativ e] if character has an upper-caseC ! equivalent (which implies that it is lower-case); 0 otherwise.= ! Note that if a character represents an alphabetic letter? ! which has only one case present (such as some ScandinavianB ! over-loading of ascii bracket characters and such), then this> ! table does not identify it as a letter; that's ok for our? ! purpose (which is upper<->lower conversion, not alphabeticD ! identification). The 'acase' array will hold the case-inverted# ! equivalent for each character. ! implicit noneC called by:#* subroutine Edit_Record C output:B byte atype(0:255), !alpha type: -1 => upper, 1 lower9 & acase(0:255) !conversion table C local:& character *256 mixed, upper, c$ *1 integer i, j byte b, cH equivalence ( i, b ), ( c, c$ ) !not very pretty, but it works!C functions: intrinsic CHAR, ZEXT"* subroutine ST R$UPCASE?C create a string containing every possible 8-bit character' do i = 0, 255 !b = -128..127$ j = i + 1 !j = 1..256 mixed(j:j) = CHAR(i); atype(i) = 0 !non-alphabetic by defaultF acase(i) = b !not strictly applicable; init anyway end do !loop!C make an uppercase-only copy call STR$UPCASE( upper, mixed)BC compare the two strings and process identifiable differences/ do j = 1, 256 !1..LEN(mixed)+ if ( upper(j:j) .ne. mixed(j:j) ) thenJC got a character which has both upper and lower case variants5 i = j - 1 !i = 0..255 (also sets 'b')% c$ = upper(j:j) !set up 'c'? atype(i) = 1 !identify 'i' (aka 'b') as lower-case6 acase(i) = c !c$ is upper-case equivalent5 atype(ZEXT(c)) = -1 !identify 'c' as upper-case; acase(ZEXT(c)) = b !'b' is its lower-case equivalent end if end do !next i return end !of Alpha_Initww?ZD.* Extr_Inp.For -- input routines for ExtractJ* Pat Rankin, Oct'882* i*4 Get_Next_File ( nextfile, nxt_len, multi )* " Reset_Next_File ( ),* i*4 Open_Input_File ( filename, rabadr )4* i*4 Rfa_Position ( rab, nxt_rec, start, finish )7* i*4 Direct_Position ( rab, nxt_rec, start, finish );* sub Determine_EOF ( fhc, last_record, lrecl, non_span )2* sub Block_Info ( fab, fhc, last_block, lrecl )1* i*4 Block_Pos ( rab, nxt_rec, start, finish )*E integer *4 function Get_Next_File ( nextfile, nxt_len, multi ) !G ! Retreive the next filename (wildcard lookup or from command line). ! implicit noneC called by:&* program Extract (main)C 2nd entry below:4 integer *4 Reset_Next_File !(not used)C constant:: include '($RMSdef)/nolist' !RMS status codesB include '($NAMdef)/nolist' !rms file name block defsC global input:1 include 'Extract.F' !options C output: character *(*) nextfile integer *2 nxt_len logical multi C local: character *128 filespec integer *2 fspc_len logical check_multi integer idx integer *4 name_opts, sts data idx /0/$ save idx, filespec, fspc_lenC functions: integer *4 Rms_Find_FileC init if necessary if ( idx .eq. 0 ) then idx = 18 call Get_Inp_Element( inp_cnt, %VAL(inp_list), idx,4 & filespec, fspc_len) check_multi = .TRUE. else check_multi = .FALSE. end ifC search for the next file3 sts = Rms_Find_File( filespec(:fspc_len), '[].;0',9 & nextfile, nxt_len, name_opts)OC if none found, move to the next file specification (if any) and try again5 if ( sts .eq. RMS$_NMF .and. idx .lt. inp_cnt ) the n idx = idx + 18 call Get_Inp_Element( inp_cnt, %VAL(inp_list), idx,4 & filespec, fspc_len)7 sts = Rms_Find_File( filespec(:fspc_len), '[].;0',= & nextfile, nxt_len, name_opts) end if?C figure out whether we're trying to process multiple files if ( check_multi )( & multi = ( inp_cnt .gt. 1@ & .or. (name_opts .and. NAM$M_WILDCARD).ne. 0E & .or. (name_opts .and. NAM$M_SEARCH_LIST).ne. 0 )MC 'multi' really determines whether to identify file before processing it if ( identify .eq. 1 ) then multi = .true.! else if ( identify .eq. 2 ) then multi = .false. end if Get_Next_File = sts return** entry Reset_Next_File ( ) ! ! Clean up. ! call Rms_Find_File_End() idx = 0 Reset_Next_File = 1 return- end !of Get_Next_File & Reset_Next_File? integer *4 function Open_Input_File ( filename, rabadr ) ! ! Open the next input file. ! implicit noneC called by:&* program Extract (main)C constant:L*- include '($CLIMSGdef)/list' !(borrow a cli status value)G parameter CLI$_INVRFM = '000388D2'x !invalid record formatD include '($DEVdef)/list' !device characteristic defs? include '($FABdef)/list' !rms File Access Block= include '($NAMdef)/list' !rms file NAMe blockA inclu de '($RABdef)/list' !rms Record Access BlockG include 'f_inc:Xabs.F' !rms extended attribute blocks= byte rAB_PROTOTYPE(2) / RAB$C_BID, RAB$C_BLN /@ byte xABDAT_PROTOTYPE(2) / XAB$C_DAT, XAB$C_DATLEN /@ byte xABFHC_PROTOTYPE(2) / XAB$C_FHC, XAB$C_FHCLEN / parameter bLKSIZ = 512 C global: include 'Extract.F'# common /findfile_rmsdata/ fab, nam record /fabdef/ fab record /namdef/ nam( common /openfile_rmsdata/ rab, fhc, dat record /rabdef/ rab record /xabs/ fhc, dat C input: character *(*) filename C output: integer *4 rabadr C local: logical is_disk integer *4 sts, stvC functions:3 integer *4 SYS$OPEN, SYS$CONNECT, SYS$CLOSE sts = 14 is_disk = ( (fab.fab$l_dev .and. DEV$M_RND).ne. 0 ); buffer_required = ( (start_val .lt. 0 .or. end_val .lt. 0). & .and. .not. is_disk )LC update fab (set acce ss options in addition to previous lookup options)2 fab.fab$b_fac = FAB$M_GET !readonly if ( block_mode )J & fab.fab$b_fac = fab.fab$b_fac .or. FAB$M_BIO !block i/oH fab.fab$b_shr = FAB$M_SHRGET !share w/ readers (not writers)> fab.fab$l_fop = FAB$M_NAM !open using NAM blockA if ( start_val .eq. 1 .and. end_val .gt. 0 .or. buffer_required)P & fab.fab$l_fop = fab.fab$l_fop .or. FAB$M_SQO !sequential onlyG fab.fab$l_xab = 0 !clear old value (avoid loop!) if ( is_disk ) thenKC set up xabs: date & time xab and file header characteristics xabF*- call LIB$MOVC5( 2, xABDAT_PROTOTYPE, 0, XAB$C_DATLEN, dat)-*- dat.xab.xab$l_nxt = fab.fab$l_xab%*- fab.fab$l_xab = %LOC(dat)? call LIB$MOVC5( 2, xABFHC_PROTOTYPE, 0, XAB$C_FHCLEN, fhc)& fhc.xab.xab$l_nxt = fab.fab$l_xab fab.fab$l_xab = %LOC(fhc) end ifC set up rabF call LIB$MOVC5( 2, rAB_PROTOTYPE, 0, RAB$C_BLN, rab) !bid,bln,0...; rab.rab$b_rac = RAB$C_SEQ !sequential accessA rab.rab$l_rop = RAB$M_RAH .or. RAB$M_NLK !read ahead, no lockCC request locate mode unless we plan buffer manipulation(s)* if ( ( buffer_required .or. .not. detab )[ & .and. .not. use_vfc ) !want to keep full buffer control when treating vfc as dataP & rab.rab$l_rop = rab.rab$l_rop .or. RAB$M_LOC !use locate mode; rab.rab$b_mbf = 2 !multibuffer count: rab.rab$b_mbc = 20 !multiblock count9 rab.rab$l_fab = %LOC(fab) !link rab to fab9 rabadr = %LOC(rab) !output argumentC open the file9 if ( SYS$OPEN( fab) ) then !access the fileF if ( fab.fab$b_rfm .eq. FAB$C_UDF !record format == 'undefined'+ & .and. .not. block_mode ) then@ sts = CLI$_INVRFM !invalid record format for our purpose else; sts = SYS$CONNECT( rab) !establish record context end ifD if ( .not. sts ) call SYS$CLOSE( fab) !give up if problem stv = rab.rab$l_stv else sts = fab.fab$l_sts stv = fab.fab$l_stv end if !$open if ( sts ) thenBC file successfully opened; perform some additional set-up if ( block_mode ) then= rab.rab$l_ctx = ZEXT(fab.fab$w_bls) !block size (for tapes)5 if ( rab.rab$l_ctx .eq. 0 ) rab.rab$l_ctx = bLKSIZ0 call Block_Info( fab, fhc, last_record, lrecl) else@ rab.rab$l_ctx = ZEXT(fab.fab$b_fsz) !fixed-header size for vfc direct_access =( is_diskM & .and. fab.fab$b_org .eq. FAB$C_SEQ !sequentialO & .and. fab.fab$b_rfm .eq. FAB$C_FIX !fixed-lengthH & .and. (start_val .ne. 1 .or. end_val .lt. 0)) if ( direct_access )H & call Determine_EOF( fhc, last_record, lrecl, non_span) end if end if !sts Open_Input_File = sts return end !of Open_Input_FileG integer *4 function Rfa_Position ( rab, nxt_rec, start, finish ) !, ! Read an entire file, caching its rfa's;D ! recalculate starting & ending records based on new information;& ! position file at starting record. ! implicit noneC called by:$* function Process_FileC constant:: include '($RMSdef)/list' !rms status codesF include '($RABdef)/list' !rms Record Access Block defs structure /rfa/ integer *4 block integer *2 offset end structure !rfa! parameter cACHE_SIZ = 2048C global input: include 'Extract.F' C input:9 record /rabdef/ rab !rms record access block C output:G integer *4 nxt_rec, !next read will retreive this record #L & start, finish !initial & final records of interest C local:& record /rfa/ rfa, rec(cACHE_SIZ),8 & big(cACHE_SIZ), huge(cACHE_SIZ)) integer recpos, bigpos, hugepos logical got_start integer *4 rec_cnt, stsC functions: integer *4 SYS$FIND intrinsic MAX, MIN sts = 1-C read the file, caching record addresses rec_cnt = 0 recpos = 0 bigpos = 0 hugepos = 0 got_start = .false. do while ( sts ) sts = SYS$FIND( rab)& if ( sts ) rec_cnt = rec_cnt + 1 if ( got_start ) thenFC do nothing [except continue counting 'til end of file]G else if ( rec_cnt .eq. start_val ) then !only if start_val > 0 rfa.block = rab.rab$l_rfa0 rfa.offset = rab.rab$w_rfa4: got_start = .true. !'rfa' will retain current value else rfa.block = rab.rab$l_rfa0 rfa.offset = rab.rab$w_rfa4 recpos = recpos + 1# if ( recpos .gt. cACHE_SIZ ) then bigpos = bigpos + 1= if ( bigpos .gt. cACHE_SIZ ) then !extremely unlikely hugepos = hugepos + 1: if ( hugepos .le. cACHE_SIZ ) !(impossible to exceed)6 & huge(hugepos) = big(1) bigpos = 1 end if big(bigpos) = rec(1) recpos = 1 end if rec(recpos).block = rfa.block! rec(recpos).offset = rfa.offset end if end do" if ( sts .eq. RMS$_EOF ) sts = 1?C we can now determine proper values for for start & finish if ( start_val .le. 0 ) then/ start = MAX( (rec_cnt + 1) + start_val, 1) else start = start_val end if if ( end_val .le. 0 ) then. finish = MAX( (rec_cnt + 1) + end_val, 0) else$ finish = MIN( end_val, rec_cnt) end ifC re-position file( if ( sts .and. start .le. finish ) then if ( got_start ) then2 nxt_rec = start !'rfa' has desired valueI else if ( (rec_cnt - start + 1) .le. cACHE_SIZ ) then !within last n! recpos = MOD( start, cACHE_SIZ)* if ( recpos .eq. 0 ) recpos = cACHE_SIZ rfa = rec(recpos)9 nxt_rec = start !no. of record about to be read$ else if ( (rec_cnt - start + 1)P & .le. cACHE_SIZ * cACHE_SIZ + recpos ) then !with last n^2 + m' bigpos = ((start - 1)/ cACHE_SIZ) + 1" bigpos = MOD( bigpos, cACHE_SIZ)* if ( bigpos .eq. 0 ) bigpos = cACHE_SIZ rfa = big(bigpos)( nxt_rec = (bigpos - 1) * cACHE_SIZ + 1 else !** NOT TESTED **!6 hugepos = ((start - 1)/ (cACHE_SIZ * cACHE_SIZ)) + 1$ hugepos = MIN( hugepos, cACHE_SIZ) rfa = huge(hugepos)5 nxt_rec = (hugepos - 1) * cACHE_SIZ * cACHE_SIZ + 1 end ifKC set rfa and fetch record (into position for next sequential read) rab.rab$l_rfa0 = rfa.block rab.rab$w_rfa4 = rfa.offset8 rab.rab$b_rac = RAB$C_RFA !access via rfa; sts = SYS$FIND( rab) !locate the recordC rab.rab$b_rac = RAB$C_SEQ !restore sequential access elseG nxt_rec = rec_cnt + 1 !beyond EOF (forces end of processing) end if4 if ( sts .eq. RMS$_NORMAL ) sts = 1 !SS$_NORMAL Rfa_Position = sts return end !of Rfa_Position integer *4 function; & Direct_Position ( rab, nxt_rec, start, finish ) !B ! Calculate & set record position for fixed length record file. ! implicit noneC called by:$* function Process_FileC constant:F include '($RABdef)/list' !rms Record Access Block defs structure /rfa/ integer *4 block integer *2 offset end structure !rfa integer *4 bLKSIZ9 parameter ( bLKSIZ = 512 ) !bytes per blockC global input: include 'Extract.F' C input:9 record /rabdef/ rab !rms record access block C output:G integer *4 nxt_rec, !next read will retreive this record #L & start, finish !initial & final records of interest C local: record /rfa/ rfa; integer *4 ltmp, rcrds_per_block, even, xtra, stsC functions: integer *4 SYS$FIND intrinsic MAX, MOD start = start_val if ( start .le. 0 )8 & start = MAX( 1, last_record + 1 + start) finish = end_val if ( finish .le. 0 ): & finish = MAX( 0, last_record + 1 + finish) sts = 1 nxt_rec = 1 if ( start .gt. 1 ) thenC calculate rfaA ltmp = lrecl + (lrecl .and. 1) !round up to even number if ( non_span ) then< rcrds_per_block = bLKSIZ / ltmp !records per block/ rfa.block = (start - 1) / rcrds_per_block + 16 rfa.offset = MOD( start - 1, rcrds_per_block) * ltmp< else !(beware of overflow near end of huge file)=* rfa.block = ((start - 1) * ltmp) / bLKSIZ + 1=* rfa.offset = MOD( (start - 1) * ltmp, bLKSIZ) even = (start - 1) / bLKSIZ& xtra = (start - 1) - (bLKSIZ * even)6 rfa.block = even * ltmp + (xtra * ltmp) / bLKSIZ + 1( rfa.offset = MOD( xtra * ltmp, bLKSIZ) end if!C set rfa & position file rab.rab$l_rfa0 = rfa.block rab.rab$w_rfa4 = rfa.offset8 rab.rab$b_rac = RAB$C_RFA !access via rfa; sts = SYS$FIND( rab) !locate the recordC rab.rab$b_rac = RAB$C_SEQ !restore sequential access nxt_rec = start end if Direct_Position = sts return end !of Direct_PositionE subroutine Determine_EOF ( fhc, last_record, lrecl, non_span ) !D ! Using file header data, figure how many records are in the file< ! (only appropriate for files with fixed length records). ! implicit noneC called by:'* function Open_Input_FileC constant:I include '($XabFHCdef)/nolist' !file header characteristics xabD include '($FABdef)/nolist' !rms File Access Block defs integer *4 bLKSIZ9 parameter ( bLKSIZ = 512 ) !bytes per block C input:2 record /xabfhcdef/ fhc !file header info C output:F integer *4 last_record, !calculated number of records in fileN & lrecl !longest record's length (limited use)C logical non_span !flag for non-block-span attribute C local:! integer *4 ltmp, ebk, ffbC functions: intrinsic ZEXT, MOD last_record = 0 !(temp)I non_span = ( (fhc.xab$b_atr .and. FAB$M_BLK).ne. 0 ) !(fab.fab$b_rat)I lrecl = ZEXT(fhc.xab$w_mrz) !maximum record size !(fab.fab$w_mrs)K if ( lrecl .eq. 0 .or. non_span .and. lre cl .gt. bLKSIZ ) return !(never!)3 ebk = fhc.xab$l_ebk !end-of-file block; ffb = fhc.xab$w_ffb !first free byte within it? ltmp = lrecl + (lrecl .and. 1) !round up to even no. of bytes if ( non_span ) then9 last_record = bLKSIZ / ltmp * (ebk - 1) + ffb / ltmp* else !(beware overflow for huge files)U* last_record = (bLKSIZ * (ebk - 1) + ffb) / ltmp !(overflow iff ebk >= 4M)0 last_record = ( (ebk - 1) / ltmp ) * bLKSIZD &  + ( MOD( ebk - 1, ltmp) * 512 + ffb ) / ltmp end if return end !of Determine_EOF< subroutine Block_Info ( fab, fhc, last_block, lrecl ) !C ! Using file header data, figure how many blocks are in the fileB ! (and determine whether it's safe to retain record structure). !* ! Note: tape handling is insufficient. ! implicit noneC called by:'* function Open_Input_FileC constant:I include '($XabFHCdef)/nolist' !file header characteristics xabD include '($FABdef)/nolist' !rms File Access Block defs parameter bLKSIZ = 512 C input:D record /fabdef/ fab !input file's rms file access block2 record /xabfhcdef/ fhc !file header info C output:K integer *4 last_block, !size of file (blocks used, not allocated)M & lrecl !record length iff safe to preserve -OC local: !+ record structure in extracted blocks integer *4 ltmp, blkC functions: intrinsic ZEXT, MOD blk = ZEXT(fab.fab$w_bls) if ( blk .eq. 0 ) blk = bLKSIZ3 last_block = fhc.xab$l_ebk !end-of-file block/ if ( blk .ne. bLKSIZ .and. last_block .gt. 0 )6 & last_block = last_block * blk / bLKSIZGC zero-out record length if input is not fixed-length records which<C evenly within blocks or non-block-spanned records.I lrecl = ZEXT(fhc.xab$w_mrz) !maximum record size !(fab.fab$w_mrs)2 if ( (fab.fab$b_rat .and. FAB$M_BLK).eq. 0 ) thenC ltmp = lrecl + (lrecl .and. 1) !round up to even no. of bytes; if ( lrecl .ne. 0 .and. ( fab.fab$b_rfm .ne. FAB$C_FIX> & .or. MOD( blk, ltmp) .ne. 0 ) & ) lrecl = 01 end if !file's records may span block boundaries return end !of Block_InfoD integer *4 function Block_Pos ( rab, nxt_rec, start, finish ) !? ! Calculate & set block position for direct access by block. ! implicit noneC called by:$* function Process_FileC constant:F include '($RABdef)/list' !rms Record Access Block defsC global input:1 include 'Extract.F' !optionsC input/output:F record /rabdef/ rab !input file's rms record access block C output:F integer *4 nxt_rec, !next read will retreive this block #K & start, finish !initial & final blocks of interestC functions: intrinsic MAX start = start_val if ( start .le. 0 )8 & start = MAX( 1, last_record + 1 + start) finish = end_val if ( finish .le. 0 ): & finish = MAX( 0, last_record + 1 + finish)F if ( start .gt. 1 ) rab.rab$l_bkt = start !read this block next nxt_rec = start Block_Pos = 1 !SS$_NORMAL return end !of Block_PoswwsD)* FindFile.For -- file search routines.J* Pat Rankin, Nov'88J* i*4 Rms_Find_File ( filespec, default_name, filename, filnamlen, fnb )K* " Rms_Parse_File ( filespec, default_name, filename, filnamlen, fnb )* " Rms_Find_File_End ( )1* " Rms_Parse_File_End ( parse_release_flag )*B INTEGER *4 FUNCTION Rms_Find_File ( filespec, default_name,E & filename, filnamlen, fnb ) !6 ! Search for a file (alternative to L IB$FIND_FILE). !5 ! Caveats: search lists are not handled properly.: ! Calls to Parse_File should not be intermixed with ! calls to Find_File. ! implicit noneC constant:: INCLUDE '($RMSdef)/nolist' !rms status codes@ INCLUDE '($FABdef)/nolist' !file-access-block defs> INCLUDE '($NAMdef)/nolist' !file name block defsE INCLUDE '($DEVdef)/nolist' !device characteristics defs9 INCLUDE 'f_inc:Dsc.F' !descriptor defsA PARAMETER aLLOC_AMOUNT = NAM$C_BLN + 2 *(NAM$C_MAXRSS + 1)C additional entries below:B INTEGER *4 Rms_Parse_File, !$parse but don't $searchB & Rms_Find_File_End, !release resources> & Rms_Parse_File_End ! " "C global input/output:# COMMON /findfile_rmsdata/ fab, nam RECORD /fabdef/ fab RECORD /namdef/ nam C input: CHARACTER *(*) filespec,$ & default_nameF LOGICAL parse_release_flag !arg for Rms_Parse_File_End() C output: CHARACTER *(*) filename INTEGER *2 filnamlen INTEGER *4 fnb C local:& RECORD /dsc/ prev_spec, prev_dflt INTEGER len_word BYTE len_byte% EQUIVALENCE ( len_word, len_byte )4 INTEGER *4 prev_nam, mem_chunk, tmp_address,$ & sts, tmpsts) LOGICAL init_done, was_non_dir,= & do_parse, do_search, release_memory DATA init_done /.FALSE./< SAVE init_done, was_non_dir !, prev_spec, prev_dfltC functions: INTEGER STR$COMPARE( INTEGER *4 SYS$PARSE, SYS$SEARCH,1 & LIB$GET_VM, LIB$FREE_VM,C & LIB$SCOPY_R_DX, STR$COPY_DX, STR$FREE1_DX! INTRINSIC LEN, MIN, ZEXT do_search = .TRUE. GOTO 100**5 ENTRY Rms_Parse_File ( filespec, default_name,8 & filename, filnamlen, fnb ) ! ! $parse but don't $search. ! do_search = .FALSE.* 100 CONTINUE IF ( .NOT. init_done ) THEN do_parse = .TRUE.5 prev_spec.d_len = 0 !length is 0E prev_spec.d_typ = DSC$K_DTYPE_T !type is text string (ascii): prev_spec.d_cls = DSC$K_CLASS_D !class is dynamic9 prev_spec.d_adr = 0 !address is NULLE prev_dflt = prev_spec !another null dynamic stringF CALL LIB$MOVC5( 0, %VAL(0), 0, FAB$C_BLN, fab) !zero out fabF fab.fab$b_bid = FAB$C_BID !block identification (FAB=3)> fab.fab$b_bln = FAB$C_BLN !block length ('50'x) init_done = .TRUE. ELSE< do_parse = ( STR$COMPARE( filespec, prev_spec) .NE. 0 ) END IF IF ( do_parse ) THEND CALL STR$COPY_DX( prev_spec, filespec) !copy the file-specC len_word = MIN( prev_spec.d_len, '00FF'x) !max length is 255< fab.fab$b_fns = len_byte !file name si ze? fab.fab$l_fna = prev_spec.d_adr !file name address7 IF ( STR$COMPARE( default_name, ' ') .NE. 0 ) THEN, CALL STR$COPY_DX( prev_dflt, default_name)+ len_word = MIN( prev_dflt.d_len, '00FF'x)8 fab.fab$b_dns = len_byte !default name size; fab.fab$l_dna = prev_dflt.d_adr !default name address END IF was_non_dir = .FALSE.LC allocate chunk of memory for nam plus expanded & resultant stringsMC (note: an extra byte [for trai ling NUL if desired] is allocated2C to both of the filename buffers)A len_word = NAM$C_MAXRSS !maximum filename lengthH sts = LIB$GET_VM( aLLOC_AMOUNT, mem_chunk) !bln + 2 * (maxrss + 1) IF ( sts ) THENB CALL LIB$MOVC5( 0, %VAL(0), 0, aLLOC_AMOUNT, !zero new memoryO & %VAL(mem_chunk) ) !(by choice, not necessity) prev_nam = fab.fab$l_nam- IF ( prev_nam .EQ. 0 ) THEN !first time!C link NAM t o FAB9 fab.fab$l_nam = %LOC(nam) !address of nam ELSECC the previous NAM now becomes the Related File NAM! IF ( .NOT. do_search ) THENLC for parse-only operation, we need to juggle inside RLF nam.nam$l_rsa = nam.nam$l_esa nam.nam$b_rsl = nam.nam$b_esl END IF0 CALL LIB$MOVC3( NAM$C_BLN, %VAL(prev_nam),Q & %VAL(mem_chunk) ) !(beginning of mem chunk)> fab.fab$b_dns = 0 !remove default name END IFC setup nam? CALL LIB$MOVC5( 0, %VAL(0), 0, NAM$C_BLN, nam) !zero out nam> nam.nam$b_bid = NAM$C_BID !block ident (NAM=2)? nam.nam$b_bln = NAM$C_BLN !block length ('60'x)E nam.nam$l_esa = mem_chunk + NAM$C_BLN !(middle part of mem chunk)7 nam.nam$b_ess = len_byte !NAM$C_MAXRSSJ nam.nam$l_rsa = nam.nam$l_esa + (len_word + 1) !(last part of mem chunk)7 nam.nam$b_rss = len_byte !NAM$C_MAXRSS IF ( prev_nam .NE. 0 )O & nam.nam$l_rlf = mem_chunk !(copy of previous nam)!C parse the file-spec sts = SYS$PARSE( fab) IF ( do_search )E & do_search = ( (fab.fab$l_dev .AND. DEV$M_DIR).NE. 0C & .OR. (nam.nam$l_fnb .AND. (NAM$M_EXP_DIRH & .OR. NAM$M_SEARCH_LIST)).NE. 0 )$ ELSE !unexpected problemB CALL LIB$MOVC5( 0, %VAL(0), 0, NAM$C_BLN, nam) !clear old stuff END IF !sts ELSE sts = 1' IF ( was_non_dir ) sts = RMS$_NMF END IF !do_parse IF ( sts .AND. do_search ) THEN6C do the real work and return resultant string sts = SYS$SEARCH( fab)# len_word = ZEXT(nam.nam$b_rsl) tmp_address = nam.nam$l_rsa ELSE C return expanded string# len_word = ZEXT(nam.nam$b_esl) tmp_address = nam.nam$l_esa END IF was_non_dir = .NOT. do_search(C store results in output parameters@ tmpsts = LIB$SCOPY_R_DX( len_word, %VAL(tmp_address), filename) IF ( sts ) sts = tmpsts* filnamlen = MIN( len_word, LEN(filename))6 fnb = nam.nam$l_fnb !filename status bits Rms_Find_File = sts RETURN**" ENTRY Rms_Find_File_End ( ) !6 ! Release resources (dynamically allocated memory). ! release_memory = .TRUE. GOTO 900**6 ENTRY Rms_Parse_File_End ( parse_release_flag ) !? ! Reset for next parse or search; optionally release memory. !$ release_memory = parse_release_flag* 900 CONTINUE sts = 1 IF ( release_memory ) THEN prev_nam = nam.nam$l_rlf+ DO WHILE ( prev_nam .NE. 0 .AND. sts )1 CALL LIB$MOVC3( NAM$C_BLN, %VAL(prev_nam), nam), sts = LIB$FREE_VM( aLLOC_AMOUNT, prev_nam) prev_nam = nam.nam$l_rlf END DO/ IF ( sts .AND. nam.nam$l_esa .NE. 0 ) THEN& prev_nam = nam.nam$l_esa - NAM$C_BLN, sts = LIB$FREE_VM( aLLOC_AMOUNT, prev_nam) END IFB CALL LIB$MOVC5( 0, %VAL(0), 0, NAM$C_BLN, nam) !zero nam& tmpsts = STR$FREE1_DX( prev_dflt)& tmpsts = STR$FREE1_DX( prev_spec) IF ( sts ) sts = tmpsts END IF@ init_done = .FALSE. !reset for next parse or search Rms_Find_File_End = sts RETURNT END !of Rms_Find_File, Rms_Parse_File, & Rms_Find_File_End, Rms_Parse_File_EndwwD>* Itm.F -- Fortran include file defining itemlist structures*C STRUCTURE /itmlst/ !standard itemlist fo r VMS system services2 INTEGER *2 itm_length /0/ !length of buffer+ INTEGER *2 itm_code /0/ !item code3 INTEGER *4 itm_bufadr /0/ !address of bufferI INTEGER *4 itm_retlen /0/ !address of i*2 to receive output length END STRUCTURE !itmlstJc same as /itmlst/ except not initialized to 0 & alternate field namesI STRUCTURE /itm3/ !three longword itemlist for VMS system services UNION MAP !long form2 INTEGER *2 itm_w_length !length of buffer+ INTEGER *2 itm_w_code !item code3 INTEGER *4 itm_l_bufadr !address of bufferI INTEGER *4 itm_l_retlen !address of i*2 to receive output length END MAP MAP !short form2 INTEGER *2 i_len !length of buffer+ INTEGER *2 i_cod !item code3 INTEGER *4 i_buf !address of bufferI INTEGER *4 i_rln !address of i*2 to receive output length END MAP END UNION END STRUCTURE !itm3& PARAMETER ITM_C_END_OF_LIST = 0& PARAMETER ITM_K_END_OF_LIST = 0 PARAMETER ITM_S_BYTE = 1 PARAMETER ITM_S_WORD = 2# PARAMETER ITM_S_LONGWORD = 4# PARAMETER ITM_S_QUADWORD = 8wwC7 DH* Xabs.F -- include file for RMS extended attribute block manipulation* INCLUDE '($XABdef)/nolist' INCLUDE '($XabALLdef)/nolist' INCLUDE '($XabDATdef)/nolist' INCLUDE '($XabFHCdef)/nolist' INCLUDE '($XabKEYdef)/nolist' INCLUDE '($XabPROdef)/nolist' INCLUDE '($XabRDTdef)/nolist' INCLUDE '($XabSUMdef)/nolist' INCLUDE '($XabTRMdef)/nolist' STRUCTURE /xabs/ UNION MAP4 RECORD /xabdef/ xab !common xab fields END MAP MAP@ RECORD /xabdef1/ xab1 !more (not very) common fields END MAP MAP5 RECORD /xaballdef/ all !allocation control END MAP MAP9 RECORD /xabdatdef/ dat !date & time (all four) END MAP MAP> RECORD /xabfhcdef/ fhc !file header characteristics END MAP MAP1 RECORD /xabkeydef/ key !key definition END MAP MAP; RECORD /xabprodef1/ pro !protection (& ownership) END MAP MAP7 RECORD /xabrdtdef/ rdt !revision date & time END MAP MAP> RECORD /xabsumdef/ sum !summary (for indexed files) END MAP MAP3 RECORD /xabtrmdef/ trm !terminal control END MAP END UNION END STRUCTURE !xabsww done* after any requested edits are performed. /VFC_HEADER % /VFC_HEADER={ IGNORE | DATA | KEEP },C Specifies how to handle files in variable-with-fixed-control-areaAE format (such as batch .log files). By default, the control area islG ignored. /VFC_HEADER=DATA causes the control area, which is normally G hidden, to be treated as part of the normal record contents. A valueoE of KEEP causes the output file to have the same format as the input E file (rather, as the *first* input file if there is more than one).aF If the [first] input file is not in VFC format, /VFC_HEADER=KEEP has no effect."!/TRUNCATE -- not implemented"!/WIDTH -- not implemented"!/WRAP -- not implemented2 edit_options Options available for /EDIT:- COLLAPSE -- remove all spaces and tabsnG COMPRESS -- convert multiple spaces and tabs into a single space; LOWERCASE -- convert unquoted letters into lower-casepG TRIM -- remove leading and tr ailing blanks (spaces and tabs)A< UNCOMMENT -- remove comments (from "!" to end of line); UPCASE -- convert unquoted letters into upper-case? STRIP_TRAILING -- remove trailing blanks (spaces and tabs)2B IGNORE_QUOTES -- don't check quotes ("xxx") when doing edits9 FALLBACK -- strip 8-bit data into 7-bit equivalentaD FORMAT -- convert non-visible (control) characters into "."F If both UPCASE and LOWERCASE are specified, UPCASE takes precedence.H COLLAPSE supercedes COMPRESS and TRIM; TRIM supercedes STRIP_TRAILING.H Quoted text is subject to FALLBACK and FORMAT modifications regardless/ of whether or not IGNORE_QUOTES is specified. 2 examples9 !Display the last 10 lines of Login.Com on the terminal ' $ EXTRACT/TAIL=10 Login.Com /IDENTIFYI: !Look at the first few lines of all Fortran source files $ EXTRACT/HEAD=5 *.For= !Copy Test.Txt to Test.Dat, converting text into upper caseg ! and removing excess blanks.; $ EXTRACT/EDIT =(UPCASE,COMPRESS) Test.Txt/OUTPUT=Test.Datt? !Extract all but the first 10 and last 10 records of Test.Datt@ $ EXTRACT Test.Dat/RECORDS=(START=11,END=-11) /OUTPUT=Test.Mid, !Get specific columns out of several files: $ EXTRACT/COLUMNS=(1:10,18:19,25,41:*) Test.*,[...]*.Tmp!#eof#wwad = .true. else need_input = .false. end if end do  if ( sts ) then& call Customize_Output( %VAL(rabadr))/ sts = Open_Output( outfile(:outf_len), width)  if ( .not. sts )H /dsc/ list(*) CHARACTER *(*) targetO LOGICAL wildcard) C local:K 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 5 INTEGER STR$COMPARE, STR$CASE_BLIND_COMPARE  INTRINSIC ABS5 IF ( STR$COMPARE( target, last_target) .NE. 0 ) THEN found = .FALSE. reverse = ( size .LT. 0 ) abs_size = ABS(size)e indx = 0 5*(old) IF ( reverse ) indx = 1 !skip "-" 6 DO WHILE ( indx .LT. abs_size .AND. .NOT. found ) indx = indx + 1lK found = LEN(target) .NE. 0 !(require explicit match for null string)FD & .AND. STR$COMPARE( target, list(indx)) .EQ. 0 IF ( .NOT. found )H & found = STR$CASE_BLIND_COMPARE( target, list(indx)) .EQ.0# IF ( .NOT. found .AND. wildcard ) H &  found = STR$MATCH_WILD( target, list(indx)).AND.1 END DOG! IF ( .NOT. found ) indx = 0)! IF ( reverse ) indx = -indxn;C save target (and result) for comparison next timen+ CALL STR$COPY_DX( last_target, target)  END IFR Search_Inp_List = indxC RETURNu END !of Search_Inp_List > INTEGER *4 FUNCTION Expand_Inp_List ( list_size, list ) !2 ! Expand a dynamic array of string descriptors. ! implicit noneC constant:Y? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptorsnD PARAMETER eLEMENT_SIZE = 8, !size of descriptor0 & eXPANSION_INCREMENT = 10 C input:C input/output:v INTEGER *4 list_size INTEGER *4 list. C local:K RECORD /dsc_d/ empty_dynamic !pre-initialized dynamic string descriptor  INTEGER loopc/ INTEGER *4 new_adr, new_size, old_size,% & address, stshC functions:* INTEGER *4 LIB$GET_VM, LIB$FREE_VM,K & OTS$MOVE3 !MOVC3 but without 65535 byte limit  INTRINSIC MINF new_size = list_size + eXPANSION_INCREMENT !increase by 10 slots4 sts = LIB$GET_VM( new_size * eLEMENT_SIZE, new_adr) IF ( sts ) THEN old_size = list_size IF ( old_size .GT. 0 ) THEN1 sts = OTS$MOVE3( %VAL(old_size * eLEMENT_SIZE),c: & %VAL(list), %VAL(new_adr)) IF ( sts )G & sts = LIB$FREE_VM( old_size * eLEMENT_SIZE, %VAL(list)) END IFi%C fill in empty (new) entries0 address = new_adr + old_size * eLEMENT_SIZEA DO loop = 1, eXPANSION_INCREMENT ! old_size + 1, new_sizes: 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 IFc Expand_Inp_List = sts RETURNo END !of Expand_Inp_List,, INTEGE R *4 FUNCTION Output ( string ) ! ! Write out a string. ! implicit noneC constant: E INCLUDE '($SSdef)/nolist' !system service status codes : INCLUDE '($RMSdef)/nolist' !RMS status codes@ INCLUDE '($FABdef)/nolist' !file-access-block defsB INCLUDE '($RABdef)/nolist' !record-access-block defs> INCLUDE '($NAMdef)/nolist' !file name block defs5 INCLUDE '($DEVdef)/nolist' !device defs(D 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 /e; BYTE nAM_PROTOTYPE(2) / NAM$C_BID, NAM$C_BLN / ! PARAMETER rETRY_LIMIT = 10nC additional entries below:rD INTEGER *4 Block_Output, !use $write instead of $putJ & Flush_Output, !update output with $flushO & Open_Output, !exp licitly open an output filelM & Close_Output ! " close the " "bC global input:s6 COMMON /output_usropn/ usropn_routine, usropn_contextI INTEGER *4 usropn_routine /0/, !address of routine to process - P & usropn_context /0/ !+ fab/rab/nam prior to $create. C input:: CHARACTER *(*) string, !string to output@ & default_name !for Open_Output C output:o: INTEGER width !from Open_Output C local: RECORD /fabdef/ fab RECORD /rabdef/ rab RECORD /namdef/ nam# CHARACTER *255 filename, buf *40f- INTEGER *2 filnamlen, ln, retry_count  INTEGER *4 len_tmp INTEGER *2 len_word  BYTE len_byted. EQUIVALENCE ( len_tmp, len_word, len_byte )? INTEGER *4 sts, clists, removed_privs(2), arglist(0:4))" LOGICAL is_open /.FALSE./ SAVE is_open !, rab4C functions:- INTEGER *4 Cli_Present, Cli_Get_Value, % & OTS$CVT_TI_L, 1 & SYS$CREATE, SYS$CONNECT,s8 & SYS$PUT, SYS$WRITE, SYS$FLUSH,3 & SYS$CLOSE, SYS$DISCONNECT, & & LIB$PUT_OUTPUT" INTRINSIC LEN, MIN, ICHAR IF ( is_open ) THENC set up record buffer len_tmp = LEN(string) rab.rab$w_rsz = len_worde! rab.rab$l_rbf = %LOC(string).&C write record & c heck results retry_count = 0+ DO WHILE ( SYS$PUT( rab) .EQ. RMS$_RSA: & .AND. retry_count .LT. rETRY_LIMIT )A CALL SYS$WAIT( rab) !if record stream active, wait & repeati retry_count = retry_count + 1R END DOa sts = rab.rab$l_sts@ IF ( sts .EQ. RMS$_EXT !did we fail to extend?J & .AND. rab.rab$l_stv .EQ. SS$_EXDISKQUOTA ) !due to quota?A & sts = SYS$PUT( rab) !if so, try againt ELSEoEC  [ no explicit open was performed (or it was unsuccessful) ]x" sts = LIB$PUT_OUTPUT( string) END IFG Output = sts$ RETURNr**$ ENTRY Block_Output ( string ) !B ! Use block i/o instead of record i/o; asynchronous contortions9 ! are not performed. Validity checks are left to RMS.r !C set up record buffer len_tmp = LEN(string) rab.rab$w_rsz = len_wordc rab.rab$l_rbf = %LOC(string)a!C write block & check results  sts = SYS$WRITE( rab)< IF ( sts .EQ. RMS$_EXT !did we fail to extend?F & .AND. rab.rab$l_stv .EQ. SS$_EXDISKQUOTA ) !due to quota?= & sts = SYS$WRITE( rab) !if so, try againe Block_Output = sts_ Output = sts  RETURN ** ENTRY Flush_Output ( )s ! ! Update output with $FLUSH.f ! sts = SYS$FLUSH( rab) Flush_Output = sts& RETURN **0 ENTRY Open_Output ( default_name, width ) !7 ! Open output file and determine desired line width.b< ! If th e width has not been specified on the command lineA ! then use the default value: tty width for terminals, 80 for E ! mailbox or network channels, 132 otherwise (ie, for disk files).e !C ! Be sure not to risk compromising system security if this imagei@ ! has been installed with SYSPRV. (/output=sys$system:xxxx!) !=C retreive filename from command line: /output='filename'R filnamlen = 0# IF ( Cli_Present( 'OUTPUT') ) THENt; clists = Cli_Get_Value( 'OUTPUT', filename, f ilnamlen)  END IF "C initialize File Access BlockF CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0...A fab.fab$l_fop = FAB$M_MXV .OR. FAB$M_SQO .OR. FAB$M_TEF !optionsn6 fab.fab$b_fac = FAB$M_PUT !write access/!-note: shr.shrget is incompatable with fop.tefB!- fab.fab$b_shr = FAB$M_SHRGET !others can readH!-!- & .OR. FAB$M_SHRPUT .OR. FAB$M_UPI .OR. FAB$M_MSEA fab.fab$b_rat = FAB$M_CR !implied carriage returne9 fab.fab$b_rfm = FAB$C_VAR !variable lengthf IF ( filnamlen .GT. 0 ) THENb; len_tmp = MIN( filnamlen, '00FF'x) !max length is 255e8 fab.fab$b_fns = len_byte !file name size; fab.fab$l_fna = %LOC(filename) !file name addresss* ELSE IF ( LEN(default_name) .EQ. 0 ) THEN& fab.fab$b_fns = LEN('SYS$OUTPUT')' fab.fab$l_fna = %LOC('SYS$OUTPUT')  END IFu; fab.fab$b_dns = LEN(default_name) !default name size > fab.fab$l_dna = %LOC(de fault_name) !default name address; fab.fab$l_nam = %LOC(nam) !link NAM with FAB C initialize file NAMe blockM CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !NAM (for device name)n!* 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 BlockF CALL LIB$MOVC5( 2, rAB_PROTOTYPE, 0, RAB$C_BLN, rab) !bid,bln,0...; rab.rab$l_rop = 0 !no special record optionss- rab.rab$l_fab = %LOC(fab) !link to FAB " IF ( usropn_routine .NE. 0 ) THENFC kludge to transparently provide useropen-like functionality;IC issue a call-back prior to $create (return status ignored):kCC call 'usropn_routine'( usropn_context, fab, rab, nam)h0 arglist(0) = 4 !4 args in list arglist(1) = usropn_context arglist(2) = %LOC(fab). arglist(3) = %LOC(rab)o arglist(4) = %LOC(nam)d3 CALL LIB$CALLG( arglist, %VAL(usropn_routine))e END IFtHC disable any privileges that this image was installed with that the0C user doesn't have in his/her own right- CALL Disable_Installed_Privs( removed_privs)R sts = SYS$CREATE( fab)d IF ( sts ) THEN sts = SYS$CONNECT( rab)+ IF ( .NOT. sts ) CALL SYS$CLOSE( fab)0@* [ if ( sts ) define/user_mode sys$output 'realname' ] END IFm! is_open = ( (sts.AND.1) .EQ. 1 )L6C if any pri vileges were removed, restore them now< IF ( removed_privs(1) .NE. 0 .OR. removed_privs(2) .NE. 0 )B & 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)o END IF# IF ( sts .AND. width .LE. 0 ) THEN7 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 = 80c? ELSE IF ( (fab.fab$l_dev .AND. (DEV$M_MBX .OR. DEV$M_NET))n" & .NE. 0 ) THEN width = 80 ELSEe width = 132r END IF  END IFb Open_Output = sts RETURNu** ENTRY Close_Output ( )i ! ! Close the file. ! sts = SYS$DISCONNECT( rab)a CALL SYS$CLOSE( fab)e if ( sts ) sts = fab.fab$l_sts4 if ( sts .eq. RMS$_NORMAL ) sts = 1 !SS$_NORMAL is_open = .false. Close_Output = stst RETURNL END !of Output, Block_Output, Flush_Output, Open_Output & Close_OutputB 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 noneC constant:c< INCLUDE '($JPIdef)/nolist' !job & process info= INCLUDE 'f_inc:Itm.F'  !item list structureo C output:l8 INTEGER *4 disabled_privs(2) !privilege mask C local:3 RECORD /itmlst/ privs(3) !item list_* INTEGER *4 procpriv(2), imagpriv(2) LOGICAL disable% privs(1).itm_length = ITM_S_QUADWORDc# privs(1).itm_code = JPI$_CURPRIV % privs(1).itm_bufadr = %LOC(procpriv) % privs(2).itm_length = ITM_S_QUADWORDm$ privs(2).itm_code = JPI$_IMAGPRIV% privs(2).itm_bufadr = %LOC(imagpriv)f( privs(3).itm_code = ITM_K_END_OF_LIST imagpriv(1) = 0 imagpriv(2) = 0 CALL SYS$GETJPIW(,,, privs,,,)e8 disabled_privs(1) = imagpriv(1) .AND. .NOT. procpriv(1)8 disabled_privs(2) = imagpriv(2) .AND. .NOT. procpriv(2)% disable = ( disabled_privs(1) .NE. 0 . & .OR. disabled_privs(2) .NE. 0 ) IF ( disable )iC & CALL SYS$SETPRV( %VAL(0), disabled_privs, %VAL(0),)f" Disable_Installed_Privs = disable RETURN % END !of Disable_Installed_Privs 8 INTEGER *4 FUNCTION  PutMsg ( facility, sts, stv ) !! ! Rudimentary message routine.l ! implicit none C input: CHARACTER *(*) facilityr INTEGER *4 sts, stv C localf INTEGER *4 msgvec(0:4) INTEGER *4 SYS$PUTMSGs' msgvec(0) = 1 !1 arg followsr msgvec(1) = sts msgvec(2) = 0 IF ( %LOC(stv) .NE. 0 ) THENA, msgvec(0) = 2 !make that two args msgvec(2) = stv END IF msgvec(3) = 0 msgvec(4) = 0) PutMsg = SYS$PUTMSG( msgvec,, facility,)O RETURN  END !of PutMsgB INTEGER *4 FUNCTION Parse_Node ( in_name, outname, outlen ) !F ! Use RMS to extract a node name (let it handle any logical names). ! implicit noneC constant:  INCLUDE '($RMSdef)/nolist'o INCLUDE '($FABdef)/nolist'r INCLUDE '($NAMdef)/nolist'!; BYTE fAB_PROTOTYPE(2) / FAB$C_BID, FAB$C_BLN /e; BYTE nAM_PROTOTYPE(2) / NAM$C_BID, NAM$C_BLN /i INTEGER *4 fILE_NAME_BITS;? PARAMETER ( fILE_NAME_BITS = NAM$M_NODE .OR. NAM$M_EXP_DEVdF & .OR. NAM$M_EXP_DIR .OR. NAM$M_EXP_NAMEH & .OR. NAM$M_EXP_TYPE .OR. NAM$M_EXP_VER ) C input: CHARACTER *(*) in_name C output:a CHARACTER *(*) outname INTEGER *2 outlena C local: RECORD /fabdef/ fab RECORD /namdef/ nam CHARACTER *256 work_string INTEGER len_tmp, pos BYTE len_byteA$ EQUIVALENCE ( len_tmp, len_byte ) INTEGER *4 stsC functions: [ INTEGER *4 SYS$PARSE) INTRINSIC LEN, MIN, INDEX, ZEXTtF CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0...C len_tmp = MIN( LEN(in_name), '00FF'x) !max length is 255e8 fab.fab$b_fns = len_byte !file name size; fab.fab$l_fna = %LOC(in_name) !file name addressx> fab.fab$l_nam = %LOC(nam) !pointer to NAM blockF CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !bid,bln,0...C len_tmp = MIN( LEN(work_string) ist(indx - (offset-1)).lowD & ) list(indx - (offset-1)).low = list(indx).high + 1 end do_ size = size - (offset-1)bF list(size).high = mAX_COLUMN !exclude (p:q) -> include (q+1:*); if ( list(size).low .gt. mAX_COLUMN ) size = size - 1h else -C consolidate redundant column ranges_ offset = 1T do indx = offset + 1, size-7 if ( list(indx).low .le. list(indx - offset).high + 1.= & ) then !overlap exists; eliminate ita : if ( list(indx).high .gt. list(indx - offset).high )F & list(indx - offset).high = list(indx).high offset = offset + 1h else if ( offset .gt. 1 ) then3 list(indx - (offset-1)).low = list(indx).low=4 list(indx - (offset-1)).high = list(indx).high end if end do 3 if ( offset .gt. 1 ) size = size - (offset-1)f end iff1C if possible, optimize list out of existenceL+ if ( size .eq. 1 .and. list(1).low .eq. 1fG &   .and. list(1).high .eq. mAX_COLUMN ) size = 0l end if !sts  Process_Column_List = sts returnn! end !of Process_Column_List$8 integer *4 function Param_Init ( outfile, o_len ) ! ! Process the command line. !D ! Note: label for input file changed from "INPUT" to "INPUT_EXTR"C ! to make it different from everything in RUN and MCR. ThiseE ! is to ensure that we get a syntax error if we're not invokedrC ! as a native command (so  that we can then parse the commandc ! ourself). ! implicit noneC called by:&* program Extract (main)C constant:e> include '($SHRdef)/nolist' !shared message codesC include 'f_inc:Cli.F' !command line routine defs F parameter mAX_RECORD = '7FFFFFFF'x !largest positive i*40 character *(*) fACILITY_VERB, fACILITY_PROMPTK parameter ( fACILITY_VERB = 'EXTRACT' ) !also in main, Give_SignalL: parameter (  fACILITY_PROMPT = fACILITY_VERB // '> ' )G external Extract_Cmd !command tables ($ set command/object)sC global output: include 'Extract.F' C output:rH character *(*) outfile !output filename (from /output)= integer *2 o_len !length of 'outfile'S C local:? character *8 qualif !holds a qualifer name(< integer *2 qlen !length of 'qualif'1 integer *4 got_start, got_end, got_count,i2 & expand_tabs, sts, tmpstsC functions: integer LIB$MATCH_COND - integer *4 Cli_Present, Cli_Get_Value,_* & Cli_Parse_Command,6 & Get_Inp_List, Get_Cli_Number,, & Process_Column_List, & STR$TRIMC input file(s)(4 inp_cnt = 0 !number of input file specs> sts = Get_Inp_List( 'INPUT_EXTR', inp_siz, inp_list, inp_cnt)5 if ( LIB$MATCH_COND( sts, C LI$_SYNTAX) .gt. 0 ) thenTLC syntax error indicates we weren't invoked as a native dcl command,?C so we now want to generate a command and parse it.? sts = Cli_Parse_Command( Extract_Cmd, !command table B & fACILITY_VERB, !"EXTRACT"D & fACILITY_PROMPT) !"EXTRACT> "& if ( sts ) !if ok, now try againH & sts = Get_Inp_List( 'INPUT_EXTR', inp_siz, inp_list,inp_cnt) end iff.C output file (/NOoutput is not supported) if ( sts ) then o_len = 03 sts = Cli_Get_Value( 'OUTPUT', outfile, o_len)l2 if ( LIB$MATCH_COND( sts, CLI$_ABSENT) .gt. 0! & .or. o_len .eq. 0 )eL & sts = STR$TRIM( outfile, 'SYS$OUTPUT', o_len) !default end ifsF if ( .not. sts ) goto 98 !give up [avoid nested if's] !GOTOFC check whether user wants each file indentified before processingNC 2 = never, 1 = always, 0 = iff list, wildcard, or searchlist in spec identify = 0R" tmpsts = Cli_Present( 'IDENTIFY')9 if ( LIB$MATCH_COND( tmpsts, CLI$_PRESENT) .gt. 0 ) then  identify = 1> else if ( LIB$MATCH_COND( tmpsts, CLI$_NEGATED) .gt. 0 ) then identify = 2. end ifh@C check for /translate={ ascii_to_ebcdic | ebcdic_to_ascii } xlate = 0& if ( Cli_Present( 'TRANSLATE') ) then: if ( Cli_Present( 'TRANSLATE.ASCII_TO_EBCDIC') ) then0 xlate = 1 !ascii -> ebcdic (after /edit)? else if ( Cli_Prese nt( 'TRANSLATE.EBCDIC_TO_ASCII') ) thenC1 xlate = 2 !ebcdic -> ascii (before /edit)) end if) end ifOI if ( identify .eq. 0 .and. xlate .eq. 1 ) identify = 2 !save some griefdFC check whether user cares about fixed-header portion of vfc files% use_vfc = 0 !/vfc=ignore ' if ( Cli_Present( 'VFC_HEADER') ) thenp0 if ( Cli_Present( 'VFC_HEADER.DATA') ) then> use_vfc = 1 !/vfc=data (treat header as part of record)5 else if ( Cli_Present( 'VFC_HEADER.KEEP') ) then)/ use_vfc = 2 !/vfc=keep (preserve header)p end if  end if:OC initialize extraction limits [tail=0, head=0, record:count=0 not allowed] ) start_val = 0 !starting recordS' end_val = 0 !ending recordl+ count_val = 0 !number of records 9 qlen = 0 !length of qualifier name string  block_mode = .FALSE.)# if ( Cli_Present( 'BLOCKS') ) theng block_mode = .TRUE.C identify = 2 !'never' (don't want id mes sage in output)+ call STR$TRIM( qualif, 'BLOCKS', qlen)n) else if ( Cli_Present( 'RECORDS') ) then , call STR$TRIM( qualif, 'RECORDS', qlen)& else if ( Cli_Present( 'HEAD') ) then+ sts = Get_Cli_Number( 'HEAD', end_val)$> start_val = 1 !first record of file if ( end_val .eq. 0 ) thenn. if ( sts ) sts = SHR$_VALERR !value error$ else if ( end_val .lt. 0 ) then8 end_val = end_val - 1 !drop last 'n' records end if & else if (  Cli_Present( 'TAIL') ) then- sts = Get_Cli_Number( 'TAIL', start_val) = end_val = -1 !last record of fileA! if ( start_val .eq. 0 ) then. if ( sts ) sts = SHR$_VALERR !value error& else if ( start_val .lt. 0 ) then9 start_val = -( start_val - 1 ) !skip first 'n' recordsR" else !standard /tail=n: start_val = -start_val !relative to end of file end ifs else CC default action is to display the first record of the  fileI9C unless some sort of conversion is requested_ start_val = 1 end_val = 1 if ( Cli_Present( 'EDIT')( & .or. Cli_Present( 'COLUMNS'), & .or. Cli_Present( 'EXPAND_TABS')I & .or. Cli_Present( 'TRANSLATE') ) end_val = -1 !whole file= end if)I if ( sts .and. qlen .gt. 0 ) then !'qualif'=="RECORDS" or "BLOCKS" MC check for "START", "END", and "COUNT" keywords and get their values 6 got_start = Cli_Present( qualif (:qlen)//'.START') if ( got_start .and. sts )nH & sts = Get_Cli_Number( qualif(:qlen)//'.START', start_val)2 got_end = Cli_Present( qualif(:qlen)//'.END') if ( got_end .and. sts )H & sts = Get_Cli_Number( qualif(:qlen)//'.END', end_val)6 got_count = Cli_Present( qualif(:qlen)//'.COUNT') if ( got_count .and. sts )fH & sts = Get_Cli_Number( qualif(:qlen)//'.COUNT', count_val)7 if ( sts .and. ( got_start .and. start_val .eq. 0 > & .or. got_end .and. end_val .eq. 0C & .or. got_count .and. count_val .le. 0 ) )M< & sts = SHR$_VALERR !value error else !skip adjustments belowm got_start = .FALSE. got_end = .FALSE. got_count = .FALSE. end if !sts & got qualL if ( sts ) thenC 3C set start & end, using count if necessaryWCDD if ( start_val .eq. 0 ) start_val = 1 !first line of fileC if ( end_val  .eq. 0 ) end_val = -1 !last line of filer if ( got_start ) then if ( got_count ) thene) end_val = start_val + count_val - 1 2 if ( start_val .lt. 0 .and. end_val .ge. 0 )( & end_val = -1 end if else if ( got_end ) thenN if ( got_count ) then) start_val = end_val - count_val + 1m2 if ( end_val .gt. 0 .and. start_val .le. 0 )) & start_val = 1e end ifD else if ( got_count ) then !'count' only => 1..'count'6 end_val = count_val !(start remains '1') end ifsF if ( end_val .eq. -1 ) end_val = mAX_RECORD !largest possible end if !sts/C miscellaneous record modification options* expand_tabs = Cli_Present( 'EXPAND_TABS')-C process column inclusion/exclusion list col_cnt = 0. if ( sts .and. Cli_Present( 'COLUMNS') ) then? sts = Get_Inp_List( 'COLUMNS', col_siz, col_list, col_cnt)o$ if ( sts .and. col_cnt .ne. 0 )G & sts = Process_Column_List( col_cnt, %VAL(col_list))  end if - if ( col_cnt .ne. 0 .or. xlate .eq. 1 ) then KC tab expansion is the default iff column processing or translation /C from ascii to ebcdic is requested < if ( LIB$MATCH_COND( expand_tabs, CLI$_ABSENT) .gt. 0 )( & expand_tabs = .TRUE. end ife< detab = ( (expand_tabs.and.1).eq. 1 ) !.and. xlate .ne. 2 edit = 0( if ( Cli_Present( 'EDIT') ). & call Parse_Edit_Options( edit)IC (should clear 'detab' if edit.collapse or edit.compress set and_4C column extraction is not being performed) 98 continue Param_Init = sts* returni end !of Param_Init: subroutine Give_Signal ( condition, param, status ) !5 ! Display an error message rather than signalling. 7 ! Special handling given for some input file errors.l ! implicit noneC called by:&* program Extract (main)C constant: F  character *(*) fACILITY_NAME !(also defined in Param_Init), parameter ( fACILITY_NAME = 'EXTRACT' )M*- include '($CLIMSGdef)/list' !command interpreter messagesTG parameter CLI$_INVRFM = '000388D2'x !invalid record formato: include '($RMSdef)/nolist' !rms status codes= include '($SHRdef)/nolist' !shared message defsC9 include 'f_inc:Dsc.F' !descriptor defs C input:# integer *4 condition, status  record /dsc/ param C local: integer *4 msgvec(0:7) logical okNC functions: integer LIB$MATCH_CONDc5 msgvec(0) = 4 !vector contains 4 longwords J msgvec(1) = condition .or. '08000002'x !severity=error, facility=non-sys; msgvec(2) = 1 !1 fao arg followsN msgvec(3) = %LOC(param)G msgvec(4) = status !secondary condition (rms sts)E7 msgvec(5) = 0 !dummy rms stvLG msgvec( Z6) = 0 !extend vector as safety precaution (just in -H msgvec(7) = 0 !+case 'status' is accvio--should never happen)KC If the error status is 'file locked by another user' or 'insufficientNC privilege (protection violation)' then treat it as a warning insteadGC of an error so that we can procede with any additional files.A ok = ( LIB$MATCH_COND( status, RMS$_FLK, RMS$_PRV, CLI$_INVRFM) & .gt. 0M & .and. LIB$MATCH_COND( condition,$4D RANKIN DYNAMIC.FOR ݷ`N RANKIN DYNAMIC `N RANKIN DYNAMIC `N RANKIN DYNAMIC `N RANKIN DYNAMIC$`N RANKIN DYNAMIC.FOR$¦ ~ RANKIN EXTRACT.FOR%~ RANKIN EXTR_COL.FOR'``'ϒ RANKIN EXTR_TODO.LIST$@&'ϒ RANKIN EXTRACT.FOR$hw'ϒ RANKIN EXTRACT.HLP$PӒ RANKIN DYNAMIC.FOR" f`NH* Dyn_Inp.For -- Dynamic Input routines & other miscellaneous routinesJ* Pat Rankin, May'88* i*4 Cli_Present ( label )/* i*4 Cli_Get_Value ( label, result, reslen )2* 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 )8* i*4 Add_Inp_Element ( size, list#_adr, indx, string )4* i*4 Put_Inp_Element ( size, list, indx, string )8* i*4 Search_Inp_List ( size, list, target, wildcard )4* i*4 Expand_Inp_List ( list_size, list, new_adr )* i*4 Output ( string )* " Block_Output ( string )* " Flush_Output ( )+* " Open_Output ( default_name, width )2* l Disable_Installed_Privs ( disabled_privs )%* i*4 PutMsg ( facility, sts, stv ).* i*4 Parse_Node ( infile, outfile, outlen )#* l Node_Available ( nodename )K* i $ Parse_Keywords( qual_name, keywrd_count, keywords, synonyms, masks)*0 INTEGER *4 FUNCTION Cli_Present ( label )/ ! Call CLI$PRESENT with signalling disabled. implicit none C input: CHARACTER *(*) labelC 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_PresentB INTEGER *4 FUNCTION Cli_Get_Value ( label, result, reslen )1% ! Call CLI$GET_VALUE with signalling disabled. implicit none C input: CHARACTER *(*) label C output: CHARACTER *(*) result INTEGER *2 reslenC functions: INTEGER *4 CLI$GET_VALUE EXTERNAL LIB$SIG_TO_RET$ CALL LIB$ESTABLISH( LIB$SIG_TO_RET) reslen = 06 Cli_Get_Value = CLI$GET_VALUE( label, result, reslen) RETURN END !of Cli_Get_ValueE INTEGER *4 FUNCTION Cli_Parse_Command ( tables, verb, prompt ) !? ! Fetch use&r's command line and parse it. If he used "RUN",= ! there was no chance to supply one, so prompt for it now. ! implicit noneC constant:7 INCLUDE '($FSCNdef)/nolist' !filescan defs7 INCLUDE '($CliVERBdef)/nolist' !cli verb defsA*- INCLUDE '($CliSERVdef)/nolist' !cli service defs> PARAMETER CLI$K_GETCMD = '00000001'x !get command line9 INCLUDE 'f_inc:Dsc.F' !descriptor defs3 STRUCTURE /clirq/ !cli reques't blockA BYTE rqtype/0/, rqindx/0/, rqflags/0/, rqstat /0/ INTEGER *4 %FILL(1) /0/G 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:B EXTERNAL tables !command tables [set command/obj]A C(HARACTER *(*) verb, prompt !command verb and prompt strings C local:? RECORD /dsc_d/ parse !descriptor for dynamic stringA RECORD /clirq/ cmd !command interface request block9 RECORD /fscn/ fscn !item list for $filescan5 INTEGER *4 sts !return status valueC functions:( INTEGER *4 SYS$CLI, CLI$DCL_PARSE1 EXTERNAL LIB$SIG_TO_RET, LIB$GET_COMMAND@ CALL LIB$ESTABLISH( LIB$SIG_TO_RET) !suppress error signa)lsC get command line? cmd.rqtype = CLI$K_GETCMD !request is 'get command line' sts = SYS$CLI( cmd,,)A IF ( sts ) THEN !ok => cli available & verb wasn't "RUN"HC invoked via symbol => have command line (which might be empty)?C [might also be invoked via mcr or dcl; that's ok]D 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 IF1C prepend verb and parse the command line2 CALL STR$CONCAT( parse, verb, ' ', cmd.rdesc)( sts = CLI$DCL_PARSE( parse, tables)? ELSE ! RUN (might be "no cli present" [CLI$_INVREQTYP])HC invoked via run => get a substitute command line from the user3 sts = CLI$DCL_PARSE(, tables, LIB$GET_COMMAND,8 & + LIB$GET_COMMAND, prompt) END IF Cli_Parse_Command = sts RETURN END !of Cli_Parse_Command9 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 stsC functions:-, INTEGER *4 Cli_Get_Value, OTS$CVT_TI_L result = 0% sts = Cli_Get_Value( key, value, ln)4 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 ) !9 ! 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: CHA-RACTER *(*) qualifC 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, clistsC functions:- INTEGER *4 Cli_Present, Cli_Get_Value,' & Add_Inp_Element INTRINSIC LEN list_cnt = 0 sts = Cli_Present( qualif) IF ( sts ) THEN4 clists = Cli_Get_Value( qua.lif, buffer, buflen); negate = ( (clists .AND. 1) .EQ. 1 .AND. buflen .GT. 06 & .AND. buffer(:buflen) .EQ. '-' )9 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))1 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 noneC constant:? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptorsD PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size RECORD /dsc/ list(*) INTEGER indx C output: CHARACT0ER *(*) result INTEGER *2 reslen C local: INTEGER *4 stsC functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS, LEN, MIN1 IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THEN sts = SS$_SUBRNG ELSEC result = list(indx)1 sts = STR$COPY_DX( result, %REF(list(indx)))1 reslen = MIN( list(indx).d_len, LEN(result)) END IF Get_Inp_Element = sts RETURN END !of Get_Inp_Element INTEGER *4 FUNCTION: & 1 Add_Inp_Element ( size, list_adr, indx, string ) !@ ! Store a string in a dynamic array of descriptors, expanding ! it if necessary. ! implicit noneC constant:D PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size, list_adr INTEGER indx CHARACTER *(*) string C local: INTEGER *4 stsC functions:2 INTEGER *4 Expand_Inp_List, Put_Inp_Element INTRINSIC ABS sts = 1 IF ( ABS(indx2) .GT. size ) THEN+ sts = Expand_Inp_List( size, list_adr); IF ( sts .AND. ABS(indx) .GT. size ) sts = SS$_SUBRNG END IF IF ( sts )G & sts = Put_Inp_Element( size, %VAL(list_adr), ABS(indx), string) Add_Inp_Element = sts RETURN END !of Add_Inp_ElementG INTEGER *4 FUNCTION Put_Inp_Element ( size, list, indx, string ) !6 ! Store a string in a dynamic array of descriptors. ! implicit noneC constant:? INCLUDE 'f_inc:Dsc.F' 3 !($DSCdef) descriptorsD 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 stsC functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS1 IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THEN sts = SS$_SUBRNG ELSEC list(indx) = string1 sts = STR$COPY_DX( %REF(list(indx)), string) END IF4 Put_Inp_Element = sts RETURN END !of Put_Inp_ElementH INTEGER FUNCTION Search_Inp_List ( size, list, target, wildcard ) !C ! Search an array of dyanamic string descriptors for a specifiedB ! string; return its index if found, 0 otherwise. [If the listF ! size is negative then return the negative of the index if found.] ! implicit noneC constant:? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptors C input: INTEGER *4 size R5ECORD /dsc/ list(*) CHARACTER *(*) target LOGICAL wildcard C local:K RECORD /dsc_d/ last_target !pre-initialized dynamic string descriptor INTEGER indx, abs_size LOGICAL found, reverse DATA indx /0/! SAVE indx !, last_targetC functions: INTEGER *4 STR$MATCH_WILD5 INTEGER STR$COMPARE, STR$CASE_BLIND_COMPARE INTRINSIC ABS5 IF ( STR$COMPARE( target, last_target) .NE. 0 ) THEN found = .FALSE.6 reverse = ( size .LT. 0 ) abs_size = ABS(size) indx = 05*(old) IF ( reverse ) indx = 1 !skip "-"6 DO WHILE ( indx .LT. abs_size .AND. .NOT. found ) indx = indx + 1K found = LEN(target) .NE. 0 !(require explicit match for null string)D & .AND. STR$COMPARE( target, list(indx)) .EQ. 0 IF ( .NOT. found )H & found = STR$CASE_BLIND_COMPARE( target, list(indx)) .EQ.0# IF ( .NOT. found .AND. wildcard )H & 7 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 ) !2 ! Expand a dynamic array of string descriptors. ! implicit noneC constant:? INCLU8DE 'f_inc:Dsc.F' !($DSCdef) descriptorsD PARAMETER eLEMENT_SIZE = 8, !size of descriptor0 & eXPANSION_INCREMENT = 10 C input:C input/output: INTEGER *4 list_size INTEGER *4 list C local:K RECORD /dsc_d/ empty_dynamic !pre-initialized dynamic string descriptor INTEGER loop/ INTEGER *4 new_adr, new_size, old_size,% & address, stsC functions:* INTEGER *4 9 LIB$GET_VM, LIB$FREE_VM,K & OTS$MOVE3 !MOVC3 but without 65535 byte limit INTRINSIC MINF new_size = list_size + eXPANSION_INCREMENT !increase by 10 slots4 sts = LIB$GET_VM( new_size * eLEMENT_SIZE, new_adr) IF ( sts ) THEN old_size = list_size IF ( old_size .GT. 0 ) THEN1 sts = OTS$MOVE3( %VAL(old_size * eLEMENT_SIZE),: & %VAL(list), %VAL(new_adr)) IF ( sts )G & sts = LIB$FREE_VM( old_s:ize * eLEMENT_SIZE, %VAL(list)) END IF%C fill in empty (new) entries0 address = new_adr + old_size * eLEMENT_SIZEA 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 noneC constant:E INCLUDE '($SSdef)/nolist' !system service status codes: INCLUDE '($RMSdef)/nolist' !RMS status codes@ INCLUDE '($FABdef)/nolist' !file-access-block defsB INCLUDE '($RABdef)/nolist' !record-access-block defs> INCLUDE '($NAMdef)/nolist' !file name block defs5 INCLUDE '($DEVdef)/nolist' !device defsD 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 = 10C additional entries below:D INTEGER *4 Block_Output, !use $write instead of $putJ & Flush_Output, !update output with $flushO & Open_Output, = !explicitly open an output fileM & Close_Output ! " close the " "C global input:6 COMMON /output_usropn/ usropn_routine, usropn_contextI INTEGER *4 usropn_routine /0/, !address of routine to process -P & 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 !, rabC functi?ons:- INTEGER *4 Cli_Present, Cli_Get_Value,% & OTS$CVT_TI_L,1 & SYS$CREATE, SYS$CONNECT,8 & SYS$PUT, SYS$WRITE, SYS$FLUSH,3 & SYS$CLOSE, SYS$DISCONNECT,& & LIB$PUT_OUTPUT" INTRINSIC LEN, MIN, ICHAR IF ( is_open ) THENC set up record buffer len_tmp = LEN(string) rab.rab$w_rsz = len_word! rab.rab$l_rbf = %LOC(string)&C write reco@rd & check results retry_count = 0+ DO WHILE ( SYS$PUT( rab) .EQ. RMS$_RSA: & .AND. retry_count .LT. rETRY_LIMIT )A 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?J & .AND. rab.rab$l_stv .EQ. SS$_EXDISKQUOTA ) !due to quota?A & sts = SYS$PUT( rab) !if so, try again ELSEAEC [ no explicit open was performed (or it was unsuccessful) ]" sts = LIB$PUT_OUTPUT( string) END IF Output = sts RETURN**$ ENTRY Block_Output ( string ) !B ! Use block i/o instead of record i/o; asynchronous contortions9 ! 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 B( sts .EQ. RMS$_EXT !did we fail to extend?F & .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**0 ENTRY Open_Output ( default_name, width ) !7 ! Open output file and determine desired line width.< ! C If the width has not been specified on the command lineA ! then use the default value: tty width for terminals, 80 forE ! mailbox or network channels, 132 otherwise (ie, for disk files). !C ! 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', filenDame, filnamlen) END IF"C initialize File Access BlockF CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0...A fab.fab$l_fop = FAB$M_MXV .OR. FAB$M_SQO .OR. FAB$M_TEF !options6 fab.fab$b_fac = FAB$M_PUT !write access/!-note: shr.shrget is incompatable with fop.tefB!- fab.fab$b_shr = FAB$M_SHRGET !others can readH!-!- & .OR. FAB$M_SHRPUT .OR. FAB$M_UPI .OR. FAB$M_MSEA fab.fab$b_rat = FAB$M_CR !implied caErriage return9 fab.fab$b_rfm = FAB$C_VAR !variable length IF ( filnamlen .GT. 0 ) THEN; len_tmp = MIN( filnamlen, '00FF'x) !max length is 2558 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 = %FLOC(default_name) !default name address; fab.fab$l_nam = %LOC(nam) !link NAM with FAB C initialize file NAMe blockM 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 BlockF CALL LIB$MOVC5( 2, rAB_PROTOTYPE, 0, RAB$C_BLN, rab) !bid,bln,0...; rab.rab$l_rGop = 0 !no special record options- rab.rab$l_fab = %LOC(fab) !link to FAB" IF ( usropn_routine .NE. 0 ) THENFC kludge to transparently provide useropen-like functionality;IC issue a call-back prior to $create (return status ignored):CC call 'usropn_routine'( usropn_context, fab, rab, nam)0 arglist(0) = 4 !4 args in list arglist(1) = usropn_context arglist(2) = %LOC(fab) arglist(3) = %LOC(rab) argHlist(4) = %LOC(nam)3 CALL LIB$CALLG( arglist, %VAL(usropn_routine)) END IFHC disable any privileges that this image was installed with that the,C user doesn't have in his 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 )6C if any pIrivileges were removed, restore them now< IF ( removed_privs(1) .NE. 0 .OR. removed_privs(2) .NE. 0 )B & 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 ) THEN7 IF ( (fab.fab$l_dev .AND. DEV$M_TRM) .NE. 0 ) THEN ln = ICHAR(nam.nam$tJ_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_stsK4 if ( sts .eq. RMS$_NORMAL ) sts = 1 !SS$_NORMAL is_open = .false. Close_Output = sts RETURNL END !of Output, Block_Output, Flush_Output, Open_Output & Close_OutputB 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 noneC constant:< INCLUDE '($JPIdef)/nolist' !job & process info= INCLUDE 'f_inc:Itm.F' L !item list structure C output:8 INTEGER *4 disabled_privs(2) !privilege mask C local:3 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$_CURPRIV% 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 M = ITM_K_END_OF_LIST imagpriv(1) = 0 imagpriv(2) = 0 CALL SYS$GETJPIW(,,, privs,,,)8 disabled_privs(1) = imagpriv(1) .AND. .NOT. procpriv(1)8 disabled_privs(2) = imagpriv(2) .AND. .NOT. procpriv(2)% disable = ( disabled_privs(1) .NE. 0. & .OR. disabled_privs(2) .NE. 0 ) IF ( disable )C & CALL SYS$SETPRV( %VAL(0), disabled_privs, %VAL(0),)" Disable_Installed_Privs = disable RETURN% END !of Disable_Installed_Privs8 INTEGER *4 FUNCTIONN 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,) ROETURN END !of PutMsgB INTEGER *4 FUNCTION Parse_Node ( in_name, outname, outlen ) !$ ! Use RMS to extract a node name. ! implicit noneC 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_DEVF &P .OR. NAM$M_EXP_DIR .OR. NAM$M_EXP_NAMEH & .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 stsC functions: INTEGER *4 SYS$PARSE) INTQRINSIC LEN, MIN, INDEX, ZEXTF CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0...C len_tmp = MIN( LEN(in_name), '00FF'x) !max length is 2558 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 blockF CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !bid,bln,0...C len_tmp = MIN( LEN(work_string), '00FF'x) !max length is R255> nam.nam$b_ess = len_byte !expanded string size> nam.nam$l_esa = %LOC(work_string) !expanded string areaD nam.nam$b_nop = NAM$M_SYNCHK !options: syntax check only sts = SYS$PARSE( fab) IF ( sts ) THEN8 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: S len_tmp = len_tmp - 2 !drop punctuation ("::") END IF3 ELSE IF ( (nam.nam$l_fnb .AND. fILE_NAME_BITS)2 & .EQ. NAM$M_EXP_NAME ) THENBC no punctuation present -- use name field as nodename len_tmp = ZEXT(nam.nam$b_name)( CALL STR$COPY_R( work_string, len_tmp,5 & %VAL(nam.nam$l_name)) ELSEGC missing node name: return "RMS-W-NOD, error in node name"> sts = RMS$_NOD .AND. .NOT. '00000007'x !setT 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 ) !A ! Determine whether the specified node is part of the cluster. ! implicit noneC constant: INCLUDE '($SYUIdef)/nolist' C input: CHARACTER *(*) nodename C local: LOGICAL avail INTEGER *4 sts, memberC functions: INTEGER *4 LIB$GETSYI8 IF ( LEN(nodename) .EQ. 0 .OR. nodename .EQ. ' ' ) THEN avail = .TRUE. ELSE member = 07 sts = LIB$GETSYI( SYI$_CLUSTER_MEMBER, member,,, ,& & nodename)' avail = ( (member .AND. 1).EQ. 1 ) END IF Node_Avail = avail RETURN END !of Node_AvailD V INTEGER *4 FUNCTION Parse_Keywords( qual_name, keywrd_count,E & keywords, synonyms, masks) !; ! Parse for a set of keywords and set up a mask longword. ! based on their corresponding mask values. ! implicit noneC constant:8 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 Wlocal: CHARACTER *32 qual_tmp INTEGER *2 ln INTEGER idx0 INTEGER *4 exp_incl, exp_excl, imp_excl,- & result, sts, tmpstsC functions: INTEGER *4 Cli_Present INTEGER LIB$MATCH_COND result = 0 sts = Cli_Present( qual_name) IF ( sts ) THEN4 exp_incl = 0 !explicitly included4 exp_excl = 0 !explicitly excluded4 imp_excl = 0 !implicitly excluded DO idx = 0, keXywrd_count2 CALL STR$TRIM( qual_tmp, keywords(idx), ln)8 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))0 IF ( LIB$MATCH_COND( tmpsts, CLI$_PRESENT,E & CLI$_NEGATED, CLI$_DEFAUYLTED)/ & .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 NOALLA 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_Keywordsww SHR$_OPENOUT) !not output error & .eq. 0 )K if ( ok ) msgvec(1) = msgvec(1) .and. .not. 7 !set severity to 'warning'* call SYS$PUTMSG( msgvec,, fACILITY_NAME,)B if ( ok ) status = status .or. 1 !transform into 'success'6 status = status .or. '10000000'x !message seen return end !of Give_Signalww \, '00FF'x) !max length is 255> nam.nam$b_ess = len_byte !expanded string size> nam.nam$l_esa = %LOC(work_string) !expanded string areaD nam.nam$b_nop = NAM$M_SYNCHK !options: syntax check only sts = SYS$PARSE( fab) IF ( sts ) THEN8 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 ac ]cess control string ELSE: len_tmp = len_tmp - 2 !drop punctuation ("::") END IF3 ELSE IF ( (nam.nam$l_fnb .AND. fILE_NAME_BITS)2 & .EQ. NAM$M_EXP_NAME ) THENBC no punctuation present -- use name field as nodename len_tmp = ZEXT(nam.nam$b_name)( CALL STR$COPY_R( work_string, len_tmp,5 & %VAL(nam.nam$l_name)) ELSEGC missing node name: return "RMS-W-NOD, error in node name"> sts = RMS$_N^OD .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 ) !A ! Determine whether the specified node is part of the cluster.D ! Used by XSHOQUE_ to decide whether to display 'host unavailable'# ! when it shows a stopped queue. ! implicit noneC constant: INCLUDE '($SYIdef)/nolist' C input: CHARACTER *(*) nodename C local: LOGICAL avail INTEGER *4 sts, member INTEGER standalone /0/ SAVE standaloneC functions: INTEGER *4 LIB$GETSYI IF ( standalone ) THEN:C known to be non-clustered, so always return True avail = .TRUE.= ELSE IF ( LEN(noden `ame) .EQ. 0 .OR. nodename .EQ. ' ' ) THENNC assumed non-cluster, so return True unless we're sure it's a cluster avail = (standalone .NE. 2) ELSE member = 07 sts = LIB$GETSYI( SYI$_CLUSTER_MEMBER, member,,, ,& & nodename)' avail = ( (member .AND. 1).EQ. 1 )OC additional code added to support standalone system w/ SCSNODE defined" IF ( standalone .EQ. 0 ) THEN IF ( avail ) THEN4 standalone = 2 !now known to bea a cluster0 ELSE !check whether we're part of a cluster9 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_AvailD INTEGER *4 FUNCTION Parse_Keywords( qual_name, keywrd_count,E & b keywords, synonyms, masks) !; ! Parse for a set of keywords and set up a mask longword. ! based on their corresponding mask values. ! implicit noneC constant:8 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 idx0 IcNTEGER *4 exp_incl, exp_excl, imp_excl,- & result, sts, tmpstsC functions: INTEGER *4 Cli_Present INTEGER LIB$MATCH_COND result = 0 sts = Cli_Present( qual_name) IF ( sts ) THEN4 exp_incl = 0 !explicitly included4 exp_excl = 0 !explicitly excluded4 imp_excl = 0 !implicitly excluded DO idx = 0, keywrd_count2 CALL STR$TRIM( qual_tmp, keywords(idx), ln)8 sts = Cli_P dresent( 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))0 IF ( LIB$MATCH_COND( tmpsts, CLI$_PRESENT,E & CLI$_NEGATED, CLI$_DEFAULTED)/ & .GT. 0 ) sts = tmpsts END IF END IeF IF ( sts ) THEN& exp_incl = exp_incl .OR. masks(idx)> exp_excl = exp_excl .AND. .NOT. masks(idx) !clear NOALLA 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_Keywordsww