PROGRAM MENU ! VERSION 2.1 ! Update with version message below !+ ! This program is designed to provide an FMS driver from the DCL ! command level. ! ! Inputs: ! Any DCL symbol which matches a defined field name in the form ! is loaded as a default value for that field. ! ! Outputs: ! For any field which is non-blank in the form, a DCL symbol ! is created (modified if it exists). If a field is blanked ! on the form the corresponding DCL symbol (if it exists) is ! deleted. Take note that only LOCAL DCL symbols will be deleted, ! if a GLOBAL symbol is blanked - it will not be modified. ! ! ! Written by Eric Wentz 8-May-1984 ! !- IMPLICIT INTEGER*4 (A-Z) INCLUDE '($SSDEF)' ! Get the status symbols INCLUDE '($LIBCLIDEF)' ! Get CLI symbols INCLUDE 'FMS$EXAMPLES:FDVDEF.FOR' ! Get the FMS (VERSION 2) defs INTEGER WORKSPACE(3) !General workspace INTEGER TCA(3) !Terminal Control Area CHARACTER*31 FIELD_NAME ! Current field name INTEGER FIELD_INDEX CHARACTER*80 FIELD_VALUE ! Current field value LOGICAL DONE ! .TRUE. when form is complete LOGICAL VALID_FIELD ! .TRUE. if a field is valid CHARACTER*60 FORM_LIBRARY ! Loaded via DCL CHARACTER*32 FORM_NAME ! Loaded via DCL LOGICAL LOCAL ! From DCL qualifier of same name LOGICAL RANGE LOGICAL LEGAL LOGICAL VALID COMMON /DCL_QUALIFIERS/LOCAL,RANGE,LEGAL,VALID ! ! See if all they want is the version number ! IF(CLI$PRESENT('VERSION'))THEN ! Version requested? TYPE *,'MENU Version 2.1' ! Yep, type it. CALL EXIT ! And just exit ENDIF ! LOCAL = CLI$PRESENT('LOCAL') ! Get the local qualif RANGE = CLI$PRESENT('RANGE') ! Get qualif from DCL LEGAL = CLI$PRESENT('LEGAL') ! Get qualif from DCL VALID = CLI$PRESENT('VALID') ! ! Get the form library and form name from the DCL command interface ! ISTAT = CLI$GET_VALUE('LIBRARY',FORM_LIBRARY) ! Get the library name IF(.NOT.ISTAT)CALL SYS$EXIT(%VAL(ISTAT)) ! Crash on failure ISTAT = CLI$GET_VALUE('FORM',FORM_NAME) ! Get the form name IF(.NOT.ISTAT)CALL SYS$EXIT(%VAL(ISTAT)) ! Crash on failure FMSSTATUS = FDV$ATERM( %DESCR(TCA),12 ,2 , 1 'SYS$COMMAND') ! Attach the terminal IF(FMSSTATUS.EQ.FDV$_SUC)THEN ! Continue if okay CONTINUE ELSE CALL SYS$EXIT(%VAL(FMSSTATUS)) ! And leave ENDIF FMSSTATUS = FDV$AWKSP(%DESCR(WORKSPACE),2000) ! Attach the workspace IF(FMSSTATUS.EQ.FDV$_SUC)THEN ! Continue if okay CONTINUE ELSE CALL SYS$EXIT(%VAL(FMSSTATUS)) ! And leave ENDIF CALL FDV$ILTRM(1) ! Return illegal terms FMSSTATUS = FDV$LOPEN( FORM_LIBRARY, 1 ) ! Open the form library IF(FMSSTATUS.EQ.FDV$_SUC)THEN ! Continue if okay CONTINUE ELSE CALL FDV$DWKSP( %DESCR(WORKSPACE) ) ! Detach workspace CALL FDV$DTERM( %DESCR(TCA)) ! Detatch the terminal CALL LIB$ERASE_PAGE(1,1) ! Clear the screen CALL LIB$SET_CURSOR(23,1) ! Position the cursor TYPE *,'%MENU-F-NOFORMLIB, form library not found' ! Error message CALL SYS$EXIT(%VAL(FMSSTATUS)) ! And leave ENDIF FMSSTATUS = FDV$CDISP(FORM_NAME) ! Display the form IF(FMSSTATUS.NE.FDV$_SUC)THEN ! Continue if okay CALL FDV$LCLOS ! Close the form lib CALL FDV$DWKSP( %DESCR(WORKSPACE) ) ! Detatch the workspace CALL FDV$DTERM( %DESCR(TCA)) ! Detatch the terminal CALL LIB$ERASE_PAGE(1,1) ! Clear the screen CALL LIB$SET_CURSOR(23,1) ! Position the cursor TYPE *,'%MENU-F-NOFORM, form not found in library' ! Error message CALL SYS$EXIT(%VAL(FMSSTATUS)) ! And leave ENDIF !+ ! This section scans the form just loaded and gets all the field names. ! When it gets a valid name it looks at the DCL symbol table to see if ! there is a corresponding name. If there is, the value from that symbol ! is used as a default value for that field. If not, the field is left blank. !- INDEX = 1 ! Field counter ISTAT = 0 ! Status variable DO WHILE (ISTAT .NE. FDV$_FLD) ! Do til no more fields ISTAT = FDV$RETFO(INDEX,FIELD_NAME,FLDIDX) ! Get (next) field IF(ISTAT.EQ.FDV$_SUC)THEN ! If okay then... INDEX = INDEX + 1 ! Set up for next field IF(LIB$GET_SYMBOL(FIELD_NAME, ! Look up DCL symbol 1 FIELD_VALUE,ILEN,TABLE))THEN ! If one's there IF(.NOT.LOCAL.OR.(LOCAL.AND. 1 TABLE.EQ.LIB$K_CLI_LOCAL_SYM))THEN ! Okay to stuff ? VALID_FIELD = .TRUE. IF(VALID) ! If we're supposed to: 1 VALID_FIELD = VALIDATE(FIELD_NAME, 1 FIELD_VALUE(1:ILEN),.TRUE.) IF(VALID_FIELD)CALL FDV$PUT(FIELD_VALUE,FIELD_NAME) ENDIF ENDIF ENDIF ENDDO !+ ! Now the preliminary setup is all done so lets see what the user has ! to say: ! ! Set the cursor on the first field of the form, get it's value ! and it's terminator ! CALL FDV$GET( FIELD_VALUE, TERMINATOR, '*') ! Get the first field CALL FDV$RETFN( FIELD_NAME, FIELD_INDEX ) ! Get it's name ! ! Now we let the user be-bop around the form until they press enter or ! return. ! DONE = .FALSE. ! Init the flag DO WHILE (.NOT.DONE) ! Loop 'till done VALID_FIELD = .TRUE. ! Assume the field's ok ILEN = 0 ! Init the str length DO IDX = 1,LEN(FIELD_VALUE) IF(FIELD_VALUE(IDX:IDX).NE.' ')ILEN=IDX ! Get the string length ENDDO IF(ILEN.NE.0)THEN ! Test non-blank fields IF(VALID) ! If we're supposed to: 1 VALID_FIELD = VALIDATE(FIELD_NAME, ! Check field validity 1 FIELD_VALUE(1:ILEN),.FALSE.) ENDIF ! ! If the field was valid we'll try to process the field terminator. ! But, if the field was invalid, we'll skip this block and re-position ! the cursor at the same field again. ! IF(VALID_FIELD)THEN ! Process term if valid IF (TERMINATOR .EQ. FDV$K_FT_NTR) THEN ! RETURN or ENTER ? FMS_STATUS = FDV$PFT( TERMINATOR) ! Process the term IF(FMS_STATUS .EQ. FDV$_INC)THEN ! Incomplete ? VALID_FIELD = .FALSE. ! Hack so PFT wont execute below ELSE DONE = .TRUE. ! Form is complete ENDIF ELSE IF(TERMINATOR .EQ. FDV$K_FT_ILG_NXT)THEN CALL FDV$BELL CALL FDV$PUTL( 'No next field on form') ELSE IF(TERMINATOR .EQ. FDV$K_FT_ILG_PRV)THEN CALL FDV$BELL CALL FDV$PUTL( 'No previous field on form') ELSE IF(TERMINATOR .EQ. FDV$K_FT_ILG_ATB)THEN FMS_STATUS = FDV$PFT( FDV$K_FT_NTR) ! Process like return IF(FMS_STATUS .EQ. FDV$_INC)THEN ! Incomplete ? CONTINUE ! FMS beeps 'em ELSE DONE = .TRUE. ! Form is complete ENDIF ELSE IF(TERMINATOR .EQ. FDV$K_FT_ILG_XBK)THEN CALL FDV$BELL ELSE IF(TERMINATOR .EQ. FDV$K_FT_ILG_XFW)THEN CALL FDV$BELL ELSE IF(TERMINATOR .EQ. FDV$K_FT_ILG_SFW)THEN CALL FDV$BELL ELSE IF(TERMINATOR .EQ. FDV$K_FT_ILG_SBK)THEN CALL FDV$BELL ENDIF ENDIF ! Valid field test ! ! Go get any other field, returning its name ! IF(.NOT.DONE)THEN IF(VALID_FIELD)CALL FDV$PFT( TERMINATOR ) ! If ok change fields CALL FDV$RETFN( FIELD_NAME, FIELD_INDEX ) ! Get field name CALL FDV$GET( FIELD_VALUE, 1 TERMINATOR, FIELD_NAME) ! Get it's value ENDIF ENDDO ! ! Once we fall out of the loop, we're all done. Clean up and exit ! !+ ! This block re-scans the field names in the form and either creates ! or deletes the corresponding DCL symbol for each field name. !- INDEX = 1 ! Field counter ISTAT = 0 ! Status variable DO WHILE (ISTAT .NE. FDV$_FLD) ! Do til no more fields ISTAT = FDV$RETFO(INDEX,FIELD_NAME,FLDIDX) ! Get (next) field IF(ISTAT.EQ.FDV$_SUC)THEN ! If okay then... INDEX = INDEX + 1 ! Set up for next field CALL FDV$RET(FIELD_VALUE,FIELD_NAME) ! Get the field value ILEN = 0 ! Init a count DO IDX = 1,LEN(FIELD_VALUE) ! Scan to find the IF(FIELD_VALUE(IDX:IDX).NE.' ')ILEN=IDX ! end of the string ENDDO ! IF(ILEN.NE.0)THEN ! Non-blank string ? CALL LIB$SET_SYMBOL(FIELD_NAME, ! Yes, define the sym 1 FIELD_VALUE(1:ILEN)) ELSE CALL LIB$DELETE_SYMBOL(FIELD_NAME, ! No, delete the sym 1 LIB$K_CLI_LOCAL_SYM) ! Local only !!!!! ENDIF ENDIF ENDDO ! ! Housekeeping: ! CALL FDV$LCLOS ! Close the form lib CALL FDV$DWKSP( %DESCR(WORKSPACE) ) ! Detatch the workspace CALL FDV$DTERM( %DESCR(TCA)) ! Detatch the terminal CALL LIB$ERASE_PAGE(1,1) ! Clear the screen CALL LIB$SET_CURSOR(23,1) ! Put cursor lower left CALL EXIT ! And exit END