C+ C NAME: C SD C PURPOSE: C Changing directory. C (Alternative to the VMS LIBCD command procedure) C CATEGORY: C Utility C CALLING SEQUENCE: program SD C INPUT: C (the input is read from the DCL command line as foreign input) C C /action indicates action to be take (only first two chars are tested) C (none) Move to directory P1 C /HELP Display help screen C /TOP Move to top directory on current disk C /UP Move to parent directory C /DOWN Move to child directory P1 C /SIDE Move to sister directory P1 C /TREE Display directory tree from P1 downward C /JUMP Jump to one of the displayed directories C /SWITCH Back to previous directory C /FAST Short cut C For >DOWN and >SIDE a list of valid directories is given if C P1 = "", followed by a prompt (unless there is only one C candidate directory to go to). C P1 indicates directory (exception: P2=? will display a brief HELP) C -- Omitting the argument is the equivalent of a C SHOW DEFAULT C -- The syntax of the argument is as for the SET DEFAULT C command. But: C -- If the disk is not explicitly given, the square brackets C may be omitted C -- If no disk is specified, the current disk is searched. C If the destination is not found the SYS$LOGIN disk and C the SYS$SCRATCH disk are searched C? -- The argument may be a global symbol (the content of C? the symbol is used as destination) C -- The argument may be a logical assigned to a directory C (e.g. SYS$LOGIN, SYS$SCRATCH) C INCLUDE: include 'dirspec.h' include 'filparts.h' C CALLS: C itrim, uppercase, Str2Str, LocFirst, LocFirstLen, iGetDefaultDir, iCheckDirectory C iSetFileSpec, iGetFileSpec, iGetTopDirectory, iGetDirectoryFragment, iFile2Dir C iSearch, Say, AskI4, ForeignArg, OSExitCmd, iGetSymbol, iSetSymbol C iGetLogical, cInt2Str, LocLast C SD_HELP, SD_PREPJUMP, SD_PROMPT, SD_JUMP,SD_TREE, SD_SCAN_CHECK, SD_FAST C SD_DISPJUMP, bInRoot C SIDE EFFECTS: C Change prompt to indicate current directory C PROCEDURE: C Identical to the LIBCD.COM procedure except for minor differences. C > The TREE option displays the directory tree from the current directory C downwards (i.e. does not invoke the symbols LOGINTREE and SCRATCHTREE) C > The change of prompt is done on program exit by issuing the DCL C 'SET PROMPT' command as argument to OSExitCmd. C MODIFICATION HISTORY: C OCT-1991/SEPT-1992, Paul Hick (UCSD), C F77 version of the DCL procedure LIBCD.COM C NOV-1994, Paul Hick (UCSD), major revamp C- parameter (nVar=5) character cVar(nVar)*40 ! Foreign input array character cArg *50 character cTree *25000 character cDefDir *(FIL__LENGTH) ! Current dir character cDir *(FIL__LENGTH) character cWild *(FIL__LENGTH) character cDisk *40 character cScratch*40 character cJumpSym*12 character cSay * 2 /'sd'/ character cInt2Str*14 integer Str2Str logical bDir logical bStay logical bSetPrev logical bSide logical bInRoot if (iGetDefaultDir(cDefDir) .eq. 0) ! Get current directory & call Say(cSay,'E','Error','in iGetDefaultDir') call SD_PREPJUMP(cDefDir,iJump,nJump) ! Get iJump,nJump iVar = nVar ! Get arguments and switches cVar(1) = 'quiet' call ForeignArg(' ',iVar,cVar,cArg) iArg = itrim(cArg) iVar = itrim(cVar(1)) iVar = iVar+Str2Str(cVar(2),cVar(1)(iVar+1:)) call uppercase(cArg) if ( LocFirst(cSwitch//'HE',cArg) .ne. 0 .or. & LocFirst(cSwitch//'?' ,cArg) .ne. 0) then call SD_HELP if (iVar .eq. 0) call SD_PROMPT(cDefDir,.FALSE.,.TRUE.,.FALSE.) end if bDir = LocFirst(cSwitch//'DI',cArg) .ne. 0 ! Directory listing bStay = LocFirst(cSwitch//'ST',cArg) .ne. 0 ! Stay in current directory bSetPrev= LocFirst(cSwitch//'PR',cArg) .eq. 0 ! Update LIB__SD_PREVIOUS ! Display tree if (LocFirst(cSwitch//'SH',cArg) .ne. 0) call SD_PROMPT(cDefDir,bDir,bStay,.FALSE.) if (LocFirst(cSwitch//'TR',cArg) .ne. 0) then cDir = cDefDir if (iCheckDirectory(cVar(1)) .eq. 1) I = iGetFileSpec(0,FIL__DIRECTORY,cDir) call SD_TREE(.TRUE.,cDir,cTree) ! Display tree call SD_PROMPT(cDefDir,bDir,bStay,.FALSE.) end if if (LocFirst(cSwitch//'FA',cArg) .ne. 0) then ! Explicitly force a fast search first call SD_FAST(cDefDir,cVar(1),bDir,bStay,cTree) end if if (LocFirst(cSwitch//'UP',cArg) .ne. 0) then ! To parent directory if (bInRoot(cDefDir)) call Say(cSay,'E',cDefDir,'root directory has no parent') call SD_PROMPT(cFullParent(:iFullParent),bDir,bStay,bSetPrev) end if if (LocFirst(cSwitch//'TO',cArg) .ne. 0) then ! To top directory if (bInRoot(cDefDir)) call Say(cSay,'E',cDefDir,'already in root') call SD_PROMPT(cDir(:iGetTopDirectory(cDir)),bDir,bStay,bSetPrev) end if if (LocFirst(cSwitch//'SW',cArg) .ne. 0) then ! To previous directory if (iGetSymbol('LIB__SD_PREVIOUS',cDir) .eq. 0) cDir = cDefDir call SD_PROMPT(cDir,bDir,bStay,bSetPrev) end if if (LocFirst(cSwitch//'JU',cArg) .ne. 0) then ! Jump if (nJump .eq. -1) call SD_PROMPT(cDefDir,bDir,bStay,.FALSE.) call SD_DISPJUMP(cDefDir) Jump = max(iJump,0) if (nJump .gt. 0) call AskI4(' ******** Which directory ?$0$'//cInt2Str(nJump,cScratch),Jump) Jump = min(max(Jump,0),nJump) I = iGetSymbol(cJumpSym(Jump),cDir) call SD_PROMPT(cDir,bDir,bStay,Jump .ne. iJump) end if bSide = LocFirst(cSwitch//'SI',cArg) .ne. 0 ! Down or side ways if (bSide .and. bInRoot(cDefDir)) call Say(cSay,'E',cDefDir,'root has no sister directories') if (bSide .or. LocFirst(cSwitch//'DO',cArg) .ne. 0) then I = 0 if (LocFirst(cParent(:iParent),cVar(1)) .eq. 1) I = iParent if (LocFirst(cDivide(:iDivide),cVar(1)) .eq. 1) I = iDivide J = iVar if (J .gt. I) J = I+LocFirstLen(cDivide,cVar(1)(I+1:J))-1 if (bSide) then iWild = Str2Str(cFullParent,cWild) else iWild = Str2Str(cFullDefault,cWild) end if if (J .gt. I) iWild = iWild+Str2Str(cVar(1)(I+1:J),cWild(iWild+1:)) iWild = iWild+Str2Str('*'//cDirExt,cWild(iWild+1:)) I = 0 iStat = -11 ! Get all directory files do while (iSearch(iStat,cWild,cDir) .eq. 1) iStat = 10 iWild = iFile2Dir(cDir,cDir) if (.not. bSide .or. cDir .ne. cDefDir) then iWild = iSetFileSpec(cDir) write (*,'(5X,A15)') cDisk(:iGetDirectoryFragment(3,cDisk)) I = I+1 end if end do if (I .eq. 0) call Say(cSay,'E','DOWN_SIDE','no directories matching '//cWild) if (I .gt. 1) then cDisk = ' ' write (*,'(3X,17(1H*),A,$)') ' Which directory ? ' read (*,'(A)') cDisk if (cDisk .eq. ' ') call SD_PROMPT(cDefDir,bDir,bStay,.FALSE.) call uppercase(cDisk) end if if (bSide) then iWild = Str2Str(cFullParent,cWild) else iWild = Str2Str(cFullDefault,cWild) end if iWild = iWild+Str2Str(cDisk ,cWild(iWild+1:)) iWild = iWild+Str2Str('*'//cDirExt,cWild(iWild+1:)) iStat = -11 ! Check whether selected directory exists do while (iSearch(iStat,cWild,cDir) .eq. 1) iStat = 10 iWild = iFile2Dir(cDir,cDir) if (.not. bSide .or. cDir .ne. cDefDir) call SD_PROMPT(cDir,bDir,bStay,bSetPrev) end do call Say(cSay,'E','DOWN_SIDE','no directories matching '//cWild) end if if (iVar .eq. 0) then ! Re-scan and show default call SD_FAST(cDefDir,cVar(1),bDir,bStay,cTree) call SD_PROMPT(cDefDir,bDir,bStay,.FALSE.) end if if ( LocFirst('*' ,cVar(1)) .ne. 0 .or. & LocFirst(cSingle ,cVar(1)) .ne. 0 .or. & LocFirst('...' ,cVar(1)) .ne. 0 ) & call Say(cSay,'E',cVar(1),'wildcards are not permitted') !------- ! Parsing the input argument itself deals with cases like: ! [HELIOS.TEMP] i.e. an explicit directory name of an existing dir ! $FOR i.e. a logical representing an existing directory if (iCheckDirectory(cVar(1)) .eq. 1) then if (iGetFileSpec(FIL__NAME,FIL__NAME,cDir) .eq. 0) then iDir = iGetFileSpec(0,FIL__DIRECTORY,cDir) if (cVar(1)(:iVar) .eq. cFullDefault(:iFullDefault) .or. & cDir .eq. cVar(1) .or. & cDir .ne. cDefDir) & call SD_PROMPT(cDir,bDir,bStay,bSetPrev) end if end if !------- ! Adding leading and trailing chars will deal with arguments like: ! HELIOS = cd [HELIOS] move to top dir (if it exists) ! .TEMP.TEST = cd [.TEMP.TEST] move to subdirectory (if it exists) ! NOTE: for directory on a foreign host the parse function does not check ! the existence of the directory. In that case, explicitly check for ! a directory file. iDir = 0 iDir = iDir+Str2Str(cLead,cDir(iDir+1:)) iDir = iDir+Str2Str(cVar(1),cDir(iDir+1:)) iDir = iDir+Str2Str(cTrail ,cDir(iDir+1:)) if (iCheckDirectory(cDir) .eq. 1) then iDir = iGetFileSpec(0,FIL__DIRECTORY,cDir) call SD_PROMPT(cDir,bDir,bStay,bSetPrev) else !------- ! Should intercept top directory on UNIX; shouldn't do anything on VAX ! HELIOS = cd /HELIOS/ iDir = 0 iDir = iDir+Str2Str(cLeadRootDivide,cDir(iDir+1:)) iDir = iDir+Str2Str(cVar(1) ,cDir(iDir+1:)) iDir = iDir+Str2Str(cTrail ,cDir(iDir+1:)) if (iCheckDirectory(cDir) .eq. 1) then iDir = iGetFileSpec(0,FIL__DIRECTORY,cDir) call SD_PROMPT(cDir,bDir,bStay,bSetPrev) end if end if !------- ! Check for concealed logicals (other than the login and the scratch disk): ! SYS$COMMON cd CASS01$DKA300:[SYS0.SYSCOMMON] ! SYS$COMMON:[SYSHLP] cd CASS01$DKA300:[SYS0.SYSCOMMON.SYSHLP] cDir = cVar(1) ! Look for device delimiter iDir = 0 if (iDevi .gt. 0) iDir = LocLast(cDevi,cDir) if (iDir .gt. 0) then I = iCheckDirectory(cHome//cDevi) iDir = iDir-1+iDevi if (cDisk(:iGetFileSpec(0,FIL__DEVICE,cDisk)) .ne. cDir(:iDir)) then I = iCheckDirectory(cTemp//cDevi) if (cDisk(:iGetFileSpec(0,FIL__DEVICE,cDisk)) .ne. cDir(:iDir)) then I = iGetLogical(cDir,cDir) if (I .ne. 0) then ! Concealed logical cDir(I+1:) = cVar(1)(iDir+1:) I = iSetFileSpec(cDir) ! Clean up translation I = iGetFileSpec(0,FIL__DIRECTORY,cDir) ! Pick up clean directory name call SD_PROMPT(cDir,bDir,bStay,bSetPrev) end if end if end if end if !------- Short cut: only name of destination directory, no full path ! Syntax 1: FD scan tree under current top directory ! Syntax 2: FD dir search for 'dir' under current top directory ! Syntax 3: FD [top] scan tree under top directory [top] ! Syntax 4: FD [top]dir search for 'dir' under top directory [top] ! Syntax 5: FD [top] dir same as FD [top]dir cDir = cVar(1) call SD_FAST(cDefDir,cDir,bDir,bStay,cTree) ! Modifies cDir!! iDsk = LocFirst(cDivide(:iDivide),cVar(1)) if (iDsk .ne. 0) then iDir = 0 iDir = iDir+Str2Str(cLead ,cDir(iDir+1:)) iDir = iDir+Str2Str(cVar(1)(:iDsk-1),cDir(iDir+1:)) iDir = iDir+Str2Str(cTrail ,cDir(iDir+1:)) iDir = iDir+Str2Str(cVar(1)(iDsk+iDivide:),cDir(iDir+1:)) call SD_FAST(cDefDir,cDir,bDir,bStay,cTree) end if iDir = iSetFileSpec(cVar(1)) iDsk = iGetFileSpec(0,FIL__DEVICE,cDisk) iDir = 0 iDir = iDir+Str2Str(cLead ,cDir(iDir+1:)) iDir = iDir+Str2Str(cVar(1),cDir(iDir+1:)) iDir = iDir+Str2Str(cTrail ,cDir(iDir+1:)) if (iDsk .eq. 0) then iDsk = iSetFileSpec(cDefDir) iDsk = iGetFileSpec(0,FIL__DEVICE,cWild) iDsk = iCheckDirectory(cHome//cDevi) iDsk = iGetFileSpec(0,FIL__DEVICE,cDisk) if (cWild .ne. cDisk) then if (iCheckDirectory(cHome//cDevi//cDir) .eq. 1) & call SD_PROMPT(cHome//cDevi//cDir,bDir,bStay,bSetPrev) end if iDsk = iCheckDirectory(cTemp//cDevi) iDsk = iGetFileSpec(0,FIL__DEVICE,cScratch) if (cWild .ne. cDisk .and. cDisk .ne. cScratch) then if (iCheckDirectory(cTemp//cDevi//cDir) .eq. 1) & call SD_PROMPT(cTemp//cDevi//cDir,bDir,bStay,bSetPrev) end if end if call Say(cSay,'E',cVar(1)(:iVar),'directory does not exist') end subroutine SD_HELP include 'dirspec.h' include 'filparts.h' character cLogin *25 character cScratch*25 iLogin = iCheckDirectory(cHome//cDevi) iLogin = iGetFileSpec(0,FIL__DIRECTORY,cLogin) iScratch = iCheckDirectory(cTemp//cDevi) iScratch = iGetFileSpec(0,FIL__DIRECTORY,cScratch) call Say(' ','I',' ', & ' Login dir : '//cLogin(:iLogin)//' Scratch dir : '//cScratch(:iScratch)// & '#---'// & '#--- The argument of SIDE and DOWN may be abbreviated ---'// & '#fd Show default'// & '#fd '//cSwitch//'? This list'// & '#fd '//cSwitch//'help This list'// & '#fd dirspec Move to directory "dirspec"'// & '#fd '//cSwitch//'fa*st dirspec Move to subdirectory "dirspec"'// & '#fd '//cSwitch//'to*p Move to top directory'// & '#fd '//cSwitch//'up Move to parent directory'// & '#fd '//cSwitch//'do*wn dirspec Move to child directory'// & '#fd '//cSwitch//'si*de dirspec Move to sister directory'// & '#fd '//cSwitch//'ju*mp Move to directory selected from list of previous working dirs'// & '#fd '//cSwitch//'sw*itch Move back to previous working directory'// & '#fd '//cSwitch//'tr*ee dirspec Display directory tree') return end C INPUTS: C cDefDir current working directory C cWild string indicating destination directory C bDir C bStay C cTree scratch string C OUTPUTS: C none subroutine SD_FAST(cDefDir,cWild,bDir,bStay,cTree) character cDefDir*(*) character cWild*(*) logical bDir character cTree*(*) logical bStay character cDir*120 character cTmp*120 character cMatch*120 character cVolNam*20 character cSay*7 /'sd_fast'/ integer Str2Str include 'dirspec.h' include 'filparts.h' I = 0 !------- ! Check for device: UD1: (VMS) or C: (DOS) if (iDevi .ne. 0) I = LocFirst(cDevi,cWild) !------- ! Check for trail character for directories if (I .lt. len(cWild)) I = I+LocLast(cTrail,cWild(I+1:)) !------- ! If I not equal zero then cWild may contain an absolute directory, ! e.g. UD1:[PHICK]TEST (VMS) or C:TEST (VMS/DOS) indicating to look ! for a subdirectory TEST in the directory tree of UD1:[PHICK] or C: if (I .ne. 0) then cDir = cWild(:I) ! Pick up the absolute directory/device if (cOpSys .ne. OS__VMS) then! On DOS make sure C: receives a \ if (cDir(I:I) .ne. cTrail) then J = Str2Str(cFullRoot,cDir(I+1:)) end if end if cTmp = cDir J = iCheckDirectory(cDir) do while (cDir .ne. cNoWhere .and. J .eq. 0) J = iSetFileSpec(cDir) J = iGetParentDirectory(cDir) J = iCheckDirectory(cDir) end do if (J .eq. 0) then ! No existing directory in cWild I = iSetFileSpec(cDefDir) else cTmp = cTmp(itrim(cDir)+1:) J = itrim(cTmp) if (J .gt. 0) then J = J-iTrail J = J+Str2Str(cDivide,cTmp(J+1:)) end if J = J+Str2Str(cWild(I+1:),cTmp(J+1:)) cWild = cTmp end if if (cWild(:iFullRoot) .eq. cFullRoot) cWild = cWild(iFullRoot+1:) else I = iSetFileSpec(cDefDir) end if !------- ! Pick up the directory establishing the tree in which to look for a ! subdirectory. cMatch is either cDefDir or it is the directory ! extracted from cWild (iCheckDirectory above calls iSetFileSpec). I = iGetFileSpec(0,FIL__DIRECTORY,cMatch) !------- ! First check whether cMatch is part of a directory tree that the user ! is allowed to save to disk. ! ! Each user can store tree info for his own home directory, so we need ! to check whether cMatch is part of the user's home directory tree. ! ! For the moment the root directory on each drive in DOS/WIN can be ! saved. On Linux the root / can be saved from the root account. ! On VMS the tree on optical disks can be saved. cVolNam = ' ' cTree = ' ' if (cOpSys .eq. OS__VMS) then I = iGetTopDirectory(cDir) ! Top dir of cMatch I = iGetLogical(cHome,cTmp) ! Home directory if (cDir .ne. cTmp) then ! cMatch is not in home tree !------- ! Check for an optical disk. The symbol LIB__OD_UNIT ! must be defined (e.g. by mounting the OD using LIBDEV.COM). I = iGetSymbol('LIB__OD_UNIT', cTmp) if (I .ne. 0) then ! OD mounted I = iGetFileSpec(0,FIL__DEVICE,cDir) ! Device of cMatch if (cDir .eq. cTmp) then ! If device the same I = I+Str2Str(cFullRoot,cDir(I+1:1)) I = iGetSymbol('LIB__OD_VOLNAM', cVolNam) end if end if end if else if (cOpSys .eq. OS__DOS) then I = iGetTopDirectory(cDir) ! C:\ else I = iGetSymbol('USER',cTmp) if (I .eq. 4 .and. cTmp .eq. 'root') then cDir = cFullRoot ! / else I = iGetLogical(cHome,cTmp) if (cTmp(:I) .ne. cMatch(:I)) I = 0 if (I .ne. 0) cDir = cTmp end if end if !------- ! If I > 0 then cMatch is part of a tree that the user is allowed to save. ! If tree info exists, pick it up in cTree. If it doesn't exist yet, ! then create the tree info and save it. Then, if cWild .ne. ' ' ! change directory and exit. if (I .gt. 0) then ! In user's home tree if (cWild .ne. ' ') call SD_FILE(0,cDir,cVolNam,cTree) ! Read tree if (cTree .eq. ' ') then ! If not available call SD_TREE(.FALSE.,cDir,cTree)! Create tree info call SD_FILE(1,cDir,cVolNam,cTree)! Save tree info end if if (cWild .eq. ' ') then ! No CD required call SD_PROMPT(cDefDir,bDir,bStay,.FALSE.) else if (cTree .eq. ' ') stop 'SD_FAST: oops 1' call SD_SCAN(cDefDir,cDir,cTree,cWild,cDir) if (cDir .eq. ' ') return call SD_PROMPT(cDir,bDir,bStay,.TRUE.) end if end if !------- ! At this point we know that cMatch is in a part of a tree the user ! is not allowed to save. Exit if cWild is the null string. Also note ! that DOS/WIN never reaches this point if (cOpSys .eq. OS__DOS) stop 'SD_FAST: oops 2' if (cWild .eq. ' ') then call Say(cSay,'W',cMatch,'scan not permitted') call SD_PROMPT(cDefDir,bDir,bStay,.FALSE.) end if ! Tree info may still be available to move to subdirectory cWild. ! On VMS and Unix we first check whether we are in some other users ! home tree. if (cOpSys .eq. OS__VMS) then I = iSetFileSpec(cMatch) I = iGetTopDirectory(cDir) else I = iGetLogical(cHome,cTmp) ! User home directory I = iSetFileSpec(cTmp) I = iGetParentDirectory(cTmp) ! Parent probably contains all ! user directories if (cTmp(:I) .eq. cMatch(:I)) then ! Might be in a user home tree I = I+LocFirst(cDivide,cMatch(I+1:)) cDir = cMatch(:I) ! Potential user directory else ! Pick the root instead cDir = cFullRoot end if end if call SD_FILE(0,cDir,cVolNam,cTree) if (cTree .ne. ' ') then call SD_SCAN(cDefDir,cDir,cTree,cWild,cDir) if (cDir .ne. ' ') call SD_PROMPT(cDir,bDir,bStay,.TRUE.) end if return end subroutine SD_TREENAME(cTopDir,cVolNam,cTreeSym) character cTopDir*(*) character cVolNam*(*) character cTreeSym*(*) character cTmp*120 integer Str2Str include 'dirspec.h' include 'filparts.h' !------- ! Establish prefix cTreeSym = 'SD_' if (cOpSys .eq. OS__VMS) cTreeSym = 'LIB__SD_' I = itrim(cTreeSym) I = I+iGetSymbol('HOST', cTreeSym(I+1:))! Append host (if symbol available) if (cVolNam .ne. ' ') then ! Identify optical disk by volume name I = I+Str2Str('OD_' , cTreeSym(I+1:)) I = I+Str2Str(cVolNam, cTreeSym(I+1:)) else J = iSetFileSpec(cTopDir) J = iGetFileSpec(0,FIL__DEVICE,cTmp) if (iNode .gt. 0) then J = LocFirst(cNode,cTmp) if (J .ne. 0) cTmp(J:J+iNode-1) = '__________' end if if (iDevi .gt. 0) then J = LocFirst(cDevi,cTmp) if (J .ne. 0) cTmp(J:J+iDevi-1) = '__________' end if I = I+Str2Str(cTmp, cTreeSym(I+1:)) J = iGetDirectoryFragment(0,cTmp) J = LocFirst(cDivide,cTmp) do while (J .ne. 0) cTmp(J:J+iDivide-1) = '__________' J = LocFirst(cDivide,cTmp) end do I = I+Str2Str(cTmp, cTreeSym(I+1:)) end if return end C+ C NAME: C SD_SCAN C PURPOSE: C CALLING SEQUENCE: subroutine SD_SCAN(cDefDir,cTreeTop,cTree,cDest,cDir) C INPUTS: C cTreeTop character*(*) top directory of cTree C (full directory spec) C cTree character*(*) tree info C cDefDir character*(*) reference directory (= working dir) C cDest character*(*) abbreviation destination spec C OUTPUTS: C cDir character*(*) full directory spec C cDest character*(*) value NOT preserved C CALLS: C itrim, iSetFileSpec, iGetFileSpec, iGetTopDirectory, iGetDirectoryFragment, C LocLast, LocFirst, iGetSymbol, iSetSymbol, Say C INCLUDE: C include 'dirspec.h' C PROCEDURE: C > The destination spec cDest identifies the destination directory: C 1. Incomplete directory name: C cDest = 'text' refers to any directory `text*.dir' C 2. Complete directory name: C cDest = 'text.' refers to a directory `text.dir' C 3. Chain of directory names, with incomplete last fragment: C cDest = 'phick.c' refers to a directory [*.phick.*]c*.dir C 3. Chain of directory names, with complete last fragment: C cDest = 'phick.c.' refers to a subdirectory [*.phick.*]c.dir C- character cDefDir *(*) character cTreeTop*(*) character cTree *(*) character cDest *(*) character cDir *(*) character cDestLast*20 character cDefFrst*20 character cDefLast*20 character cDestSave*120 character cAbove*120 character FDLAST*40 character cSay*7 /'sd_scan'/ parameter (nFrag = 10) character cDestFrag(nFrag)*20 integer iDestFrag(nFrag) integer ILfrag(nFrag) logical bFull logical bFullFrag logical bSameTop logical bAgain integer SD_SCAN_CHECK integer Str2Str integer iDirPrev(0:100) real RVEC(1) include 'dirspec.h' include 'filparts.h' N = itrim(cTree) bSameTop = itrim(cDefDir) .gt. itrim(cTreeTop) if (bSameTop) then ! Current top = Tree top? cAbove = cDefDir bSameTop = cAbove .eq. cTreeTop do while (cAbove .ne. cNoWhere .and. .not. bSameTop) I = iSetFileSpec(cAbove) I = iGetParentDirectory(cAbove) bSameTop = cAbove .eq. cTreeTop end do end if if (bSameTop) then I = iSetFileSpec(cTreeTop) ! Last fragment of tree top iDefFrst = iGetDirectoryFragment(3,cDefFrst) I = iSetFileSpec(cDefDir) ! Last fragment of def dir iDefLast = iGetDirectoryFragment(3,cDefLast) end if iDest = itrim(cDest) ! Spec for requested destination iDot = LocLast(cDivide,cDest) ! Last dot !------- ! A trailing dot in cDest implies we want to look for an exact match. ! Use it to set bFull then drop the trailing dot. bFull = iDot .gt. 0 .and. iDot .eq. iDest+1-iDivide if (bFull) then ! Dot in last position cDest(iDot:) = ' ' ! Drop trailing dot iDot = LocLast(cDivide,cDest) ! New last dot end if !------- ! If there still is a dot present (NOT a trailing dot) and the top of ! the destination is the same as the top of the working directory, and ! the top fragment is specified in the request than drop it (it is ! redundant). if (iDot .ne. 0 .and. bSameTop) then iDot = LocFirst(cDivide,cDest) ! First dot ! Drop top fragment from request if (iDefFrst .gt. 0 .and. cDefFrst(:iDefFrst) .eq. & cDest(:iDot-1)) cDest = cDest(iDot+1:) end if iDest = itrim(cDest) ! Length of request iDot = LocLast(cDivide,cDest) ! Last dot in request cDestLast = cDest(iDot+1:iDest) ! Last fragment of request iDestLast = iDest-iDot !------- ! The previous call to FD is stored in symbol LIB__SD_FDLAST. This ! information is used if two conditions are met: ! 1: the name of the top of the reference (= working) directory and the ! top directory of the destination are the same (bSameTop = .TRUE.), and ! 2: the last fragment of the reference (= working) directory is the ! same as as the last fragment of the requested destination ! (i.e. if we are trying to jump between subdirectories with the same ! name in the directory tree attached to the top directory of the ! destination. In that case we look for the next occurence in cTree. ! Otherwise start at beginning of cTree. IL = 0 if (bSameTop) then if (.not. bFull) iDefLast = iDestLast if (cDestLast(:iDestLast) .eq. cDefLast(:iDefLast)) then if (iGetSymbol('LIB__SD_FDLAST',FDLAST) .ne. 0) then ICOM = LocFirst(',',FDLAST) IL = 1 call Str2Flt(FDLAST(ICOM+1:),IL,RVEC) IL = RVEC(1)+1 FDLAST(ICOM:) = ' ' end if end if end if !------ ! By default the directory spec is interpreted as a wildcard ! (bFull = .TRUE.). If the dir spec ends with a dot, it is interpreted ! as a full directory name (i.e. no wildcard is assumed). ILfrst = 0 ! First fragent not found yet iFrag = 0 ! Fragment counter cDestSave = cDest ! Save the full input destination iDestSave = iDest do while (iDest .gt. 0) iDot = LocFirstLen(cDivide(:iDivide),cDest(:iDest)) !------ ! In VMS a leading dot in cDest is stripped off. if (cOpSys .eq. OS__VMS .and. cLead .ne. cDivide(:iDivide) .and. iDot .eq. 1) then cDest = cDest(iDivide+1:) iDest = iDest-iDivide else !------ ! The dir fragments in cDest (separated by cDivide) are ! processed separately. All but the last fragment are assumed ! to be complete fragments. Only the last may be incomplete ! (as determined from bFull) if (iDot .ne. iDest+1) then ! Not the last dir fragment bFullFrag = .TRUE. else ! Last dir fragment bFullFrag = bFull end if cDestLast = cDest(:iDot-1) ! Next (leading) fragment iDestLast = iDot-1 iFrag = iFrag+1 ! Count fragments if (iFrag .gt. nFrag) call Say('SD_SCAN','E','Too','many fragments') cDestFrag(iFrag) = cDestLast iDestFrag(iFrag) = iDestLast if (iDest .gt. iDot) then cDest = cDest(iDot+iDivide:iDest)! Discard leading fragment iDest = iDest-iDot-iDivide+1 else ! All fragments processed iDest = 0 end if !------- ! IL is position just before last occurrence (=0 for new search) bAgain = .TRUE. do while (bAgain) if (bFullFrag) then ! Checking complete fragment I1 = min( & LocFirstLen('('//cDestLast(:iDestLast)//')',cTree(IL+1:N)), & LocFirstLen('('//cDestLast(:iDestLast)//',',cTree(IL+1:N)), & LocFirstLen('('//cDestLast(:iDestLast)//'(',cTree(IL+1:N)) & ) I2 = min( & LocFirstLen(','//cDestLast(:iDestLast)//')',cTree(IL+1:N)), & LocFirstLen(','//cDestLast(:iDestLast)//',',cTree(IL+1:N)), & LocFirstLen(','//cDestLast(:iDestLast)//'(',cTree(IL+1:N)) & ) else ! Checking incomplete fragment I1 = LocFirstLen('('//cDestLast(:iDestLast),cTree(IL+1:N)) I2 = LocFirstLen(','//cDestLast(:iDestLast),cTree(IL+1:N)) end if if (iFrag .eq. 1) then !------ ! cTree was searched starting at IL+1. If IL .ne. 0, the ! leading part of cTree was not searched yet. If the ! fragment was not located in the trailing part, set IL to ! 0 and go back to search the leading part of cTree. bAgain = I1 .eq. N-IL+1 .and. I2 .eq. N-IL+1 .and. IL .ne. 0 if (bAgain) IL = 0 else !----- ! For a second or later fragment, if the fragment is not found ! or if it is found, but is not a subdirectory, then we ! step back one fragment, and continue. bAgain = I1 .eq. N-IL+1 .and. I2 .eq. N-IL+1 if (.not. bAgain) bAgain = SD_SCAN_CHECK(cTree(ILfrag(iFrag-1)+1:IL+min(I1,I2))) .le. 0 if (bAgain) then if (iDest .eq. 0) then cDest = cDestFrag(iFrag)(:iDestFrag(iFrag)) iDest = iDestFrag(iFrag) else cDest = cDestFrag(iFrag)(:iDestFrag(iFrag))//cDivide(:iDivide)//cDest(:iDest) iDest = iDestFrag(iFrag)+iDivide+iDest end if iFrag = iFrag-1 cDestLast = cDestFrag(iFrag) iDestLast = iDestFrag(iFrag) IL = ILfrag(iFrag)+1+iDestLast endif end if end do !------ ! If no match found (can only happen for the first fragment) ! display error message and return. ! When searching for the first fragment a second time, and picking ! up the same first fragment, then also stop (this happens only ! when searching for a multi-fragment destination). if ( (I1 .eq. N-IL+1 .and. I2 .eq. N-IL+1) .or. & (iFrag .eq. 1 .and. IL+min(I1,I2) .eq. ILfrst) ) then if (.not. bFullFrag) then cDestLast(iDestLast+1:) = '*' iDestLast = iDestLast+1 end if call Say(cSay,'W',cDir,'no subdirectory '//cDestSave(:iDestSave)) cDir = ' ' return end if !------ ! If a fragment is found store its position in Tree ! IL is the position of the leading bracket or comma. ! Two additional pieces of informations are needed for multi-fragment searches: ! IL is stored for each fragment in ILfrag. ! ILfrst is the position of the very first fragment in the search. IL = IL+min(I1,I2) if (iFrag .eq. 1 .and. ILfrst .eq. 0) ILfrst = IL ILfrag(iFrag) = IL end if end do !------- ! Set symbol LIB__SD_FDLAST: name of dir-spec, and string position of ! '(' or ',' in cTree, preceeding the location where dir-spec was found. L = 0 L = L+Str2Str(cDestLast,FDLAST(L+1:)) L = L+Str2Str(',' ,FDLAST(L+1:)) L = L+Int2Str(IL-1 ,FDLAST(L+1:)) L = iSetSymbol('LIB__SD_FDLAST',FDLAST(:L),2) !------- ! Scan cTree string until position IL is reached ! The full directory path is built up by concatenating the directory ! names. The result is put in cDir. iDir = Str2Str(cTreeTop,cDir) iDir = iDir-iTrail iDir = iDir+Str2Str(cDivide,cDir(iDir+1:)) IL = IL+1 L = 0 iDirPrev(L) = iDir IPOS = 1+LocFirstLen('(',cTree(2:N)) ICOM = IPOS do while (ICOM .lt. IL) IBR1 = IPOS-1+LocFirstLen('(',cTree(IPOS:N)) IBR2 = IPOS-1+LocFirstLen(')',cTree(IPOS:N)) ICOM = IPOS-1+LocFirstLen(',',cTree(IPOS:N)) ICOM = min(ICOM,IBR1,IBR2) if (ICOM .ne. IPOS) then ! 1st pass: ICOM=IPOS iDir = iDirPrev(L) iDir = iDir+Str2Str(cTree(IPOS:ICOM-1),cDir(iDir+1:)) iDir = iDir+Str2Str(cDivide ,cDir(iDir+1:)) end if IPOS = ICOM+1 if (IPOS .le. IL) then if (ICOM .eq. IBR1) then L = L+1 iDirPrev(L) = iDir else if (ICOM .eq. IBR2) then L = L-1 end if end if end do iDir = iDir-iDivide ! Remove last cDivide iDir = iDir+Str2Str(cTrail,cDir(iDir+1:)) return end integer function SD_SCAN_CHECK(cStr) character cStr*(*) logical bOK L = len(cStr) I = 0 LEVEL = 0 bOK = .TRUE. do while (bOK) IOB = LocFirstLen('(',cStr(I+1:L)) ICB = LocFirstLen(')',cStr(I+1:L)) if (IOB .lt. ICB) then LEVEL = LEVEL+1 else if (ICB .lt. IOB) then LEVEL = LEVEL-1 end if I = I+min(IOB,ICB) bOK = I+1 .le. L .and. LEVEL .gt. 0 end do SD_SCAN_CHECK = LEVEL return end subroutine SD_PROMPT(cNewDef,bDir,bStay,bSetPrev) character cNewDef*(*) logical bDir logical bStay logical bSetPrev include 'dirspec.h' include 'filparts.h' parameter (nMaxPrompt = 23) character cNewDir*80 character cOldDir*80 character cNewDisk*40 character ADD*2 c character ESC /27/ character Qd /34/ character cSay*9 /'sd_prompt'/ character cLogin*40, cScratch*40 if (bStay) then cNewDir = cNewDef if (iCheckDirectory(cNewDef) .eq. 0) call Say(cSay,'E',cNewDir, & 'directory does not exist') iNewDir = iGetFileSpec(0,FIL__DIRECTORY,cNewDir) iNewDir = iSetSymbol('LIB__ANS',cNewDir,2) call EXIT(1) end if I = iCheckDirectory(cHome(:iHome)//cDevi) I = iGetFileSpec(0,FIL__DEVICE,cLogin) I = iCheckDirectory(cTemp(:iTemp)//cDevi) I = iGetFileSpec(0,FIL__DEVICE,cScratch) I = iGetDefaultDir(cOldDir) ! Current default if (iSetDefaultDir(cNewDef) .eq. 0) then! Set New default call SD_CLEANJUMP(cNewDef) cNewDir = cNewDef call Say(cSay,'E',cNewDir,'directory does not exist') end if if (bSetPrev) I = iSetSymbol('LIB__SD_PREVIOUS',cOldDir,2) call SD_JUMP(cOldDir) ! Set default succesful !------- ! On Linux (and Unix?) the iSetDefaultDir does not affect the directory ! after the program exits (it will still be the original working directory. ! The workaround is to write the proper cd command into a scratch file. ! This can be used in a script to change directory, I hope. if (cOpSys .ne. OS__VMS) then cNewDir = cNewDef call OSExitCmd('cd '//cNewDir,1) ! Program exits here end if !------- ! On VMS the iSetDefaultDir does work, but we still have to change the ! prompt. This is done by setting up a 'set prompt' command which ! is executed on program exit. iNewDisk = iGetFileSpec(0,FIL__DEVICE,cNewDisk) iNewDir = iGetDirectoryFragment(0,cNewDir) call lowercase(cNewDir) if (iNewDir .ge. nMaxPrompt) then ! Clip if too long cNewDir = cNewDir(iNewDir-nMaxPrompt+2:iNewDir) iNewDir = nMaxPrompt-1 end if ADD = '? ' if (cNewDisk .eq. cScratch) ADD = '! ' if (cNewDisk .eq. cLogin) ADD = '$ ' cNewDir(iNewDir+1:) = ADD iNewDir = iNewDir+2 if (bDir) I = iOSSpawnCmd('DIR',2) c cNewDir = ESC//'[1m'//cNewDir(:iNewDir)//ESC//'[22m' call OSExitCmd('set prompt ='//Qd//cNewDir(:iNewDir)//Qd,0) return end subroutine SD_JUMP(cOldDir) character cOldDir*(*) parameter (nJumpMax = 9) character cJumpSym*12 character cJump*80 call SD_PREPJUMP(cOldDir,iJump,nJump) if (iJump .ne. -1) return ! Already on list if (nJump .eq. nJumpMax) then do I=1,nJumpMax J = iGetSymbol(cJumpSym(I ),cJump) J = iSetSymbol(cJumpSym(I-1),cJump,2) end do nJump = nJump-1 end if nJump = nJump+1 J = iSetSymbol(cJumpSym(nJump),cOldDir,2) return end subroutine SD_CLEANJUMP(cDir) character cDir*(*) parameter (nJumpMax = 9) character cJumpSym*12 character cJump*80 save iJump, nJump call SD_PREPJUMP(cDir,iJump,nJump) if (iJump .eq. -1) return ! Not on list J = -1 do I=0,nJump K = iGetSymbol(cJumpSym(I),cJump) if (cJump .ne. cDir) then J = J+1 if (I .ne. J) K = iSetSymbol(cJumpSym(J),cJump,2) end if end do do I=J+1,nJump K = iDeleteSymbol(cJumpSym(I),2) end do nJump = J return end subroutine SD_PREPJUMP(cNewDir,iJump,nJump) character cNewDir*(*) integer iJump integer nJump parameter (nJumpMax = 9) character cJump*80 character cJumpSym*12 iJump = -1 nJump = 0 do while (nJump .le. nJumpMax .and. iGetSymbol(cJumpSym(nJump),cJump) .ne. 0) if (cJump .eq. cNewDir) iJump = nJump nJump = nJump+1 end do nJump = nJump-1 return end subroutine SD_DISPJUMP(cDir) character cDir*(*) parameter (nJumpMax = 9) character cJump*80 character cJumpSym*12 I = 0 do while (I .le. nJumpMax .and. iGetSymbol(cJumpSym(I),cJump) .ne. 0) if (cJump .eq. cDir) then write (*,'(7X,A,I1,2A)') '* ',I,' - ',cJump(:itrim(cJump)) else write (*,'(7X,A,I1,2A)') ' ',I,' - ',cJump(:itrim(cJump)) end if I = I+1 end do return end character*12 function cJumpSym(I) integer I character cTemplate*12 /'LIB__SD_DIR0'/ parameter (nJumpMax = 9) if (I .le. nJumpMax) then write (cTemplate(12:12),'(I1)') I cJumpSym = cTemplate end if return end C+ C NAME: C SD_TREE C PURPOSE: C Displays a rudimentary directory tree from the top directory downwards C CALLING SEQUENCE: subroutine SD_TREE(bDisplay,cTopDir,cTree) C INPUTS: C bDisplay .TRUE. : display tree on screen C .FALSE.: don't display (just build cTree) C cTopDir top directory of tree (fully qualified directory name) C OUTPUTS: C cTree string containing tree information in form C (sub1(sub2,sub3(sub4,sub5),sub6)) C On Unix and Dos sub1 will be the null string when C scanning from the root directory downward. C Otherwise sub1 will be the last subdirectory fragment C of cTopDir, i.e. if cTopDir='/mnt/work/temp' then C sub1='temp'. C cTopDir and cTree together provide a complete C description of the directory tree attached to cTopDir. C INCLUDE: include 'dirspec.h' include 'filparts.h' include 'openfile.h' C CALLS: C iFilePath, bOpenFile, iFreeLun, iCheckDirectory, iGetDirectoryFragment C Say, AskYN, iGetFileSpec, Str2Str, iSearch, itrim, iSetFileSpec, LocFirstLen C MODIFICATION HISTORY: C- logical bDisplay character cTopDir*(*) character cTree*(*) character HORIZ*5 /'_____'/ character VERTI*11 /' |________'/ character APP*16 character cTopDisk*40 character NOWDIR*40 character UPDIR*80 character SDIR*80 character SUBSTR*4000 character OUTSTR*132 character cSay*7 /'sd_tree'/ integer Str2Str logical bYN parameter (nNoScan = 20) character cNoScan(nNoScan)*40 character cFile*80 logical bOpenFile iNoScan = 0 if (cOpSys .eq. OS__UNIX .or. cOpSys .eq. OS__LINUX) then iRecl = 0 I = iFilePath(cEnvi//'SYS',0,' ','SD.EXCLUDE',cFile) if (bOpenFile(OPN__TRYINPUT+OPN__ONEPASS+OPN__TEXT+OPN__READONLY,iU,cFile,iRecl)) then I = 0 do while (I .eq. 0 .and. iNoScan .lt. nNoScan) iNoScan = iNoScan+1 read (iU,'(A)',iostat=I) cNoScan(iNoScan) end do if (I .ne. 0) iNoScan = iNoScan-1 iU = iFreeLun(iU) end if end if LENMAX = len(cTree) cTree = ' ' if (iCheckDirectory(cTopDir) .eq. 0) return I = iGetDirectoryFragment(0,NOWDIR) ! Full fragment (no cLead,cTrail) if (cOpSys .ne. OS__DOS .and. index(NOWDIR,cRoot) .eq. 1) then call Say(cSay,'W','yikes','this is a root directory!!') call AskYN(' Are you sure you want to scan the entire drive$no?',bYN) if (.not. bYN) return end if call Say(cSay,'I',cTopDir,'scanning directory tree') iTopDisk = iGetFileSpec(0,FIL__DEVICE,cTopDisk) I = iGetDirectoryFragment(2,UPDIR) ! Parent fragment I = iGetDirectoryFragment(3,NOWDIR) ! Last fragment LENDIR = 0 LENDIR = LENDIR+Str2Str('(' ,cTree(LENDIR+1:)) LENDIR = LENDIR+Str2Str(NOWDIR,cTree(LENDIR+1:)) LENDIR = LENDIR+Str2Str(')' ,cTree(LENDIR+1:)) IDEPTH = LENDIR ! Skip top directory 19 continue ! TR_DIVE: I = 0 I = I+Str2Str(cTopDisk ,OUTSTR(I+1:)) I = I+Str2Str(cLead ,OUTSTR(I+1:)) if (UPDIR .ne. cNoWhere .and. (.not. bNoRoot .or. UPDIR .ne. cRoot) ) then I = I+Str2Str(UPDIR ,OUTSTR(I+1:)) I = I+Str2Str(cDivide,OUTSTR(I+1:)) end if I = I+Str2Str(NOWDIR ,OUTSTR(I+1:)) I = I+Str2Str(cTrail ,OUTSTR(I+1:)) I = I+Str2Str('*'//cDirExt,OUTSTR(I+1:)) I = 0 I = I+Str2Str('(',SUBSTR(I+1:)) iStat = -11 do while (iSearch(iStat,OUTSTR,SDIR) .eq. 1) iStat = 10 !------- ! Check whether directory needs to be excluded (Unix only) K = itrim(SDIR) bYN = .TRUE. do J=1,iNoScan bYN = bYN .and. SDIR(:K) .ne. cNoScan(J) end do if (bYN) then J = iSetFileSpec(SDIR) !------- ! In DOS, SDIR = ' ' for the default ('.') and parent ! ('..') directory. J = iGetFileSpec(FIL__NAME,FIL__NAME,SDIR) if (cOpSys .ne. OS__VMS) then ! If file type = . only then clear the dot if (iGetFileSpec(FIL__TYPE,FIL__TYPE,SDIR(J+1:)) .eq. 1) SDIR(J+1:) = ' ' end if !------- ! On an optical disk (VAX) the root contains a directory ! 000000.DIR. To avoid an infinite loop it is necessary to check ! for this. Note that in DOS, cRoot=' ', i.e. directories with ! file name SDIR = ' ' are intercepted too (not really necessary). if (SDIR .ne. cRoot) then if (I .ne. 1) I = I+Str2Str(',',SUBSTR(I+1:)) I = I+Str2Str(SDIR,SUBSTR(I+1:)) end if else call Say(cSay,'I',SDIR,'excluded') end if end do I = I+Str2Str(')',SUBSTR(I+1:)) if (I .gt. 2) then ! Subdirs found if (LENDIR+I .gt. LENMAX) call Say(cSay,'E','TREE','string not long enough') cTree(IDEPTH+I:LENDIR+I ) = cTree(IDEPTH:LENDIR) c call ShiftStr(IDEPTH,LENDIR,I,cTree)! Needed in MS-Fortran cTree(IDEPTH :IDEPTH+I-1) = SUBSTR(:I) LENDIR = LENDIR+I end if LEFTLEN = LENDIR-IDEPTH+1 if (cTree(IDEPTH:IDEPTH) .eq. ')') then 29 continue ! TR_CLIMB: Up one directory if (LEFTLEN .le. 2) go to 35! TR_SCREEN: LEFT="))" or LEFT=")": Finished !! I = 0 I = I+Str2Str(cLead ,SDIR(I+1:)) I = I+Str2Str(UPDIR ,SDIR(I+1:)) I = I+Str2Str(cTrail,SDIR(I+1:)) I = iSetFileSpec(SDIR) I = iGetDirectoryFragment(2,UPDIR) I = iGetDirectoryFragment(3,NOWDIR) if (cTree(IDEPTH+1:IDEPTH+1) .eq. ')') then ! More than one ")" on a row LEFTLEN = LEFTLEN-1 ! Skip first of a sequence of ")" IDEPTH = IDEPTH+1 go to 29 end if LEFTLEN = LEFTLEN-2 ! Skip ")," IDEPTH = IDEPTH+2 else if (cTree(IDEPTH:IDEPTH) .eq. '(') then I = 0 I = I+Str2Str(cLead ,SDIR(I+1:)) if (UPDIR .ne. cNoWhere) then I = I+Str2Str(UPDIR ,SDIR(I+1:)) I = I+Str2Str(cDivide,SDIR(I+1:)) end if I = I+Str2Str(NOWDIR ,SDIR(I+1:)) I = I+Str2Str(cTrail ,SDIR(I+1:)) I = iSetFileSpec(SDIR) I = iGetDirectoryFragment(0,UPDIR) end if LEFTLEN = LEFTLEN-1 ! Skip "(" IDEPTH = IDEPTH+1 end if IKO = min(LocFirstLen(',',cTree(IDEPTH:LENDIR)), & LocFirstLen(')',cTree(IDEPTH:LENDIR))) NOWDIR = cTree(IDEPTH:IDEPTH+IKO-2) ! Next subdirectory to be searched IDEPTH = IDEPTH+IKO-1 ! Skip subdirectory go to 19 35 continue ! TR_SCREEN: if (.not. bDisplay) return ISTARTLEVEL = 1 write (*,*) cTopDir(:itrim(cTopDir)) 49 continue ! NEXT_SCAN: if (cTree .eq. '()') return IDEPTH = 1 LEFTLEN = LENDIR-IDEPTH+1 LEVEL = 0 OUTSTR = ' ' IOUTSTR = 1 ISAVEOB = 1 NO_OUT = 0 APP = cNoWhere 59 continue ! TR_LINE: IKO = LocFirstLen(',',cTree(IDEPTH:LENDIR)) if (IKO .eq. 1) then ! Complete line write (*,*) OUTSTR(:IOUTSTR) cTree(ISAVEOB+1:) = cTree(IDEPTH+1:LENDIR) LENDIR = ISAVEOB+LENDIR-IDEPTH ISTARTLEVEL = LEVEL go to 49 end if ICB = LocFirstLen(')',cTree(IDEPTH:LENDIR)) if (ICB .eq. 1) then if (NO_OUT .eq. 0) write (*,*) OUTSTR(:IOUTSTR) IPOS = IDEPTH if (LEFTLEN .gt. 1) then IPOS = IPOS+1 if (cTree(IPOS:IPOS) .eq. ',') IPOS = IPOS+1 end if cTree(IPREVOB+1:) = cTree(IPOS:LENDIR) LENDIR = IPREVOB+LENDIR-IPOS+1 ISTARTLEVEL = LEVEL-1 go to 49 end if if (ICB .eq. 2) NO_OUT = 1 IPREVOB = ISAVEOB ISAVEOB = IDEPTH IDEPTH = IDEPTH+1 LEFTLEN = LEFTLEN-1 IKO = min(IKO-1,ICB-1,LocFirstLen('(',cTree(IDEPTH:LENDIR))) LEVEL = LEVEL+1 if (NO_OUT .eq. 0) then if (LEVEL .lt. ISTARTLEVEL-1) APP = ' ' ! Blank space if (LEVEL .eq. ISTARTLEVEL-1) APP = VERTI//HORIZ ! Connection parent - subdir if (IKO .gt. 1) then if (LEVEL .eq. ISTARTLEVEL) APP = ' '//cTree(IDEPTH:IDEPTH+IKO-2)! Top directory if (LEVEL .gt. ISTARTLEVEL) APP = HORIZ//' '//cTree(IDEPTH:IDEPTH+IKO-2) ! Connection parent - subdir end if OUTSTR(IOUTSTR+1:) = APP if (LEVEL .ne. ISTARTLEVEL) IOUTSTR = IOUTSTR+5 IOUTSTR = IOUTSTR+11 IOUTSTR = min(IOUTSTR,132) end if LEFTLEN = LEFTLEN-IKO+1 IDEPTH = IDEPTH+IKO-1 go to 59 end subroutine SD_FILE(MODE,cTopDir,cVolNam,cTree) integer MODE character cTopDir*(*) character cVolNam*(*) character cTree*(*) include 'dirspec.h' include 'openfile.h' !------- ! The directory tree info is written to file in chunks of LSTR chars. ! This is done to allow the LIBCD procedure to read the file (reading very ! long records into a DCL symbol might cause the command buffer to overflow). parameter (LSTR = 900) character cFile*80 character cTreeSym*80 character CTR*80 character cSay*7 /'sd_file'/ logical bOpenFile It = itrim(cTree) if (MODE .eq. 1 .and. It .eq. 0) return ! No tree info available call SD_TREENAME(cTopDir,cVolNam,cTreeSym) I = iFilePath(cEnvi//'TUB',0,' ',cTreeSym(:itrim(cTreeSym))//'.dat',CTR) !------- ! MODE = 0 : read cTree info ! First check the global symbol cTreeSym. If it doesn't exist read the ! file CTR if (MODE .eq. 0) then if (iGetSymbol(cTreeSym,cTree) .eq. 0) then iRecl = 0 if (bOpenFile(OPN__TRYINPUT+OPN__ONEPASS+OPN__TEXT+OPN__READONLY+OPN__NOMESSAGE,iU,CTR,iRecl)) then read (iU,'(A)',iostat=I) cTree do while (I .eq. 0) L = itrim(cTree) read (iU,'(A)',iostat=I) cTree(L+1:) end do iU = iFreeLun(iU) end if if (cTree .eq. ' ') call Say(cSay,'W',cTreeSym,'No tree info available') end if else !------- ! MODE = 2 : write cTree info !------- ! If FD is fired up before a previous run has been concluded, it ! may happen that more than one copy of cFile is created (if the ! first run has one version of cFile still open, then the second ! run can't delete it, and will subsequently create a second version. ! The following do-while loop should clean this up. do while (iSearch(11,CTR,cFile) .eq. 1) if (iOSDeleteFile(cFile) .eq. 0) call Say(cSay,'E',cFile,'error deleting file') end do !------- ! If the total length of the cTree info is less then 256 ! characters it can be stored in a global symbol if (It .lt. 256) then if (iSetSymbol(cTreeSym,cTree,2) .eq. 1) return else I = iDeleteSymbol(cTreeSym,2) end if !------- ! Store the cTree info in the file CTR. Set the protection to ! RWED for System, Owner, Group and World iRecl = min(It,LSTR)/4 if (iRecl*4 .ne. min(It,LSTR)) iRecl = iRecl+1 if (bOpenFile(OPN__TRYINPUT+OPN__ONEPASS+OPN__TEXT+OPN__NEW,iU,CTR,iRecl)) then LL = min(LSTR,It) write (iU,'(A)',iostat=I) cTree(:LL) do while (I .eq. 0 .and. LL .lt. It) L = LL LL = min(L+LSTR,It) write (iU,'(A)',iostat=I) cTree(L+1:LL) end do iU = iFreeLun(iU) if (iOSProtect(CTR,0,0) .eq. 0) call Say(cSay,'W',CTR,'error unprotecting file') if (I .ne. 0) call Say(cSay,'E',cTreeSym,'failed writing tree to file') end if end if return end logical function bInRoot(cDir) ! Input is full dir-spec character cDir*(*) include 'dirspec.h' I = LocFirst(cFullRoot(:iFullRoot),cDir) bInRoot = I .ne. 0 .and. I+iFullRoot-1 .eq. itrim(cDir) return end