C******************** START FILE UREAD.FOR ; GROUP UREAD5 ******************
C==============================================================
C& UREAD  ACCEPT PROGRAM PROMPT, FETCH PROGRAM INPUT
C
C  UREAD          D. MC CUNE APR 1980
C  UREAD2  -- JULY 1981 D. MC CUNE.  DELETED REFERENCES TO
c  uread3 -- January 1982  buffered indirect file input
C    **ALSO ADDED "SKIPTO" FEATURE LINES 300 FF.
C  UREAD4 -- RE-ORGANIZED MAIN-- BROKE OFF SPECIAL FUNCTIONS INTO
C     SEPERATE SUBROUTINES FOR BETTER MAINTAINABILITY
C  UREAD5 -- FURTHER BREAK UP OF UREAD MAIN
C     ADD SYSTEM FEATURES-- FOREIGN COMMAND SUPPORT FOR TYPEAHEAD
C     INTO UREAD PROGRAMS FROM DCL
C        SOFT-CODED UREAD COMMANDS THAT CAN BE TURNED OFF;
C     MAKE IT POSSIBLE TO TURN OFF UPPERCASE CONVERSION OF INPUT
C       >>TYPEAHEAD BUFFER STACK TO SUPPORT TYPEAHEAD THRU
C         MULTIPLE LEVELS OF COMMAND INPUT
C       >>OUTPUT LUN STACK SO THAT MULTIPLE LEVELS OF COMMAND
C         OUTPUT FILES MAY BE CREATED SIMULTANEOUSLY
C
C----------------------------------------------------------------------
C  DMC JAN 1988
C
C  UREAD IS NOW FULLY BROKEN UP, ONE SOURCE FILE / SUBROUTINE, AND
C  STORED IN THE PPLCC VAX TRANSP CMS/MMS SYSTEM, WITH OBJECTS MAPPED
C  TO LIBRARY GFLIB
C
C  NEW FEATURES
C
C  *ROUTINES TO SUPPORT RECONSTRUCTION OF TYPEAHEAD BUFFER FOR
C   ERROR MESSAGES-- EXAMPLE OF USE, SEE SUBROUTINE UERMSG
C
C  *OPTION TO ALLOW (CARRIAGE RETURN) WITHOUT ANYTHING ELSE AS
C   A USER RESPONSE TO PROGRAM PROMPTS.  THIS IS NOT ENABLED BY
C   DEFAULT
C     CALL URDCRI(1) ENABLES ACCEPTANCE OF BLANK LINES/ CARRIAGE RETURN
C                    INPUT
C     CALL URDCRI(0) DISABLES ACCEPTANCE OF BLANK LINES/ CARRIAGE RETURN
C
C   IF ENABLED, CALL TO LOGICAL FUNCTION LCHAR WITH BLANK ARGUMENT WILL
C   TEST-- E.G.
C     IF(LCHAR(' ')) THEN ... ! USER ENTERED BLANK LINE
C
C   BECAUSE ALL NON-BLANK INPUT IS LEFT JUSTIFIED, LCHAR(' ') IS TRUE
C   IF AND ONLY IF THE ENTIRE LINE IS BLANK
C
C  *THE UREAD COMMENT CHARACTER MAY BE CONTROLLED VIA THE URDCMC ROUTINE
C
C  *UREAD PROMPT MATCH CHECKING ALGORITHM MAY BE CONTROLLED VIA THE
C   URDPMA ROUTINE-- DEFAULT IS CHECK 1ST FOUR WORDS OF PROMPT FOR
C   MATCH WITH COPY OF PROMPT IN INPUT FILE
C
C  *UREAD CHARACTERISTICS HANDLING "WORD" INPUT MAY CHANGE
C   ENCLOSING A STRING IN DBL QUOTES (") WILL THE WHOLE STRING A
C   "WORD" AND SUPPRESS CASE CONVERSION.
C
C  *BLANK OR COMMA DELIMITTERS ON INPUT "WORDS" WILL NOW BE REQUIRED
C   TRUNCATION DUE TO WORD LONGER THAN PASSED STRING FROM APPLICATIONS
C   PROGRAM WILL BE REPORTED.  THE APPLICATIONS PROGRAM WILL NO LONGER
C   SEE THE REMAINDER OF THE TRUNCATED WORD IN THE NEXT WORD VIA
C   TYPEAHEAD...
C
C  ---
C  DMC FEB 1989
C
C   1)  USER DEFINED VISIBLE WORD DELIMITERS -- "PUNCTUATION" NOW
C  AVAILABLE.  APPLICATION SEES WORDS AND THE PUNCTUATION ITSELF.
C  BLANKS ARE WORD DELIMITERS NOT SEEN BY THE APPLICATION, IN THIS
C  MODE OF OPERATION.  IF NO USER DEFINED PUNCTUATION IS SPECIFIED,
C  THE BEHAVIOUR DESCRIBED ABOVE (JAN 1988) OBTAINS.
C
C   2)  A LINE PRE-BUFFER IS CREATED.  THIS ALLOWS THE APPLICATION TO
C  CREATE INPUT LINES TO THE UREAD/ APPLICATION COMMAND LINE INTERPRETER
C  THESE INPUT LINES WILL ECHO TO AN OUTPUT (SCRIPT) FILE
C  UP TO 8 LINES MAY BE CREATED IN ADVANCE (CF COMMON: NPRBUF,PREBUF)
C
C----------------------------------------------------------------------
C
C  I/O STACK IS
C   LUNTIN(1) -- TTY OR BATCH .COM FILE -- SYS$INPUT
C     IN CONTROL WHEN NLUNIN=1
C   LUNTIN(2...NLUNIO) -- UREAD OUTPUT FILE -- ECHO PROGRAM
C     PROMPTS AND LUNTIN(1) LEVEL USER RESPONSES TO ASCII FILE
C     WHICH CAN LATER BE READ BACK IN AS UREAD "INDIRECT" INPUT FILE
C           IF AN OUTPUT FILE IS OPEN, NLINDO = .TRUE.
C   LUNTIN(MAX0(2,(NLUNIO+1))...NLUNIN) -- UREAD INDIRECT INPUT FILE --
C     CONTROL PROGRAM IN LIEU OF DIRECT USER (SYS$INPUT) INPUT
C          IF AN INPUT FILE OTHER THAN SYS$INPUT IS OPEN,
C          NLINDI = .TRUE.
C
C   ASSOCIATED IN USERIO COMMON WITH EACH INPUT LEVEL IS
C     .A TYPEAHEAD BUFFER (AHDBUF(I))
C     .A SET OF "LOCAL" STRING PARAMETERS (PLCNAM(..,I),PLCVAL(..,I))
C     .A FILENAME (XFILE(I))
C     .A RECORD COUNT (NCMND(I))
C
C  EACH TIME THE I/O LEVEL IS CHANGED WITH AN ">" OR "@" COMMAND,
C   A NEW "CONTEXT" CONSISTING OF THE ABOVE FOUR ITEMS IS ESTABLISHED
C
C
C ----
c
c  rev 7-jan-81  D. Mc Cune --- all lower case letters
c     in input line converted to upper case
C
C   ROUTINE TO WRITE PROMPT AND READ USER RESPONSE AT
C  TERMINAL.  SPECIAL FEATURES:
C
C  IF USER LINE COMMENCES WITH ";" (SEMICOLON), THE ROUTINE
C  IGNORES THE LINE AND READS IN THE NEXT LINE
C
C  IF USER LINE COMMENCES WITH "@" ("AT") THE ROUTINE SWITCHES
C  THE INPUT DEVICE FROM THE TERMINAL TO THE FILE <FILNAM>
C  REFERENCED; E.G. FULL USER LINE IS "@<FILNAM>";
C  FILE <FILNAM> CONTAINING RECORDED INSTRUCTIONS THAT
C  WILL BE CORRECTLY INTERPRETED BY THE CALLER
C  AT E.O.F., THE TERMINAL IS RESTORED AS INPUT DEVICE
C
C  IF USER LINE IS ">[FILNAM]" THE ROUTINE CREATES THE FILE
C  NAMED AND RECORDS USER-PROGRAM INTERACTION IN THE
C  FILE UNTIL A LINE ">[C.R.]" IS ENCOUNTERED.  PROGRAM
C  MESSAGES ARE WRITTEN OUT COMMENCING WITH ";".
C  IF THE CALLING PROGRAM USES THIS ROUTINE THROUGHOUT,
C  THESE FILES MAY BE REFERENCED LATER AS INDIRECT INPUT FILES
C
C  CALLING PROGRAM SENDS PROMPTS THROUGH PASSED ARGUMENT "ABUFF"
C  WHICH ARE WRITTEN HERE WITH A PRECEDING ";".
C
C
C   >>>> IF INPUT STRING IS 'CLOSE$', ANY INDIRECT FILES ARE CLOSED
C        AND CONTROL RETURNED TO MAIN
C
C
      SUBROUTINE UREAD(ABUFFI)
