FUNCTION GETSTRING(STRING,length) C Function subprogram to issue a prompt and accept C an input string from a terminal. The calling routine C must declare getstring an integer and must declare C STRING as a character variable of appropriate C length. The length of STRING determines the maximum C acceptable field length. An acceptable call would be: C C ISTAT = GETSTRING(STRING) C C The function value (here equated to ISTAT) indicates C the way the string was terminated, and can be used to C determine how to step through a menu-oriented program C on a video terminal. C C The output string will equal the default value if the C first character typed is a RETURN, TAB, Question Mark C Space, CTRL_C, or backspace. CTRL_Y will cause an C immediate stop. C CTRL_C will cause the default value to be returned as C STRING, even if it is not the first character. C C FUNCTION values returned are: C -4 CTRL_W, go to top and rewrite menu C -2 Up arrow, go to previous line. C -1 Backspace, go to previous entry. C 0 ?, spawn help for this entry. C 1 Return, enter, leading tab C go to next entry. C 2 Down arrow--go to next line. C 4 CTRL_Z--end this menu. C 8 CTRL_Y or CTRL_C--end program. C C (The action described is only a suggestion and must be implemented by C the calling program) C C Programmer: T. Worlton C Argonne National Laboratory C Version 1.1 8/30/84 C Version 1.2 11/9/84 C (Added Arrow Key in-line editing) C PARAMETER IMAX=80 INTEGER GETSTRING character STRING*(*),CBUFF*80,INSTR*80,CNUM*4,MODE*15 INTEGER*4 STATUS,LENGTH LOGICAL ECHO,WAIT,CHECK,MORE,INIT,SAVE,UPPER BYTE BUFF(IMAX),EBUFF(5),CR,ESC,CTRLZ,CTRLY,CTRLW BYTE CTRLC,DELETE,CTRLU,BSPACE,SPACE,B1,HT,CTRLR DATA CR,ESC,CTRLZ,CTRLY,CTRLC/13,27,26,25,3/ DATA DELETE,CTRLU,BSPACE,SPACE/127,21,8,32/ DATA HT,CTRLW,CTRLR/9,23,18/ C THIS ROUTINE WILL ONLY WORK IN ANSI MODE C THE MAIN ROUTINE SHOULD CALL ANSI FIRST IF C THE TERMINAL COULD BE IN ANOTHER MODE (Z.B. VT52) C UPPER = .FALSE. GO TO 10 ENTRY GETSTRUP(STRING,LENGTH) UPPER = .TRUE. 10 CALL GETNARG(NARG) C ( Get number of arguments to check for presence of optional C argument, LENGTH) D WRITE(8,*) 'GETSTRING NARG=',NARG CALL GTMODE(MODE,MLEN) IF(MODE(1:MLEN) .EQ. 'BATCH') THEN CALL LIB$GET_INPUT(STRING) GOTO 30 END IF C GET STARTING CURSOR POSITION C CALL CWHERE(LL1,LC1) LC1 = 1 LF = LEN(STRING) !GET FIELD LENGTH D WRITE(8,*) 'LF=',LF IF( LF .GT. IMAX) THEN LF = IMAX C CALL CSOUT('WARNING:FIELD TRUNCATED') CALL CURBCK(23) ELSE IF (LF .LT. 1) THEN CALL CSOUT('Invalid string variable') CALL CURBCK(23) LF = 1 END IF C Get length of string without trailing blanks CALL STR_TRIM(STRING,STRING,LP) D WRITE(8,*) 'LF,LP=',LF,LP IF(LP .LE. 0) THEN STRING(:LF) = ' ' LP = 1 ELSE IF(LP .GT. LF) THEN LP = LF END IF D WRITE(8,*) 'BEFORE TRIM, LP=',LP STATUS = STR$TRIM(INSTR,STRING,LPF) !SAVE INPUT VALUE D WRITE(8,*) 'AFTER TRIM, LPF=',LPF STRING(1:LF) = ' ' !CLEAR INPUT STRING CALL KEYAPP ! Set terminal to keypad application mode. NC=0 1 CALL CURBCK(NC+1-LC1) D WRITE(8,*) '1 CURBCK ',NC+1-LC1 CBUFF(:LF) = ' ' CALL REVIMG C THE NEXT LINE COMMENTED OUT BECAUSE I DIDN'T LIKE THE BLINKING C CALL BLINK CALL CSOUT(CBUFF(:LF) ) ! FILL INPUT FIELD WITH REVERSE BLANKS C MOVE CURSOR TO START OF INPUT FIELD CALL CURBCK(LF+1-LC1) D WRITE(8,*) 'CURBCK LF,SUM',LF,LF+1-LC1 NC = 0 ! character number currently being accepted IM = 0 ! greatest character number that has been input STATUS = STR$TRIM(CBUFF,INSTR,LPC) C Display default string and move cursor to beginning of string. CALL CSOUT( CBUFF(:LP) ) CALL CURBCK(LP+1-LC1) D WRITE(8,*) 'CURBCK LP,SUM',LP,LP+1-LC1 CALL ATTOFF CALL REVIMG INIT = .FALSE. ECHO = .FALSE. WAIT = .TRUE. CHECK = .FALSE. 2 CALL INCHAR(B1,ECHO,WAIT,CHECK,IERR) IF ( B1 .EQ. CTRLY) THEN CALL ATTOFF CALL EXIT !IMMEDIATE EXIT ON CTRLY, NOT CTRLC ELSE IF( B1 .EQ. CTRLC) THEN IRET = 8 MORE = .FALSE. SAVE = .FALSE. ELSE IF(B1 .EQ. ESC) THEN ! READ REST OF ESCAPE STRING CALL INCHAR(EBUFF(1),ECHO,WAIT,CHECK,IERR) CALL INCHAR(EBUFF(2),ECHO,WAIT,CHECK,IERR) SAVE = .FALSE. B1 = EBUFF(2) IF (B1 .EQ. 65) THEN ! Up arrow MORE = .FALSE. IRET = -2 ELSE IF(B1 .EQ. 66) THEN ! Down arrow MORE = .FALSE. IRET = 2 ELSE IF(B1 .EQ. 67) THEN ! right arrow MORE = .TRUE. IF(IM .EQ. 0 .AND. LP .GT. 0) THEN ! ARROW EDIT IM = LP ! length = input string length NC = 1 CBUFF(:IM) = INSTR(:IM) CALL CSOUT(CBUFF(:IM)) CALL CURBCK(IM+1-LC1) CALL CURFWD(1) ELSE IF(NC .LT. IM) THEN NC = NC + 1 CALL CURFWD(1) ELSE NC = IM CALL RING(2) END IF ELSE IF(B1 .EQ. 68) THEN ! left arrow MORE = .TRUE. IF(NC .GT. 0) THEN NC = NC - 1 CALL CURBCK(1) ELSE NC = 0 CALL RING(2) END IF ELSE IF(B1 .EQ. 50) THEN MORE = .FALSE. CALL INCHAR(EBUFF(1),ECHO,WAIT,CHECK,IERR) CALL INCHAR(EBUFF(2),ECHO,WAIT,CHECK,IERR) B1 = EBUFF(2) IF(B1 .EQ. '~') IRET= 0 !HELP KEY PRESSED ELSE IF(B1 .EQ. 114 ) THEN ! END OF LINE MORE = .TRUE. IF(IM .EQ. 0 .AND. LP .GT. 0) THEN IM = LP CBUFF(:IM) = INSTR(:IM) END IF CALL CURBCK(NC+1-LC1) CALL CSOUT(CBUFF(1:IM)) NC = IM ELSE IF(B1 .EQ. 112 ) THEN ! KEYPAD 0 (BOL) MORE = .TRUE. CALL CURBCK(NC+1-LC1) NC = 0 MORE = .TRUE. ELSE IF(B1 .EQ. 108) THEN ! KEYPAD ',' (DEL C) MORE = .TRUE. IF(IM .EQ. 0 .AND. LP .GT. 0) THEN IM = LP CBUFF(:IM) = INSTR(:IM) END IF CBUFF(NC+1:IM) = CBUFF(NC+2:IM) IM = IM - 1 CALL CSOUT(CBUFF(NC+1:IM)) CALL REVIMG CALL CSOUT(' ') CALL ATTOFF CALL CURBCK(IM-NC+1) ELSE IF (B1 .EQ. 113) THEN ! KEYPAD 1 (MOVE WORD) MORE = .TRUE. IF(IM .EQ. 0 .AND. LP .GT. 0) THEN IM = LP CBUFF(:IM) = INSTR(:IM) END IF DO WHILE (CBUFF(NC+1:NC+1) .NE. ' ' 1 .AND. NC .LE. IM) NC = NC + 1 CALL CURFWD(1) END DO NC = NC + 1 CALL CURFWD(1) ELSE MORE = .TRUE. WRITE(CNUM,200) B1 200 FORMAT(I4) CALL CSOUT('UNRECOGNIZED KEYPAD KEY'//CNUM) CALL CURBCK(27) END IF ELSE IF(B1 .EQ. CTRLU) THEN CBUFF(1:LF) = ' ' CALL REVIMG CALL CURBCK(NC+1-LC1) CALL CSOUT(CBUFF(1:LF) ) CALL CURBCK(LF+1-LC1) LP = 0 NC = 0 IM = 0 D INIT = .FALSE. MORE = .TRUE. ELSE IF(IM .EQ. 0 .AND. 1 (B1 .EQ. CR .OR. B1 .EQ. HT) ) THEN ! Initial CR or Tab IRET = 1 MORE = .FALSE. SAVE = .FALSE. ELSE IF(NC .EQ. 0 .AND. B1 .EQ. '?' ) THEN IRET = 0 MORE = .FALSE. SAVE = .FALSE. ELSE IF(B1 .EQ. CR ) THEN IF(IM .LT. LF) CBUFF(IM+1:LF) = ' ' ! CLEAR REST OF FIELD IRET = 1 MORE = .FALSE. SAVE = .TRUE. ELSE IF(B1 .EQ. 5 ) THEN ! CTRL_E GOTO END OF LINE MORE = .TRUE. IF(IM .EQ. 0 .AND. LP .GT. 0) THEN IM = LP CBUFF(:IM) = INSTR(:IM) END IF CALL CURBCK(NC+1-LC1) CALL CSOUT(CBUFF(1:IM)) NC = IM ELSE IF(B1 .EQ. BSPACE) THEN ! GOTO BEGINNING OF LINE MORE = .TRUE. CALL CURBCK(NC+1-LC1) NC = 0 MORE = .TRUE. ELSE IF(B1 .EQ. CTRLR) THEN MORE = .TRUE. CALL CURBCK(NC+1-LC1) CALL CSOUT(CBUFF(1:IM)) NC = IM ELSE IF(B1 .EQ. DELETE) THEN MORE = .TRUE. IF (NC .LT. 1) THEN CALL RING(2) GOTO 2 ELSE IF (NC .GE. IM) THEN NC = NC - 1 IM = NC CALL CURBCK(1) CALL CSOUT(' ') CALL CURBCK(1) ELSE IF (NC .LT. IM) THEN CBUFF(NC:IM-1) = CBUFF(NC+1:IM) CALL CURBCK(NC+1-LC1) NC = NC - 1 CBUFF(IM:) = ' ' CALL CSOUT(CBUFF(:IM)) CALL CURBCK(IM-NC) IM = IM - 1 END IF ELSE IF( B1 .EQ. CTRLW ) THEN IRET = -4 MORE = .FALSE. SAVE = .FALSE. ELSE IF( B1 .EQ. CTRLZ ) THEN IRET = 4 MORE = .FALSE. SAVE = .FALSE. ELSE IF(IERR .EQ. -2) THEN TYPE *,'NO CHARACTER IN BUFFER' MORE = .FALSE. ELSE IF(IM .LE. 0 ) THEN IF(LP .GT. 0) THEN CBUFF(1:LF) = INSTR(1:LP) CALL CSOUT(CBUFF(:LP) ) IM = LP CALL CURBCK(LP+1-LC1) END IF END IF NC = NC + 1 IF(NC .GT. IM) IM = NC MORE = .TRUE. IF(NC .GT. LF) THEN CALL RING(2) CALL CURBCK(1) NC = LF IM = NC CALL BLINK END IF IF(NC .LT. IM .AND. (B1 .EQ. 32 1 .OR. CBUFF(NC:NC) .EQ. ' ') 2 .AND. IM .LT. LF) THEN IM = IM + 1 ! USE INSERT MODE CBUFF(NC+1:IM) = CBUFF(NC:) CBUFF(NC:NC) = CHAR(B1) CALL ESCOUT('[4h') ! SET TO INSERT MODE CALL CSOUT(CBUFF(NC:NC)) CALL ESCOUT('[4l') ! Set to replace mode ELSE ! Use replace mode CBUFF(NC:NC) = CHAR(B1) CALL CSOUT(CHAR(B1)) END IF END IF IF(INIT) GOTO 1 IF(MORE) GOTO 2 CALL ATTOFF CALL CURBCK(NC+1-LC1) IF(SAVE) THEN STRING(:IM) = CBUFF(:IM) CALL UNDSCR ELSE IF(LP .GT. 0) THEN NC = LP IM = LP STRING(:NC) = INSTR(:NC) END IF CALL CSOUT( STRING(:IM) ) CALL ATTOFF CALL KEYNUM IF(IM .LT. LF) CALL CSOUT(STRING(IM+1:LF) ) 30 CONTINUE IF(UPPER) THEN CALL STR$UPCASE(STRING,STRING) END IF GETSTRING = IRET C GET LENGTH IF THERE ARE TWO INPUT ARGUMENTS IF (NARG .GE. 2) THEN LL = %LOC(LENGTH) IF (LL .GT. 0) THEN CALL STR_TRIM(STRING,STRING,LENGTH) D WRITE(8,*) 'LENGTH=',LENGTH ELSE D WRITE(8,*) 'LENGTH VARIABLE ABSENT IN CALL TO GETSTRING' END IF END IF RETURN END