* FindFile.For -- file search routines. * Pat Rankin, Nov'88 * i*4 Rms_Find_File ( filespec, default_name, filename, filnamlen, fnb ) * " Rms_Parse_File ( filespec, default_name, filename, filnamlen, fnb ) * " Rms_Find_File_End ( ) * " Rms_Parse_File_End ( parse_release_flag ) * INTEGER *4 FUNCTION Rms_Find_File ( filespec, default_name, & filename, filnamlen, fnb ) ! ! Search for a file (alternative to LIB$FIND_FILE). ! ! Caveats: search lists are not handled properly. ! Calls to Parse_File should not be intermixed with ! calls to Find_File. ! implicit none C constant: INCLUDE '($RMSdef)/nolist' !rms status codes INCLUDE '($FABdef)/nolist' !file-access-block defs INCLUDE '($NAMdef)/nolist' !file name block defs INCLUDE '($DEVdef)/nolist' !device characteristics defs INCLUDE 'f_inc:Dsc.F' !descriptor defs PARAMETER aLLOC_AMOUNT = NAM$C_BLN + 2 *(NAM$C_MAXRSS + 1) C additional entries below: INTEGER *4 Rms_Parse_File, !$parse but don't $search & 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_name 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 ) 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_dflt C functions: INTEGER STR$COMPARE INTEGER *4 SYS$PARSE, SYS$SEARCH, & LIB$GET_VM, LIB$FREE_VM, & LIB$SCOPY_R_DX, STR$COPY_DX, STR$FREE1_DX INTRINSIC LEN, MIN, ZEXT do_search = .TRUE. GOTO 100 ** ENTRY Rms_Parse_File ( filespec, default_name, & filename, filnamlen, fnb ) ! ! $parse but don't $search. ! do_search = .FALSE. * 100 CONTINUE IF ( .NOT. init_done ) THEN do_parse = .TRUE. prev_spec.d_len = 0 !length is 0 prev_spec.d_typ = DSC$K_DTYPE_T !type is text string (ascii) prev_spec.d_cls = DSC$K_CLASS_D !class is dynamic prev_spec.d_adr = 0 !address is NULL prev_dflt = prev_spec !another null dynamic string CALL LIB$MOVC5( 0, %VAL(0), 0, FAB$C_BLN, fab) !zero out fab 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 ) THEN CALL STR$COPY_DX( prev_spec, filespec) !copy the file-spec len_word = MIN( prev_spec.d_len, '00FF'x) !max length is 255 fab.fab$b_fns = len_byte !file name size fab.fab$l_fna = prev_spec.d_adr !file name address 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) 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. C allocate chunk of memory for nam plus expanded & resultant strings C (note: an extra byte [for trailing NUL if desired] is allocated C to both of the filename buffers) len_word = NAM$C_MAXRSS !maximum filename length sts = LIB$GET_VM( aLLOC_AMOUNT, mem_chunk) !bln + 2 * (maxrss + 1) IF ( sts ) THEN CALL LIB$MOVC5( 0, %VAL(0), 0, aLLOC_AMOUNT, !zero new memory & %VAL(mem_chunk) ) !(by choice, not necessity) prev_nam = fab.fab$l_nam IF ( prev_nam .EQ. 0 ) THEN !first time C link NAM to FAB fab.fab$l_nam = %LOC(nam) !address of nam ELSE C the previous NAM now becomes the Related File NAM IF ( .NOT. do_search ) THEN C 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 IF CALL LIB$MOVC3( NAM$C_BLN, %VAL(prev_nam), & %VAL(mem_chunk) ) !(beginning of mem chunk) fab.fab$b_dns = 0 !remove default name END IF C 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) nam.nam$l_esa = mem_chunk + NAM$C_BLN !(middle part of mem chunk) nam.nam$b_ess = len_byte !NAM$C_MAXRSS nam.nam$l_rsa = nam.nam$l_esa + (len_word + 1) !(last part of mem chunk) nam.nam$b_rss = len_byte !NAM$C_MAXRSS IF ( prev_nam .NE. 0 ) & nam.nam$l_rlf = mem_chunk !(copy of previous nam) C parse the file-spec sts = SYS$PARSE( fab) IF ( (nam.nam$l_fnb .AND. NAM$M_PPF).NE. 0 ) & do_search = .FALSE. IF ( do_search ) & do_search = ( (fab.fab$l_dev .AND. DEV$M_DIR).NE. 0 & .OR. (nam.nam$l_fnb .AND. (NAM$M_EXP_DIR & .OR. NAM$M_SEARCH_LIST)).NE. 0 ) ELSE !unexpected problem 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 ) THEN C 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)) fnb = nam.nam$l_fnb !filename status bits Rms_Find_File = sts RETURN ** ENTRY Rms_Find_File_End ( ) ! ! Release resources (dynamically allocated memory). ! release_memory = .TRUE. GOTO 900 ** 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 ) 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 IF 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 RETURN END !of Rms_Find_File, Rms_Parse_File, & Rms_Find_File_End, Rms_Parse_File_End