FUNCTION EDIT (INLINE) ! Code directory begins in 5 pages ('S) ! ! EEEEE DDDD III TTTTT -- A text editing function for ! E D D I T -- Datatrieve. ! E D D I T -- ! EEE D D I T -- Allows the editing of contents ! E D D I T -- of DTR fields without page ! E D D I T -- products such as FMS or TDMS. ! EEEEE DDDD III T -- ! !----------------------------------------------------------------------------- ! ! contents page ! -------- ---- ! Header page . . . . . . . . 1 ! Author's name and installation guide . 2 ! Abstract . . . . . . . . 3 ! Useage example and restrictions . . . 5 ! Code directory . . . . . . . 6 ! Subroutine and Function list . . . 7 ! Code begins . . . . . . . . 8 ! ! ! ! Page 2 is all you need to install this program! ! ! ! ! ! CHANGE HISTORY ! ! 1. SPECIAL CASE FOR ONE CHARACTER FIELD 19 JAN 87 **CH001 ! ! ! ! ! ! ! ! ! FUNCTION NAME: EDIT ! ! AUTHOR/DATE: David Swan, December 1986 ! Aurora Software Development Unit ! CFB Greenwood, Greenwood, Nova Scotia, Canada B0P 1N0 ! ! (902) 765-3391 ex. 2866 ! ! PURPOSE: Datatrieve callable function ! ! FUNCTION: Edits passed text string and returns edited string. ! ! INSTALLATION: For details, refer to VAX DATATRIEVE Guide to ! Programming and Customizing, chapter 6. You will ! need SYSPRV and CMKRNL privileges. ! ! First, DTR$LIBRARY:DTRFND.MAR must be altered to include the following code ! (please note that the DTR$FUN_IN_ARG line is continued to include ORDER = 1) ! !----------------------------------------------------------------------------- ! ! ; FN$STR_EDIT - Edit string and return. ! ; ! ; Output is the input string after user editing. ! ; Input is a source string descriptor. ! ! $DTR$FUN_DEF FN$STR_EDIT, EDIT, 1 ! $DTR$FUN_OUT_ARG TYPE = FUN$K_INPUT ! $DTR$FUN_IN_ARG TYPE = FUN$K_DESC, OUT_PUT = TRUE, DTYPE = DSC$K_DTYPE_T, ! ORDER = 1 ! $DTR$FUN_END_DEF ! !----------------------------------------------------------------------------- ! ! After altering DTRFND.MAR, place it in DTR$LIBRARY. ! ! The function definition set DTRFND now must be assembled and placed in DTRFUN: ! ! $ MACRO DTR$LIBRARY:DTRFND.MAR ! $ LIBRARY/REPLACE DTR$LIBRARY:DTRFUN DTRFND ! ! Then, compile this function: ! ! $ FORTRAN DTREDIT ! ! and insert it into the DATATRIEVE function library: ! ! $ LIBRARY/INSERT DTR$LIBRARY:DTRFUN DTREDIT ! ! The last thing you need to do is build the new image: ! ! $ @DTR$LIBRARY:DTRBLD ! ! ABSTRACT: Datatrieve, by itself, does not allow the user to ! perform editing on the contents of fields. All ! modification is done by re-typing the whole field. ! ! Products such as FMS (Forms Management System) or ! TDMS (Terminal Data Management System) allow for this ! sort of editing, but are available only at additional ! cost. This function allows editing of contents of ! a field without having to purchase FMS or TDMS. ! ! Example: ! ! DECLARE LINE PIC X(50). (declare a field) ! LINE=* (input the field contents) ! LINE=FN$STR_EDIT(LINE) (edit the line) ! ! At this point, a "window" the size of the field ! (i.e. 50 characters) is opened on the screen in ! reverse video. It contains the contents of LINE. ! You may now edit using any of the control characters ! and sequences of the VMS terminal driver line editor. ! (This is emulated in the program and does not make ! reference to the terminal driver's edit facility.) ! After the line looks like what you want it to, press ! RETURN or CONTROL/Z and the window will disappear. ! Printing the line will show that your edits are now ! incorperated in the line. ! ! The supported commands are: ! ! left arrow - move cursor to the left by ! one character, don't go past ! beginning of window. ! ! right arrow - move cursor to the right by ! one character, don't go past ! end of window. ! ! up arrow - move cursor up one line. If ! on first line, move to first ! of window. ! ! down arrow - move cursor down one line. If ! on last line, move to end of ! window. If on second to last ! line and last line not long ! enough, move to end of window. ! ! backspace (^H) - move to beginning of line. If ! already at beginning of a line, ! move to beginning of previous ! line. Do not go past beginning ! of window. ! ! eol (^E) - move cursor to end of text in ! window. ! ! linefeed (^J) - delete word to left of cursor. ! ! adv. word (^W) - advance cursor one word. ! (This is an extension to the ! VMS terminal driver edit set.) ! ! N.B. "WORD" is defined the ! same way here as in the ter- ! minal driver book; i.e. ! delimited by any control char- ! acter, blank or: ! ' ,-.!"#$&()+@[\]^{|~/:;<>=? ! ! CTRL/U (^U) - delete from cursor to first of ! window. ! ! delete - delete character to left of ! cursor. ! ! abort (^C) (^Y) - restore line's contents & exit. ! ! exit (CR or ^Z) - return edited line. ! ! toggle (^A) - toggles between insert/over- ! strike modes. Default is ! insert, but may be changed ! in the source. ! ! any character - inserts typed character at ! cursor position in either ! insert or overstrike mode. ! All characters that rotate ! out of the "window" will be ! lost upon exit (i.e. what ! you see is what you get) but ! characters are "held" in a ! buffer and restored if you ! do some deletes and the line ! contents shift over to make ! room. (Hard to describe, easy ! to see in example.) ! ! ! Typical use in Datatrieve would look like: ! ! READY DATABASE MODIFY ! FIND DATABASE WITH RECORD="whatever" ! SELECT ! MODIFY USING RECORD_NAME=FN$STR_EDIT(RECORD_NAME) ! ! I realise that in many cases the typing of FN$STR_EDIT ! is nearly as much work as re-typing the whole field. ! To this I have but two things to say: ! ! 1. The name can easily be changed, but ! I chose to keep the Datatrieve naming ! convention; and ! ! 2. It really shines when used from a ! procedure. ! ! One suggested way to set it up in a procedure is to ! issue a "SAVE CURSOR POSITION" (7), reposition ! the cursor to within 5 lines of the bottom of the ! screen, call the edit function, issue a "RESTORE ! CURSOR POSITION" (8). This would have the ! effect of an editing window permanently stuck at the ! bottom of the screen. ! ! INPUTS: TEXT, VARIABLE LENGTH, ARGUEMENT ! ! OUTPUTS: TEXT, VARIABLE LENGTH, ARGUEMENT ! ! RESTRICTIONS: Written for VT100 or compatible terminal, only. ! Does not use virtual terminal system services since ! the window and all references to it are relative to ! where the cursor is at calling time. ! ! To assist you in determining VT100 compatibility, ! the cursor control characters used are: ! ! [A CURSOR UP ! [B CURSOR DOWN ! [D CURSOR LEFT ! [C CURSOR RIGHT ! [K ERASE TO END OF LINE (EEOL) ! [7m SET CHARACTER ATTRIBUTE TO REVERSE ! [5m SET CHARACTER ATTRIBUTE TO FLASH ! [5;4m SET CHARACTER ATT. TO FLASH/UNDERLINE ! [0m RESTORE CHARACTER ATTRIBUTES TO NORMAL ! ! CODE DIRECTORY: (useful in EDT, find index number & you find code) ! ! 1.0.0 code begins with type declarations and initializations ! 2.0.0 function begins ! 2.1.0 text and window are first output ! 2.2.0 top of edit loop ! 2.2.1 process timeout ! 2.2.2 right arrow ! 2.2.3 left arrow ! 2.2.4 down arrow ! 2.2.5 up arrow ! 2.2.6 carriage return or CONTROL Z ! 2.2.7 CONTROL Y or CONTROL C ! 2.2.8 CONTROL H or backspace ! 2.2.9 delete ! 2.2.10 CONTROL U ! 2.2.11 CONTROL J or linefeed ! 2.2.12 CONTROL W ! 2.2.13 CONTROL A ! 2.2.14 CONTROL E ! 2.2.15 insert character ...more ! 2.3.0 call DISPLAY in loop ! 2.4.0 tidy up and exit ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! no more... !----------------------------------------------------------------------------- ! ! SUBROUTINES AND FUNCTIONS USED BY EDIT: ! ! SUBROUTINE DISPLAY (LINE,ICP,IWRAP,LL,ICL) ! ! Displays LINE with cursor at position ICP underlined and ! blinking. Wraps window at IWRAP. Window length is LL ! characters. Text is ICL characters long (may be shorter ! than LL). ! ! SUBROUTINE GETCHAR (CHAN,GET,TIMEOUT) ! ! Gets a single character from the terminal keyboard. It uses ! the system service QIOW. It reads in passall mode and will ! timeout in TIMEOUT seconds. Character (in ASCII) is passed ! back in GET. CHAN is assigned earlier by SYS$ASSIGN. ! ! INTEGER FUNCTION ICLEN (CHAR1) ! ! Returns the position of the last non-blank character in CHAR1. ! ! INTEGER FUNCTION GETKEY (CHAN,TIMEOUT) ! ! Gets and decodes a keystroke from the terminal keyboard. It ! uses GETCHAR for the individual characters. Escape sequences ! are parsed (the four arrow keys and the four PF keys of the ! VT100) and returned with non-ASCII values to be interpreted by ! the calling program. All other keys return their ASCII codes. ! ! KEY CODE RETURNED ! ! up arrow 500 ! down arrow 501 ! left arrow 502 ! right arrow 503 ! PF1 504 ! PF2 505 ! PF3 506 ! PF4 507 ! ! !------------------------------------------------------------------------1.0.0 ! ! CODE BEGINS: ! CHARACTER*(*) INLINE CHARACTER*512 OLD_INLINE CHARACTER*512 OVERFLOW CHARACTER*80 BLANKS CHARACTER*3 EEOL,GO_UP,GO_DOWN,GO_LEFT,GO_RIGHT CHARACTER*3 BLINK CHARACTER*2 REMEMBER_CURSOR_POSITION, RESTORE_CURSOR_POSITION CHARACTER*4 R,N ! REVERSE, NORMAL CHARACTER*1 BELL CHARACTER*28 WORD_DELIMITER /' ,-.!"#$&()+@[\]^{|~/:;<>=?'/ LOGICAL TYPING_INTO_OVERFLOW /.FALSE./ ! when entering past window LOGICAL INSERT_MODE /.TRUE./ ! change these to alter the LOGICAL OVERSTRIKE_MODE /.FALSE./ ! default mode when called EXTERNAL SYS$ASSIGN ! uses QIOW, so must assign channel INTEGER CHAN,GET,OJJ INTEGER TIMEOUT/60/ ! timeout for edit input. This ! program takes no action but awaits ! more input. This means that if you ! have the automatic log-out program ! AUTOLOG running on your system, no ! input at edit will still take enough ! system resources to keep the user ! connected. This can be altered, if ! desired. See the appropriate place ! in the code for details. INTEGER GETKEY ! really a function ! give names to the keys so that code becomes more meaningful INTEGER UP /500/, DOWN /501/, LEFT /502/, RIGHT /503/ INTEGER F1 /504/, F2 /505/, F3 /506/, F4 /507/ INTEGER DELETE /127/ , RETURN /13/ INTEGER BACK_SPACE /8/ , CTRL_C /3/ , CTRL_Y /25/ , CTRL_Z /26/ INTEGER CTRL_U /21/ , CTRL_J /10/ , CTRL_E /5/ , CTRL_A /1/ INTEGER CTRL_W /23/ ! ! For edit lines longer that one screen line, the line must be wrapped. This ! is normally done at about one screen line (here it as at column 78). If you ! wish to change this wrap position, change this number and everything else ! will follow. ! INTEGER WRAP /78/ ! Define those things that are difficult to define in data statements. BELL=CHAR(7) ! ring terminal bell when used in output string R=CHAR(27)//'[7m' ! go to reverse video (small variable name to ! fit crowded lines) N=CHAR(27)//'[0m' ! go to normal video EEOL=CHAR(27)//'[K' ! erase to end of line DO I=1,512 ! fill overflow buffer with blanks OVERFLOW(I:I)=' ' END DO DO I=1,80 ! fill BLANKS with blanks BLANKS(I:I)=' ' END DO GO_UP=CHAR(27)//'[A' ! go up when used in output string GO_DOWN=CHAR(27)//'[B' ! go down GO_LEFT=CHAR(27)//'[D' ! go left GO_RIGHT=CHAR(27)//'[C' ! go right REMEMBER_CURSOR_POSITION=CHAR(27)//'7' RESTORE_CURSOR_POSITION=CHAR(27)//'8' WORD_DELIMITER(28:28)=CHAR(39) ! Put single quote into delimiter ! string since FORTRAN is rather ! sticky about that character. CALL SYS$ASSIGN('TT',CHAN,,) ! assign a channel to the terminal !------------------------------------------------------------------------2.0.0 ! ! FUNCTION BEGINS: ! LL=LEN(INLINE) ! length of window to produce. ICL=ICLEN(INLINE) ! where is last non_blank? IF (LL.EQ.1) THEN ! if only 1 character long, use **CH001 INSERT_MODE=.FALSE. ! overstrike mode as default **CH001 OVERSTRIKE_MODE=.TRUE.! **CH001 ENDIF ! **CH001 DO I=ICL+1,LL ! blank fill the input line. INLINE(I:I)=' ' END DO OLD_INLINE=INLINE ! store pre-edited line in holding area NUMBER_OF_LINES_NEEDED = INT(LL/WRAP)+1 ! to display full line NLN=NUMBER_OF_LINES_NEEDED ! synonym, shorter to use !------------------------------------------------------------------------2.1.0 ! ! output text into window ! DO I=1,NLN-1 WRITE(6,'(1X,A)'),R//EEOL//INLINE((I-1)*WRAP+1:I*WRAP) END DO WRITE(6,'(1X,A)'),R//EEOL//INLINE((NLN-1)*WRAP+1:LL)//N DO I=1,NLN ! restore cursor position to beginning of window WRITE(6,'(1X,A)'),GO_UP//GO_UP END DO JJ=1 ! JJ is CURSOR_POSITION, but easier to type... (sorry) CALL DISPLAY (INLINE,JJ,WRAP,LL,ICL) 10 CONTINUE ! 2.2.0 ! Once TYPING_INTO_OVERFLOW is truned on, the only way to turn it off ! is to re-locate the cursor (to anywhere). Since the only place that ! it can be during TYPING_INTO_OVERFLOW is at the end of the window, ! then moving it can be detected by checking that position. ! ! Therefore, if it is not at the end of the window, it is safe to assume ! that you want to turn off TYPING_INTO_OVERFLOW IF (JJ.LT.LL .AND. TYPING_INTO_OVERFLOW) + TYPING_INTO_OVERFLOW=.FALSE. IN=GETKEY(CHAN,TIMEOUT) ! get keystroke, noecho, passall ! ! If you have AUTOLOG installed on your system, you may wish to ! implement the following lines of code. If you do so, you may also ! wish to alter the amount of time before timeout (see where it is ! defined at beginning of code). ! ! ! ---- 2.2.1 ! IF (IN.EQ.0) THEN ! timeout occurred ! INLINE=OLD_INLINE ! remove any changes made to the text ! GOTO 20 ! and exit ! ENDIF ! ---- 2.2.2 IF (IN.EQ.RIGHT) THEN JJ=JJ+1 ! advance cursor one character IF (JJ.GT.LL) JJ=LL ! limit cursor to end of window ! ---- 2.2.3 ELSE IF (IN.EQ.LEFT) THEN JJ=JJ-1 ! retreat cursor one character IF (JJ.LT.1) JJ=1 ! limit cursor to beginning of window ! ---- 2.2.4 ELSE IF (IN.EQ.DOWN) THEN JJ=JJ+WRAP ! advance cursor one line IF (JJ.GT.LL) JJ=LL ! limit cursor to end of window ! ---- 2.2.5 ELSE IF (IN.EQ.UP) THEN JJ=JJ-WRAP ! retreat cursor one line IF (JJ.LT.1) JJ=1 ! limit cursor to beginning of window ! ---- 2.2.6 ELSE IF (IN.EQ.CTRL_Z .OR. IN.EQ.RETURN) THEN GOTO 20 ! goto exit handler ! ---- 2.2.7 ELSE IF (IN.EQ.CTRL_Y .OR. IN.EQ.CTRL_C) THEN INLINE=OLD_INLINE ! restore changes before exit GOTO 20 ! goto exit handler ! ---- 2.2.8 ELSE IF (IN.EQ.BACK_SPACE) THEN OLD_JJ=JJ JJ=INT(JJ/WRAP)*WRAP+1 ! move cursor to beginning of line IF (OLD_JJ.EQ.JJ) THEN ! if cursor hasn't moved, then it was JJ=JJ-WRAP ! already at the beginning of the IF (JJ.LT.1) JJ=1 ! line. Move cursor to the beginning ENDIF ! of the previous line. ! ---- 2.2.9 ELSE IF (IN.EQ.DELETE) THEN IF (JJ.EQ.1) THEN ! if at beginning of line, beep! WRITE(6,'(1X,A)'),GO_UP//BELL ELSE IF (JJ.EQ.2) THEN ! if at position #2 then handle thus: INLINE=INLINE(2:LL)//OVERFLOW(1:1) ! right fill from overflow OVERFLOW=OVERFLOW(2:)//' ' ! and modify overflow JJ=JJ-1 ! adjust cursor position ELSE IF (JJ.GT.2) THEN ! all other positions handle thus: INLINE=INLINE(1:JJ-2)//INLINE(JJ:LL)//OVERFLOW(1:1) OVERFLOW=OVERFLOW(2:)//' ' JJ=JJ-1 ENDIF ! ---- 2.2.10 ELSE IF (IN.EQ.CTRL_U) THEN ! delete to beginning of window INLINE=INLINE(JJ:LL)//OVERFLOW(1:JJ-1) ! right fill from overflow OVERFLOW=OVERFLOW(JJ:)//BLANKS ! adjust overflow JJ=1 ! ---- 2.2.11 ELSE IF (IN.EQ.CTRL_J) THEN ! delete word before cursor IF (JJ.GT.1) THEN ! do only if possibility of word ! before cursor J=JJ-1 DO WHILE (ICHAR(INLINE(J:J)).LE.CTRL_Z .OR. + INDEX(WORD_DELIMITER,INLINE(J:J)).NE.0 .AND. + J.GT.1) J=J-1 ! ignore delimiter if to left of cursor END DO DO WHILE (ICHAR(INLINE(J:J)).GT.CTRL_Z .AND. + INDEX(WORD_DELIMITER,INLINE(J:J)).EQ.0 .AND. + J.GE.1) J=J-1 ! find beginning of word END DO ! right fill from overflow & adjust overflow INLINE=INLINE(1:J)//INLINE(JJ:LL)//OVERFLOW(1:JJ-J) OVERFLOW=OVERFLOW(JJ-J+1:)//BLANKS JJ=J+1 ! adjust cursor position ENDIF ! ---- 2.2.12 ELSE IF (IN.EQ.CTRL_W) THEN ! go forward one word J=JJ+1 DO WHILE (ICHAR(INLINE(J:J)).GT.CTRL_Z .AND. + INDEX(WORD_DELIMITER,INLINE(J:J)).EQ.0 .AND. + J.LT.LL) ! find end of this word J=J+1 END DO DO WHILE ((ICHAR(INLINE(J:J)).LE.CTRL_Z .OR. + INDEX(WORD_DELIMITER,INLINE(J:J)).NE.0 ).AND. + J.LT.LL) ! find beginning of next word J=J+1 END DO JJ=J ! set cursor to that position IF (JJ.GT.LL) JJ=LL ! and limit it to end of window ! ---- 2.2.13 ELSE IF (IN.EQ.CTRL_A) THEN ! change mode (INSERT/OVERSTRIKE) OVERSTRIKE_MODE=.NOT.OVERSTRIKE_MODE INSERT_MODE=.NOT.INSERT_MODE ! ---- 2.2.14 ELSE IF (IN.EQ.CTRL_E) THEN ! cursor to end of text JJ=ICL+1 ! cursor_position=last_non-blank_character +1 IF (JJ.GT.LL) JJ=LL ! limited by end of window ! ---- 2.2.15 ELSE IF (IN.GT.CTRL_Z) THEN ! not a control character then insert ! if cursor is not at end of window IF (JJ.LE.LL .AND. .NOT. TYPING_INTO_OVERFLOW) THEN ! insert ONLY if there is room IF (INSERT_MODE) THEN ! shift last chr. into "overflow" area OVERFLOW=INLINE(LL:LL)//OVERFLOW ! ring bell if last character of window ! is non-blank (overflow warning) IF (ICL.GE.LL) WRITE(6,'(1X,A)'),GO_UP//BELL IF (JJ.EQ.1) THEN ! if cursor is on first character do: INLINE=CHAR(IN)//INLINE(JJ:LL-1) ! add character ELSE IF (JJ.GT.1) THEN ! if cursor is past first character do: INLINE=INLINE(1:JJ-1)//CHAR(IN)//INLINE(JJ:LL-1) ! add chr. ENDIF JJ=JJ+1 ! adjust cursor ELSE IF (OVERSTRIKE_MODE) THEN INLINE(JJ:JJ)=CHAR(IN) ! replace character at cursor JJ=JJ+1 ! and advance cursor ! don't go into TYPING_INTO_OVERFLOW ! mode when there's just 1 character IF (JJ.GT.LL .AND. LL.EQ.1) JJ=LL ! **CH001 ENDIF IF (JJ.GT.LL) THEN ! limit cursor to end of window JJ=LL TYPING_INTO_OVERFLOW=.TRUE. OJJ=0 ENDIF ELSE IF (TYPING_INTO_OVERFLOW) THEN ! mini-editor for overflow ! ! When, in the course of human events, you reach the end of the ! window and keep typing, this part of the code will let your ! typing be inserted into the overflow area. ! ! The "overflow edit" function is ONLY for inserting text. It ! does not support delete, arrow keys or anything else! ! ! Why? Touch typists can possibly out-speed the window refresh ! rate. This will leave a type-ahead buffer that needs emptying ! when the end-of-window is reached. I decided that one's effort ! should not be wasted by merely dumping the characters into the ! bit bucket, so I keep them in the overflow. To get them back, ! shorten the text in the window to bring the overflow area back ! into view. ! ! Beep to remind the user that WRITE(6,'(1X,A)'),GO_UP//BELL ! the cursor is at end of window IF (INSERT_MODE) THEN OVERFLOW=OVERFLOW(1:OJJ)//CHAR(IN)//OVERFLOW(OJJ+1:) OJJ=OJJ+1 ELSE IF (OVERSTRIKE_MODE) THEN OJJ=OJJ+1 OVERFLOW(OJJ:OJJ)=CHAR(IN) ENDIF IF (OJJ.GT.511) OJJ=511 ! limit overflow cursor to overflow ! buffer length. ENDIF ! end of "overflow editor" ENDIF ICL=ICLEN(INLINE) ! where is last non_blank in new string? ! re-paint window CALL DISPLAY (INLINE,JJ,WRAP,LL,ICL) ! 2.3.0 GOTO 10 ! repeat 20 continue ! 2.4.0 DO I=1,NLN ! User is done. Erase window & reset cursor PRINT*,EEOL ! to where it was when the function was called. END DO ! ! DO I=1,NLN ! PRINT*,GO_UP//GO_UP ! END DO ! EDIT=0 ! This beastie is used as a function, so it ! shall return a value. RETURN END SUBROUTINE DISPLAY (LINE,ICP,IWRAP,LL,ICL) ! LINE IS TEXT ! ICP IS CURSOR POSITION ! IWRAP IS WINDOW WIDTH ! LL IS STRING LENGTH ! ICL IS LENGTH OF CONTENTS CHARACTER*3 EEOL,GO_UP,GO_DOWN,GO_LEFT,GO_RIGHT CHARACTER*(*) LINE CHARACTER*512 READY_LINE ! hold lines must be minimum of WRAP + CURSOR_SIZE + 2*CONTROL + TRAILING_BLANK ! in length, i.e. 80+18+4+4+1=107 for wrap of 80 ! ! Hold lines are used to optimise window painting. Only the lines of the ! window that have changed are re-painted. On long fields (80+ characters), ! this will result in a savings of real time. ! CHARACTER*110 HOLD_LINE(7) INTEGER HOLD_LINE_LENGTH(7) /0,0,0,0,0,0,0/ CHARACTER*110 OLD_HOLD_LINE(7) INTEGER OLD_HOLD_LINE_LENGTH(7) /0,0,0,0,0,0,0/ ! CHARACTER*4 FLASH, R,N ! FLASH, REVERSE, NORMAL CHARACTER*6 C ! cursor of flash & underscore INTEGER WRAP WRAP=IWRAP GO_UP=CHAR(27)//'[A' GO_DOWN=CHAR(27)//'[B' GO_LEFT=CHAR(27)//'[D' GO_RIGHT=CHAR(27)//'[C' FLASH=CHAR(27)//'[5m' R=CHAR(27)//'[7m' N=CHAR(27)//'[0m' C=CHAR(27)//'[5;4m' ! insert cursor blink characters into the line itself prior to output IF (ICP.NE.1 .AND. ICP.NE.LL) THEN READY_LINE=LINE(1:ICP-1)//N//C// + LINE(ICP:ICP)//N//R//LINE(ICP+1:LL) ELSE IF (ICP.EQ.1) THEN READY_LINE=N//C//LINE(1:1)//N//R//LINE(2:LL) ELSE READY_LINE=LINE(1:LL-1)//N//C//LINE(LL:LL)//N//R ENDIF NUMBER_OF_LINES_NEEDED=INT(LL/WRAP)+1 NLN=NUMBER_OF_LINES_NEEDED ! synonym, shorter to use !----------------------------------------------------------------------------- ! output all full lines DO I=1,NLN-1 I_POS_N=(I-1)*WRAP+1 ! string position of first character of Ith line ! cursor in subsequent line IF (I_POS_N.LE.ICP .AND. I_POS_N+WRAP-1.LT.ICP) THEN HOLD_LINE(I)=R//READY_LINE(I_POS_N:I_POS_N+WRAP-1) + //N//' ' HOLD_LINE_LENGTH(I)=(I_POS_N+WRAP-1)-(I_POS_N)+1+9 ! cursor in this line ELSE IF (I_POS_N.LE.ICP .AND. I_POS_N+WRAP-1.GE.ICP) THEN HOLD_LINE(I)=R//READY_LINE(I_POS_N:I_POS_N+WRAP+18-1) + //N//' ' HOLD_LINE_LENGTH(I)=(I_POS_N+WRAP+18-1)-(I_POS_N)+1+8 ! 9? ! cursor in previous line ELSE HOLD_LINE(I)=R//READY_LINE(I_POS_N+18:I_POS_N+WRAP+18-1) + //N//' ' HOLD_LINE_LENGTH(I)=(I_POS_N+WRAP+18-1)-(I_POS_N+18)+1+9 ENDIF END DO !----------------------------------------------------------------------------- ! output last (possibly partial) line I_POS_N=(I-1)*WRAP+1 ! cursor in subsequent line (should never happen...) IF (I_POS_N.LE.ICP .AND. I_POS_N+WRAP-1.LT.ICP) THEN HOLD_LINE(NLN)=R//READY_LINE((NLN-1)*WRAP+1:LL) + //N//' ' HOLD_LINE_LENGTH(NLN)=(LL)-((NLN-1)*WRAP+1)+1+9 ! cursor in this line ELSE IF (I_POS_N.LE.ICP .AND. I_POS_N+WRAP-1.GE.ICP) THEN HOLD_LINE(NLN)=R//READY_LINE((NLN-1)*WRAP+1:LL+18) + //N//' ' HOLD_LINE_LENGTH(NLN)=(LL+18)-((NLN-1)*WRAP+1)+1+9 ! cursor in previous line ELSE HOLD_LINE(NLN)=R//READY_LINE((NLN-1)*WRAP+1+18:LL+18) + //N//' ' HOLD_LINE_LENGTH(NLN)=(LL+18)-((NLN-1)*WRAP+1+18)+1+9 ENDIF !----------------------------------------------------------------------------- ! display DO I=1,NLN IF (HOLD_LINE(I).NE.OLD_HOLD_LINE(I)) THEN WRITE(6,'(1X,A)'),HOLD_LINE(I)(1:HOLD_LINE_LENGTH(I)) OLD_HOLD_LINE(I)=HOLD_LINE(I) OLD_HOLD_LINE_LENGTH(I)=HOLD_LINE_LENGTH(I) ELSE WRITE(6,'(1X)') ENDIF END DO !----------------------------------------------------------------------------- ! reset cursor for next display DO I=1,NLN WRITE(6,'(1X,A)'),GO_UP//GO_UP END DO END SUBROUTINE GETCHAR (CHAN,GET,TIMEOUT) C C READS A CHARACTER WITH NO ECHO C IMPLICIT INTEGER (A-Z) EXTERNAL IO$_READVBLK,IO$M_NOECHO,IO$M_TIMED,IO$M_NOFILTR EXTERNAL IO$_TTYREADALL BYTE GET, CHARA, ESC /'33'O/ INTEGER*2 CHAN GET=0 CHARA=0 * * FOR MORE ON QIOW, SEE THE I/O USER'S GUIDE * CALL SYS$QIOW(,%VAL(CHAN), ! for no readall, use this line: (readall needed to read delete key) ! 1 %VAL(%LOC(IO$_READVBLK).OR.%LOC(IO$M_NOECHO) ! ! for readall, use: 1 %VAL(%LOC(IO$_TTYREADALL).OR.%LOC(IO$M_NOECHO) ! READ VIRTUAL BLOCK WITH NO ECHO 2 .OR.%LOC(IO$M_TIMED) ! AND ALLOW TIME OUT 3 ), , , ,CHARA,%VAL(1),%VAL(TIMEOUT),,,) ! BUFF BUFF LEN TIMEOUT AFTER (TIMEOUT) SECONDS GET = CHARA RETURN END INTEGER FUNCTION ICLEN (CHAR1) ! returns position of last non-blank character in string CHARACTER*(*) CHAR1 ICLEN=LEN(CHAR1) 10 CONTINUE IF (ICHAR(CHAR1(ICLEN:ICLEN)).EQ.32) THEN ICLEN=ICLEN-1 IF (ICLEN.GT.0) GOTO 10 ENDIF RETURN END INTEGER FUNCTION GETKEY (CHAN,TIMEOUT) INTEGER CHAN,GET,TIMEOUT INTEGER UP /500/, DOWN /501/, LEFT /502/, RIGHT /503/ INTEGER F1 /504/, F2 /505/, F3 /506/, F4 /507/ ! CALL GETCHAR (CHAN,GET,TIMEOUT) GETKEY=GET ! PRINT*,' GETKEY' IF (GET.EQ.27) THEN ! PRINT*,' ESCAPE SEQUENCE' CALL GETCHAR (CHAN,GET,TIMEOUT) IF (GET.EQ.91) THEN ! PRINT*,' ARROW SEQUENCE' CALL GETCHAR (CHAN,GET,TIMEOUT) IF (GET.EQ.ICHAR('A')) THEN GETKEY=UP ! PRINT*,' UP' ELSE IF (GET.EQ.ICHAR('B')) THEN GETKEY=DOWN ! PRINT*,' DOWN' ELSE IF (GET.EQ.ICHAR('D')) THEN GETKEY=LEFT ! PRINT*,' LEFT' ELSE IF (GET.EQ.ICHAR('C')) THEN GETKEY=RIGHT ! PRINT*,' RIGHT' ENDIF ENDIF IF (GET.EQ.79) THEN ! PRINT*,' FUNCTION KEY' CALL GETCHAR (CHAN,GET,TIMEOUT) IF (GET.EQ.ICHAR('P')) THEN GETKEY=F1 ! PRINT*,' F1' ELSE IF (GET.EQ.ICHAR('Q')) THEN GETKEY=F2 ! PRINT*,' F2' ELSE IF (GET.EQ.ICHAR('R')) THEN GETKEY=F3 ! PRINT*,' F3' ELSE IF (GET.EQ.ICHAR('S')) THEN GETKEY=F4 ! PRINT*,' F4' ENDIF ENDIF ENDIF RETURN END