C
C  THE PROMPT IN ABUFFI IS TERMINATED WITH A "$"
C
C  COMMON BLOCKS ---
C
      USE USERIO
C
C  LOCAL --
C
      CHARACTER*(*) ABUFFI
      CHARACTER*8 UCNTRL
C
C  START OF EXECUTABLE CODE --
C
C  INITIALIZE USER I/O COMMON IF NECESSARY
C
      CALL USICHK
C
C  CLEAR END-OF-FILE COUNTER (USED IN BRANCHING)
      IEOFL=0
C
C  PASS COUNTER
      IPASS=0
C
C  INPUT WORD
      LUWORD=0
C
C-----------------------------------------------/SEND THE PROMPT
 100  CONTINUE
      IPASS=IPASS+1
C  FLAG IF A PROMPT HAS BEEN TRIED
      IPRMTD=0
C  FLAG THAT AN INPUT LINE HAS BEEN READ
      INPUTL=0
C
      LCMDIN=1
C  CALLER REQUESTS INPUT-- PREPARE TO READ ANOTHER LINE
C  STRING PARAMETER INPUT CLEARED
      PRMSUB='                                                '
C
C  IF INLINE TYPE-AHEAD NOT IN EFFECT, CLEAR LINE-BUFFER
      IF(NLHOLD) CALL UCLEAR
