Submitted-by: keith@ibmpcug.CO.UK (Keith Jewell) Archive-name: dcl_menu/part1 $! ------------------ CUT HERE ----------------------- $ v='f$verify(f$trnlnm("SHARE_VERIFY"))' $! $! This archive created by VMS_SHARE Version 7.2-007 22-FEB-1990 $! On 12-FEB-1991 07:42:18.38 By user TP $! $! This VMS_SHARE Written by: $! Andy Harper, Kings College London UK $! $! Acknowledgements to: $! James Gray - Original VMS_SHARE $! Michael Bednarek - Original Concept and implementation $! $! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER $! AND EXECUTE AS A COMMAND PROCEDURE ( @name ) $! $! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING: $! 1. DISPLAY_MENU.FOR;5 $! 2. MENU.CLD;30 $! 3. MENU.FOR;120 $! 4. MENU.HLP;6 $! 5. MENU.TXT;2 $! $set="set" $set symbol/scope=(nolocal,noglobal) $f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID")) $e="write sys$error ""%UNPACK"", " $w="write sys$output ""%UNPACK"", " $ if f$trnlnm("SHARE_LOG") then $ w = "!" $ ve=f$getsyi("version") $ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START $ e "-E-OLDVER, Must run at least VMS 4.4" $ v=f$verify(v) $ exit 44 $UNPACK: SUBROUTINE ! P1=filename, P2=checksum $ if f$search(P1) .eqs. "" then $ goto file_absent $ e "-W-EXISTS, File ''P1' exists. Skipped." $ delete 'f'* $ exit $file_absent: $ if f$parse(P1) .nes. "" then $ goto dirok $ dn=f$parse(P1,,,"DIRECTORY") $ w "-I-CREDIR, Creating directory ''dn'." $ create/dir 'dn' $ if $status then $ goto dirok $ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped." $ delete 'f'* $ exit $dirok: $ w "-I-PROCESS, Processing file ''P1'." $ if .not. f$verify() then $ define/user sys$output nl: $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1' PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET( SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:= CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b)); LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION( BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1); IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE; MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1; ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")= 1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF"; POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r); ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1; COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE, "output_file"));ENDPROCEDURE;Unpacker;QUIT; $ delete/nolog 'f'* $ CHECKSUM 'P1' $ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT $ e "-E-CHKSMFAIL, Checksum of ''P1' failed." $ ENDSUBROUTINE $START: $ create 'f' X`09SUBROUTINE DISPLAY_MENU(IVERSION, MODE, CHOICES, N, HELPLIB, X +`09`09LABEL, LABPOS, X +`09`09ROW, COL, HEIGHT, WIDTH, X +`09`09NUMBER, CHOICE) XC+ XC Uses SMG to display and return a selection from a menu. Clears screen XC before and after menu display XC XC ARGUMENTS XC`20 XC The only arguments that must be specified are MODE, CHOICES, N, NUMBER and XC CHOICE. Everything else can be entered as 0 or ' ', to use defaults XC XC IVERSION`09INTEGER`09`09read`09Must = 1 XC MODE`09`09CHARACTER*1`09read XC`09`09`09Controls format of menu. The menu is displayed in a XC`09`09`09rectangular box. MODE controls the layout of the menu`20 XC`09`09`09items. V = vertical, H = Horizontal (1 line),`20 XC`09`09`09M = Matrix (several horizontal lines). If there are`20 XC`09`09`09more items than will fit in the box, the display scrolls XC`09`09`09vertically for modes V,M and horizontally for mode H XC CHOICES`09CHARACTER*(*)(N) read`09Choices to be displayed XC N`09`09INTEGER`09`09read`09The number of choices XC HELPLIB`09CHARACTER*(*)`09read`09Help library to be consulted when XC`09`09`09`09`09Help or PF2 is pressed. Space uses XC`09`09`09`09`09the default of SYS$HELP:HELPLIB XC LABEL`09`09CHARACTER*(*)`09read`09A label to be inserted into the frame XC`09`09`09`09`09Space means no label XC LABPOS`09CHARACTER*1`09read`09Position of label. T = top XC`09`09`09`09`09L = left, R = right, B or ' '=bottom XC ROW`09`09INTEGER`09`09read`09Row of top of frame XC`09`09`09`09`090 means default = XC`09`09`09`09`09Mode = V, HEIGHT is centred in screen XC`09`09`09`09`09 H or M row 1 XC COL`09`09INTEGER`09`09read`09Col of left of frame XC`09`09`09`09`090 means default = XC`09`09`09`09`09Mode = V, WIDTH is centred in screen XC`09`09`09`09`09 H or M col 1 XC HEIGHT`09INTEGER`09`09read`09Height of frame - remember this XC`09`09`09`09`09 should include 2 rows for the top XC`09`09`09`09`09 and bottom frame lines.`20 XC`09`09`09`09`090 means default = XC`09`09`09`09`09Mode = V, min(N+2, screen size) XC`09`09`09`09`09 H, 3 XC`09`09`09`09`09 M screen size XC WIDTH`09`09INTEGER`09`09read`09Width of frame. Remember this should XC`09`09`09`09`09include 2 cols for left and right XC`09`09`09`09`09frame lines + 2 cols for spaces`20 XC`09`09`09`09`09before and after each choice.`20 XC`09`09`09`09`090 means default = XC`09`09`09`09`09Mode = V,`20 XC`09`09`09`09`09 min(max item width + 4, screen size) XC`09`09`09`09`09 H, M screen size XC`09`09`09`09`09(screen size adjusts automatically to XC`09`09`09`09`09 80/132 column display) XC NUMBER`09INTEGER*2`09write`09number of selected choice XC CHOICE`09CHARACTER*(*)`09write`09text of selected choice XC- X`09IMPLICIT NONE X`09INCLUDE '($SMGDEF)' X`09INCLUDE 'MCS_MESSLIB(MCSMESS)' X`09INTEGER`09N,`09`09! read number of choices X +`09`09IVERSION,`09! version number = 1 X +`09`09HEIGHT, `09! read Height of frame`20 X`09`09`09`09! 0 = default X`09`09`09`09! MODE = V min(N+2, screen height) X`09`09`09`09!`09 H`091 X`09`09`09`09!`09 M screen height X +`09`09WIDTH, `09`09! read Width of frame X`09`09`09`09! 0 = default X`09`09`09`09! MODE = V width of (widest option or X`09`09`09`09! top or bottom label) + 4 X`09`09`09`09!`09 H,M,B screen width X +`09`09ROW, `09`09! read Row of top of frame X`09`09`09`09! 0 = default,`20 X`09`09`09`09! MODE = V,M,B centres HEIGHT in screen X`09`09`09`09!`09 H row 1 X +`09`09COL `09`09! read Col of left of frame X`09`09`09`09! 0 = default centres WIDTH in screen X X`09CHARACTER*(*) X +`09`09MODE*1, ! read V,H,M,B = Vertical, Horizontal,`20 X`09`09`09`09! Matrix`20 X +`09`09CHOICES(N),`09! read Array of choices `20 X +`09`09HELPLIB,`09! read Help library to use X`09`09`09`09! `09space = SYS$HELP:HELPLIB.HLB X +`09`09LABEL, `09`09! read Label in frame X +`09`09LABPOS, `09! read posn of Label in frame (L/R/B/T) X`09`09`09`09! space = B X +`09`09CHOICE`09`09! write Text of selected choice X X X`09INTEGER*2 NUMBER`09! write Number of selected choice X X`09INTEGER*4 I, I2, DISPID, PBID, KBID, ILEN, MAXWID, X +`09`09PROWS, PCOLS, IWIDTH, IHEIGHT, IROW, ICOL X X X`09CHARACTER*500 TEMPSTR XC+ XC Check for version mismatch XC- X`09IF (IVERSION .NE. 1) CALL LIB$SIGNAL (MCS_VERMISM) XC+ XC Create a pasteboard (finding the number of physical rows and columns) XC and a keyboard XC- X `09CALL SMG$CREATE_PASTEBOARD(PBID,,PROWS,PCOLS,,) X `09CALL SMG$CREATE_VIRTUAL_KEYBOARD(KBID,'TT',,,) XC+ XC Define any defaults`20 XC- XC+ XC If MODE = V .AND. either COL = 0 or WIDTH = 0 we need to know the width of XC the largest item XC- X`09IF (MODE .EQ. 'V' .AND. (COL .EQ. 0 .OR. WIDTH .EQ. 0)) THEN X`09 MAXWID = 0 X`09 IF (LABEL .NE. ' '`20 X +`09 .AND. (LABPOS .EQ. 'T' .OR. LABPOS .EQ. 'B')) X +`09 CALL STR$TRIM(TEMPSTR,LABEL,MAXWID) X`09 DO I2=1,N X`09 CALL STR$TRIM(TEMPSTR, CHOICES(I2), I) X`09 IF (I .GT. MAXWID) MAXWID= I X`09 ENDDO X`09ENDIF XC+ XC HEIGHT XC- X `09IF (HEIGHT .EQ. 0) THEN X`09 IF (MODE .EQ. 'V') THEN X`09 IF (ROW .EQ. 0) THEN X`09 IHEIGHT = MIN(N+2, PROWS) X`09 ELSE X`09 IHEIGHT = MIN(N+2, PROWS - ROW + 1) X`09 ENDIF X`09 ELSEIF (MODE .EQ. 'H') THEN X`09 IHEIGHT = 3 `20 X`09 ELSE X`09 IHEIGHT = PROWS X`09 ENDIF X`09ELSE X`09 IHEIGHT = HEIGHT X`09ENDIF XC+ XC WIDTH XC- X `09IF (WIDTH .EQ. 0) THEN X`09 IF (MODE .EQ. 'V') THEN X`09 IF (COL .EQ. 0) THEN X`09 IWIDTH = MIN(MAXWID+4, PCOLS) X`09 ELSE X`09 IWIDTH = MIN(MAXWID+4, PCOLS - COL+ 1) X`09 ENDIF X`09 ELSE X`09 IWIDTH = PCOLS X`09 ENDIF X`09ELSE X`09 IWIDTH = WIDTH X`09ENDIF XC+ XC ROW XC- X `09IF (ROW .EQ. 0) THEN X`09 IF (MODE .EQ. 'V') THEN X`09 IROW = (PROWS - IHEIGHT)/2 X`09 IF (IROW .LT. 1) IROW = 1 X`09 ELSE X`09 IROW = 1 X`09 ENDIF X`09ELSE X`09 IROW = ROW X`09ENDIF XC+ XC COL XC- X `09IF (COL .EQ. 0) THEN X`09 ICOL = (PCOLS - IWIDTH)/2 X`09 IF (ICOL .LT. 1) ICOL = 1 X`09ELSE X`09 ICOL = COL X`09ENDIF XC+ XC Create the virtual display to hold the menu, with a border XC- X`09CALL SMG$CREATE_VIRTUAL_DISPLAY (IHEIGHT-2, IWIDTH-2, DISPID, X +`09 (SMG$M_BORDER .OR. SMG$M_TRUNC_ICON),,) XC+ XC Paste the display to the pasteboard XC- X `09CALL SMG$PASTE_VIRTUAL_DISPLAY(DISPID,PBID,IROW+1,ICOL+1,) XC+ XC Put label on the border XC- X`09CALL STR$TRIM (TEMPSTR, LABEL, I) X`09IF (I .GT. 0) THEN X`09 IF (LABPOS .EQ. 'T') THEN X CALL SMG$LABEL_BORDER (DISPID, TEMPSTR(:I),SMG$K_TOP,,,,) X`09 ELSEIF (LABPOS .EQ. 'B' .OR. LABPOS .EQ. ' ') THEN X CALL SMG$LABEL_BORDER (DISPID, TEMPSTR(:I),SMG$K_BOTTOM,,,,) X`09 ELSEIF (LABPOS .EQ. 'L') THEN X CALL SMG$LABEL_BORDER (DISPID, TEMPSTR(:I),SMG$K_LEFT,,,,) X`09 ELSEIF (LABPOS .EQ. 'R') THEN X CALL SMG$LABEL_BORDER (DISPID, TEMPSTR(:I),SMG$K_RIGHT,,,,) X`09 ENDIF X`09ENDIF XC+ XC Create the menu XC- X`09IF (MODE .EQ. 'V') THEN X`09 CALL SMG$CREATE_MENU (DISPID, CHOICES ,SMG$K_VERTICAL,,,,) X`09ELSEIF (MODE .EQ. 'H') THEN X`09 CALL SMG$CREATE_MENU (DISPID, CHOICES ,SMG$K_HORIZONTAL,,,,) X`09ELSEIF (MODE .EQ. 'M') THEN X`09 CALL SMG$CREATE_MENU (DISPID, CHOICES ,SMG$K_BLOCK,,,,) X`09ENDIF XC+ XC HELPLIB XC- X`09CALL STR$TRIM(TEMPSTR,HELPLIB,I) X`09IF (I .LT. 1) CALL STR$TRIM(TEMPSTR, 'SYS$HELP:HELPLIB',I) X`09CALL SMG$SELECT_FROM_MENU (KBID, DISPID, NUMBER,,,TEMPSTR(:I), X +`09`09,,CHOICE,,) XC+ XC Delete the structures XC- X`09CALL SMG$POP_VIRTUAL_DISPLAY(DISPID,PBID) X`09CALL SMG$DELETE_PASTEBOARD(PBID,0) X`09CALL SMG$DELETE_VIRTUAL_DISPLAY(DISPID) X`09CALL SMG$DELETE_VIRTUAL_KEYBOARD(KBID) X X`09RETURN X`09END $ CALL UNPACK DISPLAY_MENU.FOR;5 842804375 $ create 'f' Xdefine verb MENU X image MCS_MENU:MENU X parameter P1 , prompt="File" X value (type=$infile) X qualifier MODE X nonnegatable X default X value (default="V") X qualifier ROW X nonnegatable X default X value (default="0",type=$number) X qualifier COLUMN X nonnegatable X default X value (default="0",type=$number) `20 X qualifier HEIGHT X nonnegatable X default X value (default="0",type=$number) X qualifier WIDTH X nonnegatable X default X value (default="0",type=$number) X qualifier LABEL X value X qualifier LABPOS X nonnegatable X default X value (default="B") X qualifier HELPLIB X value (default="SYS$HELP:HELPLIB") X qualifier NUMBER X default X value (default="MENU_NUMBER") X qualifier CHOICE X value (default="MENU_CHOICE") X qualifier SYMBOL X default X value (default="MENU_SYMBOL") X qualifier MARKER X nonnegatable X default X value (default="=") X qualifier SPAWN X default X value (default=".") X qualifier DO_COMMAND X default X value (default="`7C") X qualifier FILES X value (default="*.*;*") $ CALL UNPACK MENU.CLD;30 6045458 $ create 'f' X `09PROGRAM MENU XC+ XC Provides a DCL command interface to the SMG based routine DISPLAY_MENU XC XC define verb MENU XC image MCS_SYSTEM:MENU XC parameter P1 , prompt="File" XC value (type=$infile) XC qualifier MODE XC nonnegatable XC default XC value (default="V") XC qualifier ROW XC nonnegatable XC default XC value (default="0",type=$number) XC qualifier COLUMN XC nonnegatable XC default XC value (default="0",type=$number) `20 XC qualifier HEIGHT XC nonnegatable XC default XC value (default="0",type=$number) XC qualifier WIDTH XC nonnegatable XC default XC value (default="0",type=$number) XC qualifier LABEL XC value XC qualifier LABPOS XC nonnegatable XC default XC value (default="B") XC qualifier HELPLIB XC value (default="SYS$HELP:HELPLIB") XC qualifier NUMBER XC default XC value (default="MENU_NUMBER") XC qualifier CHOICE XC value (default="MENU_CHOICE") XC qualifier SYMBOL XC default XC value (default="MENU_SYMBOL") XC qualifier MARKER XC nonnegatable XC default XC value (default="=") XC qualifier SPAWN XC default XC value (default=".") XC qualifier DO_COMMAND XC default XC value (default="`7C") XC qualifier FILES XC value (default="*.*;*") XC XC K. Jewell 5th December 1990 XC- X`09IMPLICIT NONE X`09INTEGER MAXITEMS, MAXLEN X`09PARAMETER (MAXITEMS = 200)`09`09! Maximum number of choices X`09PARAMETER (MAXLEN = 132) ! Maximum length of choices, label,helplib etc X X`09CHARACTER*(MAXLEN) X +`09`09`09FILE,`09`09`09! input file name X +`09`09`09MODE*1,`09`09`09! Mode V/H/M/B X +`09`09`09LABEL,`09`09`09! label text X +`09`09`09LABPOS*1,`09`09! position of label T/B/L/R X +`09`09`09HELPLIB, `09`09! Help library X +`09`09`09NUM_SYMBOL,`09`09! Symbol to which number to go X +`09`09`09CHOICE_SYMBOL,`09`09! Symbol to which choice to go X +`09`09`09SYMBOL,`09`09`09! Symbol to which action to go X +`09`09`09MARKER*1,`09`09! File flag for SYMBOL X +`09`09`09SPAWN*1,`09`09! File flag for SPAWN`20 X +`09`09`09DO_COMM*1,`09`09! File flag for DO_COMMAND X +`09`09`09CHOICES(MAXITEMS+1), `09! Array of choices X +`09`09`09ACTIONS(MAXITEMS),`09! corresponding actions X +`09`09`09CHOICE,`09`09`09! selected choice string X +`09`09`09FILES,`09`09`09! file spec to be added to file X +`09`09`09TEMPSTR`09`09`09! Temporary string X X `09INTEGER*4 `09ROW,`09`09`09! top of frame X +`09`09`09COLUMN,`09`09`09! left of frame X +`09`09`09HEIGHT, `09`09! height of frame X +`09`09`09WIDTH, `09`09`09! width of frame X +`09`09`09N,`09`09`09! number of choices X +`09`09`09I, I2`09`09`09! temp variables X X`09INTEGER*2 NUMBER`09`09`09! selected choice X X `09EXTERNAL CLI$_ABSENT X `09INTEGER CLI$GET_VALUE, CLI$PRESENT, LIB$FIND_FILE X`09INTEGER ISTAT, IABS XC+ XC Define some CLI return codes XC- X `09IABS = %LOC (CLI$_ABSENT) XC+ XC Find all the command line details XC- X `09ISTAT = CLI$GET_VALUE ('P1', FILE,)`09`09! input file name X`09IF (ISTAT .EQ. IABS) FILE = CHAR(0)`09`09! null - no file X `09CALL CLI$GET_VALUE ('MODE', MODE, )`09`09! Mode X `09CALL CLI$GET_VALUE ('ROW', TEMPSTR, I)`09`09! Row X`09READ(TEMPSTR(:I),*) ROW X `09CALL CLI$GET_VALUE ('COLUMN', TEMPSTR, I)!`09! Column X`09READ(TEMPSTR(:I),*) COLUMN X `09CALL CLI$GET_VALUE ('HEIGHT', TEMPSTR, I)`09! Height X`09READ(TEMPSTR(:I),*) HEIGHT X `09CALL CLI$GET_VALUE ('WIDTH', TEMPSTR, I)`09! Width X`09READ(TEMPSTR(:I),*) WIDTH X`09ISTAT = CLI$PRESENT('LABEL')`09`09`09! Label X`09IF (ISTAT .NE. IABS ) THEN X`09 ISTAT = CLI$GET_VALUE ('LABEL',LABEL,) X`09 IF (ISTAT .EQ. IABS) LABEL = ' '`09`09! Space - use file X`09ELSE X`09 LABEL = CHAR(0)`09`09`09`09! NULL - no label X`09ENDIF X `09IF (LABEL(:1) .NE. CHAR(0)) CALL `09`09! LABPOS X +`09 CLI$GET_VALUE ('LABPOS', LABPOS,) X `09ISTAT = CLI$GET_VALUE ('HELPLIB', HELPLIB,)`09! Helplib X`09IF (ISTAT .EQ. IABS) HELPLIB = ' ' X`09ISTAT = CLI$GET_VALUE('NUMBER',NUM_SYMBOL,)`09! Number symbol X`09IF (ISTAT .EQ. IABS) NUM_SYMBOL = ' '`09`09! space - no number symbol X`09ISTAT = CLI$GET_VALUE('CHOICE',CHOICE_SYMBOL,)`09! Choice symbol X`09IF (ISTAT .EQ. IABS) CHOICE_SYMBOL = ' '`09! space - no choice symbol X`09ISTAT = CLI$GET_VALUE('SYMBOL',SYMBOL,)`09`09! symbol symbol X`09IF (ISTAT .EQ. IABS) SYMBOL = ' '`09`09! space - no symbol symbol X`09IF (SYMBOL .NE. ' ') CALL`20 X +`09 CLI$GET_VALUE ('MARKER',MARKER,)`09`09! Symbol Marker X`09ISTAT = CLI$GET_VALUE('SPAWN',SPAWN,)`09`09! Spawn marker X`09IF (ISTAT .EQ. IABS) SPAWN = ' '`09`09! space - no spawn X`09ISTAT = CLI$GET_VALUE('DO_COMMAND',DO_COMM,)`09! DO_COMMAND marker X`09IF (ISTAT .EQ. IABS) DO_COMM = ' '`09`09! space - no DO_COMM X`09ISTAT = CLI$GET_VALUE('FILES',FILES,)`09`09! FILES marker X`09IF (ISTAT .EQ. IABS) FILES = CHAR(0)`09`09! space - no FILES XC+ XC read in data, dropping commands into the ACTIONS array XC- X`09N = 0 X`09IF (FILE .EQ. CHAR(0) ) THEN X`09 IF (LABEL .EQ. ' ') READ '(A)',LABEL X 10`09 N = N+1 X`09 READ (*,'(A)', END=100) CHOICES(N) X`09 IF ((SYMBOL .NE. ' ' .AND. CHOICES(N)(1:1) .EQ. MARKER) X +`09 .OR. (SPAWN .NE. ' ' .AND. CHOICES(N)(1:1) .EQ. SPAWN) X +`09 .OR. (DO_COMM .NE. ' ' .AND. CHOICES(N)(1:1) .EQ. DO_COMM)) X +`09 THEN X`09 N = N-1 X`09 ACTIONS(N) = CHOICES(N+1) X`09 CHOICES(N+1) = ' ' X`09 ENDIF X`09 IF (N .GE. MAXITEMS) THEN X`09 LABEL='MENU SIZE EXCEEDED - ITEMS MAY BE MISSED' X`09 LABPOS='B' X`09 GOTO 100 X`09 ELSE X`09 GOTO 10 X`09 ENDIF X`09ELSE X`09 OPEN(UNIT=1, FILE=FILE, STATUS='OLD', X +`09 SHARED, READONLY, DEFAULTFILE = '.MNU') X`09 IF (LABEL .EQ. ' ') READ (1,'(A)'),LABEL X 20`09 N = N+1 X`09 READ (1,'(A)', END=90) CHOICES(N) X`09 IF (( SYMBOL .NE. ' ' .AND. CHOICES(N)(1:1) .EQ. MARKER) X +`09 .OR. (SPAWN .NE. ' ' .AND. CHOICES(N)(1:1) .EQ. SPAWN) X +`09 .OR. (DO_COMM .NE. ' ' .AND. CHOICES(N)(1:1) .EQ. DO_COMM)) X +`09 THEN X`09 N = N-1 X`09 ACTIONS(N) = CHOICES(N+1) X`09 CHOICES(N+1) = ' ' X`09 ENDIF X`09 IF (N .GE. MAXITEMS) THEN X`09 LABEL='MENU SIZE EXCEEDED - ITEMS MAY BE MISSED' X`09 LABPOS='B' X`09 GOTO 90 X`09 ELSE X`09 GOTO 20 X`09 ENDIF X`09ENDIF X 90`09CLOSE (1) X 100`09N = N-1 XC+ XC If FILES has been specified, add these to the end of the array XC- X`09IF (FILES .NE. CHAR(0) .AND. N .LT. MAXITEMS) THEN X`09 CALL STR$TRIM(TEMPSTR, FILES, I2) X`09 IF (I2 .EQ. 0) CALL STR$TRIM(TEMPSTR,'*.*;*',I2) X`09 I = 0 X 105`09 ISTAT = LIB$FIND_FILE(TEMPSTR(:I2), CHOICES(N+1), I,,,,) X`09 IF (ISTAT) THEN X`09 N = N + 1 X`09 IF (N .GE. MAXITEMS) THEN X`09 LABEL='MENU SIZE EXCEEDED - FILES MAY BE MISSED' X`09 LABPOS='B' X`09 ELSE X`09 GOTO 105 X`09 ENDIF X`09 ENDIF X`09 CALL LIB$FIND_FILE_END(I) X`09ENDIF`09`09 XC+ XC Call the menu XC- `20 X 110`09CALL DISPLAY_MENU(1, MODE, CHOICES, N, HELPLIB, LABEL, X +`09 LABPOS, ROW, COLUMN, HEIGHT, WIDTH, NUMBER, CHOICE) XC+ XC Define symbols required XC XC Number of choice XC- X`09IF (NUM_SYMBOL .NE. ' ') THEN X`09 WRITE (TEMPSTR,*) NUMBER X`09 I = 1 X`09 DO WHILE (TEMPSTR(:I) .EQ. ' ') X`09 I=I+1 X`09 ENDDO X`09 CALL STR$TRIM(TEMPSTR,TEMPSTR(I:),I) X`09 CALL LIB$SET_SYMBOL(NUM_SYMBOL, TEMPSTR(:I), ) X`09ENDIF XC+ XC Name of choice XC- X`09IF (CHOICE_SYMBOL .NE. ' ') THEN X`09 CALL STR$TRIM(TEMPSTR,CHOICE,I) X`09 CALL LIB$SET_SYMBOL(CHOICE_SYMBOL, TEMPSTR(:I), ) X`09ENDIF XC+ XC DCL action symbol - delete any old one hanging around, and set it again if XC`09`09`09required XC- X`09IF (SYMBOL .NE. ' ' ) THEN X`09 CALL LIB$DELETE_SYMBOL(SYMBOL,) X`09 IF (ACTIONS(NUMBER)(:1) .EQ. MARKER) THEN X`09 CALL STR$TRIM(TEMPSTR,ACTIONS(NUMBER)(2:),I) X`09 CALL LIB$SET_SYMBOL(SYMBOL, TEMPSTR(:I), ) X`09 ENDIF X`09ENDIF XC+ XC Spawn an action if we want to, then return to the menu XC- X`09IF (SPAWN .NE. ' ' .AND. ACTIONS(NUMBER)(:1) .EQ. SPAWN) THEN X`09 CALL STR$TRIM(TEMPSTR,ACTIONS(NUMBER)(2:),I) X`09 PRINT*,'WAIT...' X`09 CALL LIB$SPAWN(TEMPSTR(:I),,,,,,,,,,,) X`09 GOTO 110 X`09ENDIF XC+ XC Exit with a LIB$DO_COMMAND if required XC- X`09IF (DO_COMM .NE. ' ' .AND. ACTIONS(NUMBER)(:1) .EQ. DO_COMM) THEN X`09 CALL STR$TRIM(TEMPSTR,ACTIONS(NUMBER)(2:),I) X`09 CALL LIB$DO_COMMAND(TEMPSTR(:I)) X`09ENDIF X X`09END $ CALL UNPACK MENU.FOR;120 1346826032 $ create 'f' X1 MENU X XMENU`5B/qualifiers`5D `5Bfilename`5D X XDisplays a scrolling menu on the screen and allows the user Xto select from it by moving the cursor (arrow keys) and Xpressing . X XPressing or PF2 displays help text on the current Xitem. X XWhen an item has been selected :- X X a) its number can be returned to a DCL symbol X and/or b) the item text can be returned to a DCL symbol X and/or c) an associated 'action term' can be returned`20 X to a DCL symbol X Xin addition either X X a) an associated 'action term' can be executed in`20 X a subprocess as a DCL command (after which the menu`20 X is redisplayed) X or b) an associate 'action term' can be executed as a DCL X command (the menu is not redisplayed) X X2 File X XThe name of a file (default type .MNU) containing :- X optionally, the menu label (see /LABEL) X the list of choices and associated action terms X XIf file is not specified, input is taken from SYS$INPUT, the Xlist being terminated by a line beginning $ (or as otherwise Xspecified by DECK) X XA choice may be followed by an associated 'action term' Xwhich will be :- X executed as a spawned DCL command (control returns X to MENU) X or executed as a following DCL command (control returns`20 X to SYS$INPUT) X and/or returned as a DCL symbol (default name MENU_ACTION,`20 X changed with \SYMBOL) X XAn action term is indicated by the first character on the Xline being that specified by qualifiers X /SPAWN (default = ".") X /DO_COMMAND (default = "`7C") X /MARKER (default = "=") X X3 Example X X $ MENU X example 1 X example 2 X .action 2 X example 3 X `7Caction 3 X example 4 X =action 4 X XDisplays :- X X +-----------+ X `7C example 1 `7C X `7C example 2 `7C X `7C example 3 `7C X `7C example 4 `7C X +-----------+ X XSelecting`20 X example 1 leaves the menu,`20 X assigning '1' to symbol MENU_NUMBER X example 2 spawns a sub process to execute 'action 2'`20 X then returns to the menu X example 3 leaves the menu,`20 X assigns '3' to symbol MENU_NUMBER X and executes 'action 3' as a DCL command X example 4 leaves the menu,`20 X assigns '4' to symbol MENU_NUMBER X and 'action 4' to symbol MENU_SYMBOL X X X2 /MODE X X /MODE`5B=V,H,M`5D (Default /MODE=V) X XControls whether the menu is displayed as :- X X a single vertical column (V) X a single horizontal row (H) X a matrix of rows and columns (M) X X2 /ROW X X /ROW= row number (Default /ROW=0) X XSpecifies the row of the top of the frame. 0 uses the Xdefault which depends on MODE X X MODE = H or M default row = 1 X MODE = V frame centred vertically in screen X X2 /COLUMN X X /COLUMN = column number (Default /COLUMN=0) X XSpecifies the column of the left of the frame. 0 uses the Xdefault which depends on MODE X X MODE = H or M default column = 1 X MODE = V frame centred horizontally`20 X X2 /HEIGHT X X /HEIGHT = height of frame in rows (Default /HEIGHT=0) X XSpecifies the height of the frame in rows. Height should Xinclude 1 row each for the top and bottom lines of the Xframe. 0 uses the default which depends on MODE X X MODE = V default height = minimum of :- X number choices + 2 X screen height X MODE = H default height = 3 X MODE = M default height = screen height X X2 /WIDTH X X /WIDTH = width of frame in columns (Default /WIDTH=0) X XSpecifies the width of the frame in columns. Width should Xinclude 2 columns each for the left and right lines of the Xframe. 0 uses the default which depends on MODE X X MODE = V default = minimum of :- X width of widest choice/label X screen width X MODE = H or M default = screen width X XDefault width automatically adjusts to 80/132 terminal settings. X X2 /LABEL X X /`5BNO`5DLABEL`5B=text`5D (Default /NOLABEL) X XSpecifies a label to be placed on the frame in a position Xspecified by /LABPOS X X /LABEL with no text causes the first line in the file to be Xused as a label. X X2 /LABPOS X X /LABPOS=text (Default /LABPOS=B) X XSpecifies the position of any label as B bottom X T top X L left X R right X X2 /HELPLIB X X /HELPLIB=help library (DEFAULT /HELPLIB=SYS$HELP:HELPLIB) X XSpecifies the help library to be consulted when the user Xpresses or PF2 X X2 /NUMBER X X /`5BNO`5DNUMBER`5B=symbol name`5D (Default /NUMBER=MENU_NUMBER) X XSpecifies the name of a local symbol to which the number of Xthe selected item is to be assigned X X2 /CHOICE X X /`5BNO`5DCHOICE`5B=symbol name`5D (Default /NOCHOICE) X (Default symbol name = MENU_CHOICE) X XSpecifies the name of a local symbol to which the text of the`20 Xselected item is to be assigned X X2 /SYMBOL X X /`5BNO`5DSYMBOL`5B=symbol name`5D (Default /SYMBOL=MENU_SYMBOL) X XSpecifies the name of a local symbol to which appropriately Xmarked action text (see /MARKER) associated with the Xselected item is to be assigned X X2 /MARKER X X /MARKER=character (Default /MARKER="=") X XSpecifies the character used in the menu file to mark action Xtext to be assigned to a symbol (see /SYMBOL) X X2 /SPAWN X X /`5BNO`5DSPAWN`5B=character`5D (Default /SPAWN=".") X XText in the menu file marked with the character will be Xtreated as action text, and if the corresponding item is Xselected, will be executed as a DCL command in a spawned Xsub-process before control returns to the menu X X2 /DO_COMMAND X X /`5BNO`5DDO_COMMAND`5B=character`5D (Default /DO_COMMAND="`7C") X XText in the menu file marked with the character will be Xtreated as action text, and if the corresponding item is Xselected, will be executed as a DCL command before control Xreturns to SYS$INPUT. X X2 /FILES X X /`5BNO`5DFILES`5B=filespec`5D (Default /NOFILES) X (Default filespec = *.*;*) X XIf specified, a list of files meeting the filespec is Xappended to the end of the text (if any) in the menu file, Xallowing selection of a file X X2 Fortran`20 X XThe menu is implemented using a Fortran subroutine XDISPLAY_MENU. (Link against MCS_MENU:DISPLAY_MENU) X XSUBROUTINE DISPLAY_MENU(IVERSION, MODE, CHOICES, N, HELPLIB, X +`09`09LABEL, LABPOS, X +`09`09ROW, COL, HEIGHT, WIDTH, X +`09`09NUMBER, CHOICE) X XUses SMG to display and return a selection from a menu. XClears screen before and after menu display X X3 ARGUMENTS X XThe only arguments that must be specified are MODE, CHOICES, XN, NUMBER and CHOICE. Everything else can be entered as 0 Xor ' ', to use defaults X XIVERSION`09INTEGER`09`09read`09Must = 1 X XMODE`09`09CHARACTER*1`09read X XControls format of menu. The menu is displayed in a Xrectangular box. MODE controls the layout of the menu`20 Xitems. `20 X V = vertical,`20 X H = Horizontal (1 line),`20 X M = Matrix (several horizontal lines). `20 XIf there are more items than will fit in the box, the Xdisplay scrolls vertically for modes V,M and horizontally Xfor mode H X XCHOICES`09CHARACTER*(*)(N) read`09Choices to be displayed X XN`09`09INTEGER`09`09read`09The number of choices X XHELPLIB`09CHARACTER*(*)`09read`09 XHelp library to be consulted when Help or PF2 is pressed.`20 XSpace uses the default of SYS$HELP:HELPLIB X XLABEL`09`09CHARACTER*(*)`09read`09 XA label to be inserted into the frame Space means no label X XLABPOS`09CHARACTER*1`09read`09Position of label.`20 X T = top X L = left,`20 X R = right,`20 X B or ' '=bottom X XROW`09`09INTEGER`09`09read`09Row of top of frame X0 means default = X Mode = V, HEIGHT is centred in screen X H or M row 1 X XCOL`09`09INTEGER`09`09read`09Col of left of frame X0 means default = X Mode = V, WIDTH is centred in screen X H or M col 1 X XHEIGHT`09INTEGER`09`09read`09Height of frame Xremember this should include 2 rows for the top and bottom Xframe lines.`20 X0 means default = X Mode = V, min(N+2, screen size) X H, 3 X M screen size X XWIDTH`09`09INTEGER`09`09read`09Width of frame.`20 XRemember this should include 2 cols for left and right frame Xlines + 2 cols for spaces before and after each choice.`20 X0 means default = X Mode = V, min(max item width + 4, screen size) X H, M screen size X(screen size adjusts automatically to 80/132 column display) X XNUMBER`09INTEGER*2`09write`09number of selected choice X XCHOICE`09CHARACTER*(*)`09write`09text of selected choice $ CALL UNPACK MENU.HLP;6 1564388862 $ create 'f' XA couple of weeks ago Scott Marshall (TRIN7@VAX1.TRINCOLL.EDU) asked about a XDCL menu program. I've implemented one in Fortran based on SMG. I've includ Ved Xthe .HLP file below to indicate its facilities. If anyone wants it I can sen Vd Xthem the VMSSHARE files. I know posting sources to this list attracts flame Vs, Xso I won't do that unless people _really_ want it. If anyone wants to make V it Xavailable via other means, thats OK with me. X XThere are, of course, no guarantees with the software, and I'm not undertaki Vng Xto maintain/further develop, although I would be interested in any Xbugs/improvements. X X Keith Jewell X+-------------------------------------------+------------------------------- V----+ X`7C Keith Jewell`09`09`09`09 `7C Telephone: (0386)840319 ext.222 `7C X`7C Head of Mathematics & Computing Sciences `7C Telex: 337017`09 V `09 `7C X`7C Campden Food & Drink Research Association `7C Fax: (0386)841306`09 V `7C X`7C Chipping Campden `7C Email: keith@ibmpcug.C VO.UK `7C X`7C Gloucestershire GL55 6LD `7C V `7C X`7C England `7C V `7C X+-------------------------------------------+------------------------------- V---+ X`7CNo responsibility accepted for anything. Read what I write, use what I g Vive `7C X`7C at your own risk`09`09`09`09`09`09`09 `7C X+--------------------------------------------------------------------------- V---+ X X XThe files consist of :- X XMENU.TXT`09This file X XMENU.CLD;30`09command definition. Will need editing to replace the logical X`09`09MCS_MENU with the location of MENU.EXE, then use SET COMMAND X X XDISPLAY_MENU.FOR;5`09Fortran program (MENU) and subroutine (DISPLAY_MENU). XMENU.FOR;120`09`09Compile and link X XMENU.HLP;6`09Help text on the DCL MENU verb X X1 MENU X XMENU`5B/qualifiers`5D `5Bfilename`5D X XDisplays a scrolling menu on the screen and allows the user Xto select from it by moving the cursor (arrow keys) and Xpressing . X XPressing or PF2 displays help text on the current Xitem. X XWhen an item has been selected :- X X a) its number can be returned to a DCL symbol X and/or b) the item text can be returned to a DCL symbol X and/or c) an associated 'action term' can be returned`20 X to a DCL symbol X Xin addition either X X a) an associated 'action term' can be executed in`20 X a subprocess as a DCL command (after which the menu`20 X is redisplayed) X or b) an associate 'action term' can be executed as a DCL X command (the menu is not redisplayed) X X2 File X XThe name of a file (default type .MNU) containing :- X optionally, the menu label (see /LABEL) X the list of choices and associated action terms X XIf file is not specified, input is taken from SYS$INPUT, the Xlist being terminated by a line beginning $ (or as otherwise Xspecified by DECK) X XA choice may be followed by an associated 'action term' Xwhich will be :- X executed as a spawned DCL command (control returns X to MENU) X or executed as a following DCL command (control returns`20 X to SYS$INPUT) X and/or returned as a DCL symbol (default name MENU_ACTION,`20 X changed with \SYMBOL) X XAn action term is indicated by the first character on the Xline being that specified by qualifiers X /SPAWN (default = ".") X /DO_COMMAND (default = "`7C") X /MARKER (default = "=") X X3 Example X X $ MENU X example 1 X example 2 X .action 2 X example 3 X `7Caction 3 X example 4 X =action 4 X XDisplays :- X X +-----------+ X `7C example 1 `7C X `7C example 2 `7C X `7C example 3 `7C X `7C example 4 `7C X +-----------+ X XSelecting`20 X example 1 leaves the menu,`20 X assigning '1' to symbol MENU_NUMBER X example 2 spawns a sub process to execute 'action 2'`20 X then returns to the menu X example 3 leaves the menu,`20 X assigns '3' to symbol MENU_NUMBER X and executes 'action 3' as a DCL command X example 4 leaves the menu,`20 X assigns '4' to symbol MENU_NUMBER X and 'action 4' to symbol MENU_SYMBOL X X X2 /MODE X X /MODE`5B=V,H,M`5D (Default /MODE=V) X XControls whether the menu is displayed as :- X X a single vertical column (V) X a single horizontal row (H) X a matrix of rows and columns (M) X X2 /ROW X X /ROW= row number (Default /ROW=0) X XSpecifies the row of the top of the frame. 0 uses the Xdefault which depends on MODE X X MODE = H or M default row = 1 X MODE = V frame centred vertically in screen X X2 /COLUMN X X /COLUMN = column number (Default /COLUMN=0) X XSpecifies the column of the left of the frame. 0 uses the Xdefault which depends on MODE X X MODE = H or M default column = 1 X MODE = V frame centred horizontally`20 X X2 /HEIGHT X X /HEIGHT = height of frame in rows (Default /HEIGHT=0) X XSpecifies the height of the frame in rows. Height should Xinclude 1 row each for the top and bottom lines of the Xframe. 0 uses the default which depends on MODE X X MODE = V default height = minimum of :- X number choices + 2 X screen height X MODE = H default height = 3 X MODE = M default height = screen height X X2 /WIDTH X X /WIDTH = width of frame in columns (Default /WIDTH=0) X XSpecifies the width of the frame in columns. Width should Xinclude 2 columns each for the left and right lines of the Xframe. 0 uses the default which depends on MODE X X MODE = V default = minimum of :- X width of widest choice/label X screen width X MODE = H or M default = screen width X XDefault width automatically adjusts to 80/132 terminal settings. X X2 /LABEL X X /`5BNO`5DLABEL`5B=text`5D (Default /NOLABEL) X XSpecifies a label to be placed on the frame in a position Xspecified by /LABPOS X X /LABEL with no text causes the first line in the file to be Xused as a label. X X2 /LABPOS X X /LABPOS=text (Default /LABPOS=B) X XSpecifies the position of any label as B bottom X T top X L left X R right X X2 /HELPLIB X X /HELPLIB=help library (DEFAULT /HELPLIB=SYS$HELP:HELPLIB) X XSpecifies the help library to be consulted when the user Xpresses or PF2 X X2 /NUMBER X X /`5BNO`5DNUMBER`5B=symbol name`5D (Default /NUMBER=MENU_NUMBER) X XSpecifies the name of a local symbol to which the number of Xthe selected item is to be assigned X X2 /CHOICE X X /`5BNO`5DCHOICE`5B=symbol name`5D (Default /NOCHOICE) X (Default symbol name = MENU_CHOICE) X XSpecifies the name of a local symbol to which the text of the`20 Xselected item is to be assigned X X2 /SYMBOL X X /`5BNO`5DSYMBOL`5B=symbol name`5D (Default /SYMBOL=MENU_SYMBOL) X XSpecifies the name of a local symbol to which appropriately Xmarked action text (see /MARKER) associated with the Xselected item is to be assigned X X2 /MARKER X X /MARKER=character (Default /MARKER="=") X XSpecifies the character used in the menu file to mark action Xtext to be assigned to a symbol (see /SYMBOL) X X2 /SPAWN X X /`5BNO`5DSPAWN`5B=character`5D (Default /SPAWN=".") X XText in the menu file marked with the character will be Xtreated as action text, and if the corresponding item is Xselected, will be executed as a DCL command in a spawned Xsub-process before control returns to the menu X X2 /DO_COMMAND X X /`5BNO`5DDO_COMMAND`5B=character`5D (Default /DO_COMMAND="`7C") X XText in the menu file marked with the character will be Xtreated as action text, and if the corresponding item is Xselected, will be executed as a DCL command before control Xreturns to SYS$INPUT. X X2 /FILES X X /`5BNO`5DFILES`5B=filespec`5D (Default /NOFILES) X (Default filespec = *.*;*) X XIf specified, a list of files meeting the filespec is Xappended to the end of the text (if any) in the menu file, Xallowing selection of a file X X2 Fortran`20 X XThe menu is implemented using a Fortran subroutine XDISPLAY_MENU. (Link against MCS_MENU:DISPLAY_MENU) X XSUBROUTINE DISPLAY_MENU(IVERSION, MODE, CHOICES, N, HELPLIB, X +`09`09LABEL, LABPOS, X +`09`09ROW, COL, HEIGHT, WIDTH, X +`09`09NUMBER, CHOICE) X XUses SMG to display and return a selection from a menu. XClears screen before and after menu display X X3 ARGUMENTS X XThe only arguments that must be specified are MODE, CHOICES, XN, NUMBER and CHOICE. Everything else can be entered as 0 Xor ' ', to use defaults X XIVERSION`09INTEGER`09`09read`09Must = 1 X XMODE`09`09CHARACTER*1`09read X XControls format of menu. The menu is displayed in a Xrectangular box. MODE controls the layout of the menu`20 Xitems. `20 X V = vertical,`20 X H = Horizontal (1 line),`20 X M = Matrix (several horizontal lines). `20 XIf there are more items than will fit in the box, the Xdisplay scrolls vertically for modes V,M and horizontally Xfor mode H X XCHOICES`09CHARACTER*(*)(N) read`09Choices to be displayed X XN`09`09INTEGER`09`09read`09The number of choices X XHELPLIB`09CHARACTER*(*)`09read`09 XHelp library to be consulted when Help or PF2 is pressed.`20 XSpace uses the default of SYS$HELP:HELPLIB X XLABEL`09`09CHARACTER*(*)`09read`09 XA label to be inserted into the frame Space means no label X XLABPOS`09CHARACTER*1`09read`09Position of label.`20 X T = top X L = left,`20 X R = right,`20 X B or ' '=bottom X XROW`09`09INTEGER`09`09read`09Row of top of frame X0 means default = X Mode = V, HEIGHT is centred in screen X H or M row 1 X XCOL`09`09INTEGER`09`09read`09Col of left of frame X0 means default = X Mode = V, WIDTH is centred in screen X H or M col 1 X XHEIGHT`09INTEGER`09`09read`09Height of frame Xremember this should include 2 rows for the top and bottom Xframe lines.`20 X0 means default = X Mode = V, min(N+2, screen size) X H, 3 X M screen size X XWIDTH`09`09INTEGER`09`09read`09Width of frame.`20 XRemember this should include 2 cols for left and right frame Xlines + 2 cols for spaces before and after each choice.`20 X0 means default = X Mode = V, min(max item width + 4, screen size) X H, M screen size X(screen size adjusts automatically to 80/132 column display) X XNUMBER`09INTEGER*2`09write`09number of selected choice X XCHOICE`09CHARACTER*(*)`09write`09text of selected choice $ CALL UNPACK MENU.TXT;2 560120900 $ v=f$verify(v) $ EXIT