PROGRAM SDTREE * * Alan L. Zirkle Naval Surface Weapons Center * Code K53 * Dahlgren, Virginia 22448 * IMPLICIT INTEGER (A-Z) CHARACTER*256 DEFDIR CHARACTER*64 DEFDISK CHARACTER*128 TITLE COMMON /ENVIRON_/ LDEFDIR,LDEFDISK,DEFDIR,DEFDISK COMMON /TITLE_/ LTITLE,TITLE CALL ENVIRONMENT IF (INDEX(DEFDIR(1:LDEFDIR),'.').EQ.0) THEN CALL DIR_READ('[000000]'//DEFDIR(2:LDEFDIR-1),1) ELSE DO I=LDEFDIR-1,1,-1 IF (DEFDIR(I:I).EQ.'.') GO TO 10 ENDDO 10 DEFDIR(I:I) = ']' CALL DIR_READ(DEFDIR(1:LDEFDIR-1),1) ENDIF CALL START_DISPLAY END SUBROUTINE ENVIRONMENT IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) PARAMETER ( dispsize = 512 ) ! Max number of leaves in directory tree CHARACTER*256 DEFDIR CHARACTER*64 DEFDISK CHARACTER*128 TITLE CHARACTER*128 LINES(dispsize) ! 128 must be .GE. 4*(MD+5) INTEGER*2 LINELEN(dispsize) INTEGER*2 CHARBUF(2) COMMON /LINES_/ MD,LINELEN,LINES COMMON /ENVIRON_/ LDEFDIR,LDEFDISK,DEFDIR,DEFDISK COMMON /TITLE_/ LTITLE,TITLE COMMON /SMGL_CHAR/ CHARBUF CHARACTER*5 SGS_VERSION DATA MD / 13 / ! First 13 characters of directory name are displayed. STATUS = LIB$GET_SYMBOL('PARAM',DEFDIR,LDEFDIR) IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS)) IF (DEFDIR(1:LDEFDIR).EQ.'$') THEN sgs_version = '3.0' L = STR_LEN(SGS_VERSION) CALL LIB$PUT_LINE(' SDTREE Version '//SGS_VERSION(1:L)// 1 ' ',1,2) CALL EXIT ENDIF LDEFDISK = INDEX(DEFDIR,':') DEFDISK(1:LDEFDISK) = DEFDIR(1:LDEFDISK) LDEFDIR = LDEFDIR - LDEFDISK DEFDIR(1:LDEFDIR) = DEFDIR(LDEFDISK+1:LDEFDISK+LDEFDIR) TITLE = DEFDISK(1:LDEFDISK)//DEFDIR(1:LDEFDIR) LTITLE = MIN(128,LDEFDISK+LDEFDIR) CALL SMGL_GET_TERMINAL_SETTINGS IF (CHARBUF(2).EQ.132) MD = 26 END SUBROUTINE DIR_READ(DIRNAME,LISTCOLUMN) IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) CHARACTER*(*) DIRNAME CHARACTER*80 DIRENTRY CHARACTER*39 SUBDIRNAME CHARACTER*40 LIST(listsize,5) COMMON /LIST_/ CURR(5),SIZE(5),FLAG(5),LMAX(5),LIST COMMON /READ_/ DIRENTRY COMMON /LINES_/ MD SIZE(LISTCOLUMN) = 0 LMAX(LISTCOLUMN) = 1 IF (.NOT. AZ_OPEN(DIRNAME // '.DIR') ) RETURN 10 IF (.NOT. AZ_READ() ) RETURN LENGTH = ICHAR(DIRENTRY(4:4)) + 4 COL = INDEX(DIRENTRY(5:LENGTH),'.') + 5 IF (DIRENTRY(COL:LENGTH).NE.'DIR') GO TO 10 SUBDIRNAME = DIRENTRY(5:COL-2) IF (DIRNAME.EQ.'[000000]000000'.AND. 1 SUBDIRNAME.EQ.'000000') GO TO 10 I = SIZE(LISTCOLUMN) + 1 IF (I.LE.listsize) THEN LIST(I,LISTCOLUMN) = SUBDIRNAME // CHAR(COL-6) SIZE(LISTCOLUMN) = I LMAX(LISTCOLUMN) = MAX( LMAX(LISTCOLUMN) , MIN(MD,COL-6) ) GO TO 10 ELSE CALL AZ_CLOSE ENDIF END SUBROUTINE START_DISPLAY IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) PARAMETER ( dispsize = 512 ) ! Max number of leaves in directory tree CHARACTER*128 TITLE CHARACTER*40 LIST(listsize,5) CHARACTER*128 LINES(dispsize) CHARACTER*1 ESC / 27 / INTEGER*2 LINELEN(dispsize) EXTERNAL STAR_EXIT COMMON /TITLE_/ LTITLE,TITLE COMMON /LIST_/ CURR(5),SIZE(5),FLAG(5),LMAX(5),LIST COMMON /CURSOR/ TOPLINE,BOTLINE,CURLINE,CURPOS,ENDLINE COMMON /LINES_/ MD,LINELEN,LINES IF (SIZE(1).NE.0) THEN CALL CONTROL_Y(STAR_EXIT) CALL LIB$ERASE_PAGE(1,1) CALL LIB$SET_SCROLL(1,23) TITLE = ESC // '(B' // CHAR(15) // 1 'Structure of Directory ' // TITLE(1:LTITLE) // 2 ESC // ')0' // CHAR(14) LINES(2) = 'x' LTITLE = 32 + LTITLE LINELEN(2) = 1 CALL LIB$PUT_SCREEN(TITLE(1:LTITLE),1,1) CALL LIB$PUT_SCREEN(LINES(2)(1:LINELEN(2)),2,007) CURPOS = 2 ENDLINE = 2 CALL BUILD_COLUMN_1 CURLINE = ENDLINE BOTLINE = ENDLINE TOPLINE = MAX(ENDLINE-22,1) CALL EDT_MIMIC(0) CALL STAR_EXIT ELSE PRINT 1001 ENDIF 1001 FORMAT ('0No subdirectories exist in this directory.'/) END SUBROUTINE STAR_EXIT IMPLICIT INTEGER (A-Z) CHARACTER*1 ESC / 27 / CALL LIB$PUT_SCREEN( CHAR(15) // ESC // ')B' ,24,1) CALL EXIT END SUBROUTINE BUILD_COLUMN_1 IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) CHARACTER*40 LIST(listsize,5) CHARACTER*256 NEXTLEVEL COMMON /LIST_/ CURR(5),SIZE(5),FLAG(5),LMAX(5),LIST CURR(1) = 0 FLAG(1) = 0 10 CURR(1) = CURR(1)+1 IF (CURR(1).GT.SIZE(1)) RETURN L1 = ICHAR(LIST(CURR(1),1)(40:40)) NEXTLEVEL(1:L1) = LIST(CURR(1),1)(1:L1) CALL DIR_READ(NEXTLEVEL(1:L1),2) IF (SIZE(2).GT.0) CALL BUILD_COLUMN_2(NEXTLEVEL(1:L1)) IF (FLAG(1).NE.CURR(1)) CALL PRINT(1) GO TO 10 END SUBROUTINE BUILD_COLUMN_2(THISLEVEL) IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) CHARACTER*40 LIST(listsize,5) CHARACTER*(*) THISLEVEL CHARACTER*256 NEXTLEVEL COMMON /LIST_/ CURR(5),SIZE(5),FLAG(5),LMAX(5),LIST CURR(2) = 0 FLAG(2) = 0 L1 = LEN(THISLEVEL)+3 NEXTLEVEL(1:L1) = '[.' // THISLEVEL // ']' 10 CURR(2) = CURR(2) + 1 IF (CURR(2).GT.SIZE(2)) RETURN L2 = ICHAR(LIST(CURR(2),2)(40:40)) NEXTLEVEL(L1+1:L1+L2) = LIST(CURR(2),2)(1:L2) L = L1 + L2 CALL DIR_READ(NEXTLEVEL(1:L),3) IF (SIZE(3).GT.0) CALL BUILD_COLUMN_3(NEXTLEVEL(1:L)) IF (FLAG(2).NE.CURR(2)) CALL PRINT(2) GO TO 10 END SUBROUTINE BUILD_COLUMN_3(THISLEVEL) IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) CHARACTER*40 LIST(listsize,5) CHARACTER*(*) THISLEVEL CHARACTER*256 NEXTLEVEL COMMON /LIST_/ CURR(5),SIZE(5),FLAG(5),LMAX(5),LIST CURR(3) = 0 FLAG(3) = 0 L2 = LEN(THISLEVEL) + 1 NEXTLEVEL = THISLEVEL // ']' COL = INDEX(NEXTLEVEL,']') NEXTLEVEL(COL:COL) = '.' 10 CURR(3) = CURR(3) + 1 IF (CURR(3).GT.SIZE(3)) RETURN L3 = ICHAR(LIST(CURR(3),3)(40:40)) NEXTLEVEL(L2+1:L2+L3) = LIST(CURR(3),3)(1:L3) L = L2 + L3 CALL DIR_READ(NEXTLEVEL(1:L),4) IF (SIZE(4).GT.0) CALL BUILD_COLUMN_4(NEXTLEVEL(1:L)) IF (FLAG(3).NE.CURR(3)) CALL PRINT(3) GO TO 10 END SUBROUTINE BUILD_COLUMN_4(THISLEVEL) IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) CHARACTER*40 LIST(listsize,5) CHARACTER*(*) THISLEVEL CHARACTER*256 NEXTLEVEL COMMON /LIST_/ CURR(5),SIZE(5),FLAG(5),LMAX(5),LIST CURR(4) = 0 FLAG(4) = 0 L3 = LEN(THISLEVEL) + 1 NEXTLEVEL = THISLEVEL // ']' COL = INDEX(NEXTLEVEL,']') NEXTLEVEL(COL:COL) = '.' 10 CURR(4) = CURR(4) + 1 IF (CURR(4).GT.SIZE(4)) RETURN L4 = ICHAR(LIST(CURR(4),4)(40:40)) NEXTLEVEL(L3+1:L3+L4) = LIST(CURR(4),4)(1:L4) L = L3 + L4 CALL DIR_READ(NEXTLEVEL(1:L),5) CALL PRINT(4) GO TO 10 END SUBROUTINE PRINT(COLUMN) IMPLICIT INTEGER (A-Z) PARAMETER ( listsize = 256 ) PARAMETER ( dispsize = 512 ) ! Max number of leaves in directory tree CHARACTER*40 LIST(listsize,5) CHARACTER ELEMENT*32,SCREEN*512 ! 32 must be .GE. MD+5 CHARACTER*128 LINES(dispsize) INTEGER*2 LINELEN(dispsize) LOGICAL NOTEND COMMON /LIST_/ CURR(5),SIZE(5),FLAG(5),LMAX(5),LIST COMMON /CURSOR/ TOPLINE,BOTLINE,CURLINE,CURPOS,ENDLINE COMMON /LINES_/ MD,LINELEN,LINES LOGICAL TOOLONG LINE_LEN = 0 DO I=1,COLUMN NOTEND = CURR(I).LT.SIZE(I) IF (FLAG(I).LT.CURR(I)) THEN L = ICHAR(LIST(CURR(I),I)(40:40)) TOOLONG = L .GT. MD IF (TOOLONG) L = MD ELEMENT(4:MD+5) = LIST(CURR(I),I)(1:L) IF (TOOLONG) ELEMENT(L+4:L+4) = '`' ! Diamond IF (I.LT.COLUMN) THEN ELEMENT(L+5:) = 1 'qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq' ELSE IF (I.EQ.4.AND.SIZE(5).GT.0) THEN L = MIN(L+3,MD+2) LMAX(I) = MAX(LMAX(I),L) ELEMENT(L+2:) = 'q>' IF (TOOLONG) ELEMENT(L+2:) = '`>' ENDIF IF (I.GT.1.AND.CURR(I).EQ.1) THEN IF (NOTEND) THEN ELEMENT(1:3) = 'wq ' ELSE ELEMENT(1:3) = 'qq ' ENDIF ELSE IF (NOTEND) THEN ELEMENT(1:3) = 'tq ' ELSE ELEMENT(1:3) = 'mq ' ENDIF ENDIF FLAG(I) = CURR(I) ELSE IF (NOTEND) THEN ELEMENT = 'x' ELSE ELEMENT = ' ' ENDIF ENDIF SCREEN(LINE_LEN+1:LINE_LEN+MD+5) = ELEMENT LINE_LEN = LINE_LEN + LMAX(I) + 5 ENDDO LINE_LEN = STR_LEN(SCREEN(1:LINE_LEN)) IF (LINE_LEN.GT.4*(MD+5)) THEN LINE_LEN = 4*(MD+5) SCREEN(LINE_LEN:LINE_LEN) = '`' ENDIF IF (INDEX(SCREEN(1:LINE_LEN),'_').NE.0) 1 CALL UNDERSCORE(SCREEN,LINE_LEN,4*(MD+5)) IF (CURPOS.LT.23) THEN CURPOS = CURPOS + 1 ELSE CALL LIB$UP_SCROLL() ENDIF CALL LIB$PUT_SCREEN(SCREEN(1:LINE_LEN),CURPOS,007) ENDLINE = MIN( dispsize , ENDLINE + 1 ) LINES(ENDLINE)(1:LINE_LEN) = SCREEN(1:LINE_LEN) LINELEN(ENDLINE) = LINE_LEN END SUBROUTINE UNDERSCORE(STRING,CURLEN,MAXLEN) * Being in the special graphics line drawing mode, underscores in * directory names print as blanks. To prevent this, we must shift * back to normal mode temporarily for the underscore. IMPLICIT INTEGER (A-Z) CHARACTER*(*) STRING CHARACTER*1 SI / 15 / CHARACTER*1 SO / 14 / COL = 1 10 IF (CURLEN.GE.MAXLEN-1) RETURN COL2 = SUBINDEX(STRING(1:CURLEN),COL,'_') IF (COL2.EQ.0) RETURN STRING(COL2:CURLEN+2) = SI // '_' // SO // STRING(COL2+1:CURLEN) CURLEN = CURLEN + 2 COL = COL2 + 3 GO TO 10 END SUBROUTINE PUT_LINE(STRING,LINE_NO,CURSOR_POS) IMPLICIT INTEGER (A-Z) PARAMETER ( dispsize = 512 ) ! Max number of leaves in directory tree CHARACTER*(*) STRING CHARACTER*128 LINES(dispsize) CHARACTER*128 TITLE INTEGER*2 LINELEN(dispsize) COMMON /LINES_/ MD,LINELEN,LINES COMMON /TITLE_/ LTITLE,TITLE COL = 007 IF (LINE_NO.EQ.1) THEN CALL LIB$PUT_SCREEN(STRING // TITLE(1:LTITLE),CURSOR_POS,1) ELSE CALL LIB$PUT_SCREEN(STRING // 1 LINES(LINE_NO)(1:LINELEN(LINE_NO)),CURSOR_POS,COL) ENDIF END SUBROUTINE EDT_MIMIC(END_LINE) IMPLICIT INTEGER (A-Z) BYTE INCHAR CHARACTER KEYCHAR*1 LOGICAL GOLD,BACKUP COMMON /CURSOR/ TOPLINE,BOTLINE,CURLINE,CURPOS,ENDLINE COMMON /CHARACTER/ KEYCHAR COMMON /FLAGS/ GOLD,BACKUP CALL EDT_MIMIC_INITIALIZE(END_LINE) 10 CALL EDT_MIMIC_READ_KEYBOARD(INCHAR) IF (INCHAR.EQ.'10'O) THEN ! BACKSPACE CALL EDT_MIMIC_CURSOR_UP(1) ELSE IF (INCHAR.EQ.'27'O) THEN ! (REFRESH) CALL LIB$SET_SCROLL(1,23) CALL SET_KEYPAD_MODE CALL LIB$PUT_SCREEN(CHAR(27) // '(0') CALL EDT_MIMIC_FILL_SCREEN(TOPLINE,CURPOS) ELSE IF (INCHAR.GE.0) THEN ! ANY 'NORMAL' KEY CALL EDT_MIMIC_TERMINATE RETURN ELSE IF (KEYCHAR.EQ.'A') THEN ! UP ARROW CALL EDT_MIMIC_CURSOR_UP(1) ELSE IF (KEYCHAR.EQ.'B') THEN ! DOWN ARROW CALL EDT_MIMIC_CURSOR_DOWN(1) ELSE IF (KEYCHAR.EQ.'P') THEN ! GOLD GOLD = .TRUE. GO TO 10 ELSE IF (KEYCHAR.EQ.'n') THEN ! SELECT / RESET IF (GOLD) GOLD = .FALSE. ! RESET ELSE IF (KEYCHAR.EQ.'p') THEN ! LINE / OPENLINE IF (.NOT.GOLD) CALL EDT_MIMIC_MOVE_CURSOR(1) ! LINE ELSE IF (KEYCHAR.EQ.'t') THEN ! ADVANCE / BOTTOM IF (.NOT.GOLD) BACKUP = .FALSE. ! ADVANCE IF (GOLD) CALL EDT_MIMIC_FILL_SCREEN(MAX(1,ENDLINE-22),23) ELSE IF (KEYCHAR.EQ.'u') THEN ! BACKUP / TOP IF (.NOT.GOLD) BACKUP = .TRUE. ! BACKUP IF (GOLD) CALL EDT_MIMIC_FILL_SCREEN(1,1) ! TOP ELSE IF (KEYCHAR.EQ.'x') THEN ! SECTION / FILL IF (.NOT.GOLD) CALL EDT_MIMIC_MOVE_CURSOR(16) ! SECTION ENDIF GOLD = .FALSE. GO TO 10 END SUBROUTINE EDT_MIMIC_INITIALIZE(END_LINE) IMPLICIT INTEGER (A-Z) CHARACTER UPINDEX*2,DOWNINDEX*2,NULLINDEX*4 CHARACTER REPEAT_ON*5,REPEAT_OFF*5 CHARACTER*1 ESCAPE / 27 / COMMON /CURSOR/ TOPLINE,BOTLINE,CURLINE,CURPOS,ENDLINE COMMON /REPEAT/ REPEAT_ON,REPEAT_OFF COMMON /INDICES/ UPINDEX,DOWNINDEX,NULLINDEX COMMON /FLAGS/ GOLD,BACKUP DATA GOLD,BACKUP / .FALSE.,.FALSE. / DATA UPINDEX,DOWNINDEX,NULLINDEX / 'EM','ED','E[1K' / DATA REPEAT_ON,REPEAT_OFF / 'E[?8h','E[?8l' / CALL LIB$SET_SCROLL(1,23) CALL SET_KEYPAD_MODE UPINDEX(1:1) = ESCAPE DOWNINDEX(1:1) = ESCAPE NULLINDEX(1:1) = ESCAPE REPEAT_ON(1:1) = ESCAPE REPEAT_OFF(1:1) = ESCAPE IF (END_LINE.GT.0) THEN ENDLINE = END_LINE CALL EDT_MIMIC_FILL_SCREEN(1,1) ELSE CALL LIB$SET_CURSOR(CURPOS,1) ENDIF RETURN ENTRY EDT_MIMIC_TERMINATE CALL LIB$SET_SCROLL(1,24) CALL RESET_KEYPAD_MODE CALL LIB$SET_CURSOR(24,1) CALL LIB$PUT_SCREEN(REPEAT_ON) END SUBROUTINE EDT_MIMIC_MOVE_CURSOR(N_LINES) IMPLICIT INTEGER (A-Z) LOGICAL GOLD,BACKUP COMMON /FLAGS/ GOLD,BACKUP IF (.NOT.BACKUP) THEN CALL EDT_MIMIC_CURSOR_DOWN(N_LINES) ELSE CALL EDT_MIMIC_CURSOR_UP(N_LINES) ENDIF END SUBROUTINE EDT_MIMIC_CURSOR_UP(N_LINES) IMPLICIT INTEGER (A-Z) CHARACTER UPINDEX*2,DOWNINDEX*2,NULLINDEX*4 COMMON /INDICES/ UPINDEX,DOWNINDEX,NULLINDEX COMMON /CURSOR/ TOPLINE,BOTLINE,CURLINE,CURPOS,ENDLINE DATA INDEX / 'EM' / IF (CURLINE.EQ.1) RETURN N = MIN(N_LINES,CURLINE-1) DO I=1,N CURLINE = CURLINE - 1 IF (CURPOS.LE.8.AND.TOPLINE.GT.1) THEN TOPLINE = TOPLINE - 1 BOTLINE = BOTLINE - 1 CALL PUT_LINE(UPINDEX,TOPLINE,1) ELSE CURPOS = CURPOS - 1 ENDIF ENDDO CALL LIB$SET_CURSOR(CURPOS,1) END SUBROUTINE EDT_MIMIC_CURSOR_DOWN(N_LINES) IMPLICIT INTEGER (A-Z) CHARACTER UPINDEX*2,DOWNINDEX*2,NULLINDEX*4 COMMON /INDICES/ UPINDEX,DOWNINDEX,NULLINDEX COMMON /CURSOR/ TOPLINE,BOTLINE,CURLINE,CURPOS,ENDLINE DATA INDEX / 'ED' / IF (CURLINE.EQ.ENDLINE) RETURN N = MIN(N_LINES,ENDLINE-CURLINE) DO I=1,N CURLINE = CURLINE + 1 IF (CURPOS.GE.17.AND.BOTLINE.LT.ENDLINE) THEN TOPLINE = TOPLINE + 1 BOTLINE = BOTLINE + 1 CALL PUT_LINE(DOWNINDEX,BOTLINE,23) ELSE CURPOS = CURPOS + 1 ENDIF ENDDO CALL LIB$SET_CURSOR(CURPOS,1) END SUBROUTINE EDT_MIMIC_FILL_SCREEN(TOP_LINE,CURSOR_POS) IMPLICIT INTEGER (A-Z) CHARACTER UPINDEX*2,DOWNINDEX*2,NULLINDEX*4 COMMON /INDICES/ UPINDEX,DOWNINDEX,NULLINDEX COMMON /CURSOR/ TOPLINE,BOTLINE,CURLINE,CURPOS,ENDLINE TOPLINE = TOP_LINE BOTLINE = MIN(TOPLINE+22,ENDLINE) CUR_LINE = TOPLINE - 1 CUR_POS = 0 DO I=TOPLINE,BOTLINE CUR_POS = CUR_POS + 1 CUR_LINE = CUR_LINE + 1 CALL PUT_LINE(NULLINDEX,CUR_LINE,CUR_POS) CALL LIB$ERASE_LINE ENDDO IF (CUR_POS.LT.23) CALL LIB$ERASE_PAGE CURPOS = MIN(CURSOR_POS,CUR_POS) CURLINE = TOPLINE + CURPOS - 1 CALL LIB$SET_CURSOR(CURPOS,1) END SUBROUTINE EDT_MIMIC_READ_KEYBOARD(INCHAR) IMPLICIT INTEGER (A-Z) BYTE INCHAR CHARACTER*1 KEYCHAR LOGICAL FIRST_CALL / .TRUE. / CHARACTER*1 INPUT_CHAR,INPUT_FLAG CHARACTER*5 REPEAT_ON,REPEAT_OFF LOGICAL*1 INPUT_READY COMMON /CHARACTER/ KEYCHAR COMMON /REPEAT/ REPEAT_ON,REPEAT_OFF COMMON /TTIN_/ INPUT_CHAR,INPUT_FLAG,INPUT_READY CALL LIB$PUT_SCREEN(REPEAT_ON) IF (FIRST_CALL) THEN FIRST_CALL = .FALSE. 10 CALL SET_INPUT_ALARM ENDIF IF (.NOT.INPUT_READY) CALL GO_HIBERNATE KEYCHAR=INPUT_CHAR IF (INPUT_FLAG.EQ.'.') THEN INCHAR = -1 ELSE INCHAR = ICHAR(INPUT_CHAR) IF (INCHAR.NE.26.AND.INCHAR.NE.23. 1 .AND.INCHAR.NE.ICHAR(' ')) GO TO 10 ENDIF CALL SET_INPUT_ALARM CALL LIB$PUT_SCREEN(REPEAT_OFF) END