SUBROUTINE TFRGET (FIELD, IFT, IRETCH) C***************************************************************************** C C Description : Routine to get input from keyboard C C Arguments : FIELD = STRING containing the field name where data-entry C starts. C If the string is a null-string, data-entry starts C at the first field of the form C IFT = INTEGER to indicate wether TAB means return control C to application: 1 - return control after TAB C 0 - normal operation C output: C IRETCH = INTEGER indicating how returned after operation C with IFT=1. Result is 8,9 or 13. Argument obliged C if IFT=1. C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.2 Date : 22-apr-83 C C Module name : TFRGET.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRGET C C Updates : name version C H.A.M.Fikke V1.1 C description : Terminal settings changed from DCL commands to QIO's. C CTRL/Z results in a CALL EXIT. C C R.Beetz V1.2 C BS returns to application too when IFT=1 C IRETCH argument implemented C C***************************************************************************** C BYTE HOMSTR,CLRSTR,ERLSTR,NATSTR,HERPOS,ERRATT,HLPATT,FCR,SBUF, 1 FREC COMMON/TFRCOM/NUNIT,MAXBUF,NRNXFR,LLFLD,NLFCR,IHEFLG,ISCR, 1 NRFFFR,NRLFFR,NRFDFR,NRLDFR,NRFUFR,NRLUFR, 2 HOMSTR(4),CLRSTR(4),ERLSTR(4),NATSTR(6),HERPOS(8), 3 ERRATT(8),HLPATT(8),FCR(80),SBUF(120),FREC(40) C C update field record BYTE UPDFLD(8),UPDESC(22) EQUIVALENCE (UPDFLD,FREC(1)) ! field name EQUIVALENCE (LENUPD,FREC(9)) ! field length EQUIVALENCE (UPDESC,FREC(11)) ! attibutes escape string EQUIVALENCE (NRFCR ,FREC(33)) ! rec.nr. of field copy rec. EQUIVALENCE (NPFCR ,FREC(35)) ! pos. of field in field copy rec. EQUIVALENCE (NRDEF ,FREC(37)) ! rec.nr. of default-value record EQUIVALENCE (NRHLP ,FREC(39)) ! rec.nr. of help record C INTEGER IPARM(6) BYTE FIELD(1), 1 CHAR, 2 SCHAR(2),CC(3), 3 BEL,BS,TAB,LF,CR,EOF,ESC,RUB DATA SCHAR /' ',0/, CC /'+','$',0/ DATA BEL,BS,TAB,LF,CR,EOF,ESC,RUB /7,8,9,10,13,26,27,127/ C C C search first or specified field C IF (NRFUFR.EQ.0) GOTO 9000 CALL SCVTLU(FIELD) DO 20 IREC=NRFUFR,NRLUFR CALL TFRRU(IREC+0,'VAR') ! read update field record IF (LEN(FIELD).EQ.0 .OR. ISCOMP(FIELD,UPDFLD).EQ.0) 10,20,20 C THEN 10 CALL TFRRU(IREC+0,'FCR') ! read field copy record(s) GOTO 30 C ENDIF 20 CONTINUE GOTO 9000 C C 30 CALL TTBCLR !clear input ring buffer ISET="447 ! noecho CALL GETADR(IPARM(1),ISET) IPARM(2)=2 CALL QIO("2440,5,3,,,IPARM) CALL WAITFR(3) C C position at field, set video attributes and get character C 40 INSREP=0 ! replace/insert (0/1) toggle switch IPOINT=0 ! character pointer FCR CALL SWRITE(ISCR,CC,UPDESC) 50 CHAR=IGTKEY() IF (CHAR.EQ.EOF) CALL EXIT IF (CHAR.EQ.RUB) GOTO 152 IF (CHAR.GE.' ') GOTO 202 IF (CHAR.GT.0) GOTO 160 C C arrow keys C IF (CHAR.EQ.-22) 82,90,90 ! RIGHT ARROW C THEN 82 IF (IPOINT.EQ.LENUPD) GOTO 250 WRITE (ISCR,900) FCR(NPFCR+IPOINT) IPOINT=IPOINT+1 GOTO 50 C ENDIF 90 IF (CHAR.EQ.-21) 92,100,100 ! LEFT ARROW C THEN 92 IF (IPOINT.EQ.0) GOTO 250 IPOINT=IPOINT-1 WRITE (ISCR,900) BS GOTO 50 C ENDIF C C keypad keys C 100 IF (CHAR.EQ.-11) 102,110,110 ! PF1-key: INSERT/REPLACE C THEN 102 INSREP=(INSREP.XOR.1) GOTO 50 C ENDIF 110 IF (CHAR.EQ.-12) 112,250,250 ! PF2-key: HELP C THEN 112 IHREC=NRHLP SBUF(1)=BEL IF (IHREC.EQ.0) CALL SCOPY('No help available',SBUF(2)) IF (IHREC.NE.0) CALL TFRFS(IHREC) CALL SWRITE(ISCR,CC,HERPOS,HLPATT,SBUF) IHEFLG=1 GOTO 40 C ENDIF C C rubout/delete C 152 IF (IPOINT.EQ.0) GOTO 250 IF (INSREP.EQ.0) 154,156,156 C THEN ! rubout last character 154 IF (FCR(NPFCR+IPOINT).EQ.' ' .OR. 1 FCR(NPFCR+IPOINT).EQ.0) FCR(NPFCR+IPOINT-1)=' ' IPOINT=IPOINT-1 WRITE (ISCR,900) BS,FCR(NPFCR+IPOINT),BS GOTO 50 C ELSE ! delete character left of cursor 156 JMAX=NPFCR+LENUPD-1 DO 158 J=NPFCR+IPOINT,JMAX IF (J.LE.JMAX) FCR(J-1)=FCR(J) 158 CONTINUE FCR(JMAX)=' ' IPOINT=IPOINT-1 SCHAR(1)=BS CALL SWRITE(ISCR,CC,SCHAR,FCR(NPFCR+IPOINT)) WRITE (ISCR,900) (BS,J=1,LENUPD-IPOINT) ! back to original position GOTO 50 C ENDIF C C special characters C 160 IF (CHAR.EQ.CR) 162,170,170 ! RETURN C THEN 162 IF (IFT.EQ.1) IRETCH=CR GOTO 270 C ENDIF 170 IF (CHAR.EQ.LF) 172,180,180 ! LINEFEED: clear field C THEN 172 DO 174 J=NPFCR,NPFCR+LENUPD-1 FCR(J)=' ' 174 CONTINUE CALL SWRITE(ISCR,CC,UPDESC,FCR(NPFCR)) GOTO 40 C ENDIF 180 IF (CHAR.EQ.TAB) 182,190,190 ! TAB: next field C THEN 182 IF (IFT.EQ.1) 183,184,184 C THEN 183 IRETCH=TAB GOTO 270 C ENDIF 184 IF (IREC.EQ.NRLUFR) GOTO 250 IREC=IREC+1 GOTO 260 C ENDIF 190 IF (CHAR.EQ.BS) 192,250,250 ! BACKSPACE: former field C THEN 192 IF (IFT.EQ.1) 193,194,194 C THEN 193 IRETCH=BS GOTO 270 C ENDIF 194 IF (IREC.EQ.NRFUFR) GOTO 250 IREC=IREC-1 GOTO 260 C ENDIF C C printable ASCII characters C 202 IF (IPOINT.EQ.LENUPD) GOTO 250 IF (INSREP.EQ.0) 204,206,206 C THEN ! add character 204 FCR(NPFCR+IPOINT)=CHAR WRITE (ISCR,900) FCR(NPFCR+IPOINT) IPOINT=IPOINT+1 GOTO 50 C ELSE ! insert character 206 IF (IPOINT.GT.LENUPD) GOTO 50 IF (FCR(NPFCR+LENUPD-1).NE.' ') GOTO 250 JMIN=NPFCR+IPOINT+1 DO 208 J=NPFCR+LENUPD-1,JMIN,-1 IF (J.GE.JMIN) FCR(J)=FCR(J-1) 208 CONTINUE FCR(NPFCR+IPOINT)=CHAR CALL SWRITE(ISCR,CC,FCR(NPFCR+IPOINT)) IPOINT=IPOINT+1 IF (IPOINT.LT.LENUPD) WRITE (ISCR,900) (BS,J=1,LENUPD-IPOINT) GOTO 50 C ENDIF C C bel !!! C 250 SCHAR(1)=BEL CALL SWRITE(ISCR,CC,SCHAR) GOTO 50 C C position for new field C 260 CALL TFRRU(IREC,'ALL') ! read update field record and FCR IF (IHEFLG.NE.0) CALL SWRITE(ISCR,CC,HERPOS,ERLSTR) IHEFLG=0 GOTO 40 C C return control C 270 ISET="47 CALL QIO("2440,5,3,,,IPARM) CALL WAITFR(3) IF (IHEFLG.NE.0) CALL SWRITE(ISCR,CC,HERPOS,ERLSTR) IHEFLG=0 RETURN C C format C 900 FORMAT('+',1A1,$) C C errors C 9000 CALL FATAL('TFRGET','Field not found') END