C  IF TYPEAHEAD BUFFER IS NOT EMPTY, SUPPRESS PROMPT MATCH CHECKING
      IF(NCHARC.GT.0) CALL UREADY(1)
C
C     UNPACK PROGRAM PROMPT (ABUFFI) --
C     FIND LENGTH OF PROMPT (NCHARA) CHECK FOR NULL PROMPT
C     PROMPT IS STORED IN COMMON AS ABUFF
C
      IF(IPASS.EQ.1) CALL UDECOP(ABUFFI)
C
C  IF NULL PROMPT, SET READY TO ACCEPT COMMAND INPUT
      IF(NCHARA.EQ.0) CALL UREADY(1)
C
C  CHECK PROMPT; ECHO TO OUTPUT FILE IF ONE IS OPEN
      IF(IPASS.GT.1) GO TO 105
C
C  CHECK FOR CALL UREAD('CLOSE$')
      ICLOSE=ISCMP0(BBUFF,'CLOSE',1,5,IDUM)
      IF(ICLOSE.EQ.1) THEN
        IF(NLINDI) CALL URDERR(3)
        RETURN
      ENDIF
C  WRITE PROMPT TO TERMINAL AND/OR OUTPUT FILE IF NECESSARY
 105  CONTINUE
C  DONT PROMPT IF TYPEAHEAD BUFFER IS NOT EMPTY
      IF(NCHARC.GT.0) THEN
        IF(NLECHO) CALL UPROMT  ! ECHO TO TTY (DEBUG MODE)
        GO TO 200
      ENDIF
C  PROMPT...
      IPRMTD=1
      CALL UPROMT               ! SEND TO TTY
      CALL UPROMX               ! SEND TO OUTPUT FILE IF OPEN
C
C---------------------------------------/ACCEPT INPUT/--------------
 200  CONTINUE
C  DONT READ LINE FROM TTY OR FILE, IF LINE BUFFER IS NOT EMPTY
      IF(NCHARC.EQ.0) THEN
        NLSSUB=.FALSE.  ! new line; no "/" parameter substitution done.
C  READ INPUT LINE OR USER RESPONSE
        CALL URGET1(IER,IEOF)
        INPUTL=1
        IF(.NOT.NLINDI) NCLEAR=0
C  ERROR CHECKING
        IF(IER.NE.0) THEN
          CALL URDERR(1)
          GO TO 100
        ELSE IF(IEOF.NE.0) THEN
          CALL URDEOF(IEOFL)
          GO TO 100
        ENDIF
      ENDIF
