Difference between revisions of "TclStack"

From Pickwiki
Jump to navigationJump to search
(Add link to latest version on github)
(Updated with tab completion for commands, file names and dictionaries)
 
Line 48: Line 48:
 
***************************************************************************
 
***************************************************************************
 
* Program: STACK
 
* Program: STACK
* Author : Ian [[McGowan]]
+
* Author : Ian McGowan
* Date  : 06/13/89
+
* Created: 1989-06-13
* Edited : $Id: STACK,v 1.20 2005/02/10 17:36:54 dsiroot Exp $
+
* Updated: 2019-09-13
* Comment: Stacks TCL commands
+
* License: (c) 1989-2019 Ian McGowan, released under MIT license
 +
* Comment: Stacks TCL commands, utilities for programmers
 
***************************************************************************
 
***************************************************************************
EQU NUL TO '',SPC TO ' ',TRUE TO 1, FALSE TO 0, BANG TO '~', UNIX TO '!'
+
* https://github.com/ianmcgowan/SCI.BP/blob/master/STACK
EQU BELL TO CHAR(7), OTHERWISE TO 1
+
CRT 'Version 2019-09 Autocomplete'
EQU RET TO 13,ESC TO 27,UP.KEY TO 1,DOWN.KEY TO 2
+
EQUATE INSERT TO '1',REPLACE TO '-1',BEEP TO CHAR(7)
EOL=@(-4);UP=@(-10)
+
EQUATE RET TO 13, ESC TO 27, UP.KEY TO 1, DOWN.KEY TO 2
 +
EQUATE PG.UP.KEY TO 21, PG.DOWN.KEY TO 22
 +
EQUATE NUL TO '',SPC TO ' ',TRUE TO 1, FALSE TO 0
 +
EQUATE SEARCH TO '~', UNIX TO '!'
 +
EQUATE BELL TO CHAR(7), OTHERWISE TO 1
 +
TERM=UPCASE(GETENV("TERM"))
 +
CS=@(-1);EOL=@(-4);EOS=@(-3);UP=@(-10);BON=@(-81);BOFF=@(-82)
 
PROMPT NUL
 
PROMPT NUL
 
+
*
LONG.LINE = 999
+
LONG.LINE = 9999;LIST.DET.FLAG=0;TIME.COMMAND=0
 
EXECUTING = FALSE;SL.ACTIVE = FALSE
 
EXECUTING = FALSE;SL.ACTIVE = FALSE
SELECT.LIST = NUL;OLD.WORD = NUL
+
*
SELECT.STATEMENT=FALSE ; CAP.ACTIVE=FALSE
 
 
 
 
PWD=GETENV("PWD")
 
PWD=GETENV("PWD")
 
I=LEN(PWD) ; ACC=NUL
 
I=LEN(PWD) ; ACC=NUL
 
FOR F=I TO 1 STEP -1
 
FOR F=I TO 1 STEP -1
    IF PWD[F,1] = '/' THEN EXIT
+
  IF PWD[F,1] = '/' THEN EXIT
    ACC=PWD[F,1]:ACC
+
  ACC=PWD[F,1]:ACC
 
NEXT F
 
NEXT F
 
+
*
INITIALS=UPCASE(@LOGNAME)
+
USERNAME=UPCASE(@LOGNAME)
EXEC.LINE=\!grep "^\:@LOGNAME:\:" /etc/passwd | awk -F: '{print $5}'\;
 
CAP.ACTIVE=TRUE
 
GOSUB EXEC.SUB
 
USERNAME=FIELD(EXEC.CAP<1>,",",1)
 
 
HOME.DIR=GETENV("HOME")
 
HOME.DIR=GETENV("HOME")
STACK.ITEM='.STACK_':INITIALS
+
STACK.ITEM='.STACK_':USERNAME
ALIAS.ITEM='.STACK.ALIAS_':INITIALS
+
ALIAS.ITEM='.STACK.ALIAS_':USERNAME
PROGRAM.ITEM='.STACK.PROGRAM_':INITIALS
+
PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME
SETTING.ITEM='.STACK.SETTING_':INITIALS
+
SETTING.ITEM='.STACK.SETTING_':USERNAME
HOME.FILE='HOME.':UPCASE(INITIALS)
+
HOME.FILE='HOME.':UPCASE(USERNAME)
 
OPEN 'VOC' TO VOC ELSE STOP 201,'VOC'
 
OPEN 'VOC' TO VOC ELSE STOP 201,'VOC'
OPEN HOME.FILE TO HOME.F ELSE
+
OPEN '_HOLD_' TO HOLD ELSE STOP 201,'_HOLD_' ;* Exists in every Unidata account
    R='DIR' ; R<2>=HOME.DIR ; R<3>='[[D_VOC]]'
+
R='DIR' ; R<2>=HOME.DIR ; R<3>='D_VOC'
    WRITE R ON VOC, HOME.FILE
+
WRITE R ON VOC, HOME.FILE
    OPEN HOME.FILE TO HOME.F ELSE STOP 201, HOME.FILE
+
OPEN HOME.FILE TO HOME.F ELSE STOP 201, HOME.FILE
END
 
 
OPEN 'CTLGTB' TO CTLGTB ELSE STOP 201,'CTLGTB'
 
OPEN 'CTLGTB' TO CTLGTB ELSE STOP 201,'CTLGTB'
 
OPEN 'CTLG'  TO CTLG  ELSE STOP 201,'CTLG'
 
OPEN 'CTLG'  TO CTLG  ELSE STOP 201,'CTLG'
OPEN 'TRIN.GLOBAL.PARAMETER' TO TRIN.GLOBAL.PARAMETER ELSE STOP 201,'TRIN.GLOBAL.PARAMETER'
+
OPEN 'STACK.AC' TO AC ELSE
 
+
  EXECUTE \CREATE.FILE STACK.AC 967,8192\
 +
  OPEN 'STACK.AC' TO AC ELSE ABORT
 +
END
 +
*
 
SETTINGS      = ';'        ;* DEFAULT COMMAND SEPERATOR
 
SETTINGS      = ';'        ;* DEFAULT COMMAND SEPERATOR
 
SETTINGS<2>  = '.'        ;* DEFAULT STACK CHAR
 
SETTINGS<2>  = '.'        ;* DEFAULT STACK CHAR
 
SETTINGS<3>  = '/'        ;* DEFAULT PROG CHAR
 
SETTINGS<3>  = '/'        ;* DEFAULT PROG CHAR
 
SETTINGS<4>  = 9999      ;* DEFAULT MAX # LINES IN STACK
 
SETTINGS<4>  = 9999      ;* DEFAULT MAX # LINES IN STACK
SETTINGS<5>  = 'SCRED'   ;* DEFAULT SCREEN EDITOR
+
SETTINGS<5>  = '!vi'     ;* DEFAULT SCREEN EDITOR (try !joe :)
 
SETTINGS<6>  = 'AE'      ;* DEFAULT LINE EDITOR
 
SETTINGS<6>  = 'AE'      ;* DEFAULT LINE EDITOR
 
SETTINGS<7>  ='* Edited :';* DEFAULT HEADER STRING
 
SETTINGS<7>  ='* Edited :';* DEFAULT HEADER STRING
 
SETTINGS<8>  = TRUE      ;* DEFAULT USE GET.LINE SUBR
 
SETTINGS<8>  = TRUE      ;* DEFAULT USE GET.LINE SUBR
 
SETTINGS<9>  = 'BP.DEV'  ;* DEFAULT WORK FILE
 
SETTINGS<9>  = 'BP.DEV'  ;* DEFAULT WORK FILE
SETTINGS<10>  = TRUE      ;* DEFAULT = CONVERT TO UCASE
+
SETTINGS<10>  = FALSE      ;* DEFAULT = CONVERT TO UCASE
 
SETTINGS<11>  = ""        ;* DEFAULT STARTUP COMMAND
 
SETTINGS<11>  = ""        ;* DEFAULT STARTUP COMMAND
 
SETTINGS<12>  = "#R#A>"    ;* DEFAULT PROMPT
 
SETTINGS<12>  = "#R#A>"    ;* DEFAULT PROMPT
 
SETTINGS<13>  = -2        ;* DEFAULT X DISPLACEMENT FOR PROMPT
 
SETTINGS<13>  = -2        ;* DEFAULT X DISPLACEMENT FOR PROMPT
 
SETTINGS<14>  = "bash"    ;* DEFAULT SHELL FOR UNIX COMMANDS
 
SETTINGS<14>  = "bash"    ;* DEFAULT SHELL FOR UNIX COMMANDS
 
+
SETTINGS<15>  = ""        ;* DEFAULT PROGRAM STACK TO USE
 +
*
 
READ R FROM HOME.F, SETTING.ITEM ELSE R=NUL
 
READ R FROM HOME.F, SETTING.ITEM ELSE R=NUL
 
I=DCOUNT(SETTINGS,@AM)
 
I=DCOUNT(SETTINGS,@AM)
 
FOR F=1 TO I
 
FOR F=1 TO I
    IF R<F> # NUL THEN SETTINGS<F> = R<F>
+
  IF R<F> # NUL THEN SETTINGS<F> = R<F>
 
NEXT F
 
NEXT F
 
COMMAND.SEPERATOR = SETTINGS<1>
 
COMMAND.SEPERATOR = SETTINGS<1>
Line 125: Line 129:
 
PROMT        = SETTINGS<12>
 
PROMT        = SETTINGS<12>
 
X.DISP      = SETTINGS<13>
 
X.DISP      = SETTINGS<13>
 +
DEF.SHELL    = SETTINGS<14>
 +
STACK.NAME  = SETTINGS<15>
 
WRITE SETTINGS ON HOME.F, SETTING.ITEM
 
WRITE SETTINGS ON HOME.F, SETTING.ITEM
 
+
*
 +
IF STACK.NAME = '' THEN
 +
  PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME
 +
END ELSE
 +
  PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME:'_':STACK.NAME
 +
END
 +
READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
 +
*
 
EXEC.LINE="!hostname" ; CAP.ACTIVE=TRUE ; GOSUB EXEC.SUB
 
EXEC.LINE="!hostname" ; CAP.ACTIVE=TRUE ; GOSUB EXEC.SUB
 
HOST.NAME=EXEC.CAP<1>
 
HOST.NAME=EXEC.CAP<1>
 
+
*
 
READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
 
READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
+
PRINT DCOUNT(STACK,@AM):' commands in stack ':HOME.DIR:'/':HOME.FILE
 
READ ALIASES FROM HOME.F, ALIAS.ITEM ELSE ALIASES = NUL
 
READ ALIASES FROM HOME.F, ALIAS.ITEM ELSE ALIASES = NUL
 +
* Override with my favorites for now.  It's a pain to manage per system.
 +
ALIASES<1>='ACTIVE'
 +
ALIASES<1,2>='CS'
 +
ALIASES<1,3>='L'
 +
ALIASES<2>='SELECT LS.MASTER WITH NUM.OF.ASSETS > "0"'
 +
ALIASES<2,2>='CLEARSELECT'
 +
ALIASES<2,3>='LIST LS.MASTER'
 
OLD.X.DISP=X.DISP
 
OLD.X.DISP=X.DISP
 
RTN=NUL
 
RTN=NUL
 +
* IL9/IL10 Check
 +
IL.VER=''
 +
OPEN 'ACCOUNT.PARAMS' TO ACCOUNT.PARAMS THEN
 +
  READ R FROM ACCOUNT.PARAMS, 'VERSION' ELSE R=''
 +
  IL.DB=PWD
 +
  IL.VER=R<4>:'/':R<8>:'.':R<26>
 +
END ELSE
 +
  EXECUTE \!cat DBConfig.xml | grep DataSource | awk -F '[<>]' '{print $3}'\ CAPTURING JDBC
 +
  JDBC=JDBC<1>
 +
  EXECUTE \!grep \:JDBC:\ ../../jdbc-bridge/bin/jdbc.properties | grep -v "^#" | grep url\ CAPTURING IL.DB
 +
  IL.DB=IL.DB<1>
 +
  OSREAD VER FROM 'version.properties' ELSE VER='il.version=10'
 +
  CONVERT CHAR(10) TO @AM IN VER
 +
  FOR F=1 TO DCOUNT(VER,@AM)
 +
    IF FIELD(VER<F>,'=',2) # '' THEN IL.VER=FIELD(VER<F>,'=',2) ; EXIT
 +
  NEXT F
 +
END
 +
CRT IL.VER:' ':IL.DB
 
IF STARTUP # NUL THEN ANS=STARTUP ; GOSUB COMMAND ; STARTUP=NUL
 
IF STARTUP # NUL THEN ANS=STARTUP ; GOSUB COMMAND ; STARTUP=NUL
 
ANS=NUL
 
ANS=NUL
 
+
*
 
LOOP
 
LOOP
    GOSUB EXPAND.PROMPT
+
  GOSUB GET.TERM.WIDTH ;* In case terminal font or window size changes
    PRINT PROMPT.DISP:
+
  GOSUB EXPAND.PROMPT
    X = LEN(PROMPT.DISP) + X.DISP
+
  PRINT BON:PROMPT.DISP:BOFF:
    ENTRY = NUL;LEN = LONG.LINE;DISP.LEN=79-X
+
  X = LEN(PROMPT.DISP) + X.DISP
    GOSUB GET.INPUT
+
  ENTRY = NUL;LEN = LONG.LINE;DISP.LEN=TERM.WIDTH-1-X
    ANS=ENTRY
+
  GOSUB GET.INPUT
    * Reread the program and command stack, since they maybe modified
+
  ANS=ENTRY
    * in another session
+
  * Reread the program and command stack, since they may be modified
    READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
+
  * in another session
    READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
+
  READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
    READ ALIASES FROM HOME.F, ALIAS.ITEM ELSE ALIASES = NUL
+
  READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
    IF RTN # ESC THEN GOSUB COMMAND
+
  READ ALIASES FROM HOME.F, ALIAS.ITEM ELSE ALIASES = NUL
 +
  IF RTN # ESC THEN GOSUB COMMAND
 
REPEAT
 
REPEAT
 
+
*
 
GET.INPUT:
 
GET.INPUT:
    IF GET.LINE.FLAG THEN
+
  IF GET.LINE.FLAG THEN
        CALL GET.LINE.STACK(X,LEN,DISP.LEN,ENTRY,RTN)
+
    *CALL GET.LINE.STACK(X,LEN,DISP.LEN,ENTRY,RTN)
     END ELSE
+
     GOSUB GET.LINE
        PRINT @(X):;INPUT ENTRY
+
  END ELSE
        RTN = RET
+
    PRINT @(X):;INPUT ENTRY
    END
+
    RTN = RET
 +
  END
 
RETURN
 
RETURN
 
+
*
 
COMMAND:
 
COMMAND:
    BEGIN CASE
+
  MAX.STACK=DCOUNT(STACK,@AM)
            * Map up and down arrows to .R1 and .Rn
+
  BEGIN CASE
        CASE RTN = UP.KEY
+
      * Map up and down arrows to .R1 and .Rn
            ANS = '.R1'
+
    CASE RTN = UP.KEY
        CASE ANS='?'
+
      ANS = '.R1'
            ANS='.H'
+
    CASE RTN = PG.UP.KEY
    END CASE
+
      IF UNASSIGNED(P2) THEN P2 = 20
    IF ANS = NUL THEN RETURN
+
      IF UNASSIGNED(P1) THEN P1 = 1
    UNIX.COMMAND=FALSE
+
      P2 = P2 + 20
    IF ANS[1,1] = UNIX THEN UNIX.COMMAND=TRUE
+
      P1 = P1 + 20
    OLD.STACK = STACK
+
      IF P2 > MAX.STACK THEN P2 = MAX.STACK
    START.WORD.SEARCH = 1
+
      IF P1 > MAX.STACK-20 THEN P1 = MAX.STACK-20
    COMMAND.LIST = ANS
+
      ANS = '.L':P1:',':P2
    COMMAND.COUNT = 1
+
    CASE RTN = PG.DOWN.KEY
    IF STARTUP#NUL THEN EXECUTING=TRUE ELSE EXECUTING=FALSE
+
      IF UNASSIGNED(P2) THEN P2 = 20
    IF UNIX.COMMAND THEN
+
      IF UNASSIGNED(P1) THEN P1 = 1
        * Don't look for ; for unix commands
+
      P2 = P2 - 20
        GOSUB DO.COMMAND
+
      P1 = P1 - 20
    END ELSE
+
      IF P2 < 20 THEN P2=20
        LOOP
+
      IF P1 < 1 THEN P1=1
            ANS = FIELD(COMMAND.LIST,COMMAND.SEPERATOR,COMMAND.COUNT)
+
      ANS = '.L':P1:',':P2
        UNTIL ANS = NUL DO
+
    CASE ANS='?'
            GOSUB DO.COMMAND
+
      ANS='.H'
            COMMAND.COUNT = COMMAND.COUNT + 1
+
  END CASE
        REPEAT
+
  IF ANS = NUL THEN RETURN
    END
+
  UNIX.COMMAND=FALSE
    WRITE ALIASES ON HOME.F, ALIAS.ITEM
+
  IF ANS[1,1] = UNIX THEN UNIX.COMMAND=TRUE
 +
  OLD.STACK = STACK
 +
  START.WORD.SEARCH = 1
 +
  COMMAND.LIST = ANS
 +
  COMMAND.COUNT = 1
 +
  IF STARTUP#NUL THEN EXECUTING=TRUE ELSE EXECUTING=FALSE
 +
  IF UNIX.COMMAND THEN
 +
    * Don't look for ; for unix commands
 +
    GOSUB DO.COMMAND
 +
  END ELSE
 +
    LOOP
 +
      ANS = FIELD(COMMAND.LIST,COMMAND.SEPERATOR,COMMAND.COUNT)
 +
    UNTIL ANS = NUL DO
 +
      GOSUB DO.COMMAND
 +
      COMMAND.COUNT = COMMAND.COUNT + 1
 +
    REPEAT
 +
  END
 +
  WRITE ALIASES ON HOME.F, ALIAS.ITEM
 
RETURN
 
RETURN
 
+
*
 
DO.COMMAND:
 
DO.COMMAND:
    IF MCU.ON AND NOT(UNIX.COMMAND) THEN
+
  IF NOT(UNIX.COMMAND) THEN
        ANS = TRIM(UPCASE(ANS))
+
    IF MCU.ON THEN ANS = TRIM(UPCASE(ANS))
        IF ANS[1,5] # 'ALIAS' THEN GOSUB EXPAND.ALIASES
+
    IF ANS[1,5] # 'ALIAS' THEN GOSUB EXPAND.ALIASES
        GOSUB EXPAND.PROG.CHARS
+
    GOSUB EXPAND.PROG.CHARS
    END
+
  END
    IF ANS='!' THEN ANS='!':SETTINGS<14>
+
  IF ANS='!' THEN ANS='!':DEF.SHELL
    LEN.ANS = LEN(ANS)
+
  LEN.ANS = LEN(ANS)
    SEARCH.FOR=NUL
+
  SEARCH.FOR=NUL
    SELECT.STATEMENT=FALSE
+
  CAP.ACTIVE=FALSE
    CAP.ACTIVE=FALSE
+
  FIRST.WORD=FIELD(ANS,' ',1)
    BEGIN CASE
+
  UPDATE.STACK.FLAG=TRUE
        CASE ANS[1,1] = STACK.CHAR
+
  BEGIN CASE
            GOSUB STACK.COMMAND
+
    CASE ANS[1,1] = STACK.CHAR
        CASE ANS[1,1] = PROG.CHAR
+
      ANS = TRIM(UPCASE(ANS))
            GOSUB PROG.COMMAND
+
      GOSUB STACK.COMMAND
        CASE ANS[1,1] = BANG
+
      UPDATE.STACK.FLAG=FALSE
            GOSUB BANG.COMMAND
+
    CASE ANS[1,1] = PROG.CHAR
        CASE ANS = 'QUIT' OR ANS = 'OFF' OR ANS = 'EXIT'
+
      ANS = TRIM(UPCASE(ANS))
            GOSUB WRITE.INFO
+
      GOSUB PROG.COMMAND
            CHAIN 'OFF'
+
      UPDATE.STACK.FLAG=FALSE
        CASE ANS = 'Q'
+
    CASE ANS[1,1] = SEARCH
            GOSUB WRITE.INFO
+
      GOSUB SEARCH.COMMAND
            STOP
+
      UPDATE.STACK.FLAG=FALSE
         CASE ANS[1,5] = 'ALIAS'
+
    CASE UPCASE(ANS) = 'OFF' OR UPCASE(ANS) = 'Q'
            GOSUB DO.ALIAS
+
      GOSUB WRITE.INFO
        CASE OTHERWISE
+
      STOP
            IF NOT(EXECUTING) THEN
+
    CASE FIRST.WORD='AC'
                INS ANS BEFORE STACK<1>
+
      GOSUB BUILD.AC
                WRITE STACK ON HOME.F, STACK.ITEM
+
    CASE FIRST.WORD = 'ALIAS'
            END
+
      GOSUB DO.ALIAS
            IF ANS[1,6] = 'SELECT' OR ANS[2,6]= 'SELECT' OR ANS[1,8]= 'GET.LIST' OR ANS[1,6] = 'SEARCH' THEN SELECT.STATEMENT=TRUE
+
    CASE FIRST.WORD = 'SE'
            EXEC.LINE = ANS
+
      FILE=FIELD(ANS,' ',2)
            GOSUB EXEC.SUB
+
      ID=FIELD(ANS,' ',3)
            IF SELECT.STATEMENT THEN SL.ACTIVE=TRUE ELSE SL.ACTIVE=FALSE
+
      GOSUB SEARCH.BY.EXAMPLE
    END CASE
+
    CASE FIRST.WORD = 'CI'
 +
      * CONTRACT INQUIRY
 +
      CONTRACT=FIELD(ANS,' ',2)
 +
      DATA 0
 +
      DATA 0
 +
      DATA 0
 +
      DATA 0
 +
      IF CONTRACT # '' THEN
 +
        CONVERT '.' TO '-' IN CONTRACT
 +
        DATA FIELD(CONTRACT,'-',1)
 +
         DATA FIELD(CONTRACT,'-',2,2)
 +
      END
 +
      EXEC.LINE=\CMAINT.00\ ; GOSUB EXEC.SUB
 +
    CASE FIRST.WORD = 'CM'
 +
      * CONTRACT MAINTENANCE
 +
      CONTRACT=FIELD(ANS,' ',2)
 +
      DATA 1
 +
      DATA 0
 +
      DATA 0
 +
      DATA 0
 +
      IF CONTRACT # '' THEN
 +
        CONVERT '.' TO '-' IN CONTRACT
 +
        DATA FIELD(CONTRACT,'-',1)
 +
        DATA FIELD(CONTRACT,'-',2,2)
 +
      END
 +
      EXEC.LINE=\CMAINT.00\ ; GOSUB EXEC.SUB
 +
    CASE FIRST.WORD = 'CCI'
 +
      * CUSTOMER INQUIRY
 +
      DATA 0
 +
      DATA 0
 +
      DATA 0
 +
      IF FIELD(ANS,' ',2) # '' THEN
 +
        DATA FIELD(ANS,' ',2)
 +
      END
 +
      EXEC.LINE=\CDMAINT.00\ ; GOSUB EXEC.SUB
 +
    CASE FIRST.WORD = 'CCM'
 +
      * CUSTOMER MAINTENANCE
 +
      DATA 1
 +
      DATA 0
 +
      DATA 0
 +
      IF FIELD(ANS,' ',2) # '' THEN
 +
        DATA FIELD(ANS,' ',2)
 +
      END
 +
      EXEC.LINE=\CDMAINT.00\ ; GOSUB EXEC.SUB
 +
    CASE ANS = 'TM'
 +
      DATA 1
 +
      DATA 0
 +
      EXEC.LINE=\TMAINT.00\ ; GOSUB EXEC.SUB
 +
    CASE FIRST.WORD = 'CHECK.FILE'
 +
      GOSUB CHECK.FILE
 +
    CASE ANS = 'ICONV'
 +
      CONV='I'
 +
      GOSUB CONV
 +
    CASE ANS = 'OCONV'
 +
      CONV='O'
 +
      GOSUB CONV
 +
    CASE ANS = 'RULER'
 +
      GOSUB GET.TERM.WIDTH
 +
      GOSUB RULER
 +
    CASE FIRST.WORD = 'PIVOT'
 +
      GOSUB PIVOT
 +
    CASE FIRST.WORD = 'PROF'
 +
      GOSUB PROFILE
 +
    CASE FIRST.WORD = 'DDD'
 +
      GOSUB DDD
 +
    CASE FIRST.WORD = 'BPI'
 +
      GOSUB BPI
 +
    CASE FIRST.WORD = 'SF'
 +
      GOSUB SEARCH.FILE
 +
    CASE FIRST.WORD = 'AF'
 +
      GOSUB ATB.FIND
 +
    CASE ANS='PARAM'
 +
      GOSUB LIST.PARAM
 +
    CASE FIRST.WORD = 'PICKLE'
 +
      GOSUB PICKLE
 +
    CASE ANS='SETTINGS'
 +
      GOSUB SETTINGS
 +
    CASE FIRST.WORD='RS'
 +
      GOSUB RECALL.SHELL
 +
    CASE FIRST.WORD='FIND.MENU'
 +
      GOSUB FIND.MENU
 +
    CASE ANS='LISTA'
 +
      GOSUB LISTA
 +
    CASE FIRST.WORD = 'DESC'
 +
      GOSUB IL10.DESC
 +
    CASE FIRST.WORD = 'XREF'
 +
      GOSUB IL10.XREF
 +
    CASE FIRST.WORD = 'FIELD'
 +
      GOSUB IL10.AF
 +
    CASE FIRST.WORD = 'NED'
 +
      GOSUB IL10.NED
 +
    CASE FIRST.WORD = 'NSEL'
 +
      GOSUB IL10.NSEL
 +
    CASE FIRST.WORD = 'SQL'
 +
      GOSUB SQL.SEL
 +
    CASE FIRST.WORD = 'SQLF'
 +
      GOSUB SQL.FILE
 +
    CASE FIRST.WORD = 'SQL-LIST'
 +
      GOSUB SQL.SEL.LIST
 +
    CASE OTHERWISE
 +
      EXEC.LINE = ANS
 +
      T1=SYSTEM(12)
 +
      GOSUB EXEC.SUB
 +
      IF TIME.COMMAND THEN PRINT SYSTEM(12)-T1:' ms'
 +
  END CASE
 +
  IF UPDATE.STACK.FLAG THEN GOSUB UPDATE.STACK
 
RETURN
 
RETURN
 
+
*
 
DO.ALIAS:
 
DO.ALIAS:
    AL = FIELD(ANS,SPC,2)
+
  AL = FIELD(ANS,SPC,2)
    STRING = NUL;I = 3
+
  STRING = NUL;I = 3
    LOOP
+
  LOOP
        F = FIELD(ANS,SPC,I)
+
    F = FIELD(ANS,SPC,I)
    UNTIL F = NUL DO
+
  UNTIL F = NUL DO
        STRING = STRING:SPC:F
+
    STRING = STRING:SPC:F
        I = I + 1
+
    I = I + 1
    REPEAT
+
  REPEAT
    BEGIN CASE
+
  BEGIN CASE
        CASE AL = NUL AND STRING = NUL
+
    CASE AL = NUL AND STRING = NUL
            GOSUB LIST.ALIAS
+
      GOSUB LIST.ALIAS
        CASE STRING = NUL
+
    CASE STRING = NUL
            GOSUB LIST.ONE.ALIAS
+
      GOSUB LIST.ONE.ALIAS
        CASE 1
+
    CASE 1
            GOSUB SET.ALIAS
+
      GOSUB SET.ALIAS
    END CASE
+
  END CASE
 
RETURN
 
RETURN
 
+
*
 
SET.ALIAS:
 
SET.ALIAS:
    STRING=STRING[2,LONG.LINE]
+
  STRING=STRING[2,LONG.LINE]
    PRINT AL:'=':STRING
+
  PRINT AL:'=':STRING
    LOCATE AL IN ALIASES<1> BY 'AL' SETTING P THEN
+
  LOCATE AL IN ALIASES<1> BY 'AL' SETTING P THEN
        ALIASES<2,P> = STRING
+
    ALIASES<2,P> = STRING
    END ELSE
+
  END ELSE
        INS AL BEFORE ALIASES<1,P>;INS STRING BEFORE ALIASES<2,P>
+
    INS AL BEFORE ALIASES<1,P>;INS STRING BEFORE ALIASES<2,P>
    END
+
  END
 
RETURN
 
RETURN
 
+
*
 
LIST.ALIAS:
 
LIST.ALIAS:
    I = DCOUNT(ALIASES<1>,@VM)
+
  I = DCOUNT(ALIASES<1>,@VM)
    FOR F = 1 TO I
+
  FOR F = 1 TO I
        PRINT ALIASES<1,F>,ALIASES<2,F>
+
    PRINT ALIASES<1,F>,ALIASES<2,F>
    NEXT F
+
  NEXT F
 
RETURN
 
RETURN
 
+
*
 
LIST.ONE.ALIAS:
 
LIST.ONE.ALIAS:
    LOCATE AL IN ALIASES<1> BY 'AL' SETTING P ELSE PRINT AL:' not found';RETURN
+
  LOCATE AL IN ALIASES<1> BY 'AL' SETTING P ELSE PRINT AL:' not found';RETURN
    X=0;LEN=99;DISP.LEN=30;ENTRY=ALIASES<2,P>
+
  X=0;LEN=99;DISP.LEN=30;ENTRY=ALIASES<2,P>
    GOSUB GET.INPUT
+
  GOSUB GET.INPUT
    IF RTN = 27 THEN RETURN
+
  IF RTN = 27 THEN RETURN
    ALIASES<2,P> = ENTRY
+
  ALIASES<2,P> = ENTRY
    IF ENTRY = NUL THEN DEL ALIASES<1,P>;DEL ALIASES<2,P>
+
  IF ENTRY = NUL THEN DEL ALIASES<1,P>;DEL ALIASES<2,P>
 
RETURN
 
RETURN
 
+
*
 
EXEC.SUB:
 
EXEC.SUB:
     IF EXEC.LINE = NUL THEN RETURN
+
  IF EXEC.LINE = NUL THEN RETURN
 +
  IF EXEC.LINE = 'CLEARSELECT' THEN CLEARSELECT
 +
  IF CAP.ACTIVE THEN
 +
    EXECUTE EXEC.LINE CAPTURING EXEC.CAP
 +
  END ELSE
 +
    EXECUTE EXEC.LINE
 +
  END
 +
  IF SYSTEM(11) > 0 THEN SL.ACTIVE = TRUE ELSE SL.ACTIVE = FALSE
 +
  CAP.ACTIVE=FALSE
 +
RETURN
 +
*
 +
EXPAND.PROG.CHARS:
 +
  * expand //10 to be IV.BP IV.EQP.MNT for example
 +
  POS = 1
 +
  LOOP
 +
    I = INDEX(ANS,PROG.CHAR:PROG.CHAR,POS)
 +
  UNTIL I = 0 DO
 +
    VAR = NUL;IDX = I+2
 +
    LOOP
 +
      C = ANS[IDX,1]
 +
    UNTIL NOT(NUM(C)) OR C = NUL DO
 +
      VAR = VAR:C
 +
      IDX = IDX+1
 +
    REPEAT
 +
     IF NUM(VAR) AND VAR > 0 THEN
 +
      ANS = ANS[1,I-1]:PROGRAMS<VAR>:ANS[IDX,LONG.LINE]
 +
    END ELSE
 +
      POS = POS + 1
 +
    END
 +
  REPEAT
 +
RETURN
 +
*
 +
EXPAND.ALIASES:
 +
  SWAP SPC WITH @VM IN ANS ; POS = 1
 +
  LOOP
 +
    R = ANS<1,POS>
 +
  UNTIL R = NUL DO
 +
    LOCATE R IN ALIASES<1> BY 'AL' SETTING P THEN ANS<1,POS> = ALIASES<2,P>
 +
    POS = POS + 1
 +
  REPEAT
 +
  SWAP @VM WITH SPC IN ANS
 +
RETURN
 +
*
 +
EXPAND.PROMPT:
 +
  IF SL.ACTIVE THEN
 +
    PROMPT.DISP='#R':SYSTEM(11):'-SEL>'
 +
    OLD.X.DISP=X.DISP
 +
    X.DISP=-2
 +
  END ELSE
 +
    PROMPT.DISP = PROMT
 +
    X.DISP=OLD.X.DISP
 +
  END
 +
  CTR = 1
 +
  LOOP
 +
    I = INDEX(PROMPT.DISP,'#',CTR)
 +
  UNTIL I = 0 DO
 +
    F = PROMPT.DISP[I+1,1]
 +
    L = PROMPT.DISP[1,I-1];R = TRIM(PROMPT.DISP[I+2,LONG.LINE])
 
     BEGIN CASE
 
     BEGIN CASE
         CASE SL.ACTIVE AND SELECT.STATEMENT
+
      CASE F = 'B'
            EXECUTE EXEC.LINE PASSLIST SEL.LIST.IN RTNLIST SEL.LIST.OUT
+
         PROMPT.DISP = L:CHAR(7):R
            SEL.LIST.IN=SEL.LIST.OUT
+
      CASE F = 'A'
        CASE SL.ACTIVE
+
        PROMPT.DISP = L:ACC:R
            EXECUTE EXEC.LINE PASSLIST SEL.LIST.IN
+
      CASE F = 'T'
         CASE SELECT.STATEMENT
+
        PROMPT.DISP = L:OCONV(TIME(),'MTS'):R
            EXECUTE EXEC.LINE RTNLIST SEL.LIST.OUT
+
      CASE F = 'D'
            SEL.LIST.IN=SEL.LIST.OUT
+
        PROMPT.DISP = L:OCONV(DATE(),'D'):R
        CASE CAP.ACTIVE
+
      CASE F = 'E'
            EXECUTE EXEC.LINE CAPTURING EXEC.CAP
+
        PROMPT.DISP = L:CHAR(ESC):R
         CASE 1
+
      CASE F = 'R'
            EXECUTE EXEC.LINE
+
        PROMPT.DISP = L:CHAR(13):CHAR(10):R
 +
      CASE F = '#'
 +
        PROMPT.DISP = L:'#':R
 +
         CTR = CTR + 1
 +
      CASE F = 'U'
 +
        PROMPT.DISP = L:USERNAME:R
 +
      CASE F = 'H'
 +
        PROMPT.DISP=L:FIELD(HOST.NAME,".",1):R
 +
      CASE OTHERWISE
 +
         CTR = CTR + 1
 
     END CASE
 
     END CASE
 +
  REPEAT
 
RETURN
 
RETURN
 
+
*
EXPAND.PROG.CHARS:
+
STACK.COMMAND:
     * expand //10 to be IV.BP IV.EQP.MNT for example
+
  BEGIN CASE
     POS = 1
+
     CASE ANS='.D'
    LOOP
+
      LIST.DET.FLAG=NOT(LIST.DET.FLAG)
        I = INDEX(ANS,PROG.CHAR:PROG.CHAR,POS)
+
     CASE ANS[1,2] = '.L'
    UNTIL I = 0 DO
+
      IF ANS = '.L' THEN ANS = '.L,20'
        VAR = NUL;IDX = I+2
+
      GOSUB GET.PARAMS
        LOOP
+
      IF RANGE.ERROR THEN RETURN
            C = ANS[IDX,1]
+
      I = DCOUNT(STACK,@AM)
         UNTIL NOT(NUM(C)) OR C = NUL DO
+
      IF I = 0 THEN PRINT 'No items present';RETURN
            VAR = VAR:C
+
      IF P2 > I THEN P2 = I
            IDX = IDX+1
+
      PRINT
        REPEAT
+
      FOR F = P2 TO P1 STEP -1
        IF NUM(VAR) AND VAR > 0 THEN
+
         IF LIST.DET.FLAG THEN
            ANS = ANS[1,I-1]:PROGRAMS<VAR>:ANS[IDX,LONG.LINE]
+
          PRINT SPC:F'R#3':" ":STACK<F,1>'L#20':' ':OCONV(STACK<F,2>,'D-YMD'):' ':OCONV(STACK<F,3>,'MTS'):' ':STACK<F,4>
 
         END ELSE
 
         END ELSE
            POS = POS + 1
+
          PRINT SPC:F'R#3':" ":STACK<F,4>
 
         END
 
         END
 +
      NEXT F
 +
    CASE ANS[1,2] = '.R' OR ANS[1,2] = '.X'
 +
      IF STACK = NUL THEN PRINT BELL ELSE GO EDIT
 +
    CASE ANS = '.P'
 +
      PRINT '#R - Return  #A - Account  #D - Date  #T - Time #P - Port'
 +
      PRINT '#E - Escape  #L - Level    #U - User  #H - Host'
 +
      PRINT 'Prompt':
 +
      X = 7;DISP.LEN = 60;ENTRY = PROMT;LEN = 99;GOSUB GET.INPUT
 +
      PROMT = ENTRY
 +
      PRINT 'Enter the X displacement for input :':
 +
      ENTRY = NUL;LEN = 5;DISP.LEN = 5;X = 37;GOSUB GET.INPUT
 +
      X.DISP = ENTRY
 +
      IF NOT(NUM(X.DISP)) THEN X.DISP = 0
 +
      SETTINGS<12> = PROMT
 +
      SETTINGS<13> = X.DISP
 +
      OLD.X.DISP=X.DISP
 +
    CASE ANS = '.H'
 +
      CRT '--------------------------- TCL STACK COMMANDS --------------------------------'
 +
      CRT 'Ctrl-A      Start of line              Ctrl-R          Toggle insert mode'
 +
      CRT 'Ctrl-B      Back one char              Ctrl-U          Page Up'
 +
      CRT 'Ctrl-D      Delete char                Ctrl-V          Page Down'
 +
      CRT 'Ctrl-E      End of line                Ctrl-W          Delete word'
 +
      CRT 'Ctrl-F      Forward char              Ctrl-X          Forward word'
 +
      CRT 'Ctrl-G      Cancel line                Ctrl-Z          Back word'
 +
      CRT 'Ctrl-I      Forward word              ~xyz            Search for xyz'
 +
      CRT 'Ctrl-J      Delete to end              .D              Toggle detail off/on'
 +
      CRT 'Ctrl-L      Clear screen              .Lm,n            List entry m thru n'
 +
      CRT 'Ctrl-M      Accept line                .Rn              Restore entry n, edit'
 +
      CRT 'Ctrl-N      Next line                  .H              Help'
 +
      CRT 'Ctrl-P      Previous line              Q/INFO          Quit back to TCL'
 +
      CRT '---------------------- PROGRAM STACK COMMANDS ---------------------------------'
 +
      CRT '/          List the active prog stack'
 +
      CRT '/LL        List available prog stacks /L BLAH          Switch stack to BLAH'
 +
      CRT '/Nx        Add a New program          /Fx              Format the x`th program'
 +
      CRT '/Ex        Edit the x`th program      /WW              Edit the program list'
 +
      CRT '/Wx        VI the x`th program        /S              Sort the program stack'
 +
      CRT '/Bx        Compile the x`th program  /BR              Compile and run'
 +
      CRT '---------------------------- UTILITIES ----------------------------------------'
 +
      CRT '                        ----------IL9---------'
 +
      CRT 'AF          ATB Finder, search definitions                          - AF MRKTNG'
 +
      CRT 'DDD        Search dictionary definitions                - DDD LS.MASTER EQUIP'
 +
      CRT 'LISTA      Show users logged in, as well as locks'
 +
      CRT '                        ----------IL10--------'
 +
      CRT 'FIELD      Show IL10 attribute/field metadata            - FIELD LS.NET.INVEST'
 +
      CRT 'NED        Edit an IL10 record                - NED LS.MASTER 123-1234567-000'
 +
      CRT 'NSEL        Run a simple UD command - NSEL LS.INV.NUM N.CONTRACT.KEY N.DATE.DUE'
 +
      CRT 'DESC        Describe columns in a table                - DESC LS_OI_CTD_INVOICE'
 +
      CRT 'SQL        Run a SQL command -SQL SELECT TOP 10 ALTERNATE_ID FROM LS_MASTER_NF'
 +
      CRT 'SQLF        Run a SQL command from a file        - SQLF /tmp/queries/Query1.sql'
 +
      CRT 'SQL-LIST    SQL to L1 -SQL-LIST L1 SELECT TOP 10 ALTERNATE_ID FROM LS_MASTER_NF'
 +
      CRT 'XREF        Show IL10 file/table metadata                      - XREF LS.MASTER'
 +
      CRT '                              ---INFOLEASE---'
 +
      CRT 'BPI        List table definitions                        - BPI LS.CTD.PYMTHIST'
 +
      CRT 'CHECK.FILE  Show strings in a compiled program /P|/S    - CHECK.FILE DISP.00 /P'
 +
      CRT '{C}CI/CM/TM {Customer}Contract Inquiry/Maintenance/Table Maintenance'
 +
      CRT 'FIND.MENU  Search the menus                                  - FIND.MENU VOID'
 +
      CRT 'PARAM      Show parameter file mapping'
 +
      CRT 'RS          Edit a recall                                      RS DK.AUDIT.RPT'
 +
      CRT '                            -----GENERAL-----'
 +
      CRT 'ICONV/OCONV Test format masks/Convert Data'
 +
      CRT 'PICKLE      Store data records in prog    - PICKLE DICT LS.MASTER UATB.BIG.ATB'
 +
      CRT 'PIVOT      Summary data                - PIVOT LS.MASTER LESSOR GROSS.CONTRACT'
 +
      CRT 'PROF        Profile data    - PROF LS.MASTER BRANCH NUM.OF.ASSETS BOOKING.DATE'
 +
      CRT 'RULER      Reset term width, show ruler'
 +
      CRT 'SETTINGS    Change settings'
 +
      CRT 'SF          Search files and dictionaries            - SF DICT LS.MASTER ASSETS'
 +
    CASE ANS = '.T'
 +
      TIME.COMMAND=NOT(TIME.COMMAND)
 +
    CASE ANS = '.U'
 +
      IF MCU.ON THEN MCU.ON = FALSE;PRINT 'upper case off' ELSE MCU.ON = TRUE;PRINT 'UPPER CASE ON'
 +
    CASE OTHERWISE
 +
      PRINT 'There is no such STACK command':BELL
 +
      PRINT '? for help'
 +
  END CASE
 +
RETURN
 +
*
 +
GET.PARAMS:
 +
  I = INDEX(ANS,',',1)
 +
  IF I # 0 THEN
 +
    L = I-1;P1 = NUL
 +
    LOOP
 +
      IF NUM(ANS[L,1]) THEN P1 = ANS[L,1]:P1;L=L-1 ELSE EXIT
 
     REPEAT
 
     REPEAT
RETURN
+
    P2 = ANS[I + 1, LEN.ANS]
 
+
  END ELSE
EXPAND.ALIASES:
+
     P1 = NUL
     SWAP SPC WITH @VM IN ANS ; POS = 1
 
 
     LOOP
 
     LOOP
        R = ANS<1,POS>
+
      IF NUM(ANS[LEN.ANS,1]) THEN P1 = ANS[LEN.ANS,1]:P1;LEN.ANS=LEN.ANS-1 ELSE EXIT
    UNTIL R = NUL DO
 
        LOCATE R IN ALIASES<1> BY 'AL' SETTING P THEN ANS<1,POS> = ALIASES<2,P>
 
        POS = POS + 1
 
 
     REPEAT
 
     REPEAT
     SWAP @VM WITH SPC IN ANS
+
     IF P1 = NUL THEN P1 = 1
 +
    P2 = P1
 +
  END
 +
  IF P1 = NUL THEN P1 = 1
 +
  IF P2 = NUL THEN P2 = MAX.STACK
 +
  IF NUM(P1) & NUM(P2) & P1 > 0 THEN
 +
    RANGE.ERROR = FALSE
 +
  END ELSE
 +
    RANGE.ERROR = TRUE
 +
    PRINT 'Range Error':BELL
 +
  END
 
RETURN
 
RETURN
 
+
*
EXPAND.PROMPT:
+
EDIT:
     IF SL.ACTIVE THEN
+
  * Some of the stuff in here is redundant, repeating COMMAND
         PROMPT.DISP='#RSEL>'
+
  * but to gosub command introduces re-entrancy problems
         OLD.X.DISP=X.DISP
+
  * That's why we use the dreaded GOTO command
         X.DISP=-2
+
  N = ANS[3,LEN.ANS]
 +
  IF NOT(NUM(N)) THEN PRINT 'No such line number - ':N:BELL;RETURN
 +
  IF N = NUL THEN N = 1
 +
  LOOP WHILE N # NUL AND STACK<N> # NUL DO
 +
    PRINT UP:N 'R%3':':':EOL:
 +
    ENTRY = STACK<N,4>
 +
    IF ENTRY = "" THEN ENTRY = STACK<N> ;* Legacy stack commands, no timestamp
 +
    X = 5;DISP.LEN = TERM.WIDTH-1-X;LEN = LONG.LINE
 +
    IF ENTRY # NUL THEN
 +
      OLD.ENTRY = ENTRY
 +
      GOSUB GET.INPUT
 +
      ANS = ENTRY
 +
     END
 +
    BEGIN CASE
 +
      CASE RTN = UP.KEY
 +
        IF SEARCH.FOR # NUL THEN
 +
          GO SEARCH.COMMAND
 +
        END ELSE
 +
          N = N + 1
 +
          IF STACK<N> = NUL THEN N = 1
 +
        END
 +
      CASE RTN = DOWN.KEY
 +
        N = N - 1
 +
        IF N = 0 THEN
 +
          N=1; PRINT BELL:
 +
        END
 +
      CASE RTN = RET
 +
        UNIX.COMMAND=FALSE
 +
        IF ANS[1,1] = UNIX THEN UNIX.COMMAND=TRUE
 +
         IF UNIX.COMMAND THEN
 +
          EXECUTING = FALSE
 +
          IF N = 1 AND ENTRY = OLD.ENTRY THEN EXECUTING = TRUE
 +
          GOSUB DO.COMMAND
 +
          N=NUL
 +
        END ELSE
 +
          C.LIST = ANS
 +
          C.COUNT = 1
 +
          LOOP
 +
            ANS = FIELD(C.LIST,COMMAND.SEPERATOR,C.COUNT)
 +
          UNTIL ANS = NUL DO
 +
            EXECUTING = FALSE
 +
            IF N = 1 AND ENTRY = OLD.ENTRY THEN EXECUTING = TRUE
 +
            GOSUB DO.COMMAND
 +
            C.COUNT = C.COUNT + 1
 +
          REPEAT
 +
          N = NUL
 +
        END
 +
      CASE RTN = ESC
 +
        N = NUL
 +
    END CASE
 +
  REPEAT
 +
RETURN
 +
*
 +
SEARCH.COMMAND:
 +
  * Search the stack for a string
 +
  IF SEARCH.FOR = NUL THEN SEARCH.FOR = ANS[2,LONG.LINE]
 +
  FOUND = FALSE
 +
  FOR F = START.WORD.SEARCH TO MAX.STACK UNTIL FOUND OR STACK<F> = NUL
 +
    IF INDEX(STACK<F,4>,SEARCH.FOR,1) # 0 THEN FOUND = TRUE
 +
  NEXT F
 +
  IF FOUND THEN
 +
    START.WORD.SEARCH = F
 +
    ANS = '.R':F-1
 +
    GO EDIT
 +
  END
 +
  PRINT BELL:SEARCH.FOR:' event not found'
 +
RETURN
 +
*
 +
PROG.COMMAND:
 +
  IF ANS = PROG.CHAR OR ANS=PROG.CHAR:PROG.CHAR THEN GO PRINT.PROG.INFO
 +
  GOSUB PARSE.PROG.COM
 +
  ANS=PROG.COM:SPC:B.FILE:SPC:B.ITEM
 +
  *GOSUB UPDATE.STACK
 +
  BEGIN CASE
 +
    CASE PROG.COM = '/WW'
 +
      WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
 +
      WP.FILE=HOME.FILE
 +
      WP.ITEM=PROGRAM.ITEM
 +
      GOSUB WP.EDIT
 +
      READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
 +
    CASE PROG.COM = '/N'
 +
      GOSUB GET.PROG.NAME
 +
      IF RTN=13 THEN
 +
        PROGRAMS<PROG.NUM> = PROG
 +
        WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
 +
      END
 +
      IF B.FILE # '' THEN
 +
        OPEN B.FILE TO F THEN
 +
          OPTIONS=''
 +
          READ DUMMY FROM F, B.ITEM ELSE
 +
            PRINT B.ITEM:' not found.  Use standard header? ':
 +
            INPUT YORN
 +
            IF YORN = 'Y' THEN
 +
              HEADER=STR('*',80)
 +
              HEADER<2>='* Program: ':B.ITEM
 +
              HEADER<3>='* Author : ':USERNAME
 +
              HEADER<4>='* Date  : ':OCONV(DATE(),"D-YMD") ;* E.g. 2017-04-20
 +
              HEADER<5>='* Version: 1.0'
 +
              HEADER<6>='* Comment: Do NOT skip the description'
 +
              HEADER<7>=STR('*',80)
 +
              WRITE HEADER ON F, B.ITEM
 +
            END
 +
          END
 +
          CLOSE F
 +
          WP.FILE=B.FILE
 +
          WP.ITEM=B.ITEM
 +
          GOSUB WP.EDIT
 +
        END ELSE
 +
          PRINT B.FILE:' is not a file in this account'
 +
        END
 +
      END
 +
    CASE PROG.COM = '/H'
 +
      OPTIONS='LESS'
 +
      *CALL CVS.LOG(RTN, B.FILE, B.ITEM, OPTIONS)
 +
    CASE PROG.COM = '/L'
 +
      * Load a new program stack
 +
      STACK.NAME=TRIM(OPTIONS)
 +
      IF STACK.NAME = '' THEN
 +
        PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME
 +
      END ELSE
 +
         PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME:'_':STACK.NAME
 +
      END
 +
      READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
 +
      SETTINGS<15>=STACK.NAME
 +
      GOSUB WRITE.INFO
 +
    CASE PROG.COM = '/LL'
 +
      * List the different program stacks
 +
      EXEC.LINE=\SSELECT \:HOME.FILE:\ WITH @ID = ".STACK.PROGRAM]"\
 +
      GOSUB EXEC.SUB
 +
      LOOP
 +
        READNEXT ID ELSE EXIT
 +
        PRINT ID
 +
      REPEAT
 +
    CASE PROG.COM = '/CI'
 +
      * Check it in
 +
      OPTIONS=''
 +
      *CALL CVS.CHECKIN(RTN, B.FILE, B.ITEM, OPTIONS)
 +
    CASE PROG.COM = '/D'
 +
      * CVS Diff
 +
      OPTIONS='SHOW'
 +
      *CALL CVS.DIFF(RTN, B.FILE, B.ITEM, OPTIONS)
 +
    CASE B.FILE[1,1] = '*' OR B.FILE=''
 +
      NULL ;* Don't do anything with 'comment' or blank entries
 +
    CASE PROG.COM = '/BR'
 +
      GOSUB COMPILE
 +
      EXEC.LINE = B.ITEM
 +
      GOSUB EXEC.SUB
 +
    CASE PROG.COM = '/B'
 +
      GOSUB COMPILE
 +
    CASE PROG.COM = '/E' OR PROG.COM = '/W'
 +
      OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
 +
      READ R1 FROM F, B.ITEM ELSE R1=NUL
 +
      IF PROG.COM = '/E' THEN
 +
        EXEC.LINE = ED.VERB:SPC:PROG:OPTIONS
 +
        GOSUB EXEC.SUB
 +
      END ELSE
 +
        WP.FILE=B.FILE
 +
        WP.ITEM=B.ITEM
 +
        GOSUB WP.EDIT
 +
      END
 +
      CLOSE F
 +
    CASE PROG.COM = '/F'
 +
      GOSUB BFORMAT
 +
    CASE PROG.COM = '/R'
 +
      OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
 +
      READV R FROM F, B.ITEM, 1 ELSE R=NUL
 +
      CLOSE F
 +
      EXEC.LINE = B.ITEM:OPTIONS
 +
      GOSUB EXEC.SUB
 +
    CASE PROG.COM = '/S'
 +
      * A slow sort of the program stack
 +
      READ REC FROM HOME.F, PROGRAM.ITEM ELSE PRINT 'CANNOT READ ':HOME.FILE:' ':PROGRAM.ITEM ; RETURN
 +
      SORT='AL' ; NEW.REC=''
 +
      I=DCOUNT(REC,@AM)
 +
      FOR F=1 TO I
 +
        L=REC<F>
 +
        LOCATE L IN NEW.REC BY SORT SETTING POS ELSE NULL
 +
         INS L BEFORE NEW.REC<POS>
 +
      NEXT F
 +
      WRITE NEW.REC ON HOME.F, PROGRAM.ITEM
 +
    CASE OTHERWISE
 +
      PRINT 'There is no such PROGRAM command':BELL
 +
      PRINT '? for help'
 +
  END CASE
 +
RETURN
 +
*
 +
COMPILE:
 +
  OPTIONS=''
 +
  * Check for global catalog
 +
  READ DUMMY FROM CTLGTB, B.ITEM THEN
 +
    PRINT B.ITEM:' is cataloged globally'
 +
    OPTIONS='G'
 +
  END
 +
  *
 +
  * Check for local catalog
 +
  READ DUMMY FROM CTLG, B.ITEM THEN
 +
    PRINT B.ITEM:' is cataloged locally'
 +
    OPTIONS :='L'
 +
  END
 +
  *
 +
  * Check for direct catalog
 +
  READ DUMMY FROM VOC, B.ITEM THEN
 +
    IF INDEX(DUMMY<2>,'/CTLG/',1)=0 THEN
 +
      PRINT B.ITEM:' is cataloged direct to ':DUMMY<2>
 +
      OPTIONS :='D'
 +
    END
 +
  END
 +
  *
 +
  IF LEN(OPTIONS) > 1 THEN
 +
    PRINT "OPTIONS=":OPTIONS
 +
    PRINT "I do not like green eggs and ham, nor do I like"
 +
    PRINT "programs cataloged twice.  You must fix, Sam"
 +
    RETURN
 +
  END
 +
  *
 +
  LOOP
 +
  UNTIL OPTIONS#'' DO
 +
    PRINT 'Catalog ':B.ITEM:' -- D)irect, L)ocal or G)lobal :':
 +
    INPUT OPTIONS
 +
    OPTIONS=UPCASE(OPTIONS)
 +
    IF OPTIONS = '/' OR OPTIONS='' THEN RETURN
 +
    * Have to enter D, L or G
 +
    IF OPTIONS # 'L' AND OPTIONS # 'G' AND OPTIONS # 'D' THEN OPTIONS=''
 +
  REPEAT
 +
  *
 +
  EXEC.LINE = 'BASIC ':B.FILE:' ':B.ITEM:' -D' ;* -D includes symbol table
 +
  PRINT EXEC.LINE
 +
  GOSUB EXEC.SUB
 +
  *
 +
  BEGIN CASE
 +
    CASE OPTIONS='G'
 +
      EXEC.LINE = 'CATALOG ':B.FILE:' ':B.ITEM:' FORCE'
 +
      PRINT EXEC.LINE
 +
      GOSUB EXEC.SUB
 +
      * Global, so remove direct or local pointers
 +
      READ R FROM VOC, B.ITEM THEN DELETE VOC, B.ITEM
 +
    CASE OPTIONS='L'
 +
      EXEC.LINE = 'CATALOG ':PROG:' LOCAL FORCE'
 +
      PRINT EXEC.LINE
 +
      GOSUB EXEC.SUB
 +
      * Object is in CTLG file, so remove from SOURCE file
 +
      OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
 +
      DELETE F, '_':B.ITEM
 +
      CLOSE F
 +
    CASE OPTIONS='D'
 +
      EXEC.LINE = 'CATALOG ':B.FILE:' ':B.ITEM:' DIRECT FORCE'
 +
      PRINT EXEC.LINE
 +
      GOSUB EXEC.SUB
 +
  END CASE
 +
  *
 +
  EXEC.LINE = 'NEWPCODE' ;* This loads a new version of globally cataloged programs
 +
  GOSUB EXEC.SUB
 +
RETURN
 +
*
 +
PARSE.PROG.COM:
 +
  PROG.NUM = NUL
 +
  F = FIELD(ANS,SPC,1);L = LEN(F);I = L
 +
  LOOP
 +
    IF NUM(F[I,1]) THEN PROG.NUM = F[I,1]:PROG.NUM ELSE EXIT
 +
    I = I - 1
 +
  REPEAT
 +
  IF PROG.NUM = NUL THEN PROG.NUM = 1
 +
  OPTIONS = ANS[L+1,LONG.LINE]
 +
  PROG.COM = ANS[1,I]
 +
  PROG = PROGRAMS<PROG.NUM>
 +
  B.FILE = FIELD(PROG,SPC,1)
 +
  B.ITEM = FIELD(PROG,SPC,2)
 +
RETURN
 +
*
 +
GET.PROG.NAME:
 +
  X = 15;DISP.LEN = 50;LEN = LONG.LINE;ENTRY = PROG
 +
  PRINT 'Program Name :':
 +
  GOSUB GET.INPUT
 +
  ANS = UPCASE(ENTRY)
 +
  IF RTN # 13 THEN RETURN
 +
  GOSUB EXPAND.ALIASES
 +
  IF INDEX(ANS,SPC,1) THEN
 +
    B.FILE = FIELD(ANS,SPC,1)
 +
    B.ITEM = FIELD(ANS,SPC,2)
 +
    PROG=ANS
 +
  END ELSE
 +
    IF ANS = NUL THEN
 +
      B.FILE = NUL ; B.ITEM = NUL ;PROG = NUL
 
     END ELSE
 
     END ELSE
        PROMPT.DISP = PROMT
+
      B.FILE = WORK.FILE ; B.ITEM = ANS ; PROG = B.FILE:SPC:B.ITEM
        X.DISP=OLD.X.DISP
 
 
     END
 
     END
    CTR = 1
+
  END
     LOOP
+
RETURN
         I = INDEX(PROMPT.DISP,'#',CTR)
+
*
    UNTIL I = 0 DO
+
PRINT.PROG.INFO:
         F = PROMPT.DISP[I+1,1]
+
  I = DCOUNT(PROGRAMS,@AM)
         L = PROMPT.DISP[1,I-1];R = TRIM(PROMPT.DISP[I+2,LONG.LINE])
+
  PRINT STACK.NAME
 +
  FOR F = 1 TO I
 +
     IF PROGRAMS<F> # NUL THEN
 +
      CH=' '
 +
      IF ANS=PROG.CHAR:PROG.CHAR THEN
 +
         * We want cvs status as well
 +
        FILE=FIELD(PROGRAMS<F>,' ',1)
 +
        ITEM=FIELD(PROGRAMS<F>,' ',2)
 +
         R=''
 +
        *CALL CVS.STATUS(R,FILE,ITEM,'')
 +
        STATUS=R<1>
 +
         WORK.VER=R<2>
 +
        CVS.VER=R<3>
 
         BEGIN CASE
 
         BEGIN CASE
            CASE F = 'B'
+
          CASE STATUS='UPTODATE'
                PROMPT.DISP = L:CHAR(7):R
+
             CH=' ':WORK.VER'L#9'
             CASE F = 'A'
+
          CASE STATUS='MODIFIED'
                PROMPT.DISP = L:ACC:R
+
            CH='> ':WORK.VER'L#4':' ':CVS.VER'L#4'
            CASE F = 'T'
+
          CASE 1
                PROMPT.DISP = L:OCONV(TIME(),'MTS'):R
+
             CH='! ':SPACE(9)
            CASE F = 'D'
 
                PROMPT.DISP = L:OCONV(DATE(),'D'):R
 
            CASE F = 'E'
 
                PROMPT.DISP = L:CHAR(ESC):R
 
            CASE F = 'R'
 
                PROMPT.DISP = L:CHAR(13):CHAR(10):R
 
            CASE F = '#'
 
                PROMPT.DISP = L:'#':R
 
                CTR = CTR + 1
 
             CASE F = 'U'
 
                PROMPT.DISP = L:INITIALS:R
 
            CASE F = 'H'
 
                PROMPT.DISP=L:FIELD(HOST.NAME,".",1):R
 
            CASE OTHERWISE
 
                CTR = CTR + 1
 
 
         END CASE
 
         END CASE
 +
      END
 +
      PRINT F 'L#5':CH:' ':PROGRAMS<F>
 +
    END
 +
  NEXT F
 +
RETURN
 +
*
 +
WRITE.INFO:
 +
  WRITE STACK ON HOME.F, STACK.ITEM
 +
  WRITE ALIASES ON HOME.F, ALIAS.ITEM
 +
  WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
 +
  WRITE SETTINGS ON HOME.F, SETTING.ITEM
 +
RETURN
 +
*
 +
UPDATE.STACK:
 +
  INS ACC:@VM:DATE():@VM:TIME():@VM:ANS BEFORE STACK<1>
 +
  WRITE STACK ON HOME.F, STACK.ITEM
 +
RETURN
 +
*
 +
WP.EDIT:
 +
  * Edit a record using a visual editor (e.g. vi, joe or emacs)
 +
  DICT=0
 +
  IF FIELD(WP.FILE,' ',1)='DICT' THEN WP.FILE=FIELD(WP.FILE,' ',2) ; DICT=1
 +
  READ REC FROM VOC, WP.FILE ELSE PRINT WP.FILE:' - no VOC item' ; RETURN
 +
  IF (REC<1>#'DIR' AND REC<1>#'LD') OR DICT THEN
 +
    * Copy to a temp DIR type and edit there, ignore the race conditions!
 +
    IF DICT THEN WP.FILE='DICT ':WP.FILE
 +
    OPEN WP.FILE TO T ELSE PRINT WP.FILE:' - cannot OPEN' ; RETURN
 +
    READ R FROM T, WP.ITEM ELSE PRINT WP.ITEM:' - not found' ; RETURN
 +
    WRITE R ON HOLD, WP.ITEM
 +
    WP.PATH='_HOLD_'
 +
    DIR.TYPE=0
 +
  END ELSE
 +
    WP.PATH=REC<2>
 +
    IF REC<1>='LD' THEN
 +
      IF INDEX(FILE,',',1) THEN
 +
        WP.PATH=REC<2>:FIELD(FILE,',',2)
 +
      END ELSE
 +
        WP.PATH=REC<2>:'/':FIELD(REC<2>,'/',DCOUNT(REC<2>,'/'))
 +
      END
 +
    END
 +
    DIR.TYPE=1
 +
  END
 +
  EXEC.LINE=WP.VERB:' ':WP.PATH:'/':WP.ITEM
 +
  GOSUB EXEC.SUB
 +
  IF NOT(DIR.TYPE) THEN
 +
    * Copy back to original location
 +
    READ R FROM HOLD, WP.ITEM ELSE R=''
 +
    WRITE R ON T, WP.ITEM
 +
    CLOSE T
 +
  END
 +
RETURN
 +
*
 +
CHECK.FILE:
 +
  PARAM.CTR=1 ; PROG.FLAG=0 ; FILE.FLAG=0 ; ALL.FLAG=0
 +
  LOOP
 +
    P=FIELD(ANS,' ',PARAM.CTR)
 +
  UNTIL P='' DO
 +
    IF P[1,1] = '/' THEN
 +
      P=P[2,1]
 +
      BEGIN CASE
 +
        CASE P='P'
 +
          PROG.FLAG=1
 +
        CASE P='F'
 +
          FILE.FLAG=1
 +
        CASE P='A'
 +
          ALL.FLAG=1
 +
      END CASE
 +
    END ELSE
 +
      PROG=P
 +
    END
 +
    PARAM.CTR += 1
 +
  REPEAT
 +
  IF PROG.FLAG=0 AND FILE.FLAG=0 THEN ALL.FLAG=1
 +
  *
 +
  IF PROG # '' THEN
 +
    READ CAT.PTR FROM VOC, PROG ELSE PRINT 'Cannot read VOC ':PROG ; RETURN
 +
  END ELSE
 +
    LOOP
 +
      PRINT 'Enter the program to scan ':
 +
      INPUT PROG
 +
      IF PROG = '' OR PROG = '/' THEN RETURN
 +
      READ CAT.PTR FROM VOC, PROG THEN EXIT
 +
      PRINT 'Cannot read VOC ':PROG
 
     REPEAT
 
     REPEAT
 +
  END
 +
  *
 +
  EXECUTE "!strings ":CAT.PTR<2>:" > $HOME/FILE.LIST"
 +
  *
 +
  FILE.LIST=''
 +
  READ R FROM HOME.F, 'FILE.LIST' THEN
 +
    I=DCOUNT(R,@AM)
 +
    FOR F=1 TO I
 +
      TEST.FILE=R<F>
 +
      IF FILE.FLAG THEN
 +
        OPEN TEST.FILE TO DUMMY THEN
 +
          LOCATE TEST.FILE IN FILE.LIST BY 'AL' SETTING POS ELSE
 +
            INS TEST.FILE BEFORE FILE.LIST<POS>
 +
            PRINT 'FILE:':TEST.FILE
 +
          END
 +
          CLOSE DUMMY
 +
        END
 +
      END
 +
      IF PROG.FLAG THEN
 +
        READ DUMMY FROM VOC, TEST.FILE THEN
 +
          *IF DUMMY = 'C' THEN PRINT 'PROG: ':TEST.FILE
 +
          IF DUMMY<1>='C' THEN PRINT 'PROG: ':TEST.FILE'L#25':' ':DUMMY<2>
 +
        END
 +
      END
 +
      IF ALL.FLAG THEN
 +
        PRINT TEST.FILE
 +
      END
 +
    NEXT F
 +
  END
 
RETURN
 
RETURN
 
+
*
STACK.COMMAND:
+
CONV:
 +
  * Handy way to check ICONV/OCONV data
 +
  LOOP
 +
    PRINT 'Enter mask:':
 +
    INPUT MASK
 +
    IF MASK='' OR MASK='/' THEN RETURN
 +
    PRINT 'Enter data:':
 +
    INPUT DTA
 +
    PRINT 'Result:':
 +
    IF CONV='I' THEN PRINT ICONV(DTA,MASK) ELSE PRINT OCONV(DTA,MASK)
 +
  REPEAT
 +
RETURN
 +
*
 +
RULER:
 +
  CRT 'Term width=':TERM.WIDTH
 +
  FOR F=1 TO TERM.WIDTH
 +
    C=SEQ(0)+MOD(F,10)
 +
    IF MOD(F,10) THEN PRINT CHAR(C): ELSE PRINT ' ':
 +
  NEXT F
 +
  PRINT
 +
  SUP.NEXT=0
 +
  FOR F=1 TO TERM.WIDTH
 
     BEGIN CASE
 
     BEGIN CASE
        CASE ANS[1,2] = '.L'
+
      CASE MOD(F+1,10)=0 AND (F+1)/10 > 9
            IF ANS = '.L' THEN ANS = '.L,20'
+
        PRINT (F+1)/10:
            GOSUB GET.PARAMS
+
         SUP.NEXT=1
            IF RANGE.ERROR THEN RETURN
+
      CASE MOD(F,10)=0 AND F/10 <= 9
            I = DCOUNT(STACK,@AM)
+
         PRINT F/10:
            IF I = 0 THEN PRINT 'No items present';RETURN
+
        SUP.NEXT=0
            IF P2 > I THEN P2 = I
+
      CASE MOD(F,5)=0 AND NOT(SUP.NEXT)
            PRINT
+
         PRINT '+':
            FOR F = P2 TO P1 STEP -1;PRINT SPC:F'R#3':SPC:STACK<F> ; NEXT F
+
       CASE 1
         CASE ANS[1,2] = '.R' OR ANS[1,2] = '.X'
+
         IF NOT(SUP.NEXT) THEN PRINT ' ':
            IF STACK = NUL THEN PRINT BELL ELSE GO EDIT
+
         SUP.NEXT=0
        CASE ANS[1,2] = '.D'
 
            GOSUB GET.PARAMS
 
            IF RANGE.ERROR THEN RETURN
 
            FOR I = P1 TO P2
 
                DEL STACK<P1>
 
            NEXT I
 
            WRITE STACK ON HOME.F, STACK.ITEM
 
        CASE ANS = '.E'
 
            WRITE STACK ON HOME.F, STACK.ITEM
 
            EXEC.LINE = ED.VERB:SPC:HOME.FILE:SPC:STACK.ITEM
 
            GOSUB EXEC.SUB
 
            READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
 
         CASE ANS = '.W'
 
            WRITE STACK ON HOME.F, STACK.ITEM
 
            EXEC.LINE = WP.VERB:SPC:HOME.FILE:SPC:STACK.ITEM
 
            GOSUB EXEC.SUB
 
            READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
 
        CASE ANS = '.CL'
 
            STACK = NUL
 
            WRITE STACK ON HOME.F, STACK.ITEM
 
            PRINT 'Stack cleared'
 
        CASE ANS = '.P'
 
            PRINT '#R - Return  #A - Account  #D - Date  #T - Time #P - Port'
 
            PRINT '#E - Escape  #L - Level    #U - User  #H - Host'
 
            PRINT 'Prompt':
 
            X = 7;DISP.LEN = 60;ENTRY = PROMT;LEN = 99;GOSUB GET.INPUT
 
            PROMT = ENTRY
 
            PRINT 'Enter the X displacement for input :':
 
            ENTRY = NUL;LEN = 5;DISP.LEN = 5;X = 37;GOSUB GET.INPUT
 
            X.DISP = ENTRY
 
            IF NOT(NUM(X.DISP)) THEN X.DISP = 0
 
            SETTINGS<12> = PROMT
 
            SETTINGS<13> = X.DISP
 
            OLD.X.DISP=X.DISP
 
         CASE ANS = '.H'
 
            PRINT 'Ctrl-A    Start of line    Ctrl-R      Toggle insert mode'
 
            PRINT 'Ctrl-B    Back one char    Ctrl-W      Delete word'
 
            PRINT 'Ctrl-D    Delete char       Ctrl-X      Forward word'
 
            PRINT 'Ctrl-E    End of line      Ctrl-Z      Back word'
 
            PRINT 'Ctrl-F    Forward char      '
 
            PRINT 'Ctrl-G    Cancel line      '
 
            PRINT 'Ctrl-I    Forward word      ~xxx        Search for xxx'
 
            PRINT 'Ctrl-J    Delete to end    .Lm,n      List entry m thru n'
 
            PRINT 'Ctrl-M    Accept line      .Rn        Restore entry n, edit'
 
            PRINT 'Ctrl-N    Next line         .Dm,n      Delete entry m thru n'
 
            PRINT 'Ctrl-P    Previous line    Q          Quit back to TCL'
 
            PRINT
 
            PRINT '/  List the program stack  //  List the stack with cvs status'
 
            PRINT '[[/Nx]] Add a New program,'
 
            PRINT '[[/Ex]] Edit the x`th program    [[/WW]] Edit the program list'
 
            PRINT '[[/Wx]] VI the x`th program      [[/S]]  Sort the program stack'
 
            PRINT '[[/Bx]] Compile the x`th program [[/BR]] Compile and run'
 
            PRINT '[[/CI]] Checkin a program to cvs [[/D]]  Show diff with cvs version'
 
         CASE ANS = '.U'
 
            IF MCU.ON THEN MCU.ON = FALSE;PRINT 'upper case off' ELSE MCU.ON = TRUE;PRINT 'UPPER CASE ON'
 
        CASE OTHERWISE
 
            PRINT 'There is no such STACK command':BELL
 
            PRINT '? for help'
 
 
     END CASE
 
     END CASE
 +
  NEXT F
 +
  PRINT
 +
RETURN
 +
*
 +
PIVOT:
 +
  * Summarize a field, e.g. PIVOT LS.MASTER LESSOR GROSS.CONTRACT EQUIPMENT.COST
 +
  FILE=FIELD(ANS," ",2) ; ATB =FIELD(ANS," ",3) ; ATB2=FIELD(ANS," ",4) ; ATB3=FIELD(ANS," ",5) ; ATB4=FIELD(ANS," ",6)
 +
  OPEN "DICT ":FILE TO DICT ELSE PRINT "DICT ":FILE:' not a filename' ; RETURN
 +
  READ UREC FROM DICT,"UATB.COUNTER" ELSE
 +
    UREC=\I\;UREC<2>=\"1"\;UREC<4>=\CNTR\;UREC<5>=\8R\;UREC<6>=\S\
 +
    WRITE UREC ON DICT,"UATB.COUNTER"
 +
  END
 +
  CLOSE DICT
 +
  EXEC.LINE = \SORT \:FILE:\ BY \:ATB:\ BREAK-ON \:ATB:\ TOTAL UATB.COUNTER \
 +
  IF ATB2 # "" THEN EXEC.LINE := \ TOTAL \:ATB2
 +
  IF ATB3 # "" THEN EXEC.LINE := \ TOTAL \:ATB3
 +
  IF ATB4 # "" THEN EXEC.LINE := \ TOTAL \:ATB4
 +
  EXEC.LINE := \ (IDH \
 +
  GOSUB EXEC.SUB
 +
RETURN
 +
*
 +
PROFILE:
 +
  * Profile a field, e.g. PROFILE LS.MASTER REQ.SIGNATURE.PHONE
 +
  FILE=FIELD(ANS," ",2) ; ATB =FIELD(ANS," ",3) ; ATBS=FIELD(ANS," ",4,99)
 +
  EXEC.LINE = \SORT \:FILE:\ WITH \:ATB:\ \:ATB:\ \:ATBS
 +
  GOSUB EXEC.SUB
 +
RETURN
 +
*
 +
DDD:
 +
  * Tweak DICT VOC with some pickle juice
 +
  R    =\DICT VOC#AM#@ID#AM#D#AM#0#AM##AM#VOC#AM#30L#AM#S#AM#\
 +
  R<-1>=\DICT VOC#AM#F1#AM#D#AM#1#AM##AM##AM#5L#AM#S#AM#\
 +
  R<-1>=\DICT VOC#AM#F2#AM#D#AM#2#AM##AM##AM#50L#AM#S#AM#\
 +
  OPEN 'DICT VOC' TO FVAR ELSE RETURN
 +
  FOR F=1 TO DCOUNT(R,@AM)
 +
    REC=R<F>
 +
    SWAP "#AM#" WITH @AM IN REC
 +
    FILE=REC<1> ; DEL REC<1>
 +
    ITEM=REC<1> ; DEL REC<1>
 +
    WRITE REC ON FVAR,ITEM
 +
  NEXT F
 +
  CLOSE FVAR
 +
  *
 +
  * List the DICT, e.g DDD AS.MASTER EQUIP
 +
  FILE = FIELD(ANS," ",2)
 +
  SSTR = FIELD(ANS," ",3)
 +
  FIND.STR=""
 +
  IF SSTR # "" THEN FIND.STR = \WITH @ID = "[\:SSTR:\]" \
 +
  EXEC.LINE=\SORT DICT \:FILE:\ @ID F1 F2 BY F1 BY F2 \:FIND.STR:\ USING DICT VOC (I \
 +
  GOSUB EXEC.SUB
 
RETURN
 
RETURN
 
+
*
GET.PARAMS:
+
SEARCH.FILE:
    I = INDEX(ANS,',',1)
+
  FILE = FIELD(ANS," ",2)
    IF I # 0 THEN
+
  ICTR=3
        L = I-1;P1 = NUL
+
  IF FILE='DICT' THEN ICTR+=1 ; FILE='DICT ':FIELD(ANS," ",3)
        LOOP
+
  OPEN FILE TO FVAR ELSE PRINT FILE:' - not found' ; RETURN
            IF NUM(ANS[L,1]) THEN P1 = ANS[L,1]:P1;L=L-1 ELSE EXIT
+
  SSTR = FIELD(ANS," ",ICTR)
        REPEAT
+
  IF SSTR='' THEN PRINT 'Search for:': ; INPUT SSTR
        P2 = ANS[I + 1, LEN.ANS]
+
  IF SSTR='' THEN RETURN
    END ELSE
+
  *
        P1 = NUL
+
  SSTR1=UPCASE(SSTR)
        LOOP
+
  SSTR2=DOWNCASE(SSTR)
            IF NUM(ANS[LEN.ANS,1]) THEN P1 = ANS[LEN.ANS,1]:P1;LEN.ANS=LEN.ANS-1 ELSE EXIT
+
  SSTR3=OCONV(SSTR,"MCT")
        REPEAT
+
  *
        IF P1 = NUL THEN P1 = 1
+
  DATA SSTR
        P2 = P1
+
  DATA SSTR1
     END
+
  DATA SSTR2
     IF P1 = NUL THEN P1 = 1
+
  DATA SSTR3
    IF P2 = NUL THEN P2 = MAX.STACK
+
  DATA ""
    IF NUM(P1) & NUM(P2) & P1 > 0 & P2 <= MAX.STACK THEN
+
  EXEC.LINE=\ESEARCH \:FILE:\ WITH @ID # "_]" USING DICT VOC\ ; CAP.ACTIVE=TRUE
         RANGE.ERROR = FALSE
+
  GOSUB EXEC.SUB
    END ELSE
+
  *
         RANGE.ERROR = TRUE
+
  CTR=0 ; FOUND.RECS=''
        PRINT 'Range Error':BELL
+
  LOOP
 +
     READNEXT ID ELSE EXIT
 +
     READ REC FROM FVAR, ID THEN
 +
      IDX = INDEX(UPCASE(REC),SSTR1,1)
 +
      IF IDX OR INDEX(UPCASE(ID),SSTR1,1) THEN
 +
        CTR+=1
 +
        FOUND.RECS<1,CTR>=ID
 +
        IDX -= 10 ; IF IDX < 1 THEN IDX=1
 +
         LINE=REC[IDX,45]
 +
        CONVERT @VM TO "]" IN LINE
 +
        CONVERT @AM TO "~" IN LINE
 +
        LINE=OCONV(LINE,"MCP")
 +
         FOUND.RECS<2,CTR>=LINE
 +
      END
 
     END
 
     END
 +
  REPEAT
 +
  CLOSE FVAR
 +
  *
 +
  QUIT = 0 ; CTR=1 ; MAX.ITEMS=DCOUNT(FOUND.RECS<1>,@VM)
 +
  IF MAX.ITEMS=0 THEN PRINT SSTR:' Not found' ; RETURN
 +
  HDR=@(-1):\SEARCHING FOR "\:SSTR1:\,\:SSTR2:\,\:SSTR3:\" IN \:FILE
 +
  PRINT HDR
 +
  LOOP
 +
    PRINT CTR'R#4':' ':FOUND.RECS<1,CTR>'L#25':FOUND.RECS<2,CTR>'L#65'
 +
    CTR+=1
 +
    IF CTR/20=INT(CTR/20) THEN GOSUB SEARCH.FILE.PROMPT
 +
    IF QUIT THEN RETURN
 +
  REPEAT
 +
RETURN
 +
*
 +
SEARCH.FILE.PROMPT:
 +
  PRINT ; PRINT 'B)ack, E)dit #, V)iew #, W)P#, /:':
 +
  INPUT OPTION
 +
  BEGIN CASE
 +
    CASE OPTION='B'
 +
      CTR-=40
 +
      IF CTR<1 THEN CTR=1
 +
    CASE OPTION[1,1]='E'
 +
      EXEC.LINE=ED.VERB:\ \:FILE:\ \:FOUND.RECS<1,OPTION[2,99]>
 +
      GOSUB EXEC.SUB
 +
      CTR-=20
 +
      IF CTR<1 THEN CTR=1
 +
    CASE OPTION[1,1]='W'
 +
      WP.FILE=FILE
 +
      WP.ITEM=FOUND.RECS<1,OPTION[2,99]>
 +
      GOSUB WP.EDIT
 +
      CTR-=20
 +
      IF CTR<1 THEN CTR=1
 +
    CASE OPTION[1,1]='V'
 +
      PRINT CS:
 +
      EXEC.LINE=\CT \:FILE:\ \:FOUND.RECS<1,OPTION[2,99]>
 +
      GOSUB EXEC.SUB
 +
      CTR-=20
 +
      IF CTR<1 THEN CTR=1
 +
      PRINT 'Press ENTER:':
 +
      INPUT AAA
 +
    CASE OPTION # ''
 +
      * ENTER to keep moving forward
 +
      QUIT=1
 +
  END CASE
 +
  PRINT HDR
 
RETURN
 
RETURN
 
+
*
EDIT:
+
IL10.NED:
     * Some of the stuff in here is redundant, repeating COMMAND
+
  OPEN '_HOLD_' TO F.HOLD ELSE STOP 201,'_HOLD_'
     * but to gosub command introduces re-entrancy problems
+
  FILE.NAME=FIELD(ANS,' ',2)
    * That's why we use the dreaded GOTO command
+
  K.FILE=FIELD(ANS,' ',3)
    N = ANS[3,LEN.ANS]
+
  CALL FILE.OPEN(PROGRAM.NAME, FILE.NAME, F.FILE, 'STOP')
    IF NOT(NUM(N)) THEN PRINT 'No such line number - ':N:BELL;RETURN
+
  CALL IDS.READ(R.FILE, F.FILE,  K.FILE, 0, 0, BCI.ERROR)
    IF N = NUL THEN N = 1
+
  IF BCI.ERROR # '' THEN PRINT BCI.ERROR ; R.FILE=''
    LOOP WHILE N # NUL AND STACK<N> # NUL DO
+
  R.ORIG=R.FILE
        PRINT UP:N 'R%3':':':EOL:
+
  *
         ENTRY = STACK<N>;X = 5;DISP.LEN = 74;LEN = LONG.LINE
+
  LOOP
         IF ENTRY # NUL THEN
+
     PRINT DCOUNT(R.FILE,@AM):' fields in record'
            OLD.ENTRY = ENTRY
+
    PRINT 'Enter E)dit, L)ist, S)ave or Q)uit:':
            GOSUB GET.INPUT
+
    INPUT OPT
            ANS = ENTRY
+
     BEGIN CASE
 +
      CASE OPT='L'
 +
        SHOW.BPI=0 ; BPI.XREF=''
 +
        OPEN 'DATABASE.FILES,IL' TO IL ELSE PRINT 201,'DATABASE.FILES,IL' ; RETURN
 +
        OPEN 'IL.BPI' TO IL.BPI ELSE PRINT 201,'IL.BPI' ; RETURN
 +
        READV BPI FROM IL, FILE.NAME, 14 THEN
 +
          * Sample: Attached to FLOAT.INCOME bpi.
 +
          N=DCOUNT(BPI,' ')
 +
          BPI=FIELD(BPI,' ',N-1)
 +
          READ BPI.LAYOUT FROM IL.BPI, BPI THEN
 +
            * Sample: EQUATE GROSS.FINANCE              TO MASTER(1)
 +
            SHOW.BPI=1
 +
            FOR R=1 TO DCOUNT(BPI.LAYOUT,@AM)
 +
              L=TRIM(BPI.LAYOUT<R>)
 +
              IF FIELD(L,' ',1)='EQUATE' THEN
 +
                FLD.NAME=FIELD(L,' ',2)
 +
                FLD.POS=FIELD(FIELD(L,' ',4),'(',2)
 +
                FLD.POS=FIELD(FLD.POS,')',1)
 +
                BPI.XREF<FLD.POS>=FLD.NAME
 +
              END
 +
            NEXT R
 +
          END ELSE
 +
            PRINT 'Cannot read BPI:':BPI
 +
          END
 +
        END ELSE
 +
          PRINT 'Cannot get BPI name for:':FILE.NAME
 +
        END
 +
        *
 +
        PRINT @(-1):'FILE:':FILE.NAME:' ITEM:':K.FILE
 +
        FOR F=1 TO DCOUNT(R.FILE,@AM)
 +
          R=R.FILE<F>
 +
          CONVERT @VM TO "|" IN R
 +
          CONVERT @SVM TO "\" IN R
 +
          IF SHOW.BPI THEN
 +
            PRINT F'R#3':' ':BPI.XREF<F>'L#25':'=':R[1,80]
 +
          END ELSE
 +
            PRINT F'R#3':' ':R
 +
          END
 +
        NEXT F
 +
        PRINT 'PRESS ENTER:':
 +
         INPUT AAA
 +
      CASE OPT='S'
 +
        CALL IDS.WRITE(R.FILE, F.FILE, K.FILE, 0, 0)
 +
        PRINT 'Saved.  Press ENTER to continue:':
 +
        R.ORIG=R.FILE
 +
        INPUT AAA
 +
      CASE OPT='E'
 +
        R=R.FILE
 +
        SWAP CHAR(13):CHAR(10) WITH '||' IN R
 +
        WRITE R ON F.HOLD, K.FILE
 +
        EXECUTE \ED _HOLD_ \:K.FILE
 +
        READ R FROM F.HOLD, K.FILE ELSE R=''
 +
        SWAP '||' WITH CHAR(13):CHAR(10) IN R
 +
         IF R # R.FILE THEN
 +
          PRINT 'Record changed, use S to save'
 +
          R.FILE=R
 +
        END
 +
        DELETE F.HOLD, K.FILE
 +
      CASE OPT='Q'
 +
        IF R.FILE#R.ORIG THEN
 +
          PRINT 'Record changed, are you sure (Y/N):':
 +
          INPUT YORN
 +
          IF YORN # 'Y' THEN OPT=''
 
         END
 
         END
        BEGIN CASE
+
    END CASE
            CASE RTN = UP.KEY
+
  UNTIL OPT='Q' DO
                IF SEARCH.FOR # NUL THEN
+
  REPEAT
                    GO BANG.COMMAND
+
RETURN
                END ELSE
+
*
                    N = N + 1
+
BPI:
                    IF STACK<N> = NUL THEN N = 1
+
  OPEN 'DATABASE.FILES,IL' TO IL ELSE STOP 201,'DATABASE.FILES,IL'
                END
+
  OPEN 'IL.BPI' TO IL.BPI ELSE STOP 201,'IL.BPI'
            CASE RTN = DOWN.KEY
+
  BPI=FIELD(ANS,' ',2)
                N = N - 1
+
  IF BPI='' THEN PRINT 'Usage: BPI <name of infolease file|name of BPI>' ; RETURN
                IF N = 0 THEN
+
  * Param 2 can be a BPI or a FILENAME
                    *FOR F = 1 TO MAX.STACK
+
  READ DUMMY FROM IL.BPI, BPI ELSE
                    *   IF STACK<F> = NUL THEN N = F-1;F = MAX.STACK
+
    READV BPI FROM IL, BPI, 14 ELSE PRINT 'Cannot read DATABASE.FILES,IL',BPI ; RETURN
                    *NEXT F
+
    * Sample: Attached to FLOAT.INCOME bpi.
                    N=1; PRINT BELL:
+
    N=DCOUNT(BPI,' ')
                END
+
    BPI=FIELD(BPI,' ',N-1)
            CASE RTN = RET
+
    READ DUMMY FROM IL.BPI, BPI ELSE PRINT 'Cannot get BPI name' ; RETURN
                UNIX.COMMAND=FALSE
+
  END
                IF ANS[1,1] = UNIX THEN UNIX.COMMAND=TRUE
+
  EXEC.LINE=\AE IL.BPI \:BPI
                IF UNIX.COMMAND THEN
+
  GOSUB EXEC.SUB
                    EXECUTING = FALSE
+
  CLOSE IL
                    IF N = 1 AND ENTRY = OLD.ENTRY THEN EXECUTING = TRUE
+
   CLOSE IL.BPI
                    GOSUB DO.COMMAND
+
RETURN
                    N=NUL
+
*
                END ELSE
+
RECALL.SHELL:
                    C.LIST = ANS
+
  DATA 1
                    C.COUNT = 1
+
  DATA 1
                    LOOP
+
  RECALL=FIELD(ANS,' ',2)
                        ANS = FIELD(C.LIST,COMMAND.SEPERATOR,C.COUNT)
+
  IF RECALL # '' THEN DATA RECALL
                    UNTIL ANS = NUL DO
+
  EXECUTE \RECALL.00\
                        EXECUTING = FALSE
+
RETURN
                        IF N = 1 AND ENTRY = OLD.ENTRY THEN EXECUTING = TRUE
+
*
                        GOSUB DO.COMMAND
+
FIND.MENU:
                        C.COUNT = C.COUNT + 1
+
  OPEN "DB.MENUS" TO MENU.F ELSE STOP 201,"DB.MENUS"
                    REPEAT
+
  STR=FIELD(ANS,' ',2)
                    N = NUL
+
  IF STR='' THEN
                END
+
    PRINT "Enter menu or program to search for : ": ; INPUT STR
            CASE RTN = ESC
+
    IF STR="" OR STR="/" THEN RETURN
                N = NUL
+
  END
        END CASE
+
  STR = OCONV(STR,"MCU")
    REPEAT
+
  MENU.LIST=''
 +
  MENU.LIST<1>=1
 +
  MENU.LIST<2>=0
 +
  MENU.CTR=1
 +
  LOOP
 +
    MENU=MENU.LIST<1,MENU.CTR>
 +
    PATH=MENU.LIST<2,MENU.CTR>
 +
    IF MENU='' THEN EXIT
 +
    GOSUB SEARCH.MENU
 +
    MENU.CTR+=1
 +
  REPEAT
 +
  CLOSE MENU.F
 
RETURN
 
RETURN
 
+
*
BANG.COMMAND:
+
SEARCH.MENU:
    * Search the stack for a string
+
  READ R FROM MENU.F, MENU THEN
     IF SEARCH.FOR = NUL THEN SEARCH.FOR = ANS[2,LONG.LINE]
+
     TITLES = OCONVS(R<2>,"MCU") ; PROGS  = OCONVS(R<3>,"MCU") ; FLAGS = R<4> ; TYPES = R<5>
     FOUND = FALSE
+
     I = DCOUNT(PROGS,@VM)
     FOR F = START.WORD.SEARCH TO MAX.STACK UNTIL FOUND OR STACK<F> = NUL
+
     FOR F = 1 TO I
        IF INDEX(STACK<F>,SEARCH.FOR,1) # 0 THEN FOUND = TRUE
+
      IF INDEX(PROGS<1,F>,STR,1) # 0 OR INDEX(TITLES<1,F>,STR,1) # 0 THEN
 +
        PRINT MENU"R#5":" ":TITLES<1,F>"L#27":"  ":TYPES<1,F>'L#1':" ":PROGS<1,F>"L#50":" ":PATH:',':F
 +
      END
 +
      IF FLAGS<1,F>='M' THEN MENU.LIST<1,-1>=PROGS<1,F> ; MENU.LIST<2,-1>=PATH:',':F
 
     NEXT F
 
     NEXT F
     IF FOUND THEN
+
  END
         START.WORD.SEARCH = F
+
RETURN
         ANS = '.R':F-1
+
*
         GO EDIT
+
BFORMAT:
     END
+
  STAR  = '*' ; COLON = ':' ; TAB=CHAR(9)
     PRINT BELL:SEARCH.FOR:' event not found'
+
  IND = 0
 +
  *
 +
  * These are all commands that may have ELSE or THEN statements
 +
  * (or blocks) following them
 +
  SPECIAL.CASES = "GET":@AM:"INPUT":@AM:"LOCATE":@AM:"LOCK":@AM:"MATREAD":@AM:"MATREADU":@AM
 +
  SPECIAL.CASES := "MATWRITE":@AM:"MATWRITEU":@AM:"OPEN":@AM:"PROCREAD":@AM
 +
  SPECIAL.CASES := "PROCWRITE":@AM:"READ":@AM:"READNEXT":@AM:"READSEQ":@AM:"READT":@AM:"READU":@AM:"READV":@AM
 +
  SPECIAL.CASES := "READVU":@AM:"REWIND":@AM:"SEEK":@AM:"WEOF":@AM:"WRITESEQ":@AM
 +
  SPECIAL.CASES := "WRITET"
 +
  *
 +
  DEF.INDENT=2
 +
  FORMATS=":":@VM:"BEGIN":@VM:"CASE":@VM:"ELSE":@VM:"END":@VM:"FOR":@VM
 +
  FORMATS :="IF":@VM:"LOOP":@VM:"NEXT":@VM:"REPEAT":@VM:"RETURN":@VM
 +
  FORMATS :="THEN":@VM:"UNTIL":@VM:"WHILE"
 +
  * THIS.IND is the amount this line will be in or outdented
 +
  FORMATS<2>=0:@VM:0:@VM:-1:@VM:0:@VM:-1:@VM:0:@VM:0:@VM
 +
  FORMATS<2> :=0:@VM:-1:@VM:-1:@VM:-1:@VM:0:@VM:-1:@VM:-1
 +
  * NEXT.IND is the amount that all following lines will be indented
 +
  FORMATS<3>=1:@VM:2:@VM:0:@VM:1:@VM:-1:@VM:1:@VM:1:@VM
 +
  FORMATS<3> :=1:@VM:-1:@VM:-1:@VM:-1:@VM:1:@VM:0:@VM:0
 +
  FORMATS<4>=DEF.INDENT
 +
  *
 +
  OPEN B.FILE TO FI ELSE PRINT 'Cannot open ':B.FILE ; RETURN
 +
  READ REC FROM FI,B.ITEM ELSE PRINT "CANNOT READ ":B.FILE:" ":B.ITEM ; RETURN
 +
  *WRITE REC ON FI,B.NAME:".BAK"
 +
  SWAP CHAR(9) WITH SPACE(DEF.INDENT) IN REC
 +
  *
 +
  I = DCOUNT(REC,@AM)
 +
  IF I < 2 THEN RETURN
 +
  FOR F = 1 TO I
 +
    PRINT STAR:
 +
    L = REC<F> ; NEXT.LINE=REC<F+1>
 +
    GOSUB FORMAT.LINE
 +
    REC<F> = L
 +
  NEXT F
 +
  WRITE REC ON FI,B.ITEM
 +
  PRINT STAR ; PRINT I:" lines of ":B.ITEM:" formatted"
 +
  CLOSE FI
 +
RETURN
 +
*
 +
FORMAT.LINE:
 +
  L=TRIM(L,' ','B')
 +
  CONVERT TAB TO "" IN L
 +
  FIRST.WORD = FIELD(L,SPC,1)
 +
  LEN.FIRST.WORD = LEN(FIRST.WORD)
 +
  LOCATE FIRST.WORD IN SPECIAL.CASES BY 'AL' SETTING SPECIAL ELSE SPECIAL = 0
 +
  NUM.SPACES = COUNT(L,SPC) + 1
 +
  LAST.WORD = FIELD(L,SPC,NUM.SPACES)
 +
  NEXT.TO.LAST.WORD = FIELD(L,SPC,NUM.SPACES-1)
 +
  THIS.IND = 0
 +
  NEXT.IND = 0
 +
  BEGIN CASE
 +
    CASE L=""
 +
      L="*" ;* Makes pasting code around easier with no blank lines
 +
    CASE FIRST.WORD[LEN.FIRST.WORD,1] = COLON OR NUM(FIRST.WORD)
 +
      * A label
 +
      IND = 0
 +
      LOCATE COLON IN FORMATS<1> SETTING POS ELSE POS = 0
 +
      THIS.IND = FORMATS<2,POS>
 +
      NEXT.IND = FORMATS<3,POS>
 +
     CASE FIRST.WORD = "IF"
 +
      LOCATE FIRST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
 +
      IF LAST.WORD = "THEN" THEN
 +
         THIS.IND = FORMATS<2,POS>
 +
        NEXT.IND = FORMATS<3,POS>
 +
      END
 +
    CASE FIRST.WORD = "END"
 +
      SECOND.WORD = FIELD(L,SPC,2)
 +
      IF SECOND.WORD = "ELSE" THEN
 +
        LOCATE "ELSE" IN FORMATS<1> SETTING POS ELSE POS = 0
 +
        THIS.IND = -FORMATS<3,POS>
 +
        NEXT.IND = FORMATS<2,POS>
 +
      END ELSE
 +
         IF SECOND.WORD = "CASE" THEN
 +
          LOCATE "BEGIN" IN FORMATS<1> SETTING POS ELSE POS = 0
 +
          THIS.IND = -FORMATS<3,POS>
 +
          NEXT.IND = -FORMATS<3,POS>
 +
        END ELSE
 +
          LOCATE FIRST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
 +
          THIS.IND = FORMATS<2,POS>
 +
          NEXT.IND = FORMATS<3,POS>
 +
         END
 +
      END
 +
     CASE SPECIAL
 +
      * Find last word - skip until a space
 +
      IF LAST.WORD = "ELSE" OR LAST.WORD = "THEN" THEN
 +
        LOCATE LAST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
 +
        THIS.IND = FORMATS<2,POS>
 +
        NEXT.IND = FORMATS<3,POS>
 +
      END
 +
     CASE FIRST.WORD = "FOR" AND NEXT.TO.LAST.WORD = "NEXT"
 +
      * FOR loop on one line means do nothing
 +
    CASE FIRST.WORD = "RETURN" AND TRIM(NEXT.LINE) # "*"
 +
      * RETURN without a blank line means do nothing
 +
    CASE 1
 +
      LOCATE FIRST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
 +
      IF POS # 0 THEN
 +
        THIS.IND = FORMATS<2,POS>
 +
        NEXT.IND = FORMATS<3,POS>
 +
      END
 +
  END CASE
 +
  L = SPACE((IND+THIS.IND)*DEF.INDENT):L
 +
  *L = STR(TAB,IND+THIS.IND):L ;* In my misguided youth, tabs seemed cool
 +
  IND = IND + NEXT.IND
 
RETURN
 
RETURN
 
+
*
PROG.COMMAND:
+
GET.LINE:
    IF ANS = PROG.CHAR OR ANS=PROG.CHAR:PROG.CHAR THEN GO PRINT.PROG.INFO
+
  * SUBROUTINE GET.LINE(X,LEN,DISP.LEN,XXDATA,RTN)
     GOSUB PARSE.PROG.COM
+
  * X          = X POS
 +
  * LEN        = MAX ALLOWED LENGTH
 +
  * DISP.LEN    = MAX DISPLAYED LEN
 +
  * XXDATA      = ON INPUT  VARIABLE XXDATA
 +
  *            = ON OUTPUT RETURNED STRING
 +
  * RTN        = SEQ(CHAR PRESSED TO EXIT)
 +
  * -----------------
 +
  * Important globals
 +
  * CP          = Cursor Position, Y coordinate on the screen 0 -> DISP.LEN
 +
  * CH.PTR      = Pointer into string being edited            1 -> LEN
 +
  * POS        = Pointer to first char currently displayed  1 -> LEN
 +
  * ASC.CH      = The numeric value of the key just entered
 +
  *
 +
  ECHO OFF
 +
  XXDATA = ENTRY
 +
  MODE = INSERT ; TEMP.XXDATA = XXDATA
 +
  BASE = @(X) ; MASK = 'L#':DISP.LEN
 +
  PRINT BASE:
 +
  CURR.LEN = LEN(XXDATA)
 +
  GOSUB GO.END
 +
  RTN=''
 +
  *
 +
  LOOP
 +
    PRINT @(X+CP):
 +
     CH=IN()
 +
    ASC.CH = SEQ(CH)
 +
    EXIT.FLAG=FALSE
 
     BEGIN CASE
 
     BEGIN CASE
        CASE PROG.COM = '[[/WW]]'
+
      CASE ASC.CH = 1
            WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
+
        GOSUB GO.BEGIN
            EXEC.LINE = WP.VERB:SPC:HOME.FILE:SPC:PROGRAM.ITEM
+
      CASE ASC.CH = 2
            GOSUB EXEC.SUB
+
        GOSUB LEFT
            READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
+
      CASE ASC.CH = 4
         CASE PROG.COM = '[[/N]]'
+
         GOSUB DEL
            GOSUB GET.PROG.NAME
+
      CASE ASC.CH = 5
            IF RTN=13 THEN
+
        GOSUB GO.END
                PROGRAMS<PROG.NUM> = PROG
+
      CASE ASC.CH = 6
                WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
+
        GOSUB RIGHT
            END
+
      CASE ASC.CH = 8
            IF B.FILE # '' THEN
+
        GOSUB BACK
                OPEN B.FILE TO F THEN
+
      CASE ASC.CH = 9
                    OPTIONS=''
+
        GOSUB AUTO.COMPLETE
                    CALL CVS.CHECKOUT(RTN, B.FILE, B.ITEM, OPTIONS)
+
      CASE ASC.CH = 10
                    READ DUMMY FROM F, B.ITEM ELSE
+
        GOSUB DEL.TO.END
                        PRINT B.ITEM:' not found. Use standard header? ':
+
      CASE ASC.CH = 13
                        INPUT YORN
+
        EXIT.FLAG = TRUE
                        IF YORN = 'Y' THEN
+
        RTN=13
                            READ HEADER FROM TRIN.GLOBAL.PARAMETER, 'TRIN.HEADER' THEN
+
      CASE ASC.CH = 14
                                SWAP "$*" WITH "$" IN HEADER
+
        RTN=2
                                HEADER<2>=HEADER<2>[1,12]:B.ITEM
+
        EXIT.FLAG=TRUE
                                HEADER<3>=HEADER<3>[1,12]:USERNAME                             
+
      CASE ASC.CH = 16
                                HEADER<4>=HEADER<4>[1,12]:OCONV(DATE(),"D4/")
+
        RTN=1
                                WRITE HEADER ON F, B.ITEM
+
        EXIT.FLAG=TRUE
                            END
+
      CASE ASC.CH = 18
                        END
+
        GOSUB INSRT
                    END
+
      CASE ASC.CH = PG.UP.KEY
                    CLOSE F
+
         EXIT.FLAG=TRUE
                END ELSE
+
        RTN=PG.UP.KEY
                    PRINT B.FILE:' is not a file in this account'
+
      CASE ASC.CH = PG.DOWN.KEY
                END
+
         EXIT.FLAG=TRUE
            END
+
        RTN=PG.DOWN.KEY
        CASE PROG.COM = '[[/H]]'
+
      CASE ASC.CH = 23
            OPTIONS='LESS'
+
        GOSUB DELETE.WORD
            CALL CVS.LOG(RTN, B.FILE, B.ITEM, OPTIONS)
+
      CASE ASC.CH = 24
        CASE PROG.COM = '[[/L]]'
+
        GOSUB FORWARD.WORD
            OPTIONS='MODIFIED'
+
      CASE ASC.CH = 7 OR ASC.CH = 12
            X = 15;DISP.LEN=30;LEN=LONG.LINE;ENTRY=NUL
+
        IF ASC.CH = 12 THEN PRINT @(-1):
            PRINT 'Program File :':
+
        XXDATA = ''
            GOSUB GET.INPUT
+
        EXIT.FLAG=TRUE
            ANS = UPCASE(ENTRY)
+
        RTN=13
            IF RTN # 13 THEN RETURN           
+
      CASE ASC.CH = 26
            CALL CVS.LIST(RTN, ENTRY, OPTIONS)
+
        GOSUB BACK.WORD
        CASE PROG.COM = '[[/CI]]'
+
      CASE ASC.CH = 27
            * Check it in
+
        GOSUB ESC.KEY
            OPTIONS=''
+
      CASE ASC.CH < 27
            CALL CVS.CHECKIN(RTN, B.FILE, B.ITEM, OPTIONS)
+
        PRINT @(0):ASC.CH:
         CASE PROG.COM = '[[/D]]'
+
      CASE ASC.CH = 127
            * CVS Diff
+
        GOSUB BACK
            OPTIONS='SHOW'
+
      CASE 1
            CALL CVS.DIFF(RTN, B.FILE, B.ITEM, OPTIONS)
+
         GOSUB ORD
        CASE B.FILE[1,1] = '*' OR B.FILE=''
 
            NULL ;* Don't do anything with 'comment' or blank entries
 
         CASE PROG.COM = '[[/BR]]'
 
            GOSUB COMPILE
 
            EXEC.LINE = B.ITEM
 
            GOSUB EXEC.SUB
 
        CASE PROG.COM = '[[/B]]'
 
            GOSUB COMPILE
 
        CASE PROG.COM = '[[/E]]' OR PROG.COM = '[[/W]]'
 
            OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
 
            READ R1 FROM F, B.ITEM ELSE R1=NUL
 
            IF PROG.COM = '[[/E]]' THEN
 
                EXEC.LINE = ED.VERB:SPC:PROG:OPTIONS
 
            END ELSE
 
                EXEC.LINE = WP.VERB:SPC:PROG
 
            END
 
            GOSUB EXEC.SUB
 
            * Do we need to time-stamp?
 
            *READ R FROM F, B.ITEM THEN
 
            *  IF R1 # R THEN GOSUB TIME.STAMP
 
            *END
 
            CLOSE F
 
        CASE PROG.COM = '[[/F]]'
 
            EXEC.LINE = 'BFORMAT ':PROG:OPTIONS
 
            GOSUB EXEC.SUB
 
        CASE PROG.COM = '[[/R]]'
 
            OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
 
            READV R FROM F, B.ITEM, 1 ELSE R=NUL
 
            CLOSE F
 
            IF R='PQ' THEN
 
                EXEC.LINE= 'RP ':PROG:OPTIONS
 
            END ELSE
 
                EXEC.LINE = B.ITEM:OPTIONS
 
            END
 
            GOSUB EXEC.SUB
 
        CASE PROG.COM = '[[/S]]'
 
            E=\SORT.RECORD \:HOME.FILE:\ \:PROGRAM.ITEM
 
            PRINT E ; EXECUTE E
 
         CASE OTHERWISE
 
            PRINT 'There is no such PROGRAM command':BELL
 
            PRINT '? for help'
 
 
     END CASE
 
     END CASE
 +
    CURR.LEN = LEN(XXDATA)
 +
  UNTIL EXIT.FLAG DO
 +
  REPEAT
 +
  IF XXDATA[CURR.LEN,1] = SPC THEN XXDATA = XXDATA[1,CURR.LEN-1]
 +
  ECHO ON ; PRINT BASE:XXDATA MASK
 +
  ENTRY=XXDATA
 
RETURN
 
RETURN
 
+
*
COMPILE:
+
AUTO.COMPLETE:
     OPTIONS=''
+
  * Grab the current word and figure out max completion
     * Check for global catalog
+
  WORD='' ; WORD.CTR=''
     READ DUMMY FROM CTLGTB, B.ITEM THEN
+
  CH.PTR.TMP=CH.PTR-1
         PRINT B.ITEM:' is cataloged globally'
+
  LOOP
         OPTIONS='G'
+
     C=XXDATA[CH.PTR.TMP,1]
 +
  UNTIL C=' ' OR CH.PTR.TMP=0 DO
 +
    WORD=C:WORD
 +
     CH.PTR.TMP-=1
 +
  REPEAT
 +
  *
 +
  * Count which word we're on - there are different auto-completes for 1, 2 or 3+
 +
  IF CH.PTR.TMP=0 THEN
 +
    WORD.CTR=1 ;* Trying to autocomplete a command
 +
    WORD='CMD_':WORD
 +
  END ELSE
 +
    CH.PTR.TMP-=1
 +
    LOOP
 +
      C=XXDATA[CH.PTR.TMP,1]
 +
    UNTIL C=' ' OR CH.PTR.TMP=0 DO
 +
      CH.PTR.TMP-=1
 +
    REPEAT
 +
    IF CH.PTR.TMP=0 THEN
 +
      WORD.CTR=2 ;* Trying to autocomplete a filename
 +
      WORD='FILE_':WORD
 +
    END ELSE
 +
      WORD.CTR=3 ;* Trying to autocomplete from a dictionary
 +
      FNAME=FIELD(XXDATA,' ',2)
 +
      WORD='DICT-':FNAME:'_':WORD
 +
    END
 +
  END
 +
  *
 +
  IF XXDATA[CURR.LEN,1] = SPC THEN XXDATA = XXDATA[1,CURR.LEN-1]
 +
  CURR.LEN=LEN(XXDATA)
 +
  *
 +
  LOOP
 +
     READ AC.LIST FROM AC, WORD ELSE CRT BEEP: ; RETURN
 +
    * Ok, we have some auto-completion candidates, need to do two things
 +
    * 1) Check to see if we're done, return if so, or
 +
    * 2) List top 20 possible completions if there are more than one
 +
    IF DCOUNT(AC.LIST<1>,@VM)=1 AND DCOUNT(AC.LIST<2,1>,@SVM)=1 THEN
 +
      NEWF=AC.LIST<2>[LEN(WORD)+1,999]
 +
      XXDATA:=NEWF:' '
 +
      PRINT BASE:XXDATA:EOS:
 +
      CURR.LEN=LEN(XXDATA)
 +
      GOSUB GO.END
 +
      RETURN
 +
    END ELSE
 +
      CRT CS:@(0,0):BON:PROMPT.DISP:BOFF:XXDATA
 +
      NUM.CP=DCOUNT(AC.LIST<1>,@VM)
 +
      IF NUM.CP>20 THEN NUM.CP=20
 +
      FOR CP=1 TO NUM.CP
 +
         CRT CP'R#2':') ':FIELD(AC.LIST<1,CP>,'_',2,99):' (':
 +
         NUM.CP2=DCOUNT(AC.LIST<2,CP>,@SVM)
 +
        NUM.CP2.MAX=NUM.CP2
 +
        IF NUM.CP2>3 THEN NUM.CP2=3
 +
        FOR CP2=1 TO NUM.CP2
 +
          CRT FIELD(AC.LIST<2,CP,CP2>,'_',2,99):
 +
          IF CP2<NUM.CP2 THEN CRT ',':
 +
        NEXT CP2
 +
        IF NUM.CP2 # NUM.CP2.MAX THEN CRT ' [+':NUM.CP2.MAX-NUM.CP2:']':
 +
        CRT ')'
 +
      NEXT CP
 +
      WORD.CONTINUE=IN()
 +
      ASC.VAL = SEQ(WORD.CONTINUE)
 +
      CRT CS:@(0,0):BON:PROMPT.DISP:BOFF:XXDATA:
 +
      BEGIN CASE
 +
        CASE ASC.VAL=13 OR ASC.VAL=27
 +
          CURR.LEN=LEN(XXDATA)
 +
          GOSUB GO.END
 +
          RETURN
 +
        CASE ASC.VAL>=32 AND ASC.VAL<127
 +
          WORD:=WORD.CONTINUE
 +
          XXDATA:=WORD.CONTINUE
 +
      END CASE
 +
    END
 +
  REPEAT
 +
RETURN
 +
*
 +
ORD:
 +
  * Ordinary key pressed
 +
  IF CH.PTR # LEN+1 THEN
 +
    IF MODE = INSERT THEN
 +
      IF CURR.LEN = LEN THEN
 +
        PRINT BEEP:
 +
        GOTO SKIP1
 +
      END ELSE
 +
        XXDATA = XXDATA[1,CH.PTR-1]:CH:XXDATA[CH.PTR,CURR.LEN]
 +
      END
 +
    END ELSE
 +
      XXDATA = XXDATA[1,CH.PTR-1]:CH:XXDATA[CH.PTR+1,CURR.LEN]
 
     END
 
     END
      
+
     CH.PTR = CH.PTR + 1
     * Check for local catalog
+
     IF CP # DISP.LEN THEN
    READ DUMMY FROM CTLG, B.ITEM THEN
+
      PRINT @(X+CP):CH:
         PRINT B.ITEM:' is cataloged locally'
+
      IF MODE = INSERT THEN
        OPTIONS:='L'
+
         PRINT XXDATA[CH.PTR,DISP.LEN-CP-1]:
 +
      END
 +
      CP = CP + 1
 +
    END ELSE
 +
      POS = POS + 1
 +
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 
     END
 
     END
 
+
  END ELSE
     * Check for direct catalog
+
     PRINT BEEP:
    READ DUMMY FROM VOC, B.ITEM THEN
+
  END
        IF INDEX(DUMMY<2>,'[[/CTLG]]/',1)=0 THEN
+
SKIP1:
            PRINT B.ITEM:' is cataloged direct to ':DUMMY<2>
+
RETURN
            PRINT 'Bugging out:':INDEX(DUMMY<2>,'[[/CTLG]]/',1)
+
*
            RETURN
+
RIGHT:
         END
+
  * There are 3 situations here -
 +
  * 1 We're pressing the right arrow thru existing text      (CH.PTR = CURR.LEN)
 +
  * 2 We've typed text and are at the end when we press right (CH.PTR > CURR.LEN)
 +
  * 3 We're in the middle of text, pressing the right arrow  (CH.PTR < CURR.LEN)
 +
  IF CH.PTR < LEN THEN
 +
    IF CH.PTR > CURR.LEN THEN PRINT BEEP: ; GOTO SKIP2
 +
    IF CH.PTR = CURR.LEN THEN
 +
      * If the last char is not a space make it one
 +
      IF XXDATA[CURR.LEN,1] # SPC THEN
 +
        XXDATA = XXDATA:SPC
 +
        IF CP # DISP.LEN THEN PRINT @(X+CP+1):SPC:
 +
        CURR.LEN = CURR.LEN + 1
 +
      END ELSE
 +
        PRINT BEEP:
 +
         GOTO SKIP2
 +
      END
 
     END
 
     END
 
+
    CH.PTR = CH.PTR + 1
     IF LEN(OPTIONS) > 1 THEN
+
     IF CP # DISP.LEN THEN
        PRINT "OPTIONS=":OPTIONS
+
      * We're not at the end of display so just move the cursor
        PRINT "I do not like green eggs and ham, nor do I like"
+
      CP = CP + 1
        PRINT "programs cataloged twice. You must fix, Sam"
+
    END ELSE
        RETURN
+
      * We are at the end of the display so leave cursor where
 +
      * it is and scroll through line
 +
      POS = POS + 1
 +
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 
     END
 
     END
 
+
  END ELSE
 +
    PRINT BEEP:
 +
  END
 +
SKIP2:
 +
RETURN
 +
*
 +
FORWARD.WORD:
 +
  * Tab key pressed - move forwards a word
 +
  IF CH.PTR >= CURR.LEN THEN
 +
    PRINT BEEP:
 +
  END ELSE
 
     LOOP
 
     LOOP
    UNTIL OPTIONS#'' DO
+
      CH.PTR = CH.PTR + 1
        PRINT 'Catalog ':B.ITEM:' -- L)ocal or G)lobal :':
+
      CP = CP + 1
        INPUT OPTIONS
+
    UNTIL XXDATA[CH.PTR,1] = SPC OR CH.PTR = CURR.LEN DO
        OPTIONS=UPCASE(OPTIONS)
 
        IF OPTIONS = '/' OR OPTIONS='' THEN RETURN
 
        * Have to enter L or G
 
        IF OPTIONS # 'L' AND OPTIONS # 'G' THEN OPTIONS=''
 
 
     REPEAT
 
     REPEAT
 
+
    IF CH.PTR # CURR.LEN THEN
     EXEC.LINE = 'BASIC ':B.FILE:' '
+
      LOOP
    IF OPTIONS='G' THEN EXEC.LINE:='TO BP.OBJ '
+
        CH.PTR = CH.PTR + 1
     EXEC.LINE := B.ITEM:' -D'
+
        CP = CP + 1
     PRINT EXEC.LINE
+
      UNTIL XXDATA[CH.PTR,1] # SPC OR CH.PTR = CURR.LEN DO
     GOSUB EXEC.SUB
+
      REPEAT
 
+
     END
     IF OPTIONS='G' THEN
+
    IF CP > DISP.LEN THEN
        EXEC.LINE = 'CATALOG BP.OBJ ':B.ITEM:' FORCE'
+
      CP = DISP.LEN
         PRINT EXEC.LINE
+
      POS = CH.PTR - DISP.LEN
         GOSUB EXEC.SUB
+
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
         * Global, so remove direct or local pointers
+
    END
        READ R FROM VOC, B.ITEM THEN DELETE VOC, B.ITEM
+
  END
 +
RETURN
 +
*
 +
LEFT:
 +
  * If we're not at the start of data, move left
 +
  IF CH.PTR # 1 THEN
 +
    CH.PTR = CH.PTR - 1
 +
    IF CP # 0 THEN
 +
      * We're not at the start of the display so just move the cursor
 +
      CP = CP - 1
 +
     END ELSE
 +
      * We are at the start of the display so leave cursor and scroll
 +
      POS = POS - 1
 +
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 +
    END
 +
  END ELSE
 +
    PRINT BEEP:
 +
  END
 +
RETURN
 +
*
 +
DEL:
 +
  * Delete the character at the cursor and redisplay from this point
 +
  XXDATA = XXDATA[1,CH.PTR-1]:XXDATA[CH.PTR+1,CURR.LEN]
 +
  CURR.LEN = CURR.LEN - 1
 +
  PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 +
RETURN
 +
*
 +
BACK:
 +
  * Backspace key pressed
 +
  IF CH.PTR # 1 THEN
 +
     CH.PTR = CH.PTR - 1
 +
     XXDATA = XXDATA[1,CH.PTR-1]:XXDATA[CH.PTR+1,CURR.LEN]
 +
    CURR.LEN = CURR.LEN - 1
 +
     IF CP # 0 THEN
 +
      CP = CP - 1
 +
    END ELSE
 +
      POS = POS - 1
 +
    END
 +
    PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 +
  END ELSE
 +
    PRINT BEEP:
 +
  END
 +
RETURN
 +
*
 +
INSRT:
 +
  * Toggle between insert and replace modes
 +
  MODE = -MODE
 +
RETURN
 +
*
 +
ESC.KEY:
 +
  * ESC pressed, or extended key - wyse50 arrow keys
 +
  * Get next char of extended command
 +
  ALLOW = 0
 +
  EXT.KEY=IN()
 +
  EXT = SEQ(EXT.KEY)
 +
  EXT.KEY = OCONV(EXT.KEY,'MCU')
 +
  BEGIN CASE
 +
    CASE EXT.KEY = 'D'
 +
      GOSUB DELETE.WORD
 +
    CASE EXT.KEY = '[' OR EXT.KEY = 'O'
 +
      EXT.KEY=IN()
 +
      BEGIN CASE
 +
         CASE EXT.KEY = 'C'
 +
          GOSUB RIGHT
 +
         CASE EXT.KEY = 'D'
 +
          GOSUB LEFT
 +
        CASE EXT.KEY = 'A'
 +
          RTN=1
 +
          EXIT.FLAG=TRUE
 +
         CASE EXT.KEY = 'B'
 +
          RTN=2
 +
          EXIT.FLAG=TRUE
 +
      END CASE
 +
  END CASE
 +
RETURN ; * From ESC key
 +
*
 +
BACK.WORD:
 +
  * Shift tab pressed - go back a word
 +
  IF CH.PTR = 1 THEN
 +
    PRINT BEEP:
 +
  END ELSE
 +
    * 2 situations - either we're in a word already or
 +
    * we're at the start of a word
 +
    * If in a word - loop to the start of the word
 +
    * otherwise skip spaces, and then move to start of word
 +
    IF XXDATA[CH.PTR-1,1] # SPC THEN
 +
      LOOP
 +
      UNTIL XXDATA[CH.PTR-1,1] = SPC OR CH.PTR = 1 DO
 +
        CH.PTR = CH.PTR - 1
 +
        CP = CP - 1
 +
      REPEAT
 
     END ELSE
 
     END ELSE
        EXEC.LINE = 'CATALOG ':PROG:' LOCAL FORCE'
+
      * Skip spaces
         PRINT EXEC.LINE
+
      LOOP
         GOSUB EXEC.SUB
+
      UNTIL XXDATA[CH.PTR-1,1] # SPC OR CH.PTR = 1 DO
         * Object is in CTLG file, so remove from SOURCE file
+
         CH.PTR = CH.PTR - 1
         OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
+
         CP = CP - 1
        DELETE F, '_':B.ITEM
+
      REPEAT
        CLOSE F
+
      IF CH.PTR > 1 THEN
 +
         * At word end - move to start of word
 +
        LOOP
 +
        UNTIL XXDATA[CH.PTR-1,1] = SPC OR CH.PTR = 1 DO
 +
          CH.PTR = CH.PTR - 1
 +
          CP = CP - 1
 +
         REPEAT
 +
      END
 +
    END
 +
    IF CP < 0 THEN
 +
      CP = 0
 +
      POS = CH.PTR
 +
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 
     END
 
     END
 
+
  END
     EXEC.LINE = 'NEWPCODE'
+
RETURN
 +
*
 +
DEL.TO.END:
 +
  * Delete from cursor to end of line
 +
  IF CH.PTR = 1 THEN
 +
    XXDATA = ''
 +
    CP = 0
 +
    POS = 1
 +
  END ELSE
 +
    XXDATA = XXDATA[1,CH.PTR-1]
 +
  END
 +
  CURR.LEN = LEN(XXDATA)
 +
  PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 +
RETURN
 +
*
 +
DELETE.WORD:
 +
  * Delete to space at right of cursor
 +
  IF CH.PTR >= CURR.LEN THEN
 +
    PRINT BEEP:
 +
  END ELSE
 +
    C = CH.PTR
 +
    LOOP
 +
      C = C + 1
 +
    UNTIL XXDATA[C,1] = SPC OR C = CURR.LEN DO
 +
    REPEAT
 +
    XXDATA = XXDATA[1,CH.PTR-1]:XXDATA[C+1,CURR.LEN]
 +
    CURR.LEN = CURR.LEN - C + CH.PTR - 1
 +
    PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 +
  END
 +
RETURN
 +
*
 +
GO.BEGIN:
 +
  * Go to the start of data and redisplay
 +
  CP = 0
 +
  CH.PTR = 1
 +
  POS = 1
 +
  PRINT BASE:XXDATA MASK:
 +
RETURN
 +
*
 +
GO.END:
 +
  * Move to the end of data and redisplay
 +
  IF XXDATA[CURR.LEN,1] # SPC THEN
 +
    XXDATA = XXDATA:SPC
 +
    CURR.LEN = CURR.LEN + 1
 +
  END
 +
  IF CURR.LEN < DISP.LEN THEN
 +
    CP = CURR.LEN - 1
 +
    POS = 1
 +
  END ELSE
 +
    CP = DISP.LEN - 1
 +
    POS = CURR.LEN - DISP.LEN + 1
 +
  END
 +
  CH.PTR = CURR.LEN
 +
  PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
 +
RETURN
 +
*
 +
ATB.FIND:
 +
  OPEN "IL.TB.CHNG.LOG" TO IL.TB.CHNG.LOG ELSE STOP 201,"IL.TB.CHNG.LOG"
 +
  OPEN "IL.CHANGE.LOG.INDEX" TO IL.CHANGE.LOG.INDEX ELSE STOP 201,"IL.CHANGE.LOG.INDEX"
 +
  OPEN "REV.ATB.LOG" TO REV.ATB.LOG ELSE STOP 201,"REV.ATB.LOG"
 +
  OPEN "HELP.TEXT.USA" TO HELP.TEXT.USA ELSE STOP 201,"HELP.TEXT.USA"
 +
  MSK="L#22"
 +
  ATB = FIELD(ANS," ",2)
 +
  *
 +
  IF ATB="" THEN
 +
    PRINT "ENTER ATB NAME: ": ; INPUT ATB
 +
    IF ATB="" OR ATB="/" THEN RETURN
 +
  END
 +
  *
 +
  READ AREC FROM REV.ATB.LOG,ATB ELSE
 +
    ATBREC="" ; TEST=""
 +
     EXEC.LINE=\SSELECT REV.ATB.LOG = "[\:ATB:\]"\
 
     GOSUB EXEC.SUB
 
     GOSUB EXEC.SUB
RETURN
+
     CTR=0
 
 
PARSE.PROG.COM:
 
     PROG.NUM = NUL
 
    F = FIELD(ANS,SPC,1);L = LEN(F);I = L
 
 
     LOOP
 
     LOOP
        IF NUM(F[I,1]) THEN PROG.NUM = F[I,1]:PROG.NUM ELSE EXIT
+
      READNEXT ID ELSE EXIT
        I = I - 1
+
      CTR+=1
 +
      PRINT CTR "L#4":ID
 +
      ATBREC<CTR>=ID
 +
      IF MOD(CTR,23)=0 THEN PRINT "[ENTER]": ; INPUT TEST
 +
      IF TEST = "/" THEN EXIT
 
     REPEAT
 
     REPEAT
     IF PROG.NUM = NUL THEN PROG.NUM = 1
+
    PRINT
     OPTIONS = ANS[L+1,LONG.LINE]
+
    PRINT "Enter choice (1-":CTR:"): ": ; INPUT CHOICE
     PROG.COM = ANS[1,I]
+
    IF CHOICE="" OR CHOICE="/" THEN RETURN
     PROG = PROGRAMS<PROG.NUM>
+
    ATB=ATBREC<CHOICE>
    B.FILE = FIELD(PROG,SPC,1)
+
     IF ATB="" THEN RETURN
    B.ITEM = FIELD(PROG,SPC,2)
+
    READ AREC FROM REV.ATB.LOG,ATB ELSE PRINT 'Not found' ; RETURN
 +
  END
 +
  *
 +
  MAXV=DCOUNT(AREC<5>,@VM)
 +
  FNAMES=""
 +
  FOR J=1 TO MAXV
 +
    IF AREC<5,J>[1,2] # "BK" THEN FNAMES :=AREC<5,J>:",":AREC<6,J>:"  "
 +
  NEXT J
 +
  *
 +
  READV CKEY FROM IL.CHANGE.LOG.INDEX,AREC<24>,1 ELSE CKEY=""
 +
  READ CHNG_REC FROM IL.TB.CHNG.LOG,CKEY ELSE CHNG_REC=""
 +
  READ HELP.TEXT FROM HELP.TEXT.USA,ATB ELSE HELP.TEXT= " NOT FOUND"
 +
  CONVERT "~" TO "" IN HELP.TEXT
 +
  DEP=AREC<16>
 +
  CONVERT @VM TO "," IN DEP
 +
  PRINT ATB
 +
  PRINT
 +
  PRINT "IL.BPI" MSK              :AREC<1>
 +
  PRINT "FILE(S)" MSK              :FNAMES
 +
  PRINT "FIELD" MSK                :AREC<2>
 +
  PRINT "CHANGE LOG INDEX" MSK    :AREC<24>
 +
  PRINT "CHANGE LOG KEY" MSK      :CKEY
 +
  PRINT "TYPE" MSK                :AREC<3>
 +
  PRINT "MASK" MSK                :AREC<10>
 +
  PRINT "S/MV" MSK                :AREC<14>
 +
  PRINT "CONTROLLING/DEPENDENT" MSK:AREC<15>
 +
  PRINT "SUB/MASTER FIELDS" MSK    :DEP
 +
  PRINT "CHG DESCRIPTION" MSK      :CHNG_REC<1>
 +
  IF AREC<32> # "" THEN
 +
    PRINT "COMMENTS" MSK          :AREC<32>
 +
    PRINT
 +
  END
 +
  PRINT
 +
  MAXV=DCOUNT(HELP.TEXT<2>,@VM)
 +
  FOR J=1 TO MAXV
 +
     PRINT HELP.TEXT<2,J>
 +
  NEXT J
 +
RETURN
 +
*
 +
GET.TERM.WIDTH:
 +
  T='/tmp/':@LOGNAME:'.term'
 +
  EXEC.LINE=\!tput cols > \:T ;* Always returns 80 if you capture, so use tmp file
 +
  CAP.ACTIVE=FALSE
 +
  GOSUB EXEC.SUB
 +
  EXEC.LINE=\!cat \:T
 +
  CAP.ACTIVE=TRUE
 +
  GOSUB EXEC.SUB
 +
  TERM.WIDTH=EXEC.CAP<1>
 +
  EXEC.LINE=\!rm \:T
 +
  GOSUB EXEC.SUB
 +
  EXEC.LINE=\TERM \:TERM.WIDTH ; GOSUB EXEC.SUB
 +
RETURN
 +
*
 +
PICKLE:
 +
  PICKLE.LIST=''
 +
  *
 +
  IF FIELD(ANS,' ',2)='DICT' THEN
 +
    FILE='DICT ':FIELD(ANS,' ',3)
 +
    ITEM=FIELD(ANS,' ',4)
 +
  END ELSE
 +
    FILE=FIELD(ANS,' ',2)
 +
    ITEM=FIELD(ANS,' ',3)
 +
  END
 +
  OPEN FILE TO FVAR ELSE
 +
    PRINT 'Cannot open ':FILE
 +
    RETURN
 +
  END
 +
  READ REC FROM FVAR, ITEM ELSE
 +
    PRINT 'Cannot read ':FILE:' ':ITEM
 +
    RETURN
 +
  END
 +
  BLOB='R=""'
 +
  IF FILE[1,5]='DICT ' THEN DEL REC<9> ; DEL REC<8> ;* Avoid CD probs
 +
  INS ITEM BEFORE REC<1>
 +
  INS FILE BEFORE REC<1>
 +
  SWAP @AM WITH '#AM#' IN REC  ; SWAP @VM WITH '#VM#' IN REC
 +
  SWAP @SVM WITH '#SVM#' IN REC ; SWAP '\' WITH '#134#' IN REC
 +
  BLOB<-1>=\S=''\
 +
  LOOP
 +
    T=REC[1,70]
 +
     BLOB<-1>='S:=\':T:'\'
 +
    REC=REC[71,LEN(REC)]
 +
  UNTIL LEN(REC)=0 DO
 +
  REPEAT
 +
  BLOB<-1>='R<-1>=S'
 +
  BLOB<-1>='*'
 +
  *
 +
  * Write out basic code that when run will recreate the record
 +
  BLOB<-1>='FOR F=1 TO DCOUNT(R,@AM)'
 +
  BLOB<-1>='  REC=R<F>'
 +
  BLOB<-1>='  SWAP "#AM#" WITH @AM IN REC  ; SWAP "#VM#" WITH @VM IN REC'
 +
  BLOB<-1>='  SWAP "#SVM#" WITH @SVM IN REC ; SWAP "#134#" WITH "\" IN REC'
 +
  BLOB<-1>='  FILE=REC<1> ; DEL REC<1>'
 +
  BLOB<-1>='  ITEM=REC<1> ; DEL REC<1>'
 +
  BLOB<-1>='  PRINT FILE:" ":ITEM:'
 +
  BLOB<-1>='  OPEN FILE TO FVAR ELSE STOP 201, FILE'
 +
  BLOB<-1>='  WRITE REC ON FVAR,ITEM ; PRINT "*"'
 +
  BLOB<-1>='  CLOSE FVAR'
 +
  BLOB<-1>='NEXT F'
 +
  FOR I=1 TO DCOUNT(BLOB,@AM)
 +
     PRINT BLOB<I>
 +
  NEXT I
 +
RETURN
 +
*
 +
SETTINGS:
 +
  PRINT CS:
 +
  PRINT 'COMMAND.SEP  = ':SETTINGS<1>
 +
  PRINT 'STACK.CHAR  = ':SETTINGS<2>
 +
  PRINT 'PROG.CHAR    = ':SETTINGS<3>
 +
  PRINT 'MAX.STACK    = ':SETTINGS<4>
 +
  PRINT 'WP.VERB      = ':SETTINGS<5>
 +
  PRINT 'ED.VERB      = ':SETTINGS<6>
 +
  PRINT 'STAMP.STRING = ':SETTINGS<7>
 +
  PRINT 'GET.LINE.FLAG= ':SETTINGS<8>
 +
  PRINT 'WORK.FILE   = ':SETTINGS<9>
 +
  PRINT 'MCU.ON      = ':SETTINGS<10>
 +
  PRINT 'STARTUP      = ':SETTINGS<11>
 +
  PRINT 'PROMT        = ':SETTINGS<12>
 +
  PRINT 'X.DISP      = ':SETTINGS<13>
 +
  PRINT 'DEF.SHELL    = ':SETTINGS<14>
 +
  PRINT ; PRINT 'Hit ENTER to accept the current default, / to Cancel'
 +
  X=18
 +
  LEN=30
 +
  DISP.LEN=30
 +
  *
 +
  PRINT
 +
  PRINT 'The command seperator is used to run multiple commands from one entry'
 +
  PRINT 'E.g. COUNT VOC ; COUNT VOC WITH F1 = "C" will run both count commands'
 +
  PRINT 'Current value:':SETTINGS<1>
 +
  PRINT 'COMMAND SEPERATOR:':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<1>
 +
  SETTINGS<1>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'The stack character is what to prefix command stack operations with'
 +
  PRINT 'E.g. .L or .R87 or .D uses a stack character of "."'
 +
  PRINT 'Current value:':SETTINGS<2>
 +
  PRINT 'STACK CHAR      :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<2>
 +
  SETTINGS<2>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'The program character is what to prefix program stack operations with'
 +
  PRINT 'E.g. /W2 or /B3 or /L uses a program character of "/"'
 +
  PRINT 'Current value:':SETTINGS<3>
 +
  PRINT 'PROG CHAR        :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<3>
 +
  SETTINGS<3>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Max lines is the maximum number of lines to hold in the command stack'
 +
  PRINT 'E.g. 9999'
 +
  PRINT 'Current value:':SETTINGS<4>
 +
  PRINT 'MAX # LINES      :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<4>
 +
  SETTINGS<4>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Screen editor is what command to run to edit a program visually'
 +
  PRINT 'E.g. VI or !emacs or !/home/dsiroot/joe'
 +
  PRINT 'Current value:':SETTINGS<5>
 +
  PRINT 'SCREEN EDITOR    :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<5>
 +
  SETTINGS<5>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Line editor is what command to run to edit a program'
 +
  PRINT 'E.g. AE or ED'
 +
  PRINT 'Current value:':SETTINGS<6>
 +
  PRINT 'LINE EDITOR      :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<6>
 +
  SETTINGS<6>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Header string is not currently used'
 +
  PRINT 'HEADER STRING    :':SETTINGS<7>
 +
  *
 +
  PRINT
 +
  PRINT 'Use enhanced input commands, allowing editing with arrow keys'
 +
  PRINT 'Or just use plain INPUT command'
 +
  PRINT 'Current value:':SETTINGS<8>
 +
  PRINT 'USE GET.LINE SUBR:':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<8>
 +
  IF ENTRY='Y' OR ENTRY='1' THEN ENTRY='1' ELSE ENTRY='0'
 +
  SETTINGS<8>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Default file for basic programs if none specifed'
 +
  PRINT 'E.g. BP'
 +
  PRINT 'Current value:':SETTINGS<9>
 +
  PRINT 'WORK FILE        :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<9>
 +
  SETTINGS<9>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Convert commands to upper case before running'
 +
  PRINT 'E.g. 1 or 0, Y or N'
 +
  PRINT 'Current value:':SETTINGS<10>
 +
  PRINT 'CONVERT TO UCASE :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<9>
 +
  IF ENTRY='Y' OR ENTRY='1' THEN ENTRY='1' ELSE ENTRY='0'
 +
  SETTINGS<9>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Command to run when stack first starts'
 +
  PRINT 'E.g. LISTUSER ; WHO'
 +
  PRINT 'Current value:':SETTINGS<11>
 +
  PRINT 'STARTUP COMMAND  :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<11>
 +
  SETTINGS<11>=ENTRY
 +
  *
 +
  PRINT
 +
  PRINT 'Default Prompt to display, use .P to change this'
 +
  PRINT 'PROMPT          :':SETTINGS<12>
 +
  PRINT
 +
  PRINT 'Adjustment for input position (if you use #R, then CR+LF is inserted,'
 +
  PRINT 'and an adjustment of -2 is needed.  Use .P to change this'
 +
  PRINT 'X DISP FOR PROMPT:':SETTINGS<13>
 +
  *
 +
  PRINT
 +
  PRINT 'Default shell to use with !command'
 +
  PRINT 'E.g. ksh, bash, /usr/bin/ksh, /opt/freeware/bin/bash'
 +
  PRINT 'Current value:':SETTINGS<14>
 +
  PRINT 'SHELL            :':
 +
  INPUT ENTRY
 +
  IF ENTRY = '/' THEN RETURN
 +
  IF ENTRY = ''  THEN ENTRY=SETTINGS<14>
 +
  SETTINGS<14>=ENTRY
 +
  *
 +
  WRITE SETTINGS ON HOME.F, SETTING.ITEM
 
RETURN
 
RETURN
 
+
*
GET.PROG.NAME:
+
LISTA:
     X = 15;DISP.LEN = 30;LEN = LONG.LINE;ENTRY = PROG
+
  OPEN 'ACC' TO ACC.F ELSE STOP 201,'ACC'
    PRINT 'Program Name :':
+
  OPEN 'INFO.STATUS' TO INFO.STATUS ELSE STOP 201,'INFO.STATUS'
     GOSUB GET.INPUT
+
  SELECT ACC.F
    ANS = UPCASE(ENTRY)
+
  USER.LIST=''
    IF RTN # 13 THEN RETURN
+
  LOOP
    GOSUB EXPAND.ALIASES
+
    READNEXT PORT ELSE EXIT
    IF INDEX(ANS,SPC,1) THEN
+
     READ REC FROM ACC.F, PORT THEN
        B.FILE = FIELD(ANS,SPC,1)
+
      READ MENU FROM INFO.STATUS, PORT'R%3' ELSE MENU='TCL'
        B.ITEM = FIELD(ANS,SPC,2)
+
      MENU=MENU<DCOUNT(MENU,@AM)> ;* Show the last item
        PROG=ANS
+
      USER=REC<5>
     END ELSE
+
      DATE=REC<2>
         IF ANS = NUL THEN
+
      TIME=REC<3>
            B.FILE = NUL ; B.ITEM = NUL ;PROG = NUL
+
      LOCATE PORT IN USER.LIST<4> BY 'AR' SETTING POS ELSE NULL
        END ELSE
+
      INS USER BEFORE USER.LIST<1,POS>
            B.FILE = WORK.FILE ; B.ITEM = ANS ; PROG = B.FILE:SPC:B.ITEM
+
      INS DATE BEFORE USER.LIST<2,POS>
 +
      INS TIME BEFORE USER.LIST<3,POS>
 +
      INS PORT BEFORE USER.LIST<4,POS>
 +
      INS MENU BEFORE USER.LIST<5,POS>
 +
     END
 +
  REPEAT
 +
  *GET.LOCKS
 +
  LOCK.LIST=''
 +
  FLIST=''
 +
  FLIST<-1>='AS.FEATURE'
 +
  FLIST<-1>='AS.MASTER'
 +
  FLIST<-1>='AUVB.PARAMETER'
 +
  FLIST<-1>='BQ.PARAMETER'
 +
  FLIST<-1>='CS.MASTER'
 +
  FLIST<-1>='DATA.MASKING.PARAMETER'
 +
  FLIST<-1>='DB.RECORD.LOCKS'
 +
  FLIST<-1>='DE.MASTER'
 +
  FLIST<-1>='FIELD.SECURITY'
 +
  FLIST<-1>='INFO-SYSTEM'
 +
  FLIST<-1>='IT.INSURANCE'
 +
  FLIST<-1>='IT.INSURANCE.AGENT'
 +
  FLIST<-1>='LS.BANK.DEPOSIT'
 +
  FLIST<-1>='LS.DISCOUNT.PACKAGE'
 +
  FLIST<-1>='LS.DISCOUNT.WORKSHEET'
 +
  FLIST<-1>='LS.GL.HISTORY'
 +
  FLIST<-1>='LS.MASTER'
 +
  FLIST<-1>='LS.POST.DATED.CHECK'
 +
  FLIST<-1>='LS.SUPER.QUOTE'
 +
  FLIST<-1>='LS.WK.CASH'
 +
  FLIST<-1>='MISC'
 +
  FLIST<-1>='MM.GROUP'
 +
  FLIST<-1>='PARAMETER'
 +
  FLIST<-1>='PROCESSOR.PARAMETER'
 +
  FLIST<-1>='TRED.FUTURE.PROC.DATES'
 +
  FLIST<-1>='USERS.MENUS'
 +
  FLIST<-1>='WL.FOLLOW.UP'
 +
  FLIST<-1>='WL.PARAMETER'
 +
  *
 +
  FOR G=1 TO DCOUNT(FLIST,@AM)
 +
    FILE='DB.RECORD.LOCKS,':FLIST<G>
 +
     OPEN FILE TO FVAR THEN
 +
      SELECT FVAR
 +
      LOOP
 +
        READNEXT LOCK.ID ELSE EXIT
 +
         READ REC FROM FVAR, LOCK.ID THEN
 +
          PORT=REC<1>
 +
          DATE=REC<2>
 +
          TIME=REC<3>
 +
          USER=REC<4>
 +
          LOCK.LIST<1,-1>=FILE
 +
          LOCK.LIST<2,-1>=LOCK.ID
 +
          LOCK.LIST<3,-1>=PORT
 +
          LOCK.LIST<4,-1>=DATE
 +
          LOCK.LIST<5,-1>=TIME
 +
          LOCK.LIST<6,-1>=USER
 +
          LOCATE PORT IN USER.LIST<4> SETTING POS THEN
 +
            USER.LIST<6,POS>=LOCK.ID:',':USER.LIST<6,POS>
 +
          END
 
         END
 
         END
 +
      REPEAT
 +
      CLOSE FVAR
 
     END
 
     END
 +
  NEXT G
 +
  *
 +
  PRINT @(-1):'USERS'
 +
  PRINT
 +
  PRINT 'Port':' ':'User''L#12':' ':'Date''L#10':' ':'Time''L#8':' ':
 +
  PRINT 'Time On''L#8':' ':'Menu''L#30':' ':'L'
 +
  PRINT '----':' ':STR('-',12):' ':STR('-',10):' ':STR('-',8):' ':
 +
  PRINT STR('-',8):' ':STR('-',30):' ':'-'
 +
  FOR F=1 TO DCOUNT(USER.LIST<1>,@VM)
 +
    DUR=TIME()-USER.LIST<3,F>
 +
    IF DUR<0 THEN DUR+=86400 ;* Roll over midnight, add back number of seconds in a day
 +
    PRINT USER.LIST<4,F>'R#4':' ':
 +
    PRINT USER.LIST<1,F>'L#12':' ':
 +
    PRINT USER.LIST<2,F>'D4/':' ':
 +
    PRINT USER.LIST<3,F>'MTS':' ':
 +
    PRINT DUR'MTS':' ':
 +
    PRINT USER.LIST<5,F>'L#30':' ':
 +
    IF USER.LIST<6,F>#'' THEN PRINT '*' ELSE PRINT ' '
 +
  NEXT F
 +
  *
 +
  PRINT
 +
  PRINT 'LOCKS'
 +
  PRINT
 +
  PRINT 'Table''L#20':' ':'ID''L#25':' ':'Port''L#4':' ':
 +
  PRINT 'Date''L#5':' ':'Time''L#5':' ':'User''L#15'
 +
  PRINT STR('-',20):' ':STR('-',25):' ':STR('-',4):' ':
 +
  PRINT STR('-',5):' ':STR('-',5):' ':STR('-',15)
 +
  FOR L=1 TO DCOUNT(LOCK.LIST<1>,@VM)
 +
    FILE=FIELD(LOCK.LIST<1,L>,',',2)
 +
    PRINT FILE'L#20':' ':LOCK.LIST<2,L>'L#25':' ':LOCK.LIST<3,L>'R#4':' ':
 +
    PRINT (LOCK.LIST<4,L>'D4/')[1,5]:' ':LOCK.LIST<5,L>'MT':' ':LOCK.LIST<6,L>'L#15'
 +
  NEXT L
 +
  *
 +
  CLOSE ACC.F
 +
  CLOSE INFO.STATUS
 +
  *
 +
RETURN
 +
*
 +
SEARCH.BY.EXAMPLE:
 +
  * Calculate all possible ATB's for an example contract
 +
  @ID=ID
 +
  IF FILE='' OR @ID='' THEN
 +
    PRINT 'Usage: SE <FNAME> <ID>'
 +
    RETURN
 +
  END
 +
  OPEN FILE TO F ELSE PRINT 'Cannot open ':FILE ; RETURN
 +
  OPEN "DICT ":FILE TO @DICT ELSE PRINT 'Cannot open DICT ':FILE ; RETURN
 +
  READ @RECORD FROM F, @ID ELSE PRINT 'Cannot read ':@ID:' in ':FILE ; RETURN
 +
  CLOSE F
 +
  OUTPUT=''
 +
  EXECUTE \SSELECT DICT \:FILE:\ WITH F1 = "I" USING DICT VOC\
 +
  LOOP
 +
    READNEXT FLD ELSE EXIT
 +
    PRINT FLD:'=':
 +
    VAL=CALCULATE(FLD)
 +
    PRINT VAL
 +
    IF @CONV # '' THEN VAL=OCONV(VAL,@CONV)
 +
    *OUTPUT<-1>=FLD:'=':VAL
 +
  REPEAT
 +
  WRITE OUTPUT ON VOC, 'OUTPUT.TMP'
 +
  EXECUTE \AE VOC OUTPUT.TMP\
 
RETURN
 
RETURN
 
+
*
TIME.STAMP:
+
IL10.XREF:
    * Assumes that calling code opened file to F, and read record into R,
+
  FILE.NAME = FIELD(ANS,' ',2)
    *  and will take care of closing file
+
  FIELD.NAME = FIELD(ANS,' ',3)
    ERROR = FALSE
+
  SELECT.HDR=\BPI,FILE_NAME,FIELD_NAME,STRING_POS,TABLE_NAME,COLUMN_NAME,VALUE_TYPE,FIELD_TYPE\
    IF INDEX(R,STAMP.STRING,1) THEN
+
  SELECT.COMMAND = \SELECT\
        L=LEN(STAMP.STRING)
+
  SELECT.COMMAND := \ BPI, FILE_NAME, FIELD_NAME, STRING_POS, TABLE_NAME, COLUMN_NAME, VALUE_TYPE, FIELD_TYPE\
        FOR N=1 TO 10
+
  IF INDEX(FILE.NAME,'%',1) THEN
            IF R<N>[1,L] = STAMP.STRING THEN
+
    SELECT.COMMAND := \ FROM METADATA_FIELDS WHERE (FILE_NAME LIKE '\:FILE.NAME:\' OR TABLE_NAME LIKE '\:FILE.NAME:\')\
                R<N> = STAMP.STRING:' ':TIMEDATE():' By ':INITIALS'L#8'
+
  END ELSE
                WRITE R ON F,B.ITEM
+
    SELECT.COMMAND := \ FROM METADATA_FIELDS WHERE (FILE_NAME = '\:FILE.NAME:\' OR TABLE_NAME = '\:FILE.NAME:\')\
                R = NUL
+
  END
            END
+
  IF FIELD.NAME # '' THEN SELECT.COMMAND :=\ AND FIELD_NAME LIKE '%\:FIELD.NAME:\%'\
        NEXT F
+
  SELECT.COMMAND := \ ORDER BY FILE_NAME, STRING_POS\
 +
  *
 +
  GOSUB IL10.SEL
 +
RETURN
 +
*
 +
IL10.AF:
 +
  FLD = FIELD(ANS,' ',2)
 +
  SELECT.HDR=\BPI,FILE_NAME,FIELD_NAME,MV_POS,TABLE_NAME,COLUMN_NAME,MV/S,TYPE,LEN,SCALE\
 +
  SELECT.COMMAND = \SELECT BPI,FILE_NAME,FIELD_NAME,STRING_POS,TABLE_NAME,COLUMN_NAME,VALUE_TYPE,FIELD_TYPE,FIELD_LENGTH,SCALE\
 +
  SELECT.COMMAND  :=\ FROM METADATA_FIELDS\
 +
  SELECT.COMMAND  :=\ WHERE FIELD_NAME LIKE '%\:FLD:\%' OR COLUMN_NAME LIKE '%\:FLD:\%'\
 +
  GOSUB IL10.SEL
 +
RETURN
 +
*
 +
IL10.DESC:
 +
  TABLE = FIELD(ANS,' ',2)
 +
  SELECT.HDR=\COL,COLUMN_NAME,DATA_TYPE\
 +
  SELECT.COMMAND = \SELECT ORDINAL_POSITION, COLUMN_NAME, DATA_TYPE FROM INFORMATION_SCHEMA.COLUMNS\
 +
  SELECT.COMMAND:= \ WHERE TABLE_NAME = '\:TABLE:\'\
 +
  GOSUB IL10.SEL
 +
RETURN
 +
*
 +
IL10.NSEL:
 +
  PRMT=1
 +
  EXECLINE='SELECT ':FIELD(ANS,' ',2,999)
 +
  CALL EXECUTE.SELECT.SUB(EXECLINE,ERR.MSG,1,'',0,SELECTED.LIST,1,'',0,'',0,0)
 +
  CTR=0
 +
  LOOP
 +
    READNEXT ID FROM SELECTED.LIST ELSE EXIT
 +
    CTR+=1
 +
    CRT CTR'R#6':') ':ID
 +
    IF CTR/20=INT(CTR/20) AND PRMT THEN
 +
      CRT ':':
 +
      INPUT AAA
 +
      IF AAA = '/' OR AAA='Q' THEN STOP
 +
      IF AAA = 'N' THEN PRMT=0
 
     END
 
     END
 +
  REPEAT
 +
RETURN
 +
*
 +
SQL.SEL:
 +
  SELECT.HDR=''
 +
  SELECT.COMMAND=FIELD(ANS,' ',2,200)
 +
  GOSUB IL10.SEL
 +
RETURN
 +
*
 +
SQL.FILE:
 +
  SELECT.HDR=''
 +
  FILE=FIELD(ANS,' ',2) ;* Spaces in file name are not supported
 +
  OSREAD SELECT.COMMAND FROM FILE THEN
 +
  CONVERT @AM TO ' ' IN SELECT.COMMAND
 +
  SWAP CHAR(13):CHAR(10) WITH ' ' IN SELECT.COMMAND
 +
  GOSUB IL10.SEL
 +
END ELSE
 +
  CRT FILE:' not found'
 +
END
 
RETURN
 
RETURN
 
+
*
PRINT.PROG.INFO:
+
SQL.SEL.LIST:
     I = DCOUNT(PROGRAMS,@AM)
+
  LIST=FIELD(ANS,' ',2)
 +
  SELECT.COMMAND=FIELD(ANS,' ',3,200)
 +
  PRINT SELECT.COMMAND
 +
  PARAM=''
 +
  CALL IDS.EXECUTE.ANSI.SQL(SELECT.COMMAND,PARAM,'','',KEY.LIST)
 +
  CALL CONVERT.LIST(KEY.LIST)
 +
  EXECUTE \SAVE.LIST \:LIST PASSLIST KEY.LIST
 +
RETURN
 +
*
 +
IL10.SEL:
 +
  PARAM=''
 +
  CONVERT ',' TO @VM IN SELECT.HDR
 +
  PRINT SELECT.COMMAND
 +
  CALL IDS.EXECUTE.ANSI.SQL(SELECT.COMMAND,PARAM,'','',KEY.LIST)
 +
  *SUBROUTINE IDS.EXECUTE.ANSI.SQL.ERROR(SQL.STRING, PARAMS, COLUMNS, TYPES, RESULTS.ARRAY, ERROR, OFFSET, LIMIT, SORT.COLUMN, ENHANCE, ALTER.SESSION,TRANSFER.CONTRACT)
 +
  CALL IDS.EXECUTE.ANSI.SQL.ERROR(SELECT.COMMAND, PARAM, '', '', KEY.LIST, ERR, '', '', '', '0', '','')
 +
  DISP.MAX=DCOUNT(KEY.LIST,@AM)
 +
  PRINT DISP.MAX:' items selected, ERR=':ERR
 +
  IF DISP.MAX=0 THEN RETURN
 +
  *
 +
  * Get widths
 +
  W=''
 +
  IF SELECT.HDR # '' THEN
 +
    INS SELECT.HDR BEFORE KEY.LIST<1>
 +
    DISP.MAX+=1
 +
  END
 +
  FOR R=1 TO DISP.MAX
 +
    FOR C=1 TO DCOUNT(KEY.LIST<R>,@VM)
 +
      L=LEN(KEY.LIST<R,C>)
 +
      IF L > W<C> THEN W<C>=L
 +
    NEXT C
 +
  NEXT R
 +
  *
 +
  * Print the header
 +
  DISP.START=1
 +
  IF SELECT.HDR # '' THEN
 +
    DISP.START=2
 +
    FOR C=1 TO DCOUNT(KEY.LIST<1>,@VM)
 +
      PRINT FMT(KEY.LIST<1,C>,'L#':W<C>):' ':
 +
    NEXT C
 +
    PRINT
 +
    *
 +
    FOR C=1 TO DCOUNT(KEY.LIST<1>,@VM)
 +
      PRINT STR('-',W<C>):' ':
 +
    NEXT C
 +
    PRINT
 +
  END
 +
  * Now the data
 +
  FOR R=DISP.START TO DISP.MAX
 +
    IF SELECT.HDR = '' THEN CRT R,:
 +
     FOR C=1 TO DCOUNT(KEY.LIST<R>,@VM)
 +
      PRINT FMT(KEY.LIST<R,C>,'L#':W<C>):' ':
 +
    NEXT C
 
     PRINT
 
     PRINT
    FOR F = 1 TO I
+
  NEXT R
         IF PROGRAMS<F> # NUL THEN
+
RETURN
             CH=' '
+
*
             IF ANS=PROG.CHAR:PROG.CHAR THEN
+
LIST.PARAM:
                * We want cvs status as well
+
  P=''
                FILE=FIELD(PROGRAMS<F>,' ',1)
+
  P<1,-1>=STR('-', 18)        ; P<2,-1>=STR('-',33)                        ; P<3,-1>=STR('-',30)
                 ITEM=FIELD(PROGRAMS<F>,' ',2)
+
  P<1,-1>='Key Prefix'        ; P<2,-1>='InfoLease Table'                  ; P<3,-1>='RDBMS Table'
                CALL CVS.STATUS(R,FILE,ITEM,'')
+
  P<1,-1>=STR('-', 18)         ; P<2,-1>=STR('-',33)                        ; P<3,-1>=STR('-',30)
                STATUS=R<1>
+
  P<1,-1>='*00'                ; P<2,-1>='Lessor Parameters'                ; P<3,-1>='LESSOR_NF'
                 WORK.VER=R<2>
+
  P<1,-1>='*00A'              ; P<2,-1>='Temporary Lessor'                  ; P<3,-1>='TEMP_LESSOR_NF'
                 CVS.VER=R<3>
+
  P<1,-1>='*00B'              ; P<2,-1>='Additional Lessor'                ; P<3,-1>='ADDL_LESSOR_NF'
                BEGIN CASE
+
  P<1,-1>='*00GL'              ; P<2,-1>='Multiple Bookset'                  ; P<3,-1>='MULTIPLE_BOOKSET_NF'
                     CASE STATUS='UPTODATE'
+
  P<1,-1>='*00UD'              ; P<2,-1>='Lessor User-Defined'              ; P<3,-1>='LESSOR_USER_NF'
                        CH='  ':WORK.VER'L#9'
+
  P<1,-1>='*ACH'              ; P<2,-1>='Lessor ACH Flags'                  ; P<3,-1>='LESSOR_ACH_FLAGS_NF'
                    CASE STATUS='MODIFIED'
+
  P<1,-1>='*ADVICE*'          ; P<2,-1>='Advice Follow-up'                  ; P<3,-1>='ADVICE_FOLLOW_UP_NF'
                        CH='> ':WORK.VER'L#4':' ':CVS.VER'L#4'
+
  P<1,-1>='*COMMISSION'        ; P<2,-1>='Commission'                        ; P<3,-1>='COMMISSION_NF'
                     CASE 1
+
  P<1,-1>='*WARNING.MESSAGES'  ; P<2,-1>='Lessor Warning Messages'          ; P<3,-1>='LESSOR_WARNING_MESSAGES_NF'
                        CH='! ':SPACE(9)
+
  P<1,-1>='[Lessor Id]'        ; P<2,-1>='Lessor Address'                    ; P<3,-1>='LS_ADDRESS_NF'
                END CASE
+
  P<1,-1>='00*00'              ; P<2,-1>='Lease System Parameters'          ; P<3,-1>='PARAMETER_NF'
             END
+
  P<1,-1>='00*00A'             ; P<2,-1>='Temporary Lease System Params'    ; P<3,-1>='TEMP_PARAMETER_NF'
            PRINT F 'L#5':CH:' ':PROGRAMS<F>
+
  P<1,-1>='00*00B'             ; P<2,-1>='Additional Lease System Params'    ; P<3,-1>='ADDL_PARAMETER_NF'
         END
+
  P<1,-1>='00*00IRR'          ; P<2,-1>='IRR Parameter'                    ; P<3,-1>='IRR_PARAMETER_NF'
     NEXT F
+
  P<1,-1>='00*00RPT'          ; P<2,-1>='Report Parameter'                  ; P<3,-1>='RPT_PARAMETER_NF'
 +
  P<1,-1>='10*'                ; P<2,-1>='Personnel'                        ; P<3,-1>='PERSONNEL_INFO_NF'
 +
  P<1,-1>='12*'                ; P<2,-1>='Office'                            ; P<3,-1>='OFFICE_DATA_NF'
 +
  P<1,-1>='13*'                ; P<2,-1>='Vendor/Dealer'                    ; P<3,-1>='PARAM_ADDRESS_NF'
 +
  P<1,-1>='13APA*'            ; P<2,-1>='Additional Vendor/Dealer Address'  ; P<3,-1>='ADDL_PARAM_ADDRESS_NF'
 +
  P<1,-1>='14*'                ; P<2,-1>='Reason Code'                      ; P<3,-1>='REASON_CODE_NF'
 +
  P<1,-1>='15*'                ; P<2,-1>='Collateral Code'                  ; P<3,-1>='TB_COLLATERAL_NF'
 +
  P<1,-1>='16*'                ; P<2,-1>='Equipment Category'                ; P<3,-1>='EQUIP_CODE_DEFAULTS_NF'
 +
  P<1,-1>='17*'                ; P<2,-1>='Tax Description'                  ; P<3,-1>='TAX_DESC_TBL_NF'
 +
  P<1,-1>='18*'                ; P<2,-1>='Property Tax Status'              ; P<3,-1>='PROP_TAX_STATUS_TBL_NF'
 +
  P<1,-1>='19*'                ; P<2,-1>='Region'                            ; P<3,-1>='REGION_TABLE_NF'
 +
  P<1,-1>='20*'                ; P<2,-1>='Remit To'                          ; P<3,-1>='REMIT_ADDRESS_NF'
 +
  P<1,-1>='21*'                ; P<2,-1>='Base Rate Indicator'              ; P<3,-1>='FLOAT_BANK_NF'
 +
  P<1,-1>='22*'                ; P<2,-1>='Broker Address'                    ; P<3,-1>='BROKER_TABLE_NF'
 +
  P<1,-1>='23*'                ; P<2,-1>='General Ledger Account'            ; P<3,-1>='GL_ACCT_TABLE_NF'
 +
  P<1,-1>='24*'                ; P<2,-1>='Branch'                            ; P<3,-1>='BRANCH_DATA_NF'
 +
  P<1,-1>='26*'                ; P<2,-1>='Department'                        ; P<3,-1>='DEPARTMENT_NF'
 +
  P<1,-1>='27*'                ; P<2,-1>='Business'                          ; P<3,-1>='TB_BUSINESS_NF'
 +
  P<1,-1>='28*'                ; P<2,-1>='Program Type'                      ; P<3,-1>='PROG_TYPE_DEFAULTS_NF'
 +
  P<1,-1>='29*'                ; P<2,-1>='Payment Plan'                      ; P<3,-1>='TB_PAYMENT_PLAN_NF'
 +
  P<1,-1>='30*'                ; P<2,-1>='Promotion'                        ; P<3,-1>='PROMOTION_TBL_NF'
 +
  P<1,-1>='31*'                ; P<2,-1>='Account Type'                      ; P<3,-1>='TB_ACCT_TYPE_NF'
 +
  P<1,-1>='32*'                ; P<2,-1>='Business Type'                    ; P<3,-1>='TB_BUSINESS_TYPE_NF'
 +
  P<1,-1>='33*'                ; P<2,-1>='Application Status'                ; P<3,-1>='TB_STATUS_NF'
 +
  P<1,-1>='34*'                ; P<2,-1>='Disposition Payment Type'          ; P<3,-1>='TB_DISP_PAYMENT_TYPE_NF'
 +
  P<1,-1>='35*'                ; P<2,-1>='Disposition/Inventory'            ; P<3,-1>='DISP_INVENT_TABLE_NF'
 +
  P<1,-1>='36*'                ; P<2,-1>='Bank Additional User-Defined'      ; P<3,-1>='AUS_BANKS_NF'
 +
  P<1,-1>='39*'                ; P<2,-1>='Product Line'                      ; P<3,-1>='PROD_LINE_DEFAULTS_NF'
 +
  P<1,-1>='40*'                ; P<2,-1>='Insurance Type'                    ; P<3,-1>='TB_INSURANCE_TYPE_NF'
 +
  P<1,-1>='41*'                ; P<2,-1>='Insurance Status'                  ; P<3,-1>='TB_INSURANCE_STATUS_NF'
 +
  P<1,-1>='42*'                ; P<2,-1>='Contract Status'                  ; P<3,-1>='CONTRACT_STATUS_INFO_NF'
 +
  P<1,-1>='43*'                ; P<2,-1>='Guaranteed Residual'              ; P<3,-1>='TB_GUARANTEED_RESIDUAL_NF'
 +
  P<1,-1>='45*'                ; P<2,-1>='Country Code'                      ; P<3,-1>='COUNTRY_CODES_NF'
 +
  P<1,-1>='ACTIVITY.DE*'      ; P<2,-1>='Activity (Inv. Interface)'        ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='ADDL.BUYOUT*'      ; P<2,-1>='Additional Buyout Info'            ; P<3,-1>='ADDL_BUYOUT_DEFAULT_NF'
 +
  P<1,-1>='ADJ*'              ; P<2,-1>='Adjustment Code'                  ; P<3,-1>='ADJUSTMENT_CODE_TBL_NF'
 +
  P<1,-1>='ADMIN*'            ; P<2,-1>='Administrative Code'              ; P<3,-1>='TB_ADMINISTRATIVE_CODE_NF'
 +
  P<1,-1>='AP.INTERFACE*1'    ; P<2,-1>='API Parameters'                    ; P<3,-1>='API_PARAMETERS_NF'
 +
  P<1,-1>='ASSET.DE*'          ; P<2,-1>='Asset (Inv. Interface)'            ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='ASSET.STATUS*'      ; P<2,-1>='Asset Status'                      ; P<3,-1>='TB_ASSET_STATUS_NF'
 +
  P<1,-1>='ASSOCIATION*'      ; P<2,-1>='Association'                      ; P<3,-1>='ASSOC_REL_PARTY_NF'
 +
  P<1,-1>='BANK*'              ; P<2,-1>='Bank Address'                      ; P<3,-1>='BANK_ADDRESS_NF'
 +
  P<1,-1>='BANK.ADDL*'        ; P<2,-1>='Additional Bank Address'          ; P<3,-1>='ADDL_BANK_ADDRESS_NF'
 +
  P<1,-1>='BI.TYPE*'          ; P<2,-1>='Blended Income Type'              ; P<3,-1>='TB_BLENDED_INCOME_TYPE_NF'
 +
  P<1,-1>='BID*'              ; P<2,-1>='Blended Income Defaults'          ; P<3,-1>='BLENDED_INCOME_DEF_NF'
 +
  P<1,-1>='BLENDED.INCOME*'    ; P<2,-1>='Blended Income Parameter'          ; P<3,-1>='BLENDED_INCOME_TBL_NF'
 +
  P<1,-1>='BUS.PLAN*'          ; P<2,-1>='Business Plan'                    ; P<3,-1>='BUS_PLAN_DEFAULTS_NF'
 +
  P<1,-1>='BUS.SEG*'          ; P<2,-1>='Business Segment'                 ; P<3,-1>='BUS_SEGMENT_NF'
 +
  P<1,-1>='BUYOUT*'            ; P<2,-1>='Buyout Parameters'                 ; P<3,-1>='BUYOUT_DEFAULT_NF'
 +
  P<1,-1>='CADDR.DE*'          ; P<2,-1>='Customer Address (Inv. Interface)' ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='CCA*'              ; P<2,-1>='CCA Class'                        ; P<3,-1>='CCA_CLASS_DEPR_NF'
 +
  P<1,-1>='CHECK.TYPE*'        ; P<2,-1>='Check Type'                        ; P<3,-1>='CHECK_TYPE_NF'
 +
  P<1,-1>='CHRG.DE*'          ; P<2,-1>='Charge Info (Inv. Interface)'      ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='CHRG.TYPE*'        ; P<2,-1>='Open Item Charge Types'            ; P<3,-1>='CHARGE_TYPE_TABLE_NF'
 +
  P<1,-1>='CHRG.TYPE.INDEX*'  ; P<2,-1>='Open Item Charge Type Indexes'    ; P<3,-1>='CHARGE_TYPE_INDEX_NF'
 +
  P<1,-1>='CNTC.DE*'          ; P<2,-1>='Contact (Inv. Interface)'          ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='CURRENCY*'          ; P<2,-1>='Currency Code'                    ; P<3,-1>='CURRENCY_CODES_NF'
 +
  P<1,-1>='DEALER.DISTRICT*'  ; P<2,-1>='Dealer District'                  ; P<3,-1>='TB_DEALER_DISTRICT_NF'
 +
  P<1,-1>='DEALER.PARAM*'      ; P<2,-1>='Dealer Parameter'                  ; P<3,-1>='DEALER_PARAM_NF'
 +
  P<1,-1>='DEALER.REGION*'    ; P<2,-1>='Dealer Region'                    ; P<3,-1>='TB_DEALER_REGION_NF'
 +
  P<1,-1>='DEALER.SALESMAN*'  ; P<2,-1>='Dealer Salesman'                  ; P<3,-1>='DLR_SALESMAN_NF'
 +
  P<1,-1>='DEALER.SERIES*'    ; P<2,-1>='Dealer Series'                    ; P<3,-1>='TB_DEALER_SERIES_NF'
 +
  P<1,-1>='DEALER.STATUS*'    ; P<2,-1>='Dealer Status'                    ; P<3,-1>='DEALER_STATUS_NF'
 +
  P<1,-1>='DLR.RECOURSE*'      ; P<2,-1>='Dealer Recourse'                  ; P<3,-1>='TB_DEALER_RECOURSE_NF'
 +
  P<1,-1>='EARLY.TERM.OPTION*' ; P<2,-1>='Early Term Option'                 ; P<3,-1>='TB_EARLY_TERM_OPTION_NF'
 +
  P<1,-1>='ER*'                ; P<2,-1>='Exchange Rate'                    ; P<3,-1>='EXCHANGE_RATE_NF'
 +
  P<1,-1>='FAC*'              ; P<2,-1>='Void Factura Reason'              ; P<3,-1>='TB_VOID_FACTURA_REASON_NF'
 +
  P<1,-1>='FIN.CLASS*'        ; P<2,-1>='Finance Class'                    ; P<3,-1>='TB_FINANCE_CLASS_NF'
 +
  P<1,-1>='FIN.PLAN*'          ; P<2,-1>='Finance Plan'                      ; P<3,-1>='TB_FINANCE_PLAN_NF'
 +
  P<1,-1>='FOLLOW.UP*'        ; P<2,-1>='Follow Up'                        ; P<3,-1>='FOLLOW_UP_CODES_NF'
 +
  P<1,-1>='GL.LINK.INDEX*'    ; P<2,-1>='General Ledger Link Index'        ; P<3,-1>='TB_GL_LINK_INDEX_NF'
 +
  P<1,-1>='GROUP.MISC.CODES*'  ; P<2,-1>='Group Misc GL Codes'              ; P<3,-1>='GROUP_MISC_CODES_NF'
 +
  P<1,-1>='HOLIDAY.TBL*'      ; P<2,-1>='Holiday/Weekend'                  ; P<3,-1>='HOLIDAY_WEEKEND_NF'
 +
  P<1,-1>='IDC.DESC*'          ; P<2,-1>='IDC Description'                  ; P<3,-1>='TB_IDC_DESC_NF'
 +
  P<1,-1>='INVOICE.FORMAT*'    ; P<2,-1>='Invoice Format'                    ; P<3,-1>='INVOICE_FORMAT_TABLE_NF'
 +
  P<1,-1>='IP*'                ; P<2,-1>='Insurance Parameter'              ; P<3,-1>='INSURANCE_PARAMETER_NF'
 +
  P<1,-1>='IRS.CAT*'          ; P<2,-1>='IRS Category/Tax'                  ; P<3,-1>='IRS_CAT_DEFAULTS_NF'
 +
  P<1,-1>='ITP'                ; P<2,-1>='Insurance Tape Parameter'          ; P<3,-1>='INS_TAPE_PARAMETER_NF'
 +
  P<1,-1>='L.NATIONALITY*'    ; P<2,-1>='Nationality'                      ; P<3,-1>='TB_NATIONALITY_NF'
 +
  P<1,-1>='LANG*'              ; P<2,-1>='Language'                          ; P<3,-1>='TB_LANGUAGE_NF'
 +
  P<1,-1>='LEGAL.S*'          ; P<2,-1>='Legal Status'                      ; P<3,-1>='TB_LEGAL_STATUS_NF'
 +
  P<1,-1>='LESSEE.CONTACT*'    ; P<2,-1>='Lessee Contact Permitted'          ; P<3,-1>='TB_LESSEE_CONTACT_PERMIT_NF'
 +
  P<1,-1>='LESSOR.SUB*'        ; P<2,-1>='Lessor Subsidiary'                 ; P<3,-1>='SUBSIDIARY_ADDRESS_NF'
 +
  P<1,-1>='LKE.POOL*'          ; P<2,-1>='Like Kind Exchange Pool'          ; P<3,-1>='TB_LIKE_KIND_EXCHANGE_PO_NF'
 +
  P<1,-1>='LOCAL.SIC.CODE*'    ; P<2,-1>='Local SIC Code'                    ; P<3,-1>='LOCAL_SIC_CODE_TBL_NF'
 +
  P<1,-1>='LOCKBOX.PARAMS'    ; P<2,-1>='Lockbox Parameters'                ; P<3,-1>='LOCKBOX_PARAMETERS_NF'
 +
  P<1,-1>='MILE.CAT*'          ; P<2,-1>='Mileage Category'                  ; P<3,-1>='TB_MILEAGE_CATEGORY_NF'
 +
  P<1,-1>='MISC.PARAM*'        ; P<2,-1>='Miscellaneous Parameters'          ; P<3,-1>='MISC_PARAM_DEFAULTS_NF'
 +
  P<1,-1>='MMR.ASSET.DE*'      ; P<2,-1>='MMR Asset (Inv. Interface)'        ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='MMR.ASSET.RATE.DE*' ; P<2,-1>='MMR Asset Rate (Inv. Interface)'  ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='MMR.CHRG.DE*'      ; P<2,-1>='MMR Charge (Inv. Interface)'      ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='NJS.FLAG'          ; P<2,-1>='NJS Flag'                          ; P<3,-1>='NJS_FLAG_NF'
 +
  P<1,-1>='PAYMENT.STATUS*'    ; P<2,-1>='Payment Status'                    ; P<3,-1>='TB_PAYMENT_STATUS_NF'
 +
  P<1,-1>='PAYMENT.TYPE*'      ; P<2,-1>='Payment Type'                      ; P<3,-1>='PYMT_TYPE_NF'
 +
  P<1,-1>='PENDING.CODE*'      ; P<2,-1>='Pending Code'                      ; P<3,-1>='PENDING_CODE_TBL_NF'
 +
  P<1,-1>='POLICY.STATUS*'    ; P<2,-1>='Policy Status'                     ; P<3,-1>='TB_POLICY_STATUS_NF'
 +
  P<1,-1>='PROGRAM.CONTROL*'  ; P<2,-1>='Program Control'                  ; P<3,-1>='TB_PROGRAM_CONTROL_NF'
 +
  P<1,-1>='PUR.OPT*'          ; P<2,-1>='Purchase Option'                  ; P<3,-1>='PURCHASE_OPTION_TABLE_NF'
 +
  P<1,-1>='PURPOSE.LOAN*'      ; P<2,-1>='Purpose Of Loan'                  ; P<3,-1>='TB_PURPOSE_OF_LOAN_NF'
 +
  P<1,-1>='PUT.TO*'            ; P<2,-1>='Put To'                            ; P<3,-1>='TB_PUT_TO_NF'
 +
  P<1,-1>='QUOTE.BUYOUT*'      ; P<2,-1>='Quote Buyout'                      ; P<3,-1>='QUOTE_BUYOUT_TBL_NF'
 +
  P<1,-1>='RCPT*'              ; P<2,-1>='Void Receipt Reason'              ; P<3,-1>='TB_VOID_RECEIPT_REASON_NF'
 +
  P<1,-1>='RECOURSE*'          ; P<2,-1>='Recourse'                          ; P<3,-1>='TB_RECOURSE_CODE_NF'
 +
  P<1,-1>='RECOVERY.STATUS*'  ; P<2,-1>='Recovery Status'                  ; P<3,-1>='TB_RECOVERY_STATUS_NF'
 +
  P<1,-1>='RELATIONSHIP*'      ; P<2,-1>='Relationship'                      ; P<3,-1>='RELATIONSHIP_DATA_NF'
 +
  P<1,-1>='REM.PUR.OPTION*'    ; P<2,-1>='Remarketing Purchase Option'      ; P<3,-1>='TB_REMARKETING_PURCHASE_NF'
 +
  P<1,-1>='RENEWAL.OPTION*'    ; P<2,-1>='Renewal Option'                    ; P<3,-1>='RENEWAL_OPTION_NF'
 +
  P<1,-1>='REPO.STATUS*'      ; P<2,-1>='Repossession Status'              ; P<3,-1>='REPOSSESSION_CODE_NF'
 +
  P<1,-1>='RESERVE*'          ; P<2,-1>='Reserve Code'                      ; P<3,-1>='TB_RESERVE_CODE_NF'
 +
  P<1,-1>='RESIDUAL.GUAR*'    ; P<2,-1>='Residual Guarantee'                ; P<3,-1>='TB_RESIDUAL_GUARANTEE_NF'
 +
  P<1,-1>='RESIDUAL.OWNER*'    ; P<2,-1>='Residual Owner'                    ; P<3,-1>='TB_RESIDUAL_OWNER_NF'
 +
  P<1,-1>='RESIDUAL.SHARING*; P<2,-1>='Residual Sharing'                  ; P<3,-1>='TB_RESIDUAL_SHARING_NF'
 +
  P<1,-1>='RESTOCKING.FEE*'    ; P<2,-1>='Restocking Fee Obligation'        ; P<3,-1>='TB_RESTOCK_FEE_OBLIGATIO_NF'
 +
  P<1,-1>='RETURN.COSTS.PD*'  ; P<2,-1>='Return Costs Paid'                ; P<3,-1>='TB_RETURN_COSTS_PAID_NF'
 +
  P<1,-1>='REVS.PT*'           ; P<2,-1>='REVS Plate Type'                  ; P<3,-1>='TB_REVS_PLATE_TYPE_NF'
 +
  P<1,-1>='REVS.ST*'          ; P<2,-1>='REVS State'                        ; P<3,-1>='TB_REVS_STATE_NF'
 +
  P<1,-1>='SCAN.LINE.DE*'      ; P<2,-1>='Scan Line (Inv. Interface)'        ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='SCORE.DECISION*'    ; P<2,-1>='Credit Score Decision'            ; P<3,-1>='TB_CREDIT_SCORE_DECISION_NF'
 +
  P<1,-1>='SCORE.STATUS*'      ; P<2,-1>='Credit Score Status'              ; P<3,-1>='CREDIT_SCORE_STATUS_NF'
 +
  P<1,-1>='SCORING.CODE*'      ; P<2,-1>='Scoring Code'                      ; P<3,-1>='SCORING_CODE_NF'
 +
  P<1,-1>='SEC.PARTY*'        ; P<2,-1>='Secure Party'                      ; P<3,-1>='LESSOR_SEC_PARTY_NF'
 +
  P<1,-1>='SOURCE*'            ; P<2,-1>='Source'                            ; P<3,-1>='TB_SOURCE_NF'
 +
  P<1,-1>='SPECIAL.INST*'      ; P<2,-1>='Special Instructions'              ; P<3,-1>='TB_SPECIAL_INSTRUCTIONS_NF'
 +
  P<1,-1>='SPLIT.DE*'          ; P<2,-1>='Invoice Interface Data Elements'  ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='SSP'                ; P<2,-1>='System Security'                   ; P<3,-1>='SC_SECURE_PARAM_NF'
 +
  P<1,-1>='UCC.STATE*'         ; P<2,-1>='Filing State'                      ; P<3,-1>='FILING_STATE_NF'
 +
  P<1,-1>='UCC.STATUS*'        ; P<2,-1>='Filing Status'                     ; P<3,-1>='FILING_STATUS_TABLE_NF'
 +
  P<1,-1>='UCC.TITLE.CODE*'    ; P<2,-1>='Filing Code'                      ; P<3,-1>='FILING_CODE_NF'
 +
  P<1,-1>='UK.POOL*'          ; P<2,-1>='UK Pool'                          ; P<3,-1>='UK_POOL_NUM_NF'
 +
  P<1,-1>='USG.ASSET.DE*'      ; P<2,-1>='Usage Asset (Inv. Interface)'      ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='USG.CHRG.DE*'       ; P<2,-1>='Usage Charge (Inv. Interface)'    ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
 +
  P<1,-1>='VLMAKE*'            ; P<2,-1>='Vehicle Make'                      ; P<3,-1>='TB_VEHICLE_MAKE_NF'
 +
  P<1,-1>='VLMODEL*'          ; P<2,-1>='Vehicle Model'                    ; P<3,-1>='TB_VEHICLE_MODEL_NF'
 +
  P<1,-1>='VLOPT*'             ; P<2,-1>='Vehicle Option'                    ; P<3,-1>='TB_VEHICLE_OPTION_NF'
 +
  P<1,-1>='WAREHOUSE*'        ; P<2,-1>='Warehouse Location'                ; P<3,-1>='TB_WAREHOUSE_LOCATION_NF'
 +
  P<1,-1>='WHOLESALE.PLAN*'    ; P<2,-1>='Wholesale Plan'                    ; P<3,-1>='TB_WHOLESALE_PLAN_NF'
 +
  P<1,-1>='WL.FOLLOW-UP.CODE*' ; P<2,-1>='Worklist Follow-Up Codes'          ; P<3,-1>='WORKLIST_FOLLOW_UP_CODES_NF'
 +
  P<1,-1>='WP.PARAM'          ; P<2,-1>='Word Processing'                  ; P<3,-1>='WP_PARAM_NF'
 +
  P<1,-1>=STR('-', 18)        ; P<2,-1>=STR('-',33)                        ; P<3,-1>=STR('-',30)
 +
  FOR F=1 TO DCOUNT(P<1>,@VM)
 +
    PRINT '|':P<1,F>'L#18':'|':P<2,F>'L#33':'|':P<3,F>'L#30':'|'
 +
  NEXT F
 +
RETURN
 +
*
 +
BUILD.AC:
 +
  * Check for a DICT request
 +
  IF FIELD(ANS,' ',2)='DICT' THEN
 +
    DICT=FIELD(ANS,' ',3)
 +
    OPEN 'DICT',DICT TO DVAR ELSE CRT 'Cannot open DICT':DICT ; RETURN
 +
    SELECT DVAR
 +
    ID.LIST=''
 +
    LOOP
 +
      READNEXT ID ELSE EXIT
 +
      READ R FROM DVAR, ID ELSE CONTINUE
 +
      IF R<1>='D' OR R<1>='I' OR R<1>='V' THEN
 +
         ID.LIST<-1>='DICT-':DICT:'_':ID
 +
      END
 +
    REPEAT
 +
    GOSUB ADD.TO.AC
 +
    RETURN
 +
  END
 +
  *
 +
  * Build auto-complete list of VOC commands
 +
  CLEARFILE AC
 +
  L1='' ; L2=''
 +
  *
 +
  EXECUTE \SELECT VOC WITH F1 = "C" "V"\ RTNLIST L1
 +
  ID.LIST=''
 +
  LOOP
 +
     READNEXT ID FROM L1 ELSE EXIT
 +
    READ R FROM VOC, ID ELSE CONTINUE
 +
    ID.LIST<-1>='CMD_':ID
 +
  REPEAT
 +
  GOSUB ADD.TO.AC
 +
  *
 +
  * Build auto-complete list for filenames
 +
  *
 +
  EXECUTE \SELECT VOC WITH F1 = "F" "LF" "DIR" "LD" AND WITH @ID # "TMP]"\ RTNLIST L1
 +
  ID.LIST=''
 +
  LOOP
 +
    READNEXT ID FROM L1 ELSE EXIT
 +
    READ R FROM VOC, ID ELSE CONTINUE
 +
    ID.LIST<-1>='FILE_':ID
 +
    IF R<1>='LF' OR R<1>='LD' THEN
 +
      * Multi-level file or dir, dive deeper
 +
      E=\SELECT DICT \:ID:\ WITH @ID = "@]" AND WITH F1 = "LF" "LD" USING DICT VOC\
 +
      *CRT E
 +
      EXECUTE E RTNLIST L2 CAPTURING DUMMY
 +
      LOOP
 +
        READNEXT ID2 FROM L2 ELSE EXIT
 +
        ID2=ID:',':ID2[2,99]
 +
        ID.LIST<-1>='FILE_':ID2
 +
      REPEAT
 +
    END
 +
  REPEAT
 +
  GOSUB ADD.TO.AC
 
RETURN
 
RETURN
 
+
*
WRITE.INFO:
+
ADD.TO.AC:
    WRITE STACK ON HOME.F, STACK.ITEM
+
  NUM.ITEMS=DCOUNT(ID.LIST,@AM)
     WRITE ALIASES ON HOME.F, ALIAS.ITEM
+
  CRT NUM.ITEMS:' ITEMS'
    WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
+
  FOR I=1 TO NUM.ITEMS
     WRITE SETTINGS ON HOME.F, SETTING.ITEM
+
     ID=ID.LIST<I>
 +
    L=LEN(ID)
 +
    FOR C=1 TO LEN(ID)
 +
      PRE=ID[1,C]
 +
      READ NODE FROM AC, PRE ELSE NODE=''
 +
      * Now insert pointers to one level down
 +
      PTR=ID[1,C+1]
 +
      LOCATE PTR IN NODE<1> BY 'AL' SETTING POS THEN
 +
        LOCATE ID IN NODE<2,POS> BY 'AL' SETTING POS2 ELSE NULL
 +
        INS ID BEFORE NODE<2,POS, POS2>
 +
      END ELSE
 +
        INS PTR BEFORE NODE<1,POS>
 +
        INS ID  BEFORE NODE<2,POS>
 +
      END
 +
      WRITE NODE ON AC, PRE
 +
     NEXT C
 +
  NEXT I
 
RETURN
 
RETURN
 +
*
 
</PRE>
 
</PRE>

Latest revision as of 22:54, 13 September 2019

HomePage >> BasicSource >> Github:

This program is an attempt to make TCL a more productive place for programmers. You can edit the command stack using standard bash/emacs key-bindings. There is also a stack of program files being worked on and shortcuts for the common operations of editing, compiling, running and interacting with version control.

Planned new features include tab-completion on commands, file and dictionary names (how to make it quick with thousands of entries is a problem).

The help information gives a good overview of what is currently there (though aliases, program token expansion and setting the prompt are extras not mentioned).

            PRINT 'Ctrl-A     Start of line     Ctrl-R      Toggle insert mode'
            PRINT 'Ctrl-B     Back one char     Ctrl-W      Delete word'
            PRINT 'Ctrl-D     Delete char       Ctrl-X      Forward word'
            PRINT 'Ctrl-E     End of line       Ctrl-Z      Back word'
            PRINT 'Ctrl-F     Forward char      '
            PRINT 'Ctrl-G     Cancel line       '
            PRINT 'Ctrl-I     Forward word      ~xxx        Search for xxx'
            PRINT 'Ctrl-J     Delete to end     .Lm,n       List entry m thru n'
            PRINT 'Ctrl-M     Accept line       .Rn         Restore entry n, edit'
            PRINT 'Ctrl-N     Next line         .Dm,n       Delete entry m thru n'
            PRINT 'Ctrl-P     Previous line     Q           Quit back to TCL'
            PRINT
            PRINT '/   List the program stack   //  List the stack with cvs status'
            PRINT '[[/Nx]] Add a New program,'
            PRINT '[[/Ex]] Edit the x`th program    [[/WW]] Edit the program list'
            PRINT '[[/Wx]] VI the x`th program      [[/S]]  Sort the program stack'
            PRINT '[[/Bx]] Compile the x`th program [[/BR]] Compile and run'
            PRINT '[[/CI]] Checkin a program to cvs [[/D]]  Show diff with cvs version'

See also:

GetLineStack - a subroutine to allow cursor editing in wy50, vt100

CVS Integration "helpers"

CvsCheckout
CvsCheckin
CvsLog
CvsList
CvsDiff
CvsStatus
CvsGetDir
***************************************************************************
* Program: STACK
* Author : Ian McGowan
* Created: 1989-06-13
* Updated: 2019-09-13
* License: (c) 1989-2019 Ian McGowan, released under MIT license
* Comment: Stacks TCL commands, utilities for programmers
***************************************************************************
* https://github.com/ianmcgowan/SCI.BP/blob/master/STACK
CRT 'Version 2019-09 Autocomplete'
EQUATE INSERT TO '1',REPLACE TO '-1',BEEP TO CHAR(7)
EQUATE RET TO 13, ESC TO 27, UP.KEY TO 1, DOWN.KEY TO 2
EQUATE PG.UP.KEY TO 21, PG.DOWN.KEY TO 22
EQUATE NUL TO '',SPC TO ' ',TRUE TO 1, FALSE TO 0
EQUATE SEARCH TO '~', UNIX TO '!'
EQUATE BELL TO CHAR(7), OTHERWISE TO 1
TERM=UPCASE(GETENV("TERM"))
CS=@(-1);EOL=@(-4);EOS=@(-3);UP=@(-10);BON=@(-81);BOFF=@(-82)
PROMPT NUL
*
LONG.LINE = 9999;LIST.DET.FLAG=0;TIME.COMMAND=0
EXECUTING = FALSE;SL.ACTIVE = FALSE
*
PWD=GETENV("PWD")
I=LEN(PWD) ; ACC=NUL
FOR F=I TO 1 STEP -1
  IF PWD[F,1] = '/' THEN EXIT
  ACC=PWD[F,1]:ACC
NEXT F
*
USERNAME=UPCASE(@LOGNAME)
HOME.DIR=GETENV("HOME")
STACK.ITEM='.STACK_':USERNAME
ALIAS.ITEM='.STACK.ALIAS_':USERNAME
PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME
SETTING.ITEM='.STACK.SETTING_':USERNAME
HOME.FILE='HOME.':UPCASE(USERNAME)
OPEN 'VOC' TO VOC ELSE STOP 201,'VOC'
OPEN '_HOLD_' TO HOLD ELSE STOP 201,'_HOLD_' ;* Exists in every Unidata account
R='DIR' ; R<2>=HOME.DIR ; R<3>='D_VOC'
WRITE R ON VOC, HOME.FILE
OPEN HOME.FILE TO HOME.F ELSE STOP 201, HOME.FILE
OPEN 'CTLGTB' TO CTLGTB ELSE STOP 201,'CTLGTB'
OPEN 'CTLG'   TO CTLG   ELSE STOP 201,'CTLG'
OPEN 'STACK.AC' TO AC ELSE
  EXECUTE \CREATE.FILE STACK.AC 967,8192\
  OPEN 'STACK.AC' TO AC ELSE ABORT
END
*
SETTINGS      = ';'        ;* DEFAULT COMMAND SEPERATOR
SETTINGS<2>   = '.'        ;* DEFAULT STACK CHAR
SETTINGS<3>   = '/'        ;* DEFAULT PROG CHAR
SETTINGS<4>   = 9999       ;* DEFAULT MAX # LINES IN STACK
SETTINGS<5>   = '!vi'      ;* DEFAULT SCREEN EDITOR (try !joe :)
SETTINGS<6>   = 'AE'       ;* DEFAULT LINE EDITOR
SETTINGS<7>   ='* Edited :';* DEFAULT HEADER STRING
SETTINGS<8>   = TRUE       ;* DEFAULT USE GET.LINE SUBR
SETTINGS<9>   = 'BP.DEV'   ;* DEFAULT WORK FILE
SETTINGS<10>  = FALSE      ;* DEFAULT = CONVERT TO UCASE
SETTINGS<11>  = ""         ;* DEFAULT STARTUP COMMAND
SETTINGS<12>  = "#R#A>"    ;* DEFAULT PROMPT
SETTINGS<13>  = -2         ;* DEFAULT X DISPLACEMENT FOR PROMPT
SETTINGS<14>  = "bash"     ;* DEFAULT SHELL FOR UNIX COMMANDS
SETTINGS<15>  = ""         ;* DEFAULT PROGRAM STACK TO USE
*
READ R FROM HOME.F, SETTING.ITEM ELSE R=NUL
I=DCOUNT(SETTINGS,@AM)
FOR F=1 TO I
  IF R<F> # NUL THEN SETTINGS<F> = R<F>
NEXT F
COMMAND.SEPERATOR = SETTINGS<1>
STACK.CHAR   = SETTINGS<2>
PROG.CHAR    = SETTINGS<3>
MAX.STACK    = SETTINGS<4>
WP.VERB      = SETTINGS<5>
ED.VERB      = SETTINGS<6>
STAMP.STRING = SETTINGS<7>
GET.LINE.FLAG= SETTINGS<8>
WORK.FILE    = SETTINGS<9>
MCU.ON       = SETTINGS<10>
STARTUP      = SETTINGS<11>
PROMT        = SETTINGS<12>
X.DISP       = SETTINGS<13>
DEF.SHELL    = SETTINGS<14>
STACK.NAME   = SETTINGS<15>
WRITE SETTINGS ON HOME.F, SETTING.ITEM
*
IF STACK.NAME = '' THEN
  PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME
END ELSE
  PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME:'_':STACK.NAME
END
READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
*
EXEC.LINE="!hostname" ; CAP.ACTIVE=TRUE ; GOSUB EXEC.SUB
HOST.NAME=EXEC.CAP<1>
*
READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
PRINT DCOUNT(STACK,@AM):' commands in stack ':HOME.DIR:'/':HOME.FILE
READ ALIASES FROM HOME.F, ALIAS.ITEM ELSE ALIASES = NUL
* Override with my favorites for now.  It's a pain to manage per system.
ALIASES<1>='ACTIVE'
ALIASES<1,2>='CS'
ALIASES<1,3>='L'
ALIASES<2>='SELECT LS.MASTER WITH NUM.OF.ASSETS > "0"'
ALIASES<2,2>='CLEARSELECT'
ALIASES<2,3>='LIST LS.MASTER'
OLD.X.DISP=X.DISP
RTN=NUL
* IL9/IL10 Check
IL.VER=''
OPEN 'ACCOUNT.PARAMS' TO ACCOUNT.PARAMS THEN
  READ R FROM ACCOUNT.PARAMS, 'VERSION' ELSE R=''
  IL.DB=PWD
  IL.VER=R<4>:'/':R<8>:'.':R<26>
END ELSE
  EXECUTE \!cat DBConfig.xml | grep DataSource | awk -F '[<>]' '{print $3}'\ CAPTURING JDBC
  JDBC=JDBC<1>
  EXECUTE \!grep \:JDBC:\ ../../jdbc-bridge/bin/jdbc.properties | grep -v "^#" | grep url\ CAPTURING IL.DB
  IL.DB=IL.DB<1>
  OSREAD VER FROM 'version.properties' ELSE VER='il.version=10'
  CONVERT CHAR(10) TO @AM IN VER
  FOR F=1 TO DCOUNT(VER,@AM)
    IF FIELD(VER<F>,'=',2) # '' THEN IL.VER=FIELD(VER<F>,'=',2) ; EXIT
  NEXT F
END
CRT IL.VER:' ':IL.DB
IF STARTUP # NUL THEN ANS=STARTUP ; GOSUB COMMAND ; STARTUP=NUL
ANS=NUL
*
LOOP
  GOSUB GET.TERM.WIDTH ;* In case terminal font or window size changes
  GOSUB EXPAND.PROMPT
  PRINT BON:PROMPT.DISP:BOFF:
  X = LEN(PROMPT.DISP) + X.DISP
  ENTRY = NUL;LEN = LONG.LINE;DISP.LEN=TERM.WIDTH-1-X
  GOSUB GET.INPUT
  ANS=ENTRY
  * Reread the program and command stack, since they may be modified
  * in another session
  READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
  READ STACK FROM HOME.F, STACK.ITEM ELSE STACK = NUL
  READ ALIASES FROM HOME.F, ALIAS.ITEM ELSE ALIASES = NUL
  IF RTN # ESC THEN GOSUB COMMAND
REPEAT
*
GET.INPUT:
  IF GET.LINE.FLAG THEN
    *CALL GET.LINE.STACK(X,LEN,DISP.LEN,ENTRY,RTN)
    GOSUB GET.LINE
  END ELSE
    PRINT @(X):;INPUT ENTRY
    RTN = RET
  END
RETURN
*
COMMAND:
  MAX.STACK=DCOUNT(STACK,@AM)
  BEGIN CASE
      * Map up and down arrows to .R1 and .Rn
    CASE RTN = UP.KEY
      ANS = '.R1'
    CASE RTN = PG.UP.KEY
      IF UNASSIGNED(P2) THEN P2 = 20
      IF UNASSIGNED(P1) THEN P1 = 1
      P2 = P2 + 20
      P1 = P1 + 20
      IF P2 > MAX.STACK THEN P2 = MAX.STACK
      IF P1 > MAX.STACK-20 THEN P1 = MAX.STACK-20
      ANS = '.L':P1:',':P2
    CASE RTN = PG.DOWN.KEY
      IF UNASSIGNED(P2) THEN P2 = 20
      IF UNASSIGNED(P1) THEN P1 = 1
      P2 = P2 - 20
      P1 = P1 - 20
      IF P2 < 20 THEN P2=20
      IF P1 < 1 THEN P1=1
      ANS = '.L':P1:',':P2
    CASE ANS='?'
      ANS='.H'
  END CASE
  IF ANS = NUL THEN RETURN
  UNIX.COMMAND=FALSE
  IF ANS[1,1] = UNIX THEN UNIX.COMMAND=TRUE
  OLD.STACK = STACK
  START.WORD.SEARCH = 1
  COMMAND.LIST = ANS
  COMMAND.COUNT = 1
  IF STARTUP#NUL THEN EXECUTING=TRUE ELSE EXECUTING=FALSE
  IF UNIX.COMMAND THEN
    * Don't look for ; for unix commands
    GOSUB DO.COMMAND
  END ELSE
    LOOP
      ANS = FIELD(COMMAND.LIST,COMMAND.SEPERATOR,COMMAND.COUNT)
    UNTIL ANS = NUL DO
      GOSUB DO.COMMAND
      COMMAND.COUNT = COMMAND.COUNT + 1
    REPEAT
  END
  WRITE ALIASES ON HOME.F, ALIAS.ITEM
RETURN
*
DO.COMMAND:
  IF NOT(UNIX.COMMAND) THEN
    IF MCU.ON THEN ANS = TRIM(UPCASE(ANS))
    IF ANS[1,5] # 'ALIAS' THEN GOSUB EXPAND.ALIASES
    GOSUB EXPAND.PROG.CHARS
  END
  IF ANS='!' THEN ANS='!':DEF.SHELL
  LEN.ANS = LEN(ANS)
  SEARCH.FOR=NUL
  CAP.ACTIVE=FALSE
  FIRST.WORD=FIELD(ANS,' ',1)
  UPDATE.STACK.FLAG=TRUE
  BEGIN CASE
    CASE ANS[1,1] = STACK.CHAR
      ANS = TRIM(UPCASE(ANS))
      GOSUB STACK.COMMAND
      UPDATE.STACK.FLAG=FALSE
    CASE ANS[1,1] = PROG.CHAR
      ANS = TRIM(UPCASE(ANS))
      GOSUB PROG.COMMAND
      UPDATE.STACK.FLAG=FALSE
    CASE ANS[1,1] = SEARCH
      GOSUB SEARCH.COMMAND
      UPDATE.STACK.FLAG=FALSE
    CASE UPCASE(ANS) = 'OFF' OR UPCASE(ANS) = 'Q'
      GOSUB WRITE.INFO
      STOP
    CASE FIRST.WORD='AC'
      GOSUB BUILD.AC
    CASE FIRST.WORD = 'ALIAS'
      GOSUB DO.ALIAS
    CASE FIRST.WORD = 'SE'
      FILE=FIELD(ANS,' ',2)
      ID=FIELD(ANS,' ',3)
      GOSUB SEARCH.BY.EXAMPLE
    CASE FIRST.WORD = 'CI'
      * CONTRACT INQUIRY
      CONTRACT=FIELD(ANS,' ',2)
      DATA 0
      DATA 0
      DATA 0
      DATA 0
      IF CONTRACT # '' THEN
        CONVERT '.' TO '-' IN CONTRACT
        DATA FIELD(CONTRACT,'-',1)
        DATA FIELD(CONTRACT,'-',2,2)
      END
      EXEC.LINE=\CMAINT.00\ ; GOSUB EXEC.SUB
    CASE FIRST.WORD = 'CM'
      * CONTRACT MAINTENANCE
      CONTRACT=FIELD(ANS,' ',2)
      DATA 1
      DATA 0
      DATA 0
      DATA 0
      IF CONTRACT # '' THEN
        CONVERT '.' TO '-' IN CONTRACT
        DATA FIELD(CONTRACT,'-',1)
        DATA FIELD(CONTRACT,'-',2,2)
      END
      EXEC.LINE=\CMAINT.00\ ; GOSUB EXEC.SUB
    CASE FIRST.WORD = 'CCI'
      * CUSTOMER INQUIRY
      DATA 0
      DATA 0
      DATA 0
      IF FIELD(ANS,' ',2) # '' THEN
        DATA FIELD(ANS,' ',2)
      END
      EXEC.LINE=\CDMAINT.00\ ; GOSUB EXEC.SUB
    CASE FIRST.WORD = 'CCM'
      * CUSTOMER MAINTENANCE
      DATA 1
      DATA 0
      DATA 0
      IF FIELD(ANS,' ',2) # '' THEN
        DATA FIELD(ANS,' ',2)
      END
      EXEC.LINE=\CDMAINT.00\ ; GOSUB EXEC.SUB
    CASE ANS = 'TM'
      DATA 1
      DATA 0
      EXEC.LINE=\TMAINT.00\ ; GOSUB EXEC.SUB
    CASE FIRST.WORD = 'CHECK.FILE'
      GOSUB CHECK.FILE
    CASE ANS = 'ICONV'
      CONV='I'
      GOSUB CONV
    CASE ANS = 'OCONV'
      CONV='O'
      GOSUB CONV
    CASE ANS = 'RULER'
      GOSUB GET.TERM.WIDTH
      GOSUB RULER
    CASE FIRST.WORD = 'PIVOT'
      GOSUB PIVOT
    CASE FIRST.WORD = 'PROF'
      GOSUB PROFILE
    CASE FIRST.WORD = 'DDD'
      GOSUB DDD
    CASE FIRST.WORD = 'BPI'
      GOSUB BPI
    CASE FIRST.WORD = 'SF'
      GOSUB SEARCH.FILE
    CASE FIRST.WORD = 'AF'
      GOSUB ATB.FIND
    CASE ANS='PARAM'
      GOSUB LIST.PARAM
    CASE FIRST.WORD = 'PICKLE'
      GOSUB PICKLE
    CASE ANS='SETTINGS'
      GOSUB SETTINGS
    CASE FIRST.WORD='RS'
      GOSUB RECALL.SHELL
    CASE FIRST.WORD='FIND.MENU'
      GOSUB FIND.MENU
    CASE ANS='LISTA'
      GOSUB LISTA
    CASE FIRST.WORD = 'DESC'
      GOSUB IL10.DESC
    CASE FIRST.WORD = 'XREF'
      GOSUB IL10.XREF
    CASE FIRST.WORD = 'FIELD'
      GOSUB IL10.AF
    CASE FIRST.WORD = 'NED'
      GOSUB IL10.NED
    CASE FIRST.WORD = 'NSEL'
      GOSUB IL10.NSEL
    CASE FIRST.WORD = 'SQL'
      GOSUB SQL.SEL
    CASE FIRST.WORD = 'SQLF'
      GOSUB SQL.FILE
    CASE FIRST.WORD = 'SQL-LIST'
      GOSUB SQL.SEL.LIST
    CASE OTHERWISE
      EXEC.LINE = ANS
      T1=SYSTEM(12)
      GOSUB EXEC.SUB
      IF TIME.COMMAND THEN PRINT SYSTEM(12)-T1:' ms'
  END CASE
  IF UPDATE.STACK.FLAG THEN GOSUB UPDATE.STACK
RETURN
*
DO.ALIAS:
  AL = FIELD(ANS,SPC,2)
  STRING = NUL;I = 3
  LOOP
    F = FIELD(ANS,SPC,I)
  UNTIL F = NUL DO
    STRING = STRING:SPC:F
    I = I + 1
  REPEAT
  BEGIN CASE
    CASE AL = NUL AND STRING = NUL
      GOSUB LIST.ALIAS
    CASE STRING = NUL
      GOSUB LIST.ONE.ALIAS
    CASE 1
      GOSUB SET.ALIAS
  END CASE
RETURN
*
SET.ALIAS:
  STRING=STRING[2,LONG.LINE]
  PRINT AL:'=':STRING
  LOCATE AL IN ALIASES<1> BY 'AL' SETTING P THEN
    ALIASES<2,P> = STRING
  END ELSE
    INS AL BEFORE ALIASES<1,P>;INS STRING BEFORE ALIASES<2,P>
  END
RETURN
*
LIST.ALIAS:
  I = DCOUNT(ALIASES<1>,@VM)
  FOR F = 1 TO I
    PRINT ALIASES<1,F>,ALIASES<2,F>
  NEXT F
RETURN
*
LIST.ONE.ALIAS:
  LOCATE AL IN ALIASES<1> BY 'AL' SETTING P ELSE PRINT AL:' not found';RETURN
  X=0;LEN=99;DISP.LEN=30;ENTRY=ALIASES<2,P>
  GOSUB GET.INPUT
  IF RTN = 27 THEN RETURN
  ALIASES<2,P> = ENTRY
  IF ENTRY = NUL THEN DEL ALIASES<1,P>;DEL ALIASES<2,P>
RETURN
*
EXEC.SUB:
  IF EXEC.LINE = NUL THEN RETURN
  IF EXEC.LINE = 'CLEARSELECT' THEN CLEARSELECT
  IF CAP.ACTIVE THEN
    EXECUTE EXEC.LINE CAPTURING EXEC.CAP
  END ELSE
    EXECUTE EXEC.LINE
  END
  IF SYSTEM(11) > 0 THEN SL.ACTIVE = TRUE ELSE SL.ACTIVE = FALSE
  CAP.ACTIVE=FALSE
RETURN
*
EXPAND.PROG.CHARS:
  * expand //10 to be IV.BP IV.EQP.MNT for example
  POS = 1
  LOOP
    I = INDEX(ANS,PROG.CHAR:PROG.CHAR,POS)
  UNTIL I = 0 DO
    VAR = NUL;IDX = I+2
    LOOP
      C = ANS[IDX,1]
    UNTIL NOT(NUM(C)) OR C = NUL DO
      VAR = VAR:C
      IDX = IDX+1
    REPEAT
    IF NUM(VAR) AND VAR > 0 THEN
      ANS = ANS[1,I-1]:PROGRAMS<VAR>:ANS[IDX,LONG.LINE]
    END ELSE
      POS = POS + 1
    END
  REPEAT
RETURN
*
EXPAND.ALIASES:
  SWAP SPC WITH @VM IN ANS ; POS = 1
  LOOP
    R = ANS<1,POS>
  UNTIL R = NUL DO
    LOCATE R IN ALIASES<1> BY 'AL' SETTING P THEN ANS<1,POS> = ALIASES<2,P>
    POS = POS + 1
  REPEAT
  SWAP @VM WITH SPC IN ANS
RETURN
*
EXPAND.PROMPT:
  IF SL.ACTIVE THEN
    PROMPT.DISP='#R':SYSTEM(11):'-SEL>'
    OLD.X.DISP=X.DISP
    X.DISP=-2
  END ELSE
    PROMPT.DISP = PROMT
    X.DISP=OLD.X.DISP
  END
  CTR = 1
  LOOP
    I = INDEX(PROMPT.DISP,'#',CTR)
  UNTIL I = 0 DO
    F = PROMPT.DISP[I+1,1]
    L = PROMPT.DISP[1,I-1];R = TRIM(PROMPT.DISP[I+2,LONG.LINE])
    BEGIN CASE
      CASE F = 'B'
        PROMPT.DISP = L:CHAR(7):R
      CASE F = 'A'
        PROMPT.DISP = L:ACC:R
      CASE F = 'T'
        PROMPT.DISP = L:OCONV(TIME(),'MTS'):R
      CASE F = 'D'
        PROMPT.DISP = L:OCONV(DATE(),'D'):R
      CASE F = 'E'
        PROMPT.DISP = L:CHAR(ESC):R
      CASE F = 'R'
        PROMPT.DISP = L:CHAR(13):CHAR(10):R
      CASE F = '#'
        PROMPT.DISP = L:'#':R
        CTR = CTR + 1
      CASE F = 'U'
        PROMPT.DISP = L:USERNAME:R
      CASE F = 'H'
        PROMPT.DISP=L:FIELD(HOST.NAME,".",1):R
      CASE OTHERWISE
        CTR = CTR + 1
    END CASE
  REPEAT
RETURN
*
STACK.COMMAND:
  BEGIN CASE
    CASE ANS='.D'
      LIST.DET.FLAG=NOT(LIST.DET.FLAG)
    CASE ANS[1,2] = '.L'
      IF ANS = '.L' THEN ANS = '.L,20'
      GOSUB GET.PARAMS
      IF RANGE.ERROR THEN RETURN
      I = DCOUNT(STACK,@AM)
      IF I = 0 THEN PRINT 'No items present';RETURN
      IF P2 > I THEN P2 = I
      PRINT
      FOR F = P2 TO P1 STEP -1
        IF LIST.DET.FLAG THEN
          PRINT SPC:F'R#3':" ":STACK<F,1>'L#20':' ':OCONV(STACK<F,2>,'D-YMD'):' ':OCONV(STACK<F,3>,'MTS'):' ':STACK<F,4>
        END ELSE
          PRINT SPC:F'R#3':" ":STACK<F,4>
        END
      NEXT F
    CASE ANS[1,2] = '.R' OR ANS[1,2] = '.X'
      IF STACK = NUL THEN PRINT BELL ELSE GO EDIT
    CASE ANS = '.P'
      PRINT '#R - Return  #A - Account  #D - Date  #T - Time #P - Port'
      PRINT '#E - Escape  #L - Level    #U - User  #H - Host'
      PRINT 'Prompt':
      X = 7;DISP.LEN = 60;ENTRY = PROMT;LEN = 99;GOSUB GET.INPUT
      PROMT = ENTRY
      PRINT 'Enter the X displacement for input :':
      ENTRY = NUL;LEN = 5;DISP.LEN = 5;X = 37;GOSUB GET.INPUT
      X.DISP = ENTRY
      IF NOT(NUM(X.DISP)) THEN X.DISP = 0
      SETTINGS<12> = PROMT
      SETTINGS<13> = X.DISP
      OLD.X.DISP=X.DISP
    CASE ANS = '.H'
      CRT '--------------------------- TCL STACK COMMANDS --------------------------------'
      CRT 'Ctrl-A      Start of line              Ctrl-R           Toggle insert mode'
      CRT 'Ctrl-B      Back one char              Ctrl-U           Page Up'
      CRT 'Ctrl-D      Delete char                Ctrl-V           Page Down'
      CRT 'Ctrl-E      End of line                Ctrl-W           Delete word'
      CRT 'Ctrl-F      Forward char               Ctrl-X           Forward word'
      CRT 'Ctrl-G      Cancel line                Ctrl-Z           Back word'
      CRT 'Ctrl-I      Forward word               ~xyz             Search for xyz'
      CRT 'Ctrl-J      Delete to end              .D               Toggle detail off/on'
      CRT 'Ctrl-L      Clear screen               .Lm,n            List entry m thru n'
      CRT 'Ctrl-M      Accept line                .Rn              Restore entry n, edit'
      CRT 'Ctrl-N      Next line                  .H               Help'
      CRT 'Ctrl-P      Previous line              Q/INFO           Quit back to TCL'
      CRT '---------------------- PROGRAM STACK COMMANDS ---------------------------------'
      CRT '/           List the active prog stack'
      CRT '/LL         List available prog stacks /L BLAH          Switch stack to BLAH'
      CRT '/Nx         Add a New program          /Fx              Format the x`th program'
      CRT '/Ex         Edit the x`th program      /WW              Edit the program list'
      CRT '/Wx         VI the x`th program        /S               Sort the program stack'
      CRT '/Bx         Compile the x`th program   /BR              Compile and run'
      CRT '---------------------------- UTILITIES ----------------------------------------'
      CRT '                         ----------IL9---------'
      CRT 'AF          ATB Finder, search definitions                          - AF MRKTNG'
      CRT 'DDD         Search dictionary definitions                 - DDD LS.MASTER EQUIP'
      CRT 'LISTA       Show users logged in, as well as locks'
      CRT '                         ----------IL10--------'
      CRT 'FIELD       Show IL10 attribute/field metadata            - FIELD LS.NET.INVEST'
      CRT 'NED         Edit an IL10 record                 - NED LS.MASTER 123-1234567-000'
      CRT 'NSEL        Run a simple UD command - NSEL LS.INV.NUM N.CONTRACT.KEY N.DATE.DUE'
      CRT 'DESC        Describe columns in a table                - DESC LS_OI_CTD_INVOICE'
      CRT 'SQL         Run a SQL command -SQL SELECT TOP 10 ALTERNATE_ID FROM LS_MASTER_NF'
      CRT 'SQLF        Run a SQL command from a file        - SQLF /tmp/queries/Query1.sql'
      CRT 'SQL-LIST    SQL to L1 -SQL-LIST L1 SELECT TOP 10 ALTERNATE_ID FROM LS_MASTER_NF'
      CRT 'XREF        Show IL10 file/table metadata                      - XREF LS.MASTER'
      CRT '                              ---INFOLEASE---'
      CRT 'BPI         List table definitions                        - BPI LS.CTD.PYMTHIST'
      CRT 'CHECK.FILE  Show strings in a compiled program /P|/S    - CHECK.FILE DISP.00 /P'
      CRT '{C}CI/CM/TM {Customer}Contract Inquiry/Maintenance/Table Maintenance'
      CRT 'FIND.MENU   Search the menus                                   - FIND.MENU VOID'
      CRT 'PARAM       Show parameter file mapping'
      CRT 'RS          Edit a recall                                       RS DK.AUDIT.RPT'
      CRT '                             -----GENERAL-----'
      CRT 'ICONV/OCONV Test format masks/Convert Data'
      CRT 'PICKLE      Store data records in prog     - PICKLE DICT LS.MASTER UATB.BIG.ATB'
      CRT 'PIVOT       Summary data                - PIVOT LS.MASTER LESSOR GROSS.CONTRACT'
      CRT 'PROF        Profile data     - PROF LS.MASTER BRANCH NUM.OF.ASSETS BOOKING.DATE'
      CRT 'RULER       Reset term width, show ruler'
      CRT 'SETTINGS    Change settings'
      CRT 'SF          Search files and dictionaries            - SF DICT LS.MASTER ASSETS'
    CASE ANS = '.T'
      TIME.COMMAND=NOT(TIME.COMMAND)
    CASE ANS = '.U'
      IF MCU.ON THEN MCU.ON = FALSE;PRINT 'upper case off' ELSE MCU.ON = TRUE;PRINT 'UPPER CASE ON'
    CASE OTHERWISE
      PRINT 'There is no such STACK command':BELL
      PRINT '? for help'
  END CASE
RETURN
*
GET.PARAMS:
  I = INDEX(ANS,',',1)
  IF I # 0 THEN
    L = I-1;P1 = NUL
    LOOP
      IF NUM(ANS[L,1]) THEN P1 = ANS[L,1]:P1;L=L-1 ELSE EXIT
    REPEAT
    P2 = ANS[I + 1, LEN.ANS]
  END ELSE
    P1 = NUL
    LOOP
      IF NUM(ANS[LEN.ANS,1]) THEN P1 = ANS[LEN.ANS,1]:P1;LEN.ANS=LEN.ANS-1 ELSE EXIT
    REPEAT
    IF P1 = NUL THEN P1 = 1
    P2 = P1
  END
  IF P1 = NUL THEN P1 = 1
  IF P2 = NUL THEN P2 = MAX.STACK
  IF NUM(P1) & NUM(P2) & P1 > 0 THEN
    RANGE.ERROR = FALSE
  END ELSE
    RANGE.ERROR = TRUE
    PRINT 'Range Error':BELL
  END
RETURN
*
EDIT:
  * Some of the stuff in here is redundant, repeating COMMAND
  * but to gosub command introduces re-entrancy problems
  * That's why we use the dreaded GOTO command
  N = ANS[3,LEN.ANS]
  IF NOT(NUM(N)) THEN PRINT 'No such line number - ':N:BELL;RETURN
  IF N = NUL THEN N = 1
  LOOP WHILE N # NUL AND STACK<N> # NUL DO
    PRINT UP:N 'R%3':':':EOL:
    ENTRY = STACK<N,4>
    IF ENTRY = "" THEN ENTRY = STACK<N> ;* Legacy stack commands, no timestamp
    X = 5;DISP.LEN = TERM.WIDTH-1-X;LEN = LONG.LINE
    IF ENTRY # NUL THEN
      OLD.ENTRY = ENTRY
      GOSUB GET.INPUT
      ANS = ENTRY
    END
    BEGIN CASE
      CASE RTN = UP.KEY
        IF SEARCH.FOR # NUL THEN
          GO SEARCH.COMMAND
        END ELSE
          N = N + 1
          IF STACK<N> = NUL THEN N = 1
        END
      CASE RTN = DOWN.KEY
        N = N - 1
        IF N = 0 THEN
          N=1; PRINT BELL:
        END
      CASE RTN = RET
        UNIX.COMMAND=FALSE
        IF ANS[1,1] = UNIX THEN UNIX.COMMAND=TRUE
        IF UNIX.COMMAND THEN
          EXECUTING = FALSE
          IF N = 1 AND ENTRY = OLD.ENTRY THEN EXECUTING = TRUE
          GOSUB DO.COMMAND
          N=NUL
        END ELSE
          C.LIST = ANS
          C.COUNT = 1
          LOOP
            ANS = FIELD(C.LIST,COMMAND.SEPERATOR,C.COUNT)
          UNTIL ANS = NUL DO
            EXECUTING = FALSE
            IF N = 1 AND ENTRY = OLD.ENTRY THEN EXECUTING = TRUE
            GOSUB DO.COMMAND
            C.COUNT = C.COUNT + 1
          REPEAT
          N = NUL
        END
      CASE RTN = ESC
        N = NUL
    END CASE
  REPEAT
RETURN
*
SEARCH.COMMAND:
  * Search the stack for a string
  IF SEARCH.FOR = NUL THEN SEARCH.FOR = ANS[2,LONG.LINE]
  FOUND = FALSE
  FOR F = START.WORD.SEARCH TO MAX.STACK UNTIL FOUND OR STACK<F> = NUL
    IF INDEX(STACK<F,4>,SEARCH.FOR,1) # 0 THEN FOUND = TRUE
  NEXT F
  IF FOUND THEN
    START.WORD.SEARCH = F
    ANS = '.R':F-1
    GO EDIT
  END
  PRINT BELL:SEARCH.FOR:' event not found'
RETURN
*
PROG.COMMAND:
  IF ANS = PROG.CHAR OR ANS=PROG.CHAR:PROG.CHAR THEN GO PRINT.PROG.INFO
  GOSUB PARSE.PROG.COM
  ANS=PROG.COM:SPC:B.FILE:SPC:B.ITEM
  *GOSUB UPDATE.STACK
  BEGIN CASE
    CASE PROG.COM = '/WW'
      WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
      WP.FILE=HOME.FILE
      WP.ITEM=PROGRAM.ITEM
      GOSUB WP.EDIT
      READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
    CASE PROG.COM = '/N'
      GOSUB GET.PROG.NAME
      IF RTN=13 THEN
        PROGRAMS<PROG.NUM> = PROG
        WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
      END
      IF B.FILE # '' THEN
        OPEN B.FILE TO F THEN
          OPTIONS=''
          READ DUMMY FROM F, B.ITEM ELSE
            PRINT B.ITEM:' not found.  Use standard header? ':
            INPUT YORN
            IF YORN = 'Y' THEN
              HEADER=STR('*',80)
              HEADER<2>='* Program: ':B.ITEM
              HEADER<3>='* Author : ':USERNAME
              HEADER<4>='* Date   : ':OCONV(DATE(),"D-YMD") ;* E.g. 2017-04-20
              HEADER<5>='* Version: 1.0'
              HEADER<6>='* Comment: Do NOT skip the description'
              HEADER<7>=STR('*',80)
              WRITE HEADER ON F, B.ITEM
            END
          END
          CLOSE F
          WP.FILE=B.FILE
          WP.ITEM=B.ITEM
          GOSUB WP.EDIT
        END ELSE
          PRINT B.FILE:' is not a file in this account'
        END
      END
    CASE PROG.COM = '/H'
      OPTIONS='LESS'
      *CALL CVS.LOG(RTN, B.FILE, B.ITEM, OPTIONS)
    CASE PROG.COM = '/L'
      * Load a new program stack
      STACK.NAME=TRIM(OPTIONS)
      IF STACK.NAME = '' THEN
        PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME
      END ELSE
        PROGRAM.ITEM='.STACK.PROGRAM_':USERNAME:'_':STACK.NAME
      END
      READ PROGRAMS FROM HOME.F, PROGRAM.ITEM ELSE PROGRAMS = NUL
      SETTINGS<15>=STACK.NAME
      GOSUB WRITE.INFO
    CASE PROG.COM = '/LL'
      * List the different program stacks
      EXEC.LINE=\SSELECT \:HOME.FILE:\ WITH @ID = ".STACK.PROGRAM]"\
      GOSUB EXEC.SUB
      LOOP
        READNEXT ID ELSE EXIT
        PRINT ID
      REPEAT
    CASE PROG.COM = '/CI'
      * Check it in
      OPTIONS=''
      *CALL CVS.CHECKIN(RTN, B.FILE, B.ITEM, OPTIONS)
    CASE PROG.COM = '/D'
      * CVS Diff
      OPTIONS='SHOW'
      *CALL CVS.DIFF(RTN, B.FILE, B.ITEM, OPTIONS)
    CASE B.FILE[1,1] = '*' OR B.FILE=''
      NULL ;* Don't do anything with 'comment' or blank entries
    CASE PROG.COM = '/BR'
      GOSUB COMPILE
      EXEC.LINE = B.ITEM
      GOSUB EXEC.SUB
    CASE PROG.COM = '/B'
      GOSUB COMPILE
    CASE PROG.COM = '/E' OR PROG.COM = '/W'
      OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
      READ R1 FROM F, B.ITEM ELSE R1=NUL
      IF PROG.COM = '/E' THEN
        EXEC.LINE = ED.VERB:SPC:PROG:OPTIONS
        GOSUB EXEC.SUB
      END ELSE
        WP.FILE=B.FILE
        WP.ITEM=B.ITEM
        GOSUB WP.EDIT
      END
      CLOSE F
    CASE PROG.COM = '/F'
      GOSUB BFORMAT
    CASE PROG.COM = '/R'
      OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
      READV R FROM F, B.ITEM, 1 ELSE R=NUL
      CLOSE F
      EXEC.LINE = B.ITEM:OPTIONS
      GOSUB EXEC.SUB
    CASE PROG.COM = '/S'
      * A slow sort of the program stack
      READ REC FROM HOME.F, PROGRAM.ITEM ELSE PRINT 'CANNOT READ ':HOME.FILE:' ':PROGRAM.ITEM ; RETURN
      SORT='AL' ; NEW.REC=''
      I=DCOUNT(REC,@AM)
      FOR F=1 TO I
        L=REC<F>
        LOCATE L IN NEW.REC BY SORT SETTING POS ELSE NULL
        INS L BEFORE NEW.REC<POS>
      NEXT F
      WRITE NEW.REC ON HOME.F, PROGRAM.ITEM
    CASE OTHERWISE
      PRINT 'There is no such PROGRAM command':BELL
      PRINT '? for help'
  END CASE
RETURN
*
COMPILE:
  OPTIONS=''
  * Check for global catalog
  READ DUMMY FROM CTLGTB, B.ITEM THEN
    PRINT B.ITEM:' is cataloged globally'
    OPTIONS='G'
  END
  *
  * Check for local catalog
  READ DUMMY FROM CTLG, B.ITEM THEN
    PRINT B.ITEM:' is cataloged locally'
    OPTIONS :='L'
  END
  *
  * Check for direct catalog
  READ DUMMY FROM VOC, B.ITEM THEN
    IF INDEX(DUMMY<2>,'/CTLG/',1)=0 THEN
      PRINT B.ITEM:' is cataloged direct to ':DUMMY<2>
      OPTIONS :='D'
    END
  END
  *
  IF LEN(OPTIONS) > 1 THEN
    PRINT "OPTIONS=":OPTIONS
    PRINT "I do not like green eggs and ham, nor do I like"
    PRINT "programs cataloged twice.  You must fix, Sam"
    RETURN
  END
  *
  LOOP
  UNTIL OPTIONS#'' DO
    PRINT 'Catalog ':B.ITEM:' -- D)irect, L)ocal or G)lobal :':
    INPUT OPTIONS
    OPTIONS=UPCASE(OPTIONS)
    IF OPTIONS = '/' OR OPTIONS='' THEN RETURN
    * Have to enter D, L or G
    IF OPTIONS # 'L' AND OPTIONS # 'G' AND OPTIONS # 'D' THEN OPTIONS=''
  REPEAT
  *
  EXEC.LINE = 'BASIC ':B.FILE:' ':B.ITEM:' -D' ;* -D includes symbol table
  PRINT EXEC.LINE
  GOSUB EXEC.SUB
  *
  BEGIN CASE
    CASE OPTIONS='G'
      EXEC.LINE = 'CATALOG ':B.FILE:' ':B.ITEM:' FORCE'
      PRINT EXEC.LINE
      GOSUB EXEC.SUB
      * Global, so remove direct or local pointers
      READ R FROM VOC, B.ITEM THEN DELETE VOC, B.ITEM
    CASE OPTIONS='L'
      EXEC.LINE = 'CATALOG ':PROG:' LOCAL FORCE'
      PRINT EXEC.LINE
      GOSUB EXEC.SUB
      * Object is in CTLG file, so remove from SOURCE file
      OPEN B.FILE TO F ELSE PRINT 'Cannot open ':B.FILE:BELL;RETURN
      DELETE F, '_':B.ITEM
      CLOSE F
    CASE OPTIONS='D'
      EXEC.LINE = 'CATALOG ':B.FILE:' ':B.ITEM:' DIRECT FORCE'
      PRINT EXEC.LINE
      GOSUB EXEC.SUB
  END CASE
  *
  EXEC.LINE = 'NEWPCODE' ;* This loads a new version of globally cataloged programs
  GOSUB EXEC.SUB
RETURN
*
PARSE.PROG.COM:
  PROG.NUM = NUL
  F = FIELD(ANS,SPC,1);L = LEN(F);I = L
  LOOP
    IF NUM(F[I,1]) THEN PROG.NUM = F[I,1]:PROG.NUM ELSE EXIT
    I = I - 1
  REPEAT
  IF PROG.NUM = NUL THEN PROG.NUM = 1
  OPTIONS = ANS[L+1,LONG.LINE]
  PROG.COM = ANS[1,I]
  PROG = PROGRAMS<PROG.NUM>
  B.FILE = FIELD(PROG,SPC,1)
  B.ITEM = FIELD(PROG,SPC,2)
RETURN
*
GET.PROG.NAME:
  X = 15;DISP.LEN = 50;LEN = LONG.LINE;ENTRY = PROG
  PRINT 'Program Name :':
  GOSUB GET.INPUT
  ANS = UPCASE(ENTRY)
  IF RTN # 13 THEN RETURN
  GOSUB EXPAND.ALIASES
  IF INDEX(ANS,SPC,1) THEN
    B.FILE = FIELD(ANS,SPC,1)
    B.ITEM = FIELD(ANS,SPC,2)
    PROG=ANS
  END ELSE
    IF ANS = NUL THEN
      B.FILE = NUL ; B.ITEM = NUL ;PROG = NUL
    END ELSE
      B.FILE = WORK.FILE ; B.ITEM = ANS ; PROG = B.FILE:SPC:B.ITEM
    END
  END
RETURN
*
PRINT.PROG.INFO:
  I = DCOUNT(PROGRAMS,@AM)
  PRINT STACK.NAME
  FOR F = 1 TO I
    IF PROGRAMS<F> # NUL THEN
      CH=' '
      IF ANS=PROG.CHAR:PROG.CHAR THEN
        * We want cvs status as well
        FILE=FIELD(PROGRAMS<F>,' ',1)
        ITEM=FIELD(PROGRAMS<F>,' ',2)
        R=''
        *CALL CVS.STATUS(R,FILE,ITEM,'')
        STATUS=R<1>
        WORK.VER=R<2>
        CVS.VER=R<3>
        BEGIN CASE
          CASE STATUS='UPTODATE'
            CH='  ':WORK.VER'L#9'
          CASE STATUS='MODIFIED'
            CH='> ':WORK.VER'L#4':' ':CVS.VER'L#4'
          CASE 1
            CH='! ':SPACE(9)
        END CASE
      END
      PRINT F 'L#5':CH:' ':PROGRAMS<F>
    END
  NEXT F
RETURN
*
WRITE.INFO:
  WRITE STACK ON HOME.F, STACK.ITEM
  WRITE ALIASES ON HOME.F, ALIAS.ITEM
  WRITE PROGRAMS ON HOME.F, PROGRAM.ITEM
  WRITE SETTINGS ON HOME.F, SETTING.ITEM
RETURN
*
UPDATE.STACK:
  INS ACC:@VM:DATE():@VM:TIME():@VM:ANS BEFORE STACK<1>
  WRITE STACK ON HOME.F, STACK.ITEM
RETURN
*
WP.EDIT:
  * Edit a record using a visual editor (e.g. vi, joe or emacs)
  DICT=0
  IF FIELD(WP.FILE,' ',1)='DICT' THEN WP.FILE=FIELD(WP.FILE,' ',2) ; DICT=1
  READ REC FROM VOC, WP.FILE ELSE PRINT WP.FILE:' - no VOC item' ; RETURN
  IF (REC<1>#'DIR' AND REC<1>#'LD') OR DICT THEN
    * Copy to a temp DIR type and edit there, ignore the race conditions!
    IF DICT THEN WP.FILE='DICT ':WP.FILE
    OPEN WP.FILE TO T ELSE PRINT WP.FILE:' - cannot OPEN' ; RETURN
    READ R FROM T, WP.ITEM ELSE PRINT WP.ITEM:' - not found' ; RETURN
    WRITE R ON HOLD, WP.ITEM
    WP.PATH='_HOLD_'
    DIR.TYPE=0
  END ELSE
    WP.PATH=REC<2>
    IF REC<1>='LD' THEN
      IF INDEX(FILE,',',1) THEN
        WP.PATH=REC<2>:FIELD(FILE,',',2)
      END ELSE
        WP.PATH=REC<2>:'/':FIELD(REC<2>,'/',DCOUNT(REC<2>,'/'))
      END
    END
    DIR.TYPE=1
  END
  EXEC.LINE=WP.VERB:' ':WP.PATH:'/':WP.ITEM
  GOSUB EXEC.SUB
  IF NOT(DIR.TYPE) THEN
    * Copy back to original location
    READ R FROM HOLD, WP.ITEM ELSE R=''
    WRITE R ON T, WP.ITEM
    CLOSE T
  END
RETURN
*
CHECK.FILE:
  PARAM.CTR=1 ; PROG.FLAG=0 ; FILE.FLAG=0 ; ALL.FLAG=0
  LOOP
    P=FIELD(ANS,' ',PARAM.CTR)
  UNTIL P='' DO
    IF P[1,1] = '/' THEN
      P=P[2,1]
      BEGIN CASE
        CASE P='P'
          PROG.FLAG=1
        CASE P='F'
          FILE.FLAG=1
        CASE P='A'
          ALL.FLAG=1
      END CASE
    END ELSE
      PROG=P
    END
    PARAM.CTR += 1
  REPEAT
  IF PROG.FLAG=0 AND FILE.FLAG=0 THEN ALL.FLAG=1
  *
  IF PROG # '' THEN
    READ CAT.PTR FROM VOC, PROG ELSE PRINT 'Cannot read VOC ':PROG ; RETURN
  END ELSE
    LOOP
      PRINT 'Enter the program to scan ':
      INPUT PROG
      IF PROG = '' OR PROG = '/' THEN RETURN
      READ CAT.PTR FROM VOC, PROG THEN EXIT
      PRINT 'Cannot read VOC ':PROG
    REPEAT
  END
  *
  EXECUTE "!strings ":CAT.PTR<2>:" > $HOME/FILE.LIST"
  *
  FILE.LIST=''
  READ R FROM HOME.F, 'FILE.LIST' THEN
    I=DCOUNT(R,@AM)
    FOR F=1 TO I
      TEST.FILE=R<F>
      IF FILE.FLAG THEN
        OPEN TEST.FILE TO DUMMY THEN
          LOCATE TEST.FILE IN FILE.LIST BY 'AL' SETTING POS ELSE
            INS TEST.FILE BEFORE FILE.LIST<POS>
            PRINT 'FILE:':TEST.FILE
          END
          CLOSE DUMMY
        END
      END
      IF PROG.FLAG THEN
        READ DUMMY FROM VOC, TEST.FILE THEN
          *IF DUMMY = 'C' THEN PRINT 'PROG: ':TEST.FILE
          IF DUMMY<1>='C' THEN PRINT 'PROG: ':TEST.FILE'L#25':' ':DUMMY<2>
        END
      END
      IF ALL.FLAG THEN
        PRINT TEST.FILE
      END
    NEXT F
  END
RETURN
*
CONV:
  * Handy way to check ICONV/OCONV data
  LOOP
    PRINT 'Enter mask:':
    INPUT MASK
    IF MASK='' OR MASK='/' THEN RETURN
    PRINT 'Enter data:':
    INPUT DTA
    PRINT 'Result:':
    IF CONV='I' THEN PRINT ICONV(DTA,MASK) ELSE PRINT OCONV(DTA,MASK)
  REPEAT
RETURN
*
RULER:
  CRT 'Term width=':TERM.WIDTH
  FOR F=1 TO TERM.WIDTH
    C=SEQ(0)+MOD(F,10)
    IF MOD(F,10) THEN PRINT CHAR(C): ELSE PRINT ' ':
  NEXT F
  PRINT
  SUP.NEXT=0
  FOR F=1 TO TERM.WIDTH
    BEGIN CASE
      CASE MOD(F+1,10)=0 AND (F+1)/10 > 9
        PRINT (F+1)/10:
        SUP.NEXT=1
      CASE MOD(F,10)=0 AND F/10 <= 9
        PRINT F/10:
        SUP.NEXT=0
      CASE MOD(F,5)=0 AND NOT(SUP.NEXT)
        PRINT '+':
      CASE 1
        IF NOT(SUP.NEXT) THEN PRINT ' ':
        SUP.NEXT=0
    END CASE
  NEXT F
  PRINT
RETURN
*
PIVOT:
  * Summarize a field, e.g. PIVOT LS.MASTER LESSOR GROSS.CONTRACT EQUIPMENT.COST
  FILE=FIELD(ANS," ",2) ; ATB =FIELD(ANS," ",3) ; ATB2=FIELD(ANS," ",4) ; ATB3=FIELD(ANS," ",5) ; ATB4=FIELD(ANS," ",6)
  OPEN "DICT ":FILE TO DICT ELSE PRINT "DICT ":FILE:' not a filename' ; RETURN
  READ UREC FROM DICT,"UATB.COUNTER" ELSE
    UREC=\I\;UREC<2>=\"1"\;UREC<4>=\CNTR\;UREC<5>=\8R\;UREC<6>=\S\
    WRITE UREC ON DICT,"UATB.COUNTER"
  END
  CLOSE DICT
  EXEC.LINE = \SORT \:FILE:\ BY \:ATB:\ BREAK-ON \:ATB:\ TOTAL UATB.COUNTER \
  IF ATB2 # "" THEN EXEC.LINE := \ TOTAL \:ATB2
  IF ATB3 # "" THEN EXEC.LINE := \ TOTAL \:ATB3
  IF ATB4 # "" THEN EXEC.LINE := \ TOTAL \:ATB4
  EXEC.LINE := \ (IDH \
  GOSUB EXEC.SUB
RETURN
*
PROFILE:
  * Profile a field, e.g. PROFILE LS.MASTER REQ.SIGNATURE.PHONE
  FILE=FIELD(ANS," ",2) ; ATB =FIELD(ANS," ",3) ; ATBS=FIELD(ANS," ",4,99)
  EXEC.LINE = \SORT \:FILE:\ WITH \:ATB:\ \:ATB:\ \:ATBS
  GOSUB EXEC.SUB
RETURN
*
DDD:
  * Tweak DICT VOC with some pickle juice
  R    =\DICT VOC#AM#@ID#AM#D#AM#0#AM##AM#VOC#AM#30L#AM#S#AM#\
  R<-1>=\DICT VOC#AM#F1#AM#D#AM#1#AM##AM##AM#5L#AM#S#AM#\
  R<-1>=\DICT VOC#AM#F2#AM#D#AM#2#AM##AM##AM#50L#AM#S#AM#\
  OPEN 'DICT VOC' TO FVAR ELSE RETURN
  FOR F=1 TO DCOUNT(R,@AM)
    REC=R<F>
    SWAP "#AM#" WITH @AM IN REC
    FILE=REC<1> ; DEL REC<1>
    ITEM=REC<1> ; DEL REC<1>
    WRITE REC ON FVAR,ITEM
  NEXT F
  CLOSE FVAR
  *
  * List the DICT, e.g DDD AS.MASTER EQUIP
  FILE = FIELD(ANS," ",2)
  SSTR = FIELD(ANS," ",3)
  FIND.STR=""
  IF SSTR # "" THEN FIND.STR = \WITH @ID = "[\:SSTR:\]" \
  EXEC.LINE=\SORT DICT \:FILE:\ @ID F1 F2 BY F1 BY F2 \:FIND.STR:\ USING DICT VOC (I \
  GOSUB EXEC.SUB
RETURN
*
SEARCH.FILE:
  FILE = FIELD(ANS," ",2)
  ICTR=3
  IF FILE='DICT' THEN ICTR+=1 ; FILE='DICT ':FIELD(ANS," ",3)
  OPEN FILE TO FVAR ELSE PRINT FILE:' - not found' ; RETURN
  SSTR = FIELD(ANS," ",ICTR)
  IF SSTR='' THEN PRINT 'Search for:': ; INPUT SSTR
  IF SSTR='' THEN RETURN
  *
  SSTR1=UPCASE(SSTR)
  SSTR2=DOWNCASE(SSTR)
  SSTR3=OCONV(SSTR,"MCT")
  *
  DATA SSTR
  DATA SSTR1
  DATA SSTR2
  DATA SSTR3
  DATA ""
  EXEC.LINE=\ESEARCH \:FILE:\ WITH @ID # "_]" USING DICT VOC\ ; CAP.ACTIVE=TRUE
  GOSUB EXEC.SUB
  *
  CTR=0 ; FOUND.RECS=''
  LOOP
    READNEXT ID ELSE EXIT
    READ REC FROM FVAR, ID THEN
      IDX = INDEX(UPCASE(REC),SSTR1,1)
      IF IDX OR INDEX(UPCASE(ID),SSTR1,1) THEN
        CTR+=1
        FOUND.RECS<1,CTR>=ID
        IDX -= 10 ; IF IDX < 1 THEN IDX=1
        LINE=REC[IDX,45]
        CONVERT @VM TO "]" IN LINE
        CONVERT @AM TO "~" IN LINE
        LINE=OCONV(LINE,"MCP")
        FOUND.RECS<2,CTR>=LINE
      END
    END
  REPEAT
  CLOSE FVAR
  *
  QUIT = 0 ; CTR=1 ; MAX.ITEMS=DCOUNT(FOUND.RECS<1>,@VM)
  IF MAX.ITEMS=0 THEN PRINT SSTR:' Not found' ; RETURN
  HDR=@(-1):\SEARCHING FOR "\:SSTR1:\,\:SSTR2:\,\:SSTR3:\" IN \:FILE
  PRINT HDR
  LOOP
    PRINT CTR'R#4':' ':FOUND.RECS<1,CTR>'L#25':FOUND.RECS<2,CTR>'L#65'
    CTR+=1
    IF CTR/20=INT(CTR/20) THEN GOSUB SEARCH.FILE.PROMPT
    IF QUIT THEN RETURN
  REPEAT
RETURN
*
SEARCH.FILE.PROMPT:
  PRINT ; PRINT 'B)ack, E)dit #, V)iew #, W)P#, /:':
  INPUT OPTION
  BEGIN CASE
    CASE OPTION='B'
      CTR-=40
      IF CTR<1 THEN CTR=1
    CASE OPTION[1,1]='E'
      EXEC.LINE=ED.VERB:\ \:FILE:\ \:FOUND.RECS<1,OPTION[2,99]>
      GOSUB EXEC.SUB
      CTR-=20
      IF CTR<1 THEN CTR=1
    CASE OPTION[1,1]='W'
      WP.FILE=FILE
      WP.ITEM=FOUND.RECS<1,OPTION[2,99]>
      GOSUB WP.EDIT
      CTR-=20
      IF CTR<1 THEN CTR=1
    CASE OPTION[1,1]='V'
      PRINT CS:
      EXEC.LINE=\CT \:FILE:\ \:FOUND.RECS<1,OPTION[2,99]>
      GOSUB EXEC.SUB
      CTR-=20
      IF CTR<1 THEN CTR=1
      PRINT 'Press ENTER:':
      INPUT AAA
    CASE OPTION # ''
      * ENTER to keep moving forward
      QUIT=1
  END CASE
  PRINT HDR
RETURN
*
IL10.NED:
  OPEN '_HOLD_' TO F.HOLD ELSE STOP 201,'_HOLD_'
  FILE.NAME=FIELD(ANS,' ',2)
  K.FILE=FIELD(ANS,' ',3)
  CALL FILE.OPEN(PROGRAM.NAME, FILE.NAME, F.FILE, 'STOP')
  CALL IDS.READ(R.FILE, F.FILE,  K.FILE, 0, 0, BCI.ERROR)
  IF BCI.ERROR # '' THEN PRINT BCI.ERROR ; R.FILE=''
  R.ORIG=R.FILE
  *
  LOOP
    PRINT DCOUNT(R.FILE,@AM):' fields in record'
    PRINT 'Enter E)dit, L)ist, S)ave or Q)uit:':
    INPUT OPT
    BEGIN CASE
      CASE OPT='L'
        SHOW.BPI=0 ; BPI.XREF=''
        OPEN 'DATABASE.FILES,IL' TO IL ELSE PRINT 201,'DATABASE.FILES,IL' ; RETURN
        OPEN 'IL.BPI' TO IL.BPI ELSE PRINT 201,'IL.BPI' ; RETURN
        READV BPI FROM IL, FILE.NAME, 14 THEN
          * Sample: Attached to FLOAT.INCOME bpi.
          N=DCOUNT(BPI,' ')
          BPI=FIELD(BPI,' ',N-1)
          READ BPI.LAYOUT FROM IL.BPI, BPI THEN
            * Sample: EQUATE GROSS.FINANCE               TO MASTER(1)
            SHOW.BPI=1
            FOR R=1 TO DCOUNT(BPI.LAYOUT,@AM)
              L=TRIM(BPI.LAYOUT<R>)
              IF FIELD(L,' ',1)='EQUATE' THEN
                FLD.NAME=FIELD(L,' ',2)
                FLD.POS=FIELD(FIELD(L,' ',4),'(',2)
                FLD.POS=FIELD(FLD.POS,')',1)
                BPI.XREF<FLD.POS>=FLD.NAME
              END
            NEXT R
          END ELSE
            PRINT 'Cannot read BPI:':BPI
          END
        END ELSE
          PRINT 'Cannot get BPI name for:':FILE.NAME
        END
        *
        PRINT @(-1):'FILE:':FILE.NAME:' ITEM:':K.FILE
        FOR F=1 TO DCOUNT(R.FILE,@AM)
          R=R.FILE<F>
          CONVERT @VM TO "|" IN R
          CONVERT @SVM TO "\" IN R
          IF SHOW.BPI THEN
            PRINT F'R#3':' ':BPI.XREF<F>'L#25':'=':R[1,80]
          END ELSE
            PRINT F'R#3':' ':R
          END
        NEXT F
        PRINT 'PRESS ENTER:':
        INPUT AAA
      CASE OPT='S'
        CALL IDS.WRITE(R.FILE, F.FILE, K.FILE, 0, 0)
        PRINT 'Saved.  Press ENTER to continue:':
        R.ORIG=R.FILE
        INPUT AAA
      CASE OPT='E'
        R=R.FILE
        SWAP CHAR(13):CHAR(10) WITH '||' IN R
        WRITE R ON F.HOLD, K.FILE
        EXECUTE \ED _HOLD_ \:K.FILE
        READ R FROM F.HOLD, K.FILE ELSE R=''
        SWAP '||' WITH CHAR(13):CHAR(10) IN R
        IF R # R.FILE THEN
          PRINT 'Record changed, use S to save'
          R.FILE=R
        END
        DELETE F.HOLD, K.FILE
      CASE OPT='Q'
        IF R.FILE#R.ORIG THEN
          PRINT 'Record changed, are you sure (Y/N):':
          INPUT YORN
          IF YORN # 'Y' THEN OPT=''
        END
    END CASE
  UNTIL OPT='Q' DO
  REPEAT
RETURN
*
BPI:
  OPEN 'DATABASE.FILES,IL' TO IL ELSE STOP 201,'DATABASE.FILES,IL'
  OPEN 'IL.BPI' TO IL.BPI ELSE STOP 201,'IL.BPI'
  BPI=FIELD(ANS,' ',2)
  IF BPI='' THEN PRINT 'Usage: BPI <name of infolease file|name of BPI>' ; RETURN
  * Param 2 can be a BPI or a FILENAME
  READ DUMMY FROM IL.BPI, BPI ELSE
    READV BPI FROM IL, BPI, 14 ELSE PRINT 'Cannot read DATABASE.FILES,IL',BPI ; RETURN
    * Sample: Attached to FLOAT.INCOME bpi.
    N=DCOUNT(BPI,' ')
    BPI=FIELD(BPI,' ',N-1)
    READ DUMMY FROM IL.BPI, BPI ELSE PRINT 'Cannot get BPI name' ; RETURN
  END
  EXEC.LINE=\AE IL.BPI \:BPI
  GOSUB EXEC.SUB
  CLOSE IL
  CLOSE IL.BPI
RETURN
*
RECALL.SHELL:
  DATA 1
  DATA 1
  RECALL=FIELD(ANS,' ',2)
  IF RECALL # '' THEN DATA RECALL
  EXECUTE \RECALL.00\
RETURN
*
FIND.MENU:
  OPEN "DB.MENUS" TO MENU.F ELSE STOP 201,"DB.MENUS"
  STR=FIELD(ANS,' ',2)
  IF STR='' THEN
    PRINT "Enter menu or program to search for : ": ; INPUT STR
    IF STR="" OR STR="/" THEN RETURN
  END
  STR = OCONV(STR,"MCU")
  MENU.LIST=''
  MENU.LIST<1>=1
  MENU.LIST<2>=0
  MENU.CTR=1
  LOOP
    MENU=MENU.LIST<1,MENU.CTR>
    PATH=MENU.LIST<2,MENU.CTR>
    IF MENU='' THEN EXIT
    GOSUB SEARCH.MENU
    MENU.CTR+=1
  REPEAT
  CLOSE MENU.F
RETURN
*
SEARCH.MENU:
  READ R FROM MENU.F, MENU THEN
    TITLES = OCONVS(R<2>,"MCU") ; PROGS  = OCONVS(R<3>,"MCU") ; FLAGS = R<4> ; TYPES = R<5>
    I = DCOUNT(PROGS,@VM)
    FOR F = 1 TO I
      IF INDEX(PROGS<1,F>,STR,1) # 0 OR INDEX(TITLES<1,F>,STR,1) # 0 THEN
        PRINT MENU"R#5":" ":TITLES<1,F>"L#27":"  ":TYPES<1,F>'L#1':" ":PROGS<1,F>"L#50":" ":PATH:',':F
      END
      IF FLAGS<1,F>='M' THEN MENU.LIST<1,-1>=PROGS<1,F> ; MENU.LIST<2,-1>=PATH:',':F
    NEXT F
  END
RETURN
*
BFORMAT:
  STAR  = '*' ; COLON = ':' ; TAB=CHAR(9)
  IND = 0
  *
  * These are all commands that may have ELSE or THEN statements
  * (or blocks) following them
  SPECIAL.CASES = "GET":@AM:"INPUT":@AM:"LOCATE":@AM:"LOCK":@AM:"MATREAD":@AM:"MATREADU":@AM
  SPECIAL.CASES := "MATWRITE":@AM:"MATWRITEU":@AM:"OPEN":@AM:"PROCREAD":@AM
  SPECIAL.CASES := "PROCWRITE":@AM:"READ":@AM:"READNEXT":@AM:"READSEQ":@AM:"READT":@AM:"READU":@AM:"READV":@AM
  SPECIAL.CASES := "READVU":@AM:"REWIND":@AM:"SEEK":@AM:"WEOF":@AM:"WRITESEQ":@AM
  SPECIAL.CASES := "WRITET"
  *
  DEF.INDENT=2
  FORMATS=":":@VM:"BEGIN":@VM:"CASE":@VM:"ELSE":@VM:"END":@VM:"FOR":@VM
  FORMATS :="IF":@VM:"LOOP":@VM:"NEXT":@VM:"REPEAT":@VM:"RETURN":@VM
  FORMATS :="THEN":@VM:"UNTIL":@VM:"WHILE"
  * THIS.IND is the amount this line will be in or outdented
  FORMATS<2>=0:@VM:0:@VM:-1:@VM:0:@VM:-1:@VM:0:@VM:0:@VM
  FORMATS<2> :=0:@VM:-1:@VM:-1:@VM:-1:@VM:0:@VM:-1:@VM:-1
  * NEXT.IND is the amount that all following lines will be indented
  FORMATS<3>=1:@VM:2:@VM:0:@VM:1:@VM:-1:@VM:1:@VM:1:@VM
  FORMATS<3> :=1:@VM:-1:@VM:-1:@VM:-1:@VM:1:@VM:0:@VM:0
  FORMATS<4>=DEF.INDENT
  *
  OPEN B.FILE TO FI ELSE PRINT 'Cannot open ':B.FILE ; RETURN
  READ REC FROM FI,B.ITEM ELSE PRINT "CANNOT READ ":B.FILE:" ":B.ITEM ; RETURN
  *WRITE REC ON FI,B.NAME:".BAK"
  SWAP CHAR(9) WITH SPACE(DEF.INDENT) IN REC
  *
  I = DCOUNT(REC,@AM)
  IF I < 2 THEN RETURN
  FOR F = 1 TO I
    PRINT STAR:
    L = REC<F> ; NEXT.LINE=REC<F+1>
    GOSUB FORMAT.LINE
    REC<F> = L
  NEXT F
  WRITE REC ON FI,B.ITEM
  PRINT STAR ; PRINT I:" lines of ":B.ITEM:" formatted"
  CLOSE FI
RETURN
*
FORMAT.LINE:
  L=TRIM(L,' ','B')
  CONVERT TAB TO "" IN L
  FIRST.WORD = FIELD(L,SPC,1)
  LEN.FIRST.WORD = LEN(FIRST.WORD)
  LOCATE FIRST.WORD IN SPECIAL.CASES BY 'AL' SETTING SPECIAL ELSE SPECIAL = 0
  NUM.SPACES = COUNT(L,SPC) + 1
  LAST.WORD = FIELD(L,SPC,NUM.SPACES)
  NEXT.TO.LAST.WORD = FIELD(L,SPC,NUM.SPACES-1)
  THIS.IND = 0
  NEXT.IND = 0
  BEGIN CASE
    CASE L=""
      L="*" ;* Makes pasting code around easier with no blank lines
    CASE FIRST.WORD[LEN.FIRST.WORD,1] = COLON OR NUM(FIRST.WORD)
      * A label
      IND = 0
      LOCATE COLON IN FORMATS<1> SETTING POS ELSE POS = 0
      THIS.IND = FORMATS<2,POS>
      NEXT.IND = FORMATS<3,POS>
    CASE FIRST.WORD = "IF"
      LOCATE FIRST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
      IF LAST.WORD = "THEN" THEN
        THIS.IND = FORMATS<2,POS>
        NEXT.IND = FORMATS<3,POS>
      END
    CASE FIRST.WORD = "END"
      SECOND.WORD = FIELD(L,SPC,2)
      IF SECOND.WORD = "ELSE" THEN
        LOCATE "ELSE" IN FORMATS<1> SETTING POS ELSE POS = 0
        THIS.IND = -FORMATS<3,POS>
        NEXT.IND = FORMATS<2,POS>
      END ELSE
        IF SECOND.WORD = "CASE" THEN
          LOCATE "BEGIN" IN FORMATS<1> SETTING POS ELSE POS = 0
          THIS.IND = -FORMATS<3,POS>
          NEXT.IND = -FORMATS<3,POS>
        END ELSE
          LOCATE FIRST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
          THIS.IND = FORMATS<2,POS>
          NEXT.IND = FORMATS<3,POS>
        END
      END
    CASE SPECIAL
      * Find last word - skip until a space
      IF LAST.WORD = "ELSE" OR LAST.WORD = "THEN" THEN
        LOCATE LAST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
        THIS.IND = FORMATS<2,POS>
        NEXT.IND = FORMATS<3,POS>
      END
    CASE FIRST.WORD = "FOR" AND NEXT.TO.LAST.WORD = "NEXT"
      * FOR loop on one line means do nothing
    CASE FIRST.WORD = "RETURN" AND TRIM(NEXT.LINE) # "*"
      * RETURN without a blank line means do nothing
    CASE 1
      LOCATE FIRST.WORD IN FORMATS<1> SETTING POS ELSE POS = 0
      IF POS # 0 THEN
        THIS.IND = FORMATS<2,POS>
        NEXT.IND = FORMATS<3,POS>
      END
  END CASE
  L = SPACE((IND+THIS.IND)*DEF.INDENT):L
  *L = STR(TAB,IND+THIS.IND):L ;* In my misguided youth, tabs seemed cool
  IND = IND + NEXT.IND
RETURN
*
GET.LINE:
  * SUBROUTINE GET.LINE(X,LEN,DISP.LEN,XXDATA,RTN)
  * X           = X POS
  * LEN         = MAX ALLOWED LENGTH
  * DISP.LEN    = MAX DISPLAYED LEN
  * XXDATA      = ON INPUT  VARIABLE XXDATA
  *             = ON OUTPUT RETURNED STRING
  * RTN         = SEQ(CHAR PRESSED TO EXIT)
  * -----------------
  * Important globals
  * CP          = Cursor Position, Y coordinate on the screen 0 -> DISP.LEN
  * CH.PTR      = Pointer into string being edited            1 -> LEN
  * POS         = Pointer to first char currently displayed   1 -> LEN
  * ASC.CH      = The numeric value of the key just entered
  *
  ECHO OFF
  XXDATA = ENTRY
  MODE = INSERT ; TEMP.XXDATA = XXDATA
  BASE = @(X) ; MASK = 'L#':DISP.LEN
  PRINT BASE:
  CURR.LEN = LEN(XXDATA)
  GOSUB GO.END
  RTN=''
  *
  LOOP
    PRINT @(X+CP):
    CH=IN()
    ASC.CH = SEQ(CH)
    EXIT.FLAG=FALSE
    BEGIN CASE
      CASE ASC.CH = 1
        GOSUB GO.BEGIN
      CASE ASC.CH = 2
        GOSUB LEFT
      CASE ASC.CH = 4
        GOSUB DEL
      CASE ASC.CH = 5
        GOSUB GO.END
      CASE ASC.CH = 6
        GOSUB RIGHT
      CASE ASC.CH = 8
        GOSUB BACK
      CASE ASC.CH = 9
        GOSUB AUTO.COMPLETE
      CASE ASC.CH = 10
        GOSUB DEL.TO.END
      CASE ASC.CH = 13
        EXIT.FLAG = TRUE
        RTN=13
      CASE ASC.CH = 14
        RTN=2
        EXIT.FLAG=TRUE
      CASE ASC.CH = 16
        RTN=1
        EXIT.FLAG=TRUE
      CASE ASC.CH = 18
        GOSUB INSRT
      CASE ASC.CH = PG.UP.KEY
        EXIT.FLAG=TRUE
        RTN=PG.UP.KEY
      CASE ASC.CH = PG.DOWN.KEY
        EXIT.FLAG=TRUE
        RTN=PG.DOWN.KEY
      CASE ASC.CH = 23
        GOSUB DELETE.WORD
      CASE ASC.CH = 24
        GOSUB FORWARD.WORD
      CASE ASC.CH = 7 OR ASC.CH = 12
        IF ASC.CH = 12 THEN PRINT @(-1):
        XXDATA = ''
        EXIT.FLAG=TRUE
        RTN=13
      CASE ASC.CH = 26
        GOSUB BACK.WORD
      CASE ASC.CH = 27
        GOSUB ESC.KEY
      CASE ASC.CH < 27
        PRINT @(0):ASC.CH:
      CASE ASC.CH = 127
        GOSUB BACK
      CASE 1
        GOSUB ORD
    END CASE
    CURR.LEN = LEN(XXDATA)
  UNTIL EXIT.FLAG DO
  REPEAT
  IF XXDATA[CURR.LEN,1] = SPC THEN XXDATA = XXDATA[1,CURR.LEN-1]
  ECHO ON ; PRINT BASE:XXDATA MASK
  ENTRY=XXDATA
RETURN
*
AUTO.COMPLETE:
  * Grab the current word and figure out max completion
  WORD='' ; WORD.CTR=''
  CH.PTR.TMP=CH.PTR-1
  LOOP
    C=XXDATA[CH.PTR.TMP,1]
  UNTIL C=' ' OR CH.PTR.TMP=0 DO
    WORD=C:WORD
    CH.PTR.TMP-=1
  REPEAT
  *
  * Count which word we're on - there are different auto-completes for 1, 2 or 3+
  IF CH.PTR.TMP=0 THEN
    WORD.CTR=1 ;* Trying to autocomplete a command
    WORD='CMD_':WORD
  END ELSE
    CH.PTR.TMP-=1
    LOOP
      C=XXDATA[CH.PTR.TMP,1]
    UNTIL C=' ' OR CH.PTR.TMP=0 DO
      CH.PTR.TMP-=1
    REPEAT
    IF CH.PTR.TMP=0 THEN
      WORD.CTR=2 ;* Trying to autocomplete a filename
      WORD='FILE_':WORD
    END ELSE
      WORD.CTR=3 ;* Trying to autocomplete from a dictionary
      FNAME=FIELD(XXDATA,' ',2)
      WORD='DICT-':FNAME:'_':WORD
    END
  END
  *
  IF XXDATA[CURR.LEN,1] = SPC THEN XXDATA = XXDATA[1,CURR.LEN-1]
  CURR.LEN=LEN(XXDATA)
  *
  LOOP
    READ AC.LIST FROM AC, WORD ELSE CRT BEEP: ; RETURN
    * Ok, we have some auto-completion candidates, need to do two things
    * 1) Check to see if we're done, return if so, or
    * 2) List top 20 possible completions if there are more than one
    IF DCOUNT(AC.LIST<1>,@VM)=1 AND DCOUNT(AC.LIST<2,1>,@SVM)=1 THEN
      NEWF=AC.LIST<2>[LEN(WORD)+1,999]
      XXDATA:=NEWF:' '
      PRINT BASE:XXDATA:EOS:
      CURR.LEN=LEN(XXDATA)
      GOSUB GO.END
      RETURN
    END ELSE
      CRT CS:@(0,0):BON:PROMPT.DISP:BOFF:XXDATA
      NUM.CP=DCOUNT(AC.LIST<1>,@VM)
      IF NUM.CP>20 THEN NUM.CP=20
      FOR CP=1 TO NUM.CP
        CRT CP'R#2':') ':FIELD(AC.LIST<1,CP>,'_',2,99):' (':
        NUM.CP2=DCOUNT(AC.LIST<2,CP>,@SVM)
        NUM.CP2.MAX=NUM.CP2
        IF NUM.CP2>3 THEN NUM.CP2=3
        FOR CP2=1 TO NUM.CP2
          CRT FIELD(AC.LIST<2,CP,CP2>,'_',2,99):
          IF CP2<NUM.CP2 THEN CRT ',':
        NEXT CP2
        IF NUM.CP2 # NUM.CP2.MAX THEN CRT ' [+':NUM.CP2.MAX-NUM.CP2:']':
        CRT ')'
      NEXT CP
      WORD.CONTINUE=IN()
      ASC.VAL = SEQ(WORD.CONTINUE)
      CRT CS:@(0,0):BON:PROMPT.DISP:BOFF:XXDATA:
      BEGIN CASE
        CASE ASC.VAL=13 OR ASC.VAL=27
          CURR.LEN=LEN(XXDATA)
          GOSUB GO.END
          RETURN
        CASE ASC.VAL>=32 AND ASC.VAL<127
          WORD:=WORD.CONTINUE
          XXDATA:=WORD.CONTINUE
      END CASE
    END
  REPEAT
RETURN
*
ORD:
  * Ordinary key pressed
  IF CH.PTR # LEN+1 THEN
    IF MODE = INSERT THEN
      IF CURR.LEN = LEN THEN
        PRINT BEEP:
        GOTO SKIP1
      END ELSE
        XXDATA = XXDATA[1,CH.PTR-1]:CH:XXDATA[CH.PTR,CURR.LEN]
      END
    END ELSE
      XXDATA = XXDATA[1,CH.PTR-1]:CH:XXDATA[CH.PTR+1,CURR.LEN]
    END
    CH.PTR = CH.PTR + 1
    IF CP # DISP.LEN THEN
      PRINT @(X+CP):CH:
      IF MODE = INSERT THEN
        PRINT XXDATA[CH.PTR,DISP.LEN-CP-1]:
      END
      CP = CP + 1
    END ELSE
      POS = POS + 1
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
    END
  END ELSE
    PRINT BEEP:
  END
SKIP1:
RETURN
*
RIGHT:
  * There are 3 situations here -
  * 1 We're pressing the right arrow thru existing text       (CH.PTR = CURR.LEN)
  * 2 We've typed text and are at the end when we press right (CH.PTR > CURR.LEN)
  * 3 We're in the middle of text, pressing the right arrow   (CH.PTR < CURR.LEN)
  IF CH.PTR < LEN THEN
    IF CH.PTR > CURR.LEN THEN PRINT BEEP: ; GOTO SKIP2
    IF CH.PTR = CURR.LEN THEN
      * If the last char is not a space make it one
      IF XXDATA[CURR.LEN,1] # SPC THEN
        XXDATA = XXDATA:SPC
        IF CP # DISP.LEN THEN PRINT @(X+CP+1):SPC:
        CURR.LEN = CURR.LEN + 1
      END ELSE
        PRINT BEEP:
        GOTO SKIP2
      END
    END
    CH.PTR = CH.PTR + 1
    IF CP # DISP.LEN THEN
      * We're not at the end of display so just move the cursor
      CP = CP + 1
    END ELSE
      * We are at the end of the display so leave cursor where
      * it is and scroll through line
      POS = POS + 1
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
    END
  END ELSE
    PRINT BEEP:
  END
SKIP2:
RETURN
*
FORWARD.WORD:
  * Tab key pressed - move forwards a word
  IF CH.PTR >= CURR.LEN THEN
    PRINT BEEP:
  END ELSE
    LOOP
      CH.PTR = CH.PTR + 1
      CP = CP + 1
    UNTIL XXDATA[CH.PTR,1] = SPC OR CH.PTR = CURR.LEN DO
    REPEAT
    IF CH.PTR # CURR.LEN THEN
      LOOP
        CH.PTR = CH.PTR + 1
        CP = CP + 1
      UNTIL XXDATA[CH.PTR,1] # SPC OR CH.PTR = CURR.LEN DO
      REPEAT
    END
    IF CP > DISP.LEN THEN
      CP = DISP.LEN
      POS = CH.PTR - DISP.LEN
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
    END
  END
RETURN
*
LEFT:
  * If we're not at the start of data, move left
  IF CH.PTR # 1 THEN
    CH.PTR = CH.PTR - 1
    IF CP # 0 THEN
      * We're not at the start of the display so just move the cursor
      CP = CP - 1
    END ELSE
      * We are at the start of the display so leave cursor and scroll
      POS = POS - 1
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
    END
  END ELSE
    PRINT BEEP:
  END
RETURN
*
DEL:
  * Delete the character at the cursor and redisplay from this point
  XXDATA = XXDATA[1,CH.PTR-1]:XXDATA[CH.PTR+1,CURR.LEN]
  CURR.LEN = CURR.LEN - 1
  PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
RETURN
*
BACK:
  * Backspace key pressed
  IF CH.PTR # 1 THEN
    CH.PTR = CH.PTR - 1
    XXDATA = XXDATA[1,CH.PTR-1]:XXDATA[CH.PTR+1,CURR.LEN]
    CURR.LEN = CURR.LEN - 1
    IF CP # 0 THEN
      CP = CP - 1
    END ELSE
      POS = POS - 1
    END
    PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
  END ELSE
    PRINT BEEP:
  END
RETURN
*
INSRT:
  * Toggle between insert and replace modes
  MODE = -MODE
RETURN
*
ESC.KEY:
  * ESC pressed, or extended key - wyse50 arrow keys
  * Get next char of extended command
  ALLOW = 0
  EXT.KEY=IN()
  EXT = SEQ(EXT.KEY)
  EXT.KEY = OCONV(EXT.KEY,'MCU')
  BEGIN CASE
    CASE EXT.KEY = 'D'
      GOSUB DELETE.WORD
    CASE EXT.KEY = '[' OR EXT.KEY = 'O'
      EXT.KEY=IN()
      BEGIN CASE
        CASE EXT.KEY = 'C'
          GOSUB RIGHT
        CASE EXT.KEY = 'D'
          GOSUB LEFT
        CASE EXT.KEY = 'A'
          RTN=1
          EXIT.FLAG=TRUE
        CASE EXT.KEY = 'B'
          RTN=2
          EXIT.FLAG=TRUE
      END CASE
  END CASE
RETURN ; * From ESC key
*
BACK.WORD:
  * Shift tab pressed - go back a word
  IF CH.PTR = 1 THEN
    PRINT BEEP:
  END ELSE
    * 2 situations - either we're in a word already or
    * we're at the start of a word
    * If in a word - loop to the start of the word
    * otherwise skip spaces, and then move to start of word
    IF XXDATA[CH.PTR-1,1] # SPC THEN
      LOOP
      UNTIL XXDATA[CH.PTR-1,1] = SPC OR CH.PTR = 1 DO
        CH.PTR = CH.PTR - 1
        CP = CP - 1
      REPEAT
    END ELSE
      * Skip spaces
      LOOP
      UNTIL XXDATA[CH.PTR-1,1] # SPC OR CH.PTR = 1 DO
        CH.PTR = CH.PTR - 1
        CP = CP - 1
      REPEAT
      IF CH.PTR > 1 THEN
        * At word end - move to start of word
        LOOP
        UNTIL XXDATA[CH.PTR-1,1] = SPC OR CH.PTR = 1 DO
          CH.PTR = CH.PTR - 1
          CP = CP - 1
        REPEAT
      END
    END
    IF CP < 0 THEN
      CP = 0
      POS = CH.PTR
      PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
    END
  END
RETURN
*
DEL.TO.END:
  * Delete from cursor to end of line
  IF CH.PTR = 1 THEN
    XXDATA = ''
    CP = 0
    POS = 1
  END ELSE
    XXDATA = XXDATA[1,CH.PTR-1]
  END
  CURR.LEN = LEN(XXDATA)
  PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
RETURN
*
DELETE.WORD:
  * Delete to space at right of cursor
  IF CH.PTR >= CURR.LEN THEN
    PRINT BEEP:
  END ELSE
    C = CH.PTR
    LOOP
      C = C + 1
    UNTIL XXDATA[C,1] = SPC OR C = CURR.LEN DO
    REPEAT
    XXDATA = XXDATA[1,CH.PTR-1]:XXDATA[C+1,CURR.LEN]
    CURR.LEN = CURR.LEN - C + CH.PTR - 1
    PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
  END
RETURN
*
GO.BEGIN:
  * Go to the start of data and redisplay
  CP = 0
  CH.PTR = 1
  POS = 1
  PRINT BASE:XXDATA MASK:
RETURN
*
GO.END:
  * Move to the end of data and redisplay
  IF XXDATA[CURR.LEN,1] # SPC THEN
    XXDATA = XXDATA:SPC
    CURR.LEN = CURR.LEN + 1
  END
  IF CURR.LEN < DISP.LEN THEN
    CP = CURR.LEN - 1
    POS = 1
  END ELSE
    CP = DISP.LEN - 1
    POS = CURR.LEN - DISP.LEN + 1
  END
  CH.PTR = CURR.LEN
  PRINT BASE:XXDATA[POS,DISP.LEN] MASK:
RETURN
*
ATB.FIND:
  OPEN "IL.TB.CHNG.LOG" TO IL.TB.CHNG.LOG ELSE STOP 201,"IL.TB.CHNG.LOG"
  OPEN "IL.CHANGE.LOG.INDEX" TO IL.CHANGE.LOG.INDEX ELSE STOP 201,"IL.CHANGE.LOG.INDEX"
  OPEN "REV.ATB.LOG" TO REV.ATB.LOG ELSE STOP 201,"REV.ATB.LOG"
  OPEN "HELP.TEXT.USA" TO HELP.TEXT.USA ELSE STOP 201,"HELP.TEXT.USA"
  MSK="L#22"
  ATB = FIELD(ANS," ",2)
  *
  IF ATB="" THEN
    PRINT "ENTER ATB NAME: ": ; INPUT ATB
    IF ATB="" OR ATB="/" THEN RETURN
  END
  *
  READ AREC FROM REV.ATB.LOG,ATB ELSE
    ATBREC="" ; TEST=""
    EXEC.LINE=\SSELECT REV.ATB.LOG = "[\:ATB:\]"\
    GOSUB EXEC.SUB
    CTR=0
    LOOP
      READNEXT ID ELSE EXIT
      CTR+=1
      PRINT CTR "L#4":ID
      ATBREC<CTR>=ID
      IF MOD(CTR,23)=0 THEN PRINT "[ENTER]": ; INPUT TEST
      IF TEST = "/" THEN EXIT
    REPEAT
    PRINT
    PRINT "Enter choice (1-":CTR:"): ": ; INPUT CHOICE
    IF CHOICE="" OR CHOICE="/" THEN RETURN
    ATB=ATBREC<CHOICE>
    IF ATB="" THEN RETURN
    READ AREC FROM REV.ATB.LOG,ATB ELSE PRINT 'Not found' ; RETURN
  END
  *
  MAXV=DCOUNT(AREC<5>,@VM)
  FNAMES=""
  FOR J=1 TO MAXV
    IF AREC<5,J>[1,2] # "BK" THEN FNAMES :=AREC<5,J>:",":AREC<6,J>:"  "
  NEXT J
  *
  READV CKEY FROM IL.CHANGE.LOG.INDEX,AREC<24>,1 ELSE CKEY=""
  READ CHNG_REC FROM IL.TB.CHNG.LOG,CKEY ELSE CHNG_REC=""
  READ HELP.TEXT FROM HELP.TEXT.USA,ATB ELSE HELP.TEXT= " NOT FOUND"
  CONVERT "~" TO "" IN HELP.TEXT
  DEP=AREC<16>
  CONVERT @VM TO "," IN DEP
  PRINT ATB
  PRINT
  PRINT "IL.BPI" MSK               :AREC<1>
  PRINT "FILE(S)" MSK              :FNAMES
  PRINT "FIELD" MSK                :AREC<2>
  PRINT "CHANGE LOG INDEX" MSK     :AREC<24>
  PRINT "CHANGE LOG KEY" MSK       :CKEY
  PRINT "TYPE" MSK                 :AREC<3>
  PRINT "MASK" MSK                 :AREC<10>
  PRINT "S/MV" MSK                 :AREC<14>
  PRINT "CONTROLLING/DEPENDENT" MSK:AREC<15>
  PRINT "SUB/MASTER FIELDS" MSK    :DEP
  PRINT "CHG DESCRIPTION" MSK      :CHNG_REC<1>
  IF AREC<32> # "" THEN
    PRINT "COMMENTS" MSK           :AREC<32>
    PRINT
  END
  PRINT
  MAXV=DCOUNT(HELP.TEXT<2>,@VM)
  FOR J=1 TO MAXV
    PRINT HELP.TEXT<2,J>
  NEXT J
RETURN
*
GET.TERM.WIDTH:
  T='/tmp/':@LOGNAME:'.term'
  EXEC.LINE=\!tput cols > \:T ;* Always returns 80 if you capture, so use tmp file
  CAP.ACTIVE=FALSE
  GOSUB EXEC.SUB
  EXEC.LINE=\!cat \:T
  CAP.ACTIVE=TRUE
  GOSUB EXEC.SUB
  TERM.WIDTH=EXEC.CAP<1>
  EXEC.LINE=\!rm \:T
  GOSUB EXEC.SUB
  EXEC.LINE=\TERM \:TERM.WIDTH ; GOSUB EXEC.SUB
RETURN
*
PICKLE:
  PICKLE.LIST=''
  *
  IF FIELD(ANS,' ',2)='DICT' THEN
    FILE='DICT ':FIELD(ANS,' ',3)
    ITEM=FIELD(ANS,' ',4)
  END ELSE
    FILE=FIELD(ANS,' ',2)
    ITEM=FIELD(ANS,' ',3)
  END
  OPEN FILE TO FVAR ELSE
    PRINT 'Cannot open ':FILE
    RETURN
  END
  READ REC FROM FVAR, ITEM ELSE
    PRINT 'Cannot read ':FILE:' ':ITEM
    RETURN
  END
  BLOB='R=""'
  IF FILE[1,5]='DICT ' THEN DEL REC<9> ; DEL REC<8> ;* Avoid CD probs
  INS ITEM BEFORE REC<1>
  INS FILE BEFORE REC<1>
  SWAP @AM WITH '#AM#' IN REC   ; SWAP @VM WITH '#VM#' IN REC
  SWAP @SVM WITH '#SVM#' IN REC ; SWAP '\' WITH '#134#' IN REC
  BLOB<-1>=\S=''\
  LOOP
    T=REC[1,70]
    BLOB<-1>='S:=\':T:'\'
    REC=REC[71,LEN(REC)]
  UNTIL LEN(REC)=0 DO
  REPEAT
  BLOB<-1>='R<-1>=S'
  BLOB<-1>='*'
  *
  * Write out basic code that when run will recreate the record
  BLOB<-1>='FOR F=1 TO DCOUNT(R,@AM)'
  BLOB<-1>='  REC=R<F>'
  BLOB<-1>='  SWAP "#AM#" WITH @AM IN REC   ; SWAP "#VM#" WITH @VM IN REC'
  BLOB<-1>='  SWAP "#SVM#" WITH @SVM IN REC ; SWAP "#134#" WITH "\" IN REC'
  BLOB<-1>='  FILE=REC<1> ; DEL REC<1>'
  BLOB<-1>='  ITEM=REC<1> ; DEL REC<1>'
  BLOB<-1>='  PRINT FILE:" ":ITEM:'
  BLOB<-1>='  OPEN FILE TO FVAR ELSE STOP 201, FILE'
  BLOB<-1>='  WRITE REC ON FVAR,ITEM ; PRINT "*"'
  BLOB<-1>='  CLOSE FVAR'
  BLOB<-1>='NEXT F'
  FOR I=1 TO DCOUNT(BLOB,@AM)
    PRINT BLOB<I>
  NEXT I
RETURN
*
SETTINGS:
  PRINT CS:
  PRINT 'COMMAND.SEP  = ':SETTINGS<1>
  PRINT 'STACK.CHAR   = ':SETTINGS<2>
  PRINT 'PROG.CHAR    = ':SETTINGS<3>
  PRINT 'MAX.STACK    = ':SETTINGS<4>
  PRINT 'WP.VERB      = ':SETTINGS<5>
  PRINT 'ED.VERB      = ':SETTINGS<6>
  PRINT 'STAMP.STRING = ':SETTINGS<7>
  PRINT 'GET.LINE.FLAG= ':SETTINGS<8>
  PRINT 'WORK.FILE    = ':SETTINGS<9>
  PRINT 'MCU.ON       = ':SETTINGS<10>
  PRINT 'STARTUP      = ':SETTINGS<11>
  PRINT 'PROMT        = ':SETTINGS<12>
  PRINT 'X.DISP       = ':SETTINGS<13>
  PRINT 'DEF.SHELL    = ':SETTINGS<14>
  PRINT ; PRINT 'Hit ENTER to accept the current default, / to Cancel'
  X=18
  LEN=30
  DISP.LEN=30
  *
  PRINT
  PRINT 'The command seperator is used to run multiple commands from one entry'
  PRINT 'E.g. COUNT VOC ; COUNT VOC WITH F1 = "C" will run both count commands'
  PRINT 'Current value:':SETTINGS<1>
  PRINT 'COMMAND SEPERATOR:':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<1>
  SETTINGS<1>=ENTRY
  *
  PRINT
  PRINT 'The stack character is what to prefix command stack operations with'
  PRINT 'E.g. .L or .R87 or .D uses a stack character of "."'
  PRINT 'Current value:':SETTINGS<2>
  PRINT 'STACK CHAR       :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<2>
  SETTINGS<2>=ENTRY
  *
  PRINT
  PRINT 'The program character is what to prefix program stack operations with'
  PRINT 'E.g. /W2 or /B3 or /L uses a program character of "/"'
  PRINT 'Current value:':SETTINGS<3>
  PRINT 'PROG CHAR        :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<3>
  SETTINGS<3>=ENTRY
  *
  PRINT
  PRINT 'Max lines is the maximum number of lines to hold in the command stack'
  PRINT 'E.g. 9999'
  PRINT 'Current value:':SETTINGS<4>
  PRINT 'MAX # LINES      :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<4>
  SETTINGS<4>=ENTRY
  *
  PRINT
  PRINT 'Screen editor is what command to run to edit a program visually'
  PRINT 'E.g. VI or !emacs or !/home/dsiroot/joe'
  PRINT 'Current value:':SETTINGS<5>
  PRINT 'SCREEN EDITOR    :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<5>
  SETTINGS<5>=ENTRY
  *
  PRINT
  PRINT 'Line editor is what command to run to edit a program'
  PRINT 'E.g. AE or ED'
  PRINT 'Current value:':SETTINGS<6>
  PRINT 'LINE EDITOR      :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<6>
  SETTINGS<6>=ENTRY
  *
  PRINT
  PRINT 'Header string is not currently used'
  PRINT 'HEADER STRING    :':SETTINGS<7>
  *
  PRINT
  PRINT 'Use enhanced input commands, allowing editing with arrow keys'
  PRINT 'Or just use plain INPUT command'
  PRINT 'Current value:':SETTINGS<8>
  PRINT 'USE GET.LINE SUBR:':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<8>
  IF ENTRY='Y' OR ENTRY='1' THEN ENTRY='1' ELSE ENTRY='0'
  SETTINGS<8>=ENTRY
  *
  PRINT
  PRINT 'Default file for basic programs if none specifed'
  PRINT 'E.g. BP'
  PRINT 'Current value:':SETTINGS<9>
  PRINT 'WORK FILE        :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<9>
  SETTINGS<9>=ENTRY
  *
  PRINT
  PRINT 'Convert commands to upper case before running'
  PRINT 'E.g. 1 or 0, Y or N'
  PRINT 'Current value:':SETTINGS<10>
  PRINT 'CONVERT TO UCASE :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<9>
  IF ENTRY='Y' OR ENTRY='1' THEN ENTRY='1' ELSE ENTRY='0'
  SETTINGS<9>=ENTRY
  *
  PRINT
  PRINT 'Command to run when stack first starts'
  PRINT 'E.g. LISTUSER ; WHO'
  PRINT 'Current value:':SETTINGS<11>
  PRINT 'STARTUP COMMAND  :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<11>
  SETTINGS<11>=ENTRY
  *
  PRINT
  PRINT 'Default Prompt to display, use .P to change this'
  PRINT 'PROMPT           :':SETTINGS<12>
  PRINT
  PRINT 'Adjustment for input position (if you use #R, then CR+LF is inserted,'
  PRINT 'and an adjustment of -2 is needed.  Use .P to change this'
  PRINT 'X DISP FOR PROMPT:':SETTINGS<13>
  *
  PRINT
  PRINT 'Default shell to use with !command'
  PRINT 'E.g. ksh, bash, /usr/bin/ksh, /opt/freeware/bin/bash'
  PRINT 'Current value:':SETTINGS<14>
  PRINT 'SHELL            :':
  INPUT ENTRY
  IF ENTRY = '/' THEN RETURN
  IF ENTRY = ''  THEN ENTRY=SETTINGS<14>
  SETTINGS<14>=ENTRY
  *
  WRITE SETTINGS ON HOME.F, SETTING.ITEM
RETURN
*
LISTA:
  OPEN 'ACC' TO ACC.F ELSE STOP 201,'ACC'
  OPEN 'INFO.STATUS' TO INFO.STATUS ELSE STOP 201,'INFO.STATUS'
  SELECT ACC.F
  USER.LIST=''
  LOOP
    READNEXT PORT ELSE EXIT
    READ REC FROM ACC.F, PORT THEN
      READ MENU FROM INFO.STATUS, PORT'R%3' ELSE MENU='TCL'
      MENU=MENU<DCOUNT(MENU,@AM)> ;* Show the last item
      USER=REC<5>
      DATE=REC<2>
      TIME=REC<3>
      LOCATE PORT IN USER.LIST<4> BY 'AR' SETTING POS ELSE NULL
      INS USER BEFORE USER.LIST<1,POS>
      INS DATE BEFORE USER.LIST<2,POS>
      INS TIME BEFORE USER.LIST<3,POS>
      INS PORT BEFORE USER.LIST<4,POS>
      INS MENU BEFORE USER.LIST<5,POS>
    END
  REPEAT
  *GET.LOCKS
  LOCK.LIST=''
  FLIST=''
  FLIST<-1>='AS.FEATURE'
  FLIST<-1>='AS.MASTER'
  FLIST<-1>='AUVB.PARAMETER'
  FLIST<-1>='BQ.PARAMETER'
  FLIST<-1>='CS.MASTER'
  FLIST<-1>='DATA.MASKING.PARAMETER'
  FLIST<-1>='DB.RECORD.LOCKS'
  FLIST<-1>='DE.MASTER'
  FLIST<-1>='FIELD.SECURITY'
  FLIST<-1>='INFO-SYSTEM'
  FLIST<-1>='IT.INSURANCE'
  FLIST<-1>='IT.INSURANCE.AGENT'
  FLIST<-1>='LS.BANK.DEPOSIT'
  FLIST<-1>='LS.DISCOUNT.PACKAGE'
  FLIST<-1>='LS.DISCOUNT.WORKSHEET'
  FLIST<-1>='LS.GL.HISTORY'
  FLIST<-1>='LS.MASTER'
  FLIST<-1>='LS.POST.DATED.CHECK'
  FLIST<-1>='LS.SUPER.QUOTE'
  FLIST<-1>='LS.WK.CASH'
  FLIST<-1>='MISC'
  FLIST<-1>='MM.GROUP'
  FLIST<-1>='PARAMETER'
  FLIST<-1>='PROCESSOR.PARAMETER'
  FLIST<-1>='TRED.FUTURE.PROC.DATES'
  FLIST<-1>='USERS.MENUS'
  FLIST<-1>='WL.FOLLOW.UP'
  FLIST<-1>='WL.PARAMETER'
  *
  FOR G=1 TO DCOUNT(FLIST,@AM)
    FILE='DB.RECORD.LOCKS,':FLIST<G>
    OPEN FILE TO FVAR THEN
      SELECT FVAR
      LOOP
        READNEXT LOCK.ID ELSE EXIT
        READ REC FROM FVAR, LOCK.ID THEN
          PORT=REC<1>
          DATE=REC<2>
          TIME=REC<3>
          USER=REC<4>
          LOCK.LIST<1,-1>=FILE
          LOCK.LIST<2,-1>=LOCK.ID
          LOCK.LIST<3,-1>=PORT
          LOCK.LIST<4,-1>=DATE
          LOCK.LIST<5,-1>=TIME
          LOCK.LIST<6,-1>=USER
          LOCATE PORT IN USER.LIST<4> SETTING POS THEN
            USER.LIST<6,POS>=LOCK.ID:',':USER.LIST<6,POS>
          END
        END
      REPEAT
      CLOSE FVAR
    END
  NEXT G
  *
  PRINT @(-1):'USERS'
  PRINT
  PRINT 'Port':' ':'User''L#12':' ':'Date''L#10':' ':'Time''L#8':' ':
  PRINT 'Time On''L#8':' ':'Menu''L#30':' ':'L'
  PRINT '----':' ':STR('-',12):' ':STR('-',10):' ':STR('-',8):' ':
  PRINT STR('-',8):' ':STR('-',30):' ':'-'
  FOR F=1 TO DCOUNT(USER.LIST<1>,@VM)
    DUR=TIME()-USER.LIST<3,F>
    IF DUR<0 THEN DUR+=86400 ;* Roll over midnight, add back number of seconds in a day
    PRINT USER.LIST<4,F>'R#4':' ':
    PRINT USER.LIST<1,F>'L#12':' ':
    PRINT USER.LIST<2,F>'D4/':' ':
    PRINT USER.LIST<3,F>'MTS':' ':
    PRINT DUR'MTS':' ':
    PRINT USER.LIST<5,F>'L#30':' ':
    IF USER.LIST<6,F>#'' THEN PRINT '*' ELSE PRINT ' '
  NEXT F
  *
  PRINT
  PRINT 'LOCKS'
  PRINT
  PRINT 'Table''L#20':' ':'ID''L#25':' ':'Port''L#4':' ':
  PRINT 'Date''L#5':' ':'Time''L#5':' ':'User''L#15'
  PRINT STR('-',20):' ':STR('-',25):' ':STR('-',4):' ':
  PRINT STR('-',5):' ':STR('-',5):' ':STR('-',15)
  FOR L=1 TO DCOUNT(LOCK.LIST<1>,@VM)
    FILE=FIELD(LOCK.LIST<1,L>,',',2)
    PRINT FILE'L#20':' ':LOCK.LIST<2,L>'L#25':' ':LOCK.LIST<3,L>'R#4':' ':
    PRINT (LOCK.LIST<4,L>'D4/')[1,5]:' ':LOCK.LIST<5,L>'MT':' ':LOCK.LIST<6,L>'L#15'
  NEXT L
  *
  CLOSE ACC.F
  CLOSE INFO.STATUS
  *
RETURN
*
SEARCH.BY.EXAMPLE:
  * Calculate all possible ATB's for an example contract
  @ID=ID
  IF FILE='' OR @ID='' THEN
    PRINT 'Usage: SE <FNAME> <ID>'
    RETURN
  END
  OPEN FILE TO F ELSE PRINT 'Cannot open ':FILE ; RETURN
  OPEN "DICT ":FILE TO @DICT ELSE PRINT 'Cannot open DICT ':FILE ; RETURN
  READ @RECORD FROM F, @ID ELSE PRINT 'Cannot read ':@ID:' in ':FILE ; RETURN
  CLOSE F
  OUTPUT=''
  EXECUTE \SSELECT DICT \:FILE:\ WITH F1 = "I" USING DICT VOC\
  LOOP
    READNEXT FLD ELSE EXIT
    PRINT FLD:'=':
    VAL=CALCULATE(FLD)
    PRINT VAL
    IF @CONV # '' THEN VAL=OCONV(VAL,@CONV)
    *OUTPUT<-1>=FLD:'=':VAL
  REPEAT
  WRITE OUTPUT ON VOC, 'OUTPUT.TMP'
  EXECUTE \AE VOC OUTPUT.TMP\
RETURN
*
IL10.XREF:
  FILE.NAME = FIELD(ANS,' ',2)
  FIELD.NAME = FIELD(ANS,' ',3)
  SELECT.HDR=\BPI,FILE_NAME,FIELD_NAME,STRING_POS,TABLE_NAME,COLUMN_NAME,VALUE_TYPE,FIELD_TYPE\
  SELECT.COMMAND = \SELECT\
  SELECT.COMMAND := \ BPI, FILE_NAME, FIELD_NAME, STRING_POS, TABLE_NAME, COLUMN_NAME, VALUE_TYPE, FIELD_TYPE\
  IF INDEX(FILE.NAME,'%',1) THEN
    SELECT.COMMAND := \ FROM METADATA_FIELDS WHERE (FILE_NAME LIKE '\:FILE.NAME:\' OR TABLE_NAME LIKE '\:FILE.NAME:\')\
  END ELSE
    SELECT.COMMAND := \ FROM METADATA_FIELDS WHERE (FILE_NAME = '\:FILE.NAME:\' OR TABLE_NAME = '\:FILE.NAME:\')\
  END
  IF FIELD.NAME # '' THEN SELECT.COMMAND :=\ AND FIELD_NAME LIKE '%\:FIELD.NAME:\%'\
  SELECT.COMMAND := \ ORDER BY FILE_NAME, STRING_POS\
  *
  GOSUB IL10.SEL
RETURN
*
IL10.AF:
  FLD = FIELD(ANS,' ',2)
  SELECT.HDR=\BPI,FILE_NAME,FIELD_NAME,MV_POS,TABLE_NAME,COLUMN_NAME,MV/S,TYPE,LEN,SCALE\
  SELECT.COMMAND = \SELECT BPI,FILE_NAME,FIELD_NAME,STRING_POS,TABLE_NAME,COLUMN_NAME,VALUE_TYPE,FIELD_TYPE,FIELD_LENGTH,SCALE\
  SELECT.COMMAND  :=\ FROM METADATA_FIELDS\
  SELECT.COMMAND  :=\ WHERE FIELD_NAME LIKE '%\:FLD:\%' OR COLUMN_NAME LIKE '%\:FLD:\%'\
  GOSUB IL10.SEL
RETURN
*
IL10.DESC:
  TABLE = FIELD(ANS,' ',2)
  SELECT.HDR=\COL,COLUMN_NAME,DATA_TYPE\
  SELECT.COMMAND = \SELECT ORDINAL_POSITION, COLUMN_NAME, DATA_TYPE FROM INFORMATION_SCHEMA.COLUMNS\
  SELECT.COMMAND:= \ WHERE TABLE_NAME = '\:TABLE:\'\
  GOSUB IL10.SEL
RETURN
*
IL10.NSEL:
  PRMT=1
  EXECLINE='SELECT ':FIELD(ANS,' ',2,999)
  CALL EXECUTE.SELECT.SUB(EXECLINE,ERR.MSG,1,'',0,SELECTED.LIST,1,'',0,'',0,0)
  CTR=0
  LOOP
    READNEXT ID FROM SELECTED.LIST ELSE EXIT
    CTR+=1
    CRT CTR'R#6':') ':ID
    IF CTR/20=INT(CTR/20) AND PRMT THEN
      CRT ':':
      INPUT AAA
      IF AAA = '/' OR AAA='Q' THEN STOP
      IF AAA = 'N' THEN PRMT=0
    END
  REPEAT
RETURN
*
SQL.SEL:
  SELECT.HDR=''
  SELECT.COMMAND=FIELD(ANS,' ',2,200)
  GOSUB IL10.SEL
RETURN
*
SQL.FILE:
  SELECT.HDR=''
  FILE=FIELD(ANS,' ',2) ;* Spaces in file name are not supported
  OSREAD SELECT.COMMAND FROM FILE THEN
  CONVERT @AM TO ' ' IN SELECT.COMMAND
  SWAP CHAR(13):CHAR(10) WITH ' ' IN SELECT.COMMAND
  GOSUB IL10.SEL
END ELSE
  CRT FILE:' not found'
END
RETURN
*
SQL.SEL.LIST:
  LIST=FIELD(ANS,' ',2)
  SELECT.COMMAND=FIELD(ANS,' ',3,200)
  PRINT SELECT.COMMAND
  PARAM=''
  CALL IDS.EXECUTE.ANSI.SQL(SELECT.COMMAND,PARAM,'','',KEY.LIST)
  CALL CONVERT.LIST(KEY.LIST)
  EXECUTE \SAVE.LIST \:LIST PASSLIST KEY.LIST
RETURN
*
IL10.SEL:
  PARAM=''
  CONVERT ',' TO @VM IN SELECT.HDR
  PRINT SELECT.COMMAND
  CALL IDS.EXECUTE.ANSI.SQL(SELECT.COMMAND,PARAM,'','',KEY.LIST)
  *SUBROUTINE IDS.EXECUTE.ANSI.SQL.ERROR(SQL.STRING, PARAMS, COLUMNS, TYPES, RESULTS.ARRAY, ERROR, OFFSET, LIMIT, SORT.COLUMN, ENHANCE, ALTER.SESSION,TRANSFER.CONTRACT)
  CALL IDS.EXECUTE.ANSI.SQL.ERROR(SELECT.COMMAND, PARAM, '', '', KEY.LIST, ERR, '', '', '', '0', '','')
  DISP.MAX=DCOUNT(KEY.LIST,@AM)
  PRINT DISP.MAX:' items selected, ERR=':ERR
  IF DISP.MAX=0 THEN RETURN
  *
  * Get widths
  W=''
  IF SELECT.HDR # '' THEN
    INS SELECT.HDR BEFORE KEY.LIST<1>
    DISP.MAX+=1
  END
  FOR R=1 TO DISP.MAX
    FOR C=1 TO DCOUNT(KEY.LIST<R>,@VM)
      L=LEN(KEY.LIST<R,C>)
      IF L > W<C> THEN W<C>=L
    NEXT C
  NEXT R
  *
  * Print the header
  DISP.START=1
  IF SELECT.HDR # '' THEN
    DISP.START=2
    FOR C=1 TO DCOUNT(KEY.LIST<1>,@VM)
      PRINT FMT(KEY.LIST<1,C>,'L#':W<C>):' ':
    NEXT C
    PRINT
    *
    FOR C=1 TO DCOUNT(KEY.LIST<1>,@VM)
      PRINT STR('-',W<C>):' ':
    NEXT C
    PRINT
  END
  * Now the data
  FOR R=DISP.START TO DISP.MAX
    IF SELECT.HDR = '' THEN CRT R,:
    FOR C=1 TO DCOUNT(KEY.LIST<R>,@VM)
      PRINT FMT(KEY.LIST<R,C>,'L#':W<C>):' ':
    NEXT C
    PRINT
  NEXT R
RETURN
*
LIST.PARAM:
  P=''
  P<1,-1>=STR('-', 18)         ; P<2,-1>=STR('-',33)                         ; P<3,-1>=STR('-',30)
  P<1,-1>='Key Prefix'         ; P<2,-1>='InfoLease Table'                   ; P<3,-1>='RDBMS Table'
  P<1,-1>=STR('-', 18)         ; P<2,-1>=STR('-',33)                         ; P<3,-1>=STR('-',30)
  P<1,-1>='*00'                ; P<2,-1>='Lessor Parameters'                 ; P<3,-1>='LESSOR_NF'
  P<1,-1>='*00A'               ; P<2,-1>='Temporary Lessor'                  ; P<3,-1>='TEMP_LESSOR_NF'
  P<1,-1>='*00B'               ; P<2,-1>='Additional Lessor'                 ; P<3,-1>='ADDL_LESSOR_NF'
  P<1,-1>='*00GL'              ; P<2,-1>='Multiple Bookset'                  ; P<3,-1>='MULTIPLE_BOOKSET_NF'
  P<1,-1>='*00UD'              ; P<2,-1>='Lessor User-Defined'               ; P<3,-1>='LESSOR_USER_NF'
  P<1,-1>='*ACH'               ; P<2,-1>='Lessor ACH Flags'                  ; P<3,-1>='LESSOR_ACH_FLAGS_NF'
  P<1,-1>='*ADVICE*'           ; P<2,-1>='Advice Follow-up'                  ; P<3,-1>='ADVICE_FOLLOW_UP_NF'
  P<1,-1>='*COMMISSION'        ; P<2,-1>='Commission'                        ; P<3,-1>='COMMISSION_NF'
  P<1,-1>='*WARNING.MESSAGES'  ; P<2,-1>='Lessor Warning Messages'           ; P<3,-1>='LESSOR_WARNING_MESSAGES_NF'
  P<1,-1>='[Lessor Id]'        ; P<2,-1>='Lessor Address'                    ; P<3,-1>='LS_ADDRESS_NF'
  P<1,-1>='00*00'              ; P<2,-1>='Lease System Parameters'           ; P<3,-1>='PARAMETER_NF'
  P<1,-1>='00*00A'             ; P<2,-1>='Temporary Lease System Params'     ; P<3,-1>='TEMP_PARAMETER_NF'
  P<1,-1>='00*00B'             ; P<2,-1>='Additional Lease System Params'    ; P<3,-1>='ADDL_PARAMETER_NF'
  P<1,-1>='00*00IRR'           ; P<2,-1>='IRR Parameter'                     ; P<3,-1>='IRR_PARAMETER_NF'
  P<1,-1>='00*00RPT'           ; P<2,-1>='Report Parameter'                  ; P<3,-1>='RPT_PARAMETER_NF'
  P<1,-1>='10*'                ; P<2,-1>='Personnel'                         ; P<3,-1>='PERSONNEL_INFO_NF'
  P<1,-1>='12*'                ; P<2,-1>='Office'                            ; P<3,-1>='OFFICE_DATA_NF'
  P<1,-1>='13*'                ; P<2,-1>='Vendor/Dealer'                     ; P<3,-1>='PARAM_ADDRESS_NF'
  P<1,-1>='13APA*'             ; P<2,-1>='Additional Vendor/Dealer Address'  ; P<3,-1>='ADDL_PARAM_ADDRESS_NF'
  P<1,-1>='14*'                ; P<2,-1>='Reason Code'                       ; P<3,-1>='REASON_CODE_NF'
  P<1,-1>='15*'                ; P<2,-1>='Collateral Code'                   ; P<3,-1>='TB_COLLATERAL_NF'
  P<1,-1>='16*'                ; P<2,-1>='Equipment Category'                ; P<3,-1>='EQUIP_CODE_DEFAULTS_NF'
  P<1,-1>='17*'                ; P<2,-1>='Tax Description'                   ; P<3,-1>='TAX_DESC_TBL_NF'
  P<1,-1>='18*'                ; P<2,-1>='Property Tax Status'               ; P<3,-1>='PROP_TAX_STATUS_TBL_NF'
  P<1,-1>='19*'                ; P<2,-1>='Region'                            ; P<3,-1>='REGION_TABLE_NF'
  P<1,-1>='20*'                ; P<2,-1>='Remit To'                          ; P<3,-1>='REMIT_ADDRESS_NF'
  P<1,-1>='21*'                ; P<2,-1>='Base Rate Indicator'               ; P<3,-1>='FLOAT_BANK_NF'
  P<1,-1>='22*'                ; P<2,-1>='Broker Address'                    ; P<3,-1>='BROKER_TABLE_NF'
  P<1,-1>='23*'                ; P<2,-1>='General Ledger Account'            ; P<3,-1>='GL_ACCT_TABLE_NF'
  P<1,-1>='24*'                ; P<2,-1>='Branch'                            ; P<3,-1>='BRANCH_DATA_NF'
  P<1,-1>='26*'                ; P<2,-1>='Department'                        ; P<3,-1>='DEPARTMENT_NF'
  P<1,-1>='27*'                ; P<2,-1>='Business'                          ; P<3,-1>='TB_BUSINESS_NF'
  P<1,-1>='28*'                ; P<2,-1>='Program Type'                      ; P<3,-1>='PROG_TYPE_DEFAULTS_NF'
  P<1,-1>='29*'                ; P<2,-1>='Payment Plan'                      ; P<3,-1>='TB_PAYMENT_PLAN_NF'
  P<1,-1>='30*'                ; P<2,-1>='Promotion'                         ; P<3,-1>='PROMOTION_TBL_NF'
  P<1,-1>='31*'                ; P<2,-1>='Account Type'                      ; P<3,-1>='TB_ACCT_TYPE_NF'
  P<1,-1>='32*'                ; P<2,-1>='Business Type'                     ; P<3,-1>='TB_BUSINESS_TYPE_NF'
  P<1,-1>='33*'                ; P<2,-1>='Application Status'                ; P<3,-1>='TB_STATUS_NF'
  P<1,-1>='34*'                ; P<2,-1>='Disposition Payment Type'          ; P<3,-1>='TB_DISP_PAYMENT_TYPE_NF'
  P<1,-1>='35*'                ; P<2,-1>='Disposition/Inventory'             ; P<3,-1>='DISP_INVENT_TABLE_NF'
  P<1,-1>='36*'                ; P<2,-1>='Bank Additional User-Defined'      ; P<3,-1>='AUS_BANKS_NF'
  P<1,-1>='39*'                ; P<2,-1>='Product Line'                      ; P<3,-1>='PROD_LINE_DEFAULTS_NF'
  P<1,-1>='40*'                ; P<2,-1>='Insurance Type'                    ; P<3,-1>='TB_INSURANCE_TYPE_NF'
  P<1,-1>='41*'                ; P<2,-1>='Insurance Status'                  ; P<3,-1>='TB_INSURANCE_STATUS_NF'
  P<1,-1>='42*'                ; P<2,-1>='Contract Status'                   ; P<3,-1>='CONTRACT_STATUS_INFO_NF'
  P<1,-1>='43*'                ; P<2,-1>='Guaranteed Residual'               ; P<3,-1>='TB_GUARANTEED_RESIDUAL_NF'
  P<1,-1>='45*'                ; P<2,-1>='Country Code'                      ; P<3,-1>='COUNTRY_CODES_NF'
  P<1,-1>='ACTIVITY.DE*'       ; P<2,-1>='Activity (Inv. Interface)'         ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='ADDL.BUYOUT*'       ; P<2,-1>='Additional Buyout Info'            ; P<3,-1>='ADDL_BUYOUT_DEFAULT_NF'
  P<1,-1>='ADJ*'               ; P<2,-1>='Adjustment Code'                   ; P<3,-1>='ADJUSTMENT_CODE_TBL_NF'
  P<1,-1>='ADMIN*'             ; P<2,-1>='Administrative Code'               ; P<3,-1>='TB_ADMINISTRATIVE_CODE_NF'
  P<1,-1>='AP.INTERFACE*1'     ; P<2,-1>='API Parameters'                    ; P<3,-1>='API_PARAMETERS_NF'
  P<1,-1>='ASSET.DE*'          ; P<2,-1>='Asset (Inv. Interface)'            ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='ASSET.STATUS*'      ; P<2,-1>='Asset Status'                      ; P<3,-1>='TB_ASSET_STATUS_NF'
  P<1,-1>='ASSOCIATION*'       ; P<2,-1>='Association'                       ; P<3,-1>='ASSOC_REL_PARTY_NF'
  P<1,-1>='BANK*'              ; P<2,-1>='Bank Address'                      ; P<3,-1>='BANK_ADDRESS_NF'
  P<1,-1>='BANK.ADDL*'         ; P<2,-1>='Additional Bank Address'           ; P<3,-1>='ADDL_BANK_ADDRESS_NF'
  P<1,-1>='BI.TYPE*'           ; P<2,-1>='Blended Income Type'               ; P<3,-1>='TB_BLENDED_INCOME_TYPE_NF'
  P<1,-1>='BID*'               ; P<2,-1>='Blended Income Defaults'           ; P<3,-1>='BLENDED_INCOME_DEF_NF'
  P<1,-1>='BLENDED.INCOME*'    ; P<2,-1>='Blended Income Parameter'          ; P<3,-1>='BLENDED_INCOME_TBL_NF'
  P<1,-1>='BUS.PLAN*'          ; P<2,-1>='Business Plan'                     ; P<3,-1>='BUS_PLAN_DEFAULTS_NF'
  P<1,-1>='BUS.SEG*'           ; P<2,-1>='Business Segment'                  ; P<3,-1>='BUS_SEGMENT_NF'
  P<1,-1>='BUYOUT*'            ; P<2,-1>='Buyout Parameters'                 ; P<3,-1>='BUYOUT_DEFAULT_NF'
  P<1,-1>='CADDR.DE*'          ; P<2,-1>='Customer Address (Inv. Interface)' ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='CCA*'               ; P<2,-1>='CCA Class'                         ; P<3,-1>='CCA_CLASS_DEPR_NF'
  P<1,-1>='CHECK.TYPE*'        ; P<2,-1>='Check Type'                        ; P<3,-1>='CHECK_TYPE_NF'
  P<1,-1>='CHRG.DE*'           ; P<2,-1>='Charge Info (Inv. Interface)'      ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='CHRG.TYPE*'         ; P<2,-1>='Open Item Charge Types'            ; P<3,-1>='CHARGE_TYPE_TABLE_NF'
  P<1,-1>='CHRG.TYPE.INDEX*'   ; P<2,-1>='Open Item Charge Type Indexes'     ; P<3,-1>='CHARGE_TYPE_INDEX_NF'
  P<1,-1>='CNTC.DE*'           ; P<2,-1>='Contact (Inv. Interface)'          ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='CURRENCY*'          ; P<2,-1>='Currency Code'                     ; P<3,-1>='CURRENCY_CODES_NF'
  P<1,-1>='DEALER.DISTRICT*'   ; P<2,-1>='Dealer District'                   ; P<3,-1>='TB_DEALER_DISTRICT_NF'
  P<1,-1>='DEALER.PARAM*'      ; P<2,-1>='Dealer Parameter'                  ; P<3,-1>='DEALER_PARAM_NF'
  P<1,-1>='DEALER.REGION*'     ; P<2,-1>='Dealer Region'                     ; P<3,-1>='TB_DEALER_REGION_NF'
  P<1,-1>='DEALER.SALESMAN*'   ; P<2,-1>='Dealer Salesman'                   ; P<3,-1>='DLR_SALESMAN_NF'
  P<1,-1>='DEALER.SERIES*'     ; P<2,-1>='Dealer Series'                     ; P<3,-1>='TB_DEALER_SERIES_NF'
  P<1,-1>='DEALER.STATUS*'     ; P<2,-1>='Dealer Status'                     ; P<3,-1>='DEALER_STATUS_NF'
  P<1,-1>='DLR.RECOURSE*'      ; P<2,-1>='Dealer Recourse'                   ; P<3,-1>='TB_DEALER_RECOURSE_NF'
  P<1,-1>='EARLY.TERM.OPTION*' ; P<2,-1>='Early Term Option'                 ; P<3,-1>='TB_EARLY_TERM_OPTION_NF'
  P<1,-1>='ER*'                ; P<2,-1>='Exchange Rate'                     ; P<3,-1>='EXCHANGE_RATE_NF'
  P<1,-1>='FAC*'               ; P<2,-1>='Void Factura Reason'               ; P<3,-1>='TB_VOID_FACTURA_REASON_NF'
  P<1,-1>='FIN.CLASS*'         ; P<2,-1>='Finance Class'                     ; P<3,-1>='TB_FINANCE_CLASS_NF'
  P<1,-1>='FIN.PLAN*'          ; P<2,-1>='Finance Plan'                      ; P<3,-1>='TB_FINANCE_PLAN_NF'
  P<1,-1>='FOLLOW.UP*'         ; P<2,-1>='Follow Up'                         ; P<3,-1>='FOLLOW_UP_CODES_NF'
  P<1,-1>='GL.LINK.INDEX*'     ; P<2,-1>='General Ledger Link Index'         ; P<3,-1>='TB_GL_LINK_INDEX_NF'
  P<1,-1>='GROUP.MISC.CODES*'  ; P<2,-1>='Group Misc GL Codes'               ; P<3,-1>='GROUP_MISC_CODES_NF'
  P<1,-1>='HOLIDAY.TBL*'       ; P<2,-1>='Holiday/Weekend'                   ; P<3,-1>='HOLIDAY_WEEKEND_NF'
  P<1,-1>='IDC.DESC*'          ; P<2,-1>='IDC Description'                   ; P<3,-1>='TB_IDC_DESC_NF'
  P<1,-1>='INVOICE.FORMAT*'    ; P<2,-1>='Invoice Format'                    ; P<3,-1>='INVOICE_FORMAT_TABLE_NF'
  P<1,-1>='IP*'                ; P<2,-1>='Insurance Parameter'               ; P<3,-1>='INSURANCE_PARAMETER_NF'
  P<1,-1>='IRS.CAT*'           ; P<2,-1>='IRS Category/Tax'                  ; P<3,-1>='IRS_CAT_DEFAULTS_NF'
  P<1,-1>='ITP'                ; P<2,-1>='Insurance Tape Parameter'          ; P<3,-1>='INS_TAPE_PARAMETER_NF'
  P<1,-1>='L.NATIONALITY*'     ; P<2,-1>='Nationality'                       ; P<3,-1>='TB_NATIONALITY_NF'
  P<1,-1>='LANG*'              ; P<2,-1>='Language'                          ; P<3,-1>='TB_LANGUAGE_NF'
  P<1,-1>='LEGAL.S*'           ; P<2,-1>='Legal Status'                      ; P<3,-1>='TB_LEGAL_STATUS_NF'
  P<1,-1>='LESSEE.CONTACT*'    ; P<2,-1>='Lessee Contact Permitted'          ; P<3,-1>='TB_LESSEE_CONTACT_PERMIT_NF'
  P<1,-1>='LESSOR.SUB*'        ; P<2,-1>='Lessor Subsidiary'                 ; P<3,-1>='SUBSIDIARY_ADDRESS_NF'
  P<1,-1>='LKE.POOL*'          ; P<2,-1>='Like Kind Exchange Pool'           ; P<3,-1>='TB_LIKE_KIND_EXCHANGE_PO_NF'
  P<1,-1>='LOCAL.SIC.CODE*'    ; P<2,-1>='Local SIC Code'                    ; P<3,-1>='LOCAL_SIC_CODE_TBL_NF'
  P<1,-1>='LOCKBOX.PARAMS'     ; P<2,-1>='Lockbox Parameters'                ; P<3,-1>='LOCKBOX_PARAMETERS_NF'
  P<1,-1>='MILE.CAT*'          ; P<2,-1>='Mileage Category'                  ; P<3,-1>='TB_MILEAGE_CATEGORY_NF'
  P<1,-1>='MISC.PARAM*'        ; P<2,-1>='Miscellaneous Parameters'          ; P<3,-1>='MISC_PARAM_DEFAULTS_NF'
  P<1,-1>='MMR.ASSET.DE*'      ; P<2,-1>='MMR Asset (Inv. Interface)'        ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='MMR.ASSET.RATE.DE*' ; P<2,-1>='MMR Asset Rate (Inv. Interface)'   ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='MMR.CHRG.DE*'       ; P<2,-1>='MMR Charge (Inv. Interface)'       ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='NJS.FLAG'           ; P<2,-1>='NJS Flag'                          ; P<3,-1>='NJS_FLAG_NF'
  P<1,-1>='PAYMENT.STATUS*'    ; P<2,-1>='Payment Status'                    ; P<3,-1>='TB_PAYMENT_STATUS_NF'
  P<1,-1>='PAYMENT.TYPE*'      ; P<2,-1>='Payment Type'                      ; P<3,-1>='PYMT_TYPE_NF'
  P<1,-1>='PENDING.CODE*'      ; P<2,-1>='Pending Code'                      ; P<3,-1>='PENDING_CODE_TBL_NF'
  P<1,-1>='POLICY.STATUS*'     ; P<2,-1>='Policy Status'                     ; P<3,-1>='TB_POLICY_STATUS_NF'
  P<1,-1>='PROGRAM.CONTROL*'   ; P<2,-1>='Program Control'                   ; P<3,-1>='TB_PROGRAM_CONTROL_NF'
  P<1,-1>='PUR.OPT*'           ; P<2,-1>='Purchase Option'                   ; P<3,-1>='PURCHASE_OPTION_TABLE_NF'
  P<1,-1>='PURPOSE.LOAN*'      ; P<2,-1>='Purpose Of Loan'                   ; P<3,-1>='TB_PURPOSE_OF_LOAN_NF'
  P<1,-1>='PUT.TO*'            ; P<2,-1>='Put To'                            ; P<3,-1>='TB_PUT_TO_NF'
  P<1,-1>='QUOTE.BUYOUT*'      ; P<2,-1>='Quote Buyout'                      ; P<3,-1>='QUOTE_BUYOUT_TBL_NF'
  P<1,-1>='RCPT*'              ; P<2,-1>='Void Receipt Reason'               ; P<3,-1>='TB_VOID_RECEIPT_REASON_NF'
  P<1,-1>='RECOURSE*'          ; P<2,-1>='Recourse'                          ; P<3,-1>='TB_RECOURSE_CODE_NF'
  P<1,-1>='RECOVERY.STATUS*'   ; P<2,-1>='Recovery Status'                   ; P<3,-1>='TB_RECOVERY_STATUS_NF'
  P<1,-1>='RELATIONSHIP*'      ; P<2,-1>='Relationship'                      ; P<3,-1>='RELATIONSHIP_DATA_NF'
  P<1,-1>='REM.PUR.OPTION*'    ; P<2,-1>='Remarketing Purchase Option'       ; P<3,-1>='TB_REMARKETING_PURCHASE_NF'
  P<1,-1>='RENEWAL.OPTION*'    ; P<2,-1>='Renewal Option'                    ; P<3,-1>='RENEWAL_OPTION_NF'
  P<1,-1>='REPO.STATUS*'       ; P<2,-1>='Repossession Status'               ; P<3,-1>='REPOSSESSION_CODE_NF'
  P<1,-1>='RESERVE*'           ; P<2,-1>='Reserve Code'                      ; P<3,-1>='TB_RESERVE_CODE_NF'
  P<1,-1>='RESIDUAL.GUAR*'     ; P<2,-1>='Residual Guarantee'                ; P<3,-1>='TB_RESIDUAL_GUARANTEE_NF'
  P<1,-1>='RESIDUAL.OWNER*'    ; P<2,-1>='Residual Owner'                    ; P<3,-1>='TB_RESIDUAL_OWNER_NF'
  P<1,-1>='RESIDUAL.SHARING*'  ; P<2,-1>='Residual Sharing'                  ; P<3,-1>='TB_RESIDUAL_SHARING_NF'
  P<1,-1>='RESTOCKING.FEE*'    ; P<2,-1>='Restocking Fee Obligation'         ; P<3,-1>='TB_RESTOCK_FEE_OBLIGATIO_NF'
  P<1,-1>='RETURN.COSTS.PD*'   ; P<2,-1>='Return Costs Paid'                 ; P<3,-1>='TB_RETURN_COSTS_PAID_NF'
  P<1,-1>='REVS.PT*'           ; P<2,-1>='REVS Plate Type'                   ; P<3,-1>='TB_REVS_PLATE_TYPE_NF'
  P<1,-1>='REVS.ST*'           ; P<2,-1>='REVS State'                        ; P<3,-1>='TB_REVS_STATE_NF'
  P<1,-1>='SCAN.LINE.DE*'      ; P<2,-1>='Scan Line (Inv. Interface)'        ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='SCORE.DECISION*'    ; P<2,-1>='Credit Score Decision'             ; P<3,-1>='TB_CREDIT_SCORE_DECISION_NF'
  P<1,-1>='SCORE.STATUS*'      ; P<2,-1>='Credit Score Status'               ; P<3,-1>='CREDIT_SCORE_STATUS_NF'
  P<1,-1>='SCORING.CODE*'      ; P<2,-1>='Scoring Code'                      ; P<3,-1>='SCORING_CODE_NF'
  P<1,-1>='SEC.PARTY*'         ; P<2,-1>='Secure Party'                      ; P<3,-1>='LESSOR_SEC_PARTY_NF'
  P<1,-1>='SOURCE*'            ; P<2,-1>='Source'                            ; P<3,-1>='TB_SOURCE_NF'
  P<1,-1>='SPECIAL.INST*'      ; P<2,-1>='Special Instructions'              ; P<3,-1>='TB_SPECIAL_INSTRUCTIONS_NF'
  P<1,-1>='SPLIT.DE*'          ; P<2,-1>='Invoice Interface Data Elements'   ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='SSP'                ; P<2,-1>='System Security'                   ; P<3,-1>='SC_SECURE_PARAM_NF'
  P<1,-1>='UCC.STATE*'         ; P<2,-1>='Filing State'                      ; P<3,-1>='FILING_STATE_NF'
  P<1,-1>='UCC.STATUS*'        ; P<2,-1>='Filing Status'                     ; P<3,-1>='FILING_STATUS_TABLE_NF'
  P<1,-1>='UCC.TITLE.CODE*'    ; P<2,-1>='Filing Code'                       ; P<3,-1>='FILING_CODE_NF'
  P<1,-1>='UK.POOL*'           ; P<2,-1>='UK Pool'                           ; P<3,-1>='UK_POOL_NUM_NF'
  P<1,-1>='USG.ASSET.DE*'      ; P<2,-1>='Usage Asset (Inv. Interface)'      ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='USG.CHRG.DE*'       ; P<2,-1>='Usage Charge (Inv. Interface)'     ; P<3,-1>='INV_INT_DATA_ELEMENTS_NF'
  P<1,-1>='VLMAKE*'            ; P<2,-1>='Vehicle Make'                      ; P<3,-1>='TB_VEHICLE_MAKE_NF'
  P<1,-1>='VLMODEL*'           ; P<2,-1>='Vehicle Model'                     ; P<3,-1>='TB_VEHICLE_MODEL_NF'
  P<1,-1>='VLOPT*'             ; P<2,-1>='Vehicle Option'                    ; P<3,-1>='TB_VEHICLE_OPTION_NF'
  P<1,-1>='WAREHOUSE*'         ; P<2,-1>='Warehouse Location'                ; P<3,-1>='TB_WAREHOUSE_LOCATION_NF'
  P<1,-1>='WHOLESALE.PLAN*'    ; P<2,-1>='Wholesale Plan'                    ; P<3,-1>='TB_WHOLESALE_PLAN_NF'
  P<1,-1>='WL.FOLLOW-UP.CODE*' ; P<2,-1>='Worklist Follow-Up Codes'          ; P<3,-1>='WORKLIST_FOLLOW_UP_CODES_NF'
  P<1,-1>='WP.PARAM'           ; P<2,-1>='Word Processing'                   ; P<3,-1>='WP_PARAM_NF'
  P<1,-1>=STR('-', 18)         ; P<2,-1>=STR('-',33)                         ; P<3,-1>=STR('-',30)
  FOR F=1 TO DCOUNT(P<1>,@VM)
    PRINT '|':P<1,F>'L#18':'|':P<2,F>'L#33':'|':P<3,F>'L#30':'|'
  NEXT F
RETURN
*
BUILD.AC:
  * Check for a DICT request
  IF FIELD(ANS,' ',2)='DICT' THEN
    DICT=FIELD(ANS,' ',3)
    OPEN 'DICT',DICT TO DVAR ELSE CRT 'Cannot open DICT':DICT ; RETURN
    SELECT DVAR
    ID.LIST=''
    LOOP
      READNEXT ID ELSE EXIT
      READ R FROM DVAR, ID ELSE CONTINUE
      IF R<1>='D' OR R<1>='I' OR R<1>='V' THEN
        ID.LIST<-1>='DICT-':DICT:'_':ID
      END
    REPEAT
    GOSUB ADD.TO.AC
    RETURN
  END
  *
  * Build auto-complete list of VOC commands
  CLEARFILE AC
  L1='' ; L2=''
  *
  EXECUTE \SELECT VOC WITH F1 = "C" "V"\ RTNLIST L1
  ID.LIST=''
  LOOP
    READNEXT ID FROM L1 ELSE EXIT
    READ R FROM VOC, ID ELSE CONTINUE
    ID.LIST<-1>='CMD_':ID
  REPEAT
  GOSUB ADD.TO.AC
  *
  * Build auto-complete list for filenames
  *
  EXECUTE \SELECT VOC WITH F1 = "F" "LF" "DIR" "LD" AND WITH @ID # "TMP]"\ RTNLIST L1
  ID.LIST=''
  LOOP
    READNEXT ID FROM L1 ELSE EXIT
    READ R FROM VOC, ID ELSE CONTINUE
    ID.LIST<-1>='FILE_':ID
    IF R<1>='LF' OR R<1>='LD' THEN
      * Multi-level file or dir, dive deeper
      E=\SELECT DICT \:ID:\ WITH @ID = "@]" AND WITH F1 = "LF" "LD" USING DICT VOC\
      *CRT E
      EXECUTE E RTNLIST L2 CAPTURING DUMMY
      LOOP
        READNEXT ID2 FROM L2 ELSE EXIT
        ID2=ID:',':ID2[2,99]
        ID.LIST<-1>='FILE_':ID2
      REPEAT
    END
  REPEAT
  GOSUB ADD.TO.AC
RETURN
*
ADD.TO.AC:
  NUM.ITEMS=DCOUNT(ID.LIST,@AM)
  CRT NUM.ITEMS:' ITEMS'
  FOR I=1 TO NUM.ITEMS
    ID=ID.LIST<I>
    L=LEN(ID)
    FOR C=1 TO LEN(ID)
      PRE=ID[1,C]
      READ NODE FROM AC, PRE ELSE NODE=''
      * Now insert pointers to one level down
      PTR=ID[1,C+1]
      LOCATE PTR IN NODE<1> BY 'AL' SETTING POS THEN
        LOCATE ID IN NODE<2,POS> BY 'AL' SETTING POS2 ELSE NULL
        INS ID BEFORE NODE<2,POS, POS2>
      END ELSE
        INS PTR BEFORE NODE<1,POS>
        INS ID  BEFORE NODE<2,POS>
      END
      WRITE NODE ON AC, PRE
    NEXT C
  NEXT I
RETURN
*