C
C  UNPACK INPUT LINE
C
      CALL UDECOD
C  CHECK FOR ALL BLANKS
      IF(NCHARC.EQ.0) THEN
C  NULL LINE -- HAS USER HAD A CHANCE TO FILL IT?
        IF(IPRMTD.EQ.0) GO TO 105
C  NULL LINE ACCEPTABLE?
        IF(.NOT.NLNULL) THEN
C  REPEAT PROMPT-- BLANK LINES IGNORED
          CALL UPROMT
          GO TO 200
        ENDIF
      ENDIF
C---
C  ECHO INPUT LINE IF NECESSARY
      CALL URECHO(INPUTL)
C  PERFORM INLINE PARAMETER SUBSTITUTION ON NEWLY READ LINE
      IF((.NOT.NLSKIP).AND.(INPUTL.EQ.1)) THEN
        CALL UPSINL(IER)
C  IF THIS RESULTS IN AN ERROR...
        IF(IER.NE.0) THEN
          CALL UPROMT
          GO TO 200
        ENDIF
      ENDIF
C---------------------------------------------------
C  CHECK FIRST CHARACTER
C  BRANCH TO SPECIAL FUNCTION CODING ****
 222  CONTINUE
C  GENERATE SPECIAL CHARACTER STRING
      CALL URCSTR(UCNTRL)
C  CHECK AGAINST USER INPUT
      ISELEC=JXUOPC(UCNTRL,DBUFF(1))
      IF(ISELEC.NE.0) THEN
        CALL URDSPC(ISELEC,IRET,IEOFL,IERC)
        IF((IRET.LT.4).AND.(IRET.GT.0)) GO TO (222,100,500) IRET
      ELSE
        GO TO 500
      ENDIF
C  ERROR TO DROP THRU TO HERE
      IARGHH=1/IARGHH
C
C=============================/ RETURN INPUT TO CALLER /============
C
C  INPUT TO BE INTERPRETED BY CALLING PROGRAM
C
C  CHECK FOR PROMPT MATCH ERROR
C
 500  CONTINUE
C  IF SKIP FLAG SET, THROW AWAY LINE AND GET A NEW ONE (E.G. LOOKING
C  FOR BRANCH TARGET MARKER)
      IF(NLSKIP) THEN
        CALL UCLEAR
        GO TO 200
      ENDIF
C  LREADY=0 INDICATES PROMPT MATCH ERROR:  INDIRECT FILE INPUT WHICH
C   WAS NOT PRECEDED BY A COPY OF THE CORRECT PROMPT SENT FROM
C   THE MAIN PROGRAM
C  NB DMC JAN 1988:  IF LPMMSG.LT.0 THIS ERROR IS IGNORED AND THERE
C  IS NO PROMPT MATCH CHECKING
      IF((LREADY.EQ.0).AND.(LPMMSG.GE.0)) THEN
C  PROMPT ERROR MESSAGE SUPPRESION?
        IF(LPMMSG.EQ.1) THEN
          IF(NLECHO) CALL UPAUST(1)
          WRITE(LUNTRM,9050)
 9050 FORMAT(
     >' ? UREAD PROMPT MISMATCH; FILE INPUT LINE OUT OF SEQUENCE'/)
C  TRACEBACK INDIRECT INPUT FILES
          CALL UTRACE
          WRITE(LUNTRM,5050) (BBUFF(IJ),IJ=1,NCHARA)
 5050 FORMAT(/' FILE INPUT EXECUTION SUSPENDED UNTIL',
     >   ' NEXT PROMPT MATCH'/
     >   ' PROGRAM PROMPT IS:'/(1X,79A1)/)
C  DUMP RECENT RESPONSES
          CALL UCBUFX
          CALL UPAUST(1)
C
        ENDIF
C  LOOK FOR MATCHING PROMPT BEFORE PROCEEDING
C  (EVEN IF ERROR MESSAGE WAS SUPPRESSED)
        NLSKIP=.TRUE.
        CALL UCLEAR
        GO TO 200
      ENDIF
C
C  COMMAND ACCEPTED -- NORMAL EXIT -- CLEAR READY FLAG
C
      CALL UREADY(0)
C
      RETURN
C
      END
C******************** END FILE UREAD.FOR ; GROUP UREAD5 ******************
