johnblood/tldm-universe
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
0db1062b54
tldm-universe/Ardent/UV/BP/ED.B
John Paul Wohlscheid 77e33191cb first push of universe files
2024-09-09 17:51:08 -04:00

3912 lines
148 KiB
Brainfuck
Executable File
Raw Blame History

*******************************************************************************
*
* uniVerse PI/open EDITOR
*
* Module %M% Version %I% Date %H%
*
* (c) Copyright 1998 Ardent Software Inc. - All Rights Reserved
* This is unpublished proprietary source code of Ardent Software Inc.
* The copyright notice above does not evidence any actual or intended
* publication of such source code.
*
*******************************************************************************
*
* Maintenance log - insert most recent change descriptions at top
*
* Date.... GTAR# WHO Description.........................................
* 10/14/98 23801 SAP Change copyrights.
* 07/30/96 18933 ALC Corrected fix below, it had quoting problems
* 06/10/96 18598 PEJ Modified create.file &ED& for NT
* 04/12/96 18194 KAM Disallow VOC Fptr changes if MODFPTRS tunable set
* 03/13/96 17797 AGM Replace 'SH -c' with OS.EXEC
* 10/27/95 17576 LDG If NLS on, check ^ mode display for invalid UTF.
* 06/28/95 16793 LDG Hide NLS functionality until after 8.3.3
* 05/18/95 15741 EAP Added error message for NLS write errors
* 05/16/95 15741 EAP Added error message for NLS unmappable Ids
* 05/03/95 16475 LDG Only display record ID in ^ mode if ^ or ^X is
* actually on if NLS is enabled.
* 04/28/95 16433 LDG Changed ^X handling of char 128 (SQL NULL)
* 04/26/95 16433 LDG Changed ^X handling of chars 248 thru 250.
* 03/09/95 13096 SAP Fixed problem with SPOOL command core dumping.
* 02/07/95 16092 LDG Added ^X for Unicode UP ARROW mode, plus ability to
* input all Unicode characters via ^X.
* 12/07/94 15420 PVW Fix error handling on opens
* 11/08/94 13738 JSM Change definition of non-printing characters to be
* compatible with release 6 editor
* 03/15/94 12299 LA Replaced calls to PRINTER.IO to reset terminal and/or
* printer with PRINTER CLOSE and PRINTER RESET
* statements to make sure printer buffer is flushed.
* 02/16/94 12267 FTW Allow nulls to be edited in all cases.
* 02/11/94 12101 FTW Fixed several lock releasing problems.
* 01/24/94 12516 KAM Fixed LOOP functionality for prestored commands.
* 11/05/93 11751 WLG Fixed to recognize difference between "" and no
* Record-id being supplied.
* 10/28/93 11751 WLG Fixed to allow null record-ids.
* 08/18/93 12082 PVW Changed message 970012 and added message 970013
* 07/07/93 11317 PVW Fix problem with SPOOL command
* 07/07/93 11762 PVW Save and Restore all COMMON variables
* 06/29/93 11742 PVW Handle SQL Integrity Constraint Violations
* 06/29/93 11762 PVW Clear COMMON variables before exiting ED
* 06/01/93 11645 PVW Remove DEVSYS.STRIPSTRS.MODE from code
* 03/18/93 11152 WLG Fixed non-existent error to use message 20141
* 02/23/93 11109 PVW Fix handling of sql null when inserting.
* 02/19/93 10797 PVW Check status() before writing out to another record
* for part files.
* 02/02/93 10955 PVW Fixed editor error messages if DICT file.
* 02/01/93 10966 PVW Allow SQL NULL as element in multivalued data.
* 01/25/93 10716 LPC Enforce data restrictions for partfiles.
* 01/21/93 10797 LPC Check for invalid partfiles
* 01/21/93 10908 PVW Fix problem with I types.
* 01/06/93 10826 PVW Change the way the LOOP handles start command.
* 01/06/93 10785 PVW Make 'FI file item' behave as 'FILE file item'
* 01/05/93 10812 PVW Fix problem when line = char(128) in ^ mode.
* 01/05/93 10757 PVW Correct permissions handling for the new editor
* 12/31/92 10793 PVW Set DEVSYS.STRIPSTRS.MODE to "Editor".
* 12/30/92 10757 PVW Changed handling for Pnn,"-",and "+".
* 12/18/92 10757 PVW Change special character handling.
* 12/17/92 10214 PVW Further changes to merge the two editors.
* 12/17/92 10692 PVW Show char 128 in up arrow mode.
* 12/11/92 10708 PVW Open and close DEVSYS.VOC.FILE within ED.
* 12/09/92 10214 PVW Help Message added.
* 12/07/92 10214 PVW More formatting problems.
* 12/03/92 10214 PVW Fixed miscellaneous problems regarding QA.
* 11/11/92 10214 PVW Port PI/open EDITOR to replace uniVerse EDITOR.
*
*******************************************************************************
$OPTIONS INFORMATION
$INCLUDE UNIVERSE.INCLUDE VERBINSERT.H
$INCLUDE UNIVERSE.INCLUDE UV.COM
$INCLUDE UNIVERSE.INCLUDE FORMAT.OPTS.H
$INCLUDE UNIVERSE.INCLUDE GETPU.H
$INCLUDE UNIVERSE.INCLUDE FILENAMES.H
$INCLUDE UNIVERSE.INCLUDE UVNLS.H
$INCLUDE UNIVERSE.INCLUDE MACHINE.NAME
*******************************************************************************
*
* The following lines of code are included to setup this program
* with then same input as the PI/open ED.B subroutine receives
* from the PI/open command line processor PERFORM.B.
*
* SUBROUTINE ED (SENTENCE, MAT SYMBOLS)
*
$INCLUDE UNIVERSE.INCLUDE SYMBOL.TBL.H
OPEN "VOC" TO DEVSYS.VOC.FILE ELSE
CALL *UVPRINTMSG(001752,"")
STOP
END
DIM SYMBOLS (VALSTART + MAXTOKENS)
MAT SYMBOLS = ''
SYMBOLS (NEXT.TKN.VALUE) = VALSTART
SYMBOLS (ORIGINAL.SENTENCE) = @SENTENCE
SENTENCE = TRIMF(@SENTENCE)
CHECK.TOKEN = FIELD(SENTENCE," ",1)
IF CHECK.TOKEN = "RUN" OR CHECK.TOKEN = "RAID" THEN
SENTENCE = FIELD(SENTENCE," ",2,9999)
SENTENCE = TRIMF(SENTENCE)
SENTENCE = FIELD(SENTENCE," ",2,9999)
END
*******************************************************************************
*
*---- EQU's and DIMensions.
EQU IntegrityViolation TO -3
EQU OBJ.FMC TO 19
EQU VOC.K.CODE.DICT TO 20
EQU LINES.PER.CELL TO 40 ; * LINES PER CELL OF MEMORY MATRIX
EQU STARS LIT 'STR("*", 5)'
SETPU = '!SETPU'
GETPU = '!GETPU'
MATBLOCK = '-MATBLOCK'
GET.FILE.NAME = '-GET.FILE.NAME' ; * To get file name from command line.
STRIPSTRINGS = '-STRIPSTRINGS'
FORMAT.BASIC = '-FORMAT.BASIC'
PERMISSIONS = '-PERMISSIONS'
SQLINTCHK = '-SQLINTCHK'
OpenError = '-OpenError'
*---- Define vital elements of blocked memory (see GET.LINE comments).
@SYSTEM.SET = 0
MEMORY.DIM = 100 ; * Initial size of memory matrix.
DIM MEMORY (MEMORY.DIM)
DIM LPC (MEMORY.DIM)
DIM PRIOR.MEMORY (MEMORY.DIM)
DIM PRIOR.LPC (MEMORY.DIM)
DIM SAVED.MEMORY (MEMORY.DIM)
DIM SAVED.LPC (MEMORY.DIM)
NEW.MEMORY.DIM = 20 ; * INITIAL SIZE OF NEW.MEMORY MATRICES
DIM NEW.MEMORY (NEW.MEMORY.DIM)
DIM NEW.LPC (NEW.MEMORY.DIM)
GOSUB CLEAR.NEW.MEMORY ; * CLEAR MATRICES AND INITIALIZE VARIABLES
DIM CMD.STACK (101), CMD.NAME (5)
MAT CMD.STACK = ''
DIM ED.CMD.STRING (1)
*---- Initialize for this EDIT session.
OVERFLOW.FLAG = 0 ; * SJE 23 Apr 84
ABORT.FLAG = ''
STACK.MODE = FALSE ; * indicates if stack processor mode
INPUT.MODE = FALSE ; * indicates if prompt is '=' or ':'
INPUT.LINE = ''
BLOCK.VERIFY.FLAG = TRUE
RECORD.NAME.LOCKED = FALSE
PROMPT ' ' ; AT.LIST = '' ; AT.SUB = '' ; HELP.RECORD = ''
X = '@FILE' ; Y = ''
GOSUB AT.INSERT
X = '@ID' ; Y = ''
GOSUB AT.INSERT
X = '@LINE' ; Y = ''
GOSUB AT.INSERT
X = '@IM' ; Y = @IM
GOSUB AT.INSERT
X = '@VM' ; Y = @VM
GOSUB AT.INSERT
X = '@SM' ; Y = @SM
GOSUB AT.INSERT
X = '@COMMAND' ; Y = @COMMAND
GOSUB AT.INSERT
X = '@PARASENTENCE' ; Y = @PARASENTENCE
GOSUB AT.INSERT
X = '@SENTENCE' ; Y = @SENTENCE
GOSUB AT.INSERT
X = '@LEVEL' ; Y = @LEVEL
GOSUB AT.INSERT
X = '@LOGNAME' ; Y = @LOGNAME
GOSUB AT.INSERT
X = '@WHO' ; Y = @WHO
GOSUB AT.INSERT
X = '@USERNO' ; Y = @USERNO
GOSUB AT.INSERT
X = '@TIME' ; Y = OCONV(@TIME, 'MTHS')
GOSUB AT.INSERT
X = '@DATE' ; Y = OCONV(@DATE, 'D4')
GOSUB AT.INSERT
X = '@MONTH' ; Y = @MONTH
GOSUB AT.INSERT
X = '@DAY' ; Y = @DAY
GOSUB AT.INSERT
X = '@YEAR' ; Y = @YEAR
GOSUB AT.INSERT
X = '@TM' ; Y = @TM ; * 007
GOSUB AT.INSERT ; * 007
LINES.MESSAGE = @SYS.BELL:'Number of lines to print must be a'
PRE.STORE = 'Pre-stored command'
REC = 'record'
UREC = 'Record'
ENABLED = 'enabled'
DISABLED = 'disabled'
UNICODE = '+Unicode' ;* NLS, for when ^X enabled, not just ^
IN.FILE = ' in file "'
DUMMY = @(0) ; * TURN OFF CRT PAGING ON DISPLAY
FIRST.RECORD = TRUE
APPEND = '' ; * APPEND STRING
CMD = '' ; * COMMAND LINE
CMD.STACK (1) = '$' ; * END OF STACK INDICATOR
CMD.STRING = '' ; * CMD STACK DUMPED INTO HERE BEFORE BEING SAVED (.S)
COMMA = FALSE ; * FOR ANALYZING SAVE (.S) COMMAND
CURR.CMD.NAME = '' ; * INIT VARIABLE
DELIM.STRING = '!"#$%&()*+,-./:=@[\]_`{|}':"'"
ED.CMD.STRING (1) = '$' ; * INIT END OF PRE-STORED COMMAND STRING INDICATOR
ED.CMD.STRING.ACTIVE = FALSE ; * FLAG TRUE IF A CMD STRING IS BEING EXECUTED
ED.CMD.STRING.SUSPENDED = FALSE ; * FLAG TRUE IF AN EXECUTING COMMAND STRING IS IN 'PAUSE' MODE
END.STACK = 1 ; * POINTER TO THE END OF STACK INDICATOR
L.SELECT.FLAG = FALSE ; * FLAG TRUE IF CMD STRING RECORD NAMES SELECTED FROM A FILE
LOOP.FLAG = FALSE ; * FLAG TRUE IF CMD STRING IS BEING REPEATED BY A 'LOOP' COMMAND
NULL.CTR = 0 ; * COUNTER FOR SUCCESSIVE NULL COMMANDS
STACK.LIMIT = 100 ; * MAX NR OF STACK COMMANDS IS 99
UNLOAD.FLAG = FALSE ; * FLAG TRUE IF USING STRING.WRITE SUBR TO UNLOAD LINES
UPCMD = '' ; * INIT VARIABLE
UPCMD4 = '' ; * INIT VARIABLE
ERROR.COND = CHAR(0):@IM:CHAR(0) ; * ERROR INDICATOR
FIND.STRING = '' ; * 'FIND' STRING
FLEN = 0 ; * LENGTH OF FIND.STRING
ST.COLUMN = 1 ; * STARTING COLUMN (FIND COMMAND)
LOCATE.STRING = '' ; * LOCATE SEARCH STRING
MATCH.STRING = '' ; * 'MATCH' STRING
OLD.CHANGE.CMD = '' ; * PREVIOUS CHANGE COMMAND
PNUM = @CRTHIGH - 2 ; * LAST NUMBER OF LINES PRINTED
REPLACE.STRING = '' ; * PREVIOUS REPLACE COMMAND STRING
UP.ARROW = '^' ; * DEFINE UP ARROW CHARACTER
UP.ARROW.FLAG = FALSE ; * DISPLAY SPECIAL CHAR AS !XXX, FLAG
UP.ARROW.UNIC = '^x' ; * NLS up arrow mode that uses Unicode
UP.ARROW.UNIC.UP = UPCASE(UP.ARROW.UNIC) ;* used frequently
LEN.UP.ARROW.UNIC = LEN(UP.ARROW.UNIC) ;* ...ditto
UP.ARROW.UNIC.FLAG = FALSE ; * (display chars as ^xhhhh) in hex
NLS.ON.FLAG = SYSTEM(NLS$ON) ; * Set to 1 if NLS support switched on
PP.LINES = 20 ; * Default line count for PP command.
PL.LINES = 20 ; * Default line count for PL command.
NUM.REMAINING = '' ; * to control null editing
*---- Get CRT line width for folding.
CRT.WIDTH = @CRTWIDE
IF CRT.WIDTH < 1 OR CRT.WIDTH > 132 THEN CRT.WIDTH = 80
*---- Parse command sentence for file and record names.
SENT = TRIMF(FIELD(SENTENCE, ' ', 2, 9999))
INPUT.FILENAME:
PROMPT.FOR.FILE = TRUE ; NO.SELECT.LIST = TRUE
SINGLE.FILE.ONLY = TRUE ; ONLY.ONE.RECORD.FLAG = FALSE
FILE.NAME = '' ; DICT = ''
CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, DICT, FILE.NAME,
PROMPT.FOR.FILE, SINGLE.FILE.ONLY)
IF DICT = '' THEN DICT.TEXT = '' ELSE DICT.TEXT = DICT:' '
IF LEN(FILE.NAME) = 0 OR FILE.NAME # FILE.NAME <1> THEN GOTO STOP
*
* Open the file to be edited. Carry on if partially successful open
* of distributed file.
*
TEMP.SENTENCE = ''
FILE.NAME.VALID = FALSE
LOOP
UNTIL FILE.NAME.VALID DO
IF FILE.NAME = '' THEN
CALL @GET.FILE.NAME(NO.SELECT.LIST,TEMP.SENTENCE,DICT,FILE.NAME,PROMPT.FOR.FILE,SINGLE.FILE.ONLY)
END
IF DICT = '' THEN DICT.TEXT = '' ELSE DICT.TEXT = DICT:' '
IF LEN(FILE.NAME) = 0 OR FILE.NAME # FILE.NAME<1> THEN GOTO STOP
OPENCHECK DICT, FILE.NAME TO EDIT.FILE THEN
FILE.TYPE = STATUS()
FILE.NAME.VALID = TRUE
EDIT.READ.ONLY = FALSE
EDIT.PERM.MODE = 1
EDIT.PERM.IN = 6
EDIT.PERM.OUT = ''
CALL @PERMISSIONS(EDIT.FILE,EDIT.PERM.MODE,EDIT.PERM.IN,EDIT.PERM.OUT)
IF NOT(EDIT.PERM.OUT) THEN
EDIT.READ.ONLY = TRUE
END
END ELSE
ErrorCode = STATUS()
READL FileRec FROM DEVSYS.VOC.FILE,FILE.NAME THEN
IF DICT = "" THEN
PathName = FileRec<2>
END ELSE
PathName = FileRec<3>
END
RELEASE DEVSYS.VOC.FILE,FILE.NAME
END ELSE
PathName = ""
END
IF DICT = "" THEN
FileName = FILE.NAME
END ELSE
FileName = "DICT,":FILE.NAME
END
CALL @OpenError(ErrorCode,FileName,PathName)
DICT = '' ; FILE.NAME = ''
END
REPEAT
X = '@FILE' ; Y = FILE.NAME ; GOSUB AT.INSERT
IF TRIM(SENT) = '""' OR TRIM(SENT) = "''" THEN
NULL.ID = TRUE
END ELSE NULL.ID = FALSE
IF INDEX(SENT, "'", 1) + INDEX(SENT, '"', 1) THEN
CALL @STRIPSTRINGS(SENT, MAT SYMBOLS)
END ELSE SENT = TRIM(SENT)
IF SENT = '*' THEN
CALL *UVPRINTMSG(001295,"")
SELECT EDIT.FILE
SENT = ''
END
SELECT.LIST.FLAG = FALSE
READLIST RECORD.LIST
THEN
CONVERT @IM TO @FM IN RECORD.LIST
SELECT.LIST.FLAG = TRUE
NUM.REMAINING=DCOUNT(RECORD.LIST,@FM)
END
ELSE
RECORD.LIST = ''
END
IF LEN(SENT) # 0 THEN
IF COUNT(SENT, ' ') = 0 AND NOT(SELECT.LIST.FLAG) THEN ONLY.ONE.RECORD.FLAG = TRUE
NUMSENT=COUNT(SENT,' ')+1
SENT.AVAIL=NUMSENT
NUM.REMAINING=NUMSENT
LOOP
RECORD.NAME = FIELD(SENT, ' ', 1)
IF RECORD.NAME [1, 1] = CHAR(LITERAL) THEN
RECORD.NAME = SYMBOLS(RECORD.NAME [2, 999])
END
SENT = SENT [COL2() + 1, 999999]
WHILE SENT.AVAIL GT 0
SENT.AVAIL=SENT.AVAIL-1
RECORD.LIST<NUMSENT-SENT.AVAIL>=RECORD.NAME
REPEAT
END
IF COUNT(RECORD.LIST, @FM) THEN SELECT.LIST.FLAG = TRUE
GET.NEXT.RECORD: ; * Get the next record.
GOSUB GET.RECORD
GOSUB OOPS.INITIAL.SAVE ; * SET UP FOR OOPS <====
GET.CMD: ; * Get next command from user.
* Set up to save record prior to change for 'OOPS'.
IF CHANGE.FLAG OR CHANGE.DURING.CMD.STRING THEN
IF NOT(ED.CMD.STRING.ACTIVE) THEN
GOSUB OOPS.AFTER.CHANGE.CMD ; * SET UP FOR OOPS <====
CHANGE.DURING.CMD.STRING = FALSE
END ELSE CHANGE.DURING.CMD.STRING = TRUE
END
GET.CMD.0:
IF CHANGE.FLAG THEN RECORD.CHANGE.FLAG = TRUE
IF BOT = 0 THEN LNUM = 0 ; * BOT=0 MEANS RECORD IS NULL
IF BOT THEN GOSUB GET.LINE ; * GET LINE IF RECORD IS NOT NULL
ELSE IF CHANGE.FLAG THEN CHANGE.FLAG = FALSE ; RECORD.CHANGE.FLAG = TRUE
IF NOT(ED.CMD.STRING.ACTIVE) THEN
IF LNUM => BOT AND BOT > 0 THEN
CALL *UVPRINTMSG(001209,BOT)
END
CALL *UVPRINTMSG(001210,"")
END ELSE
IF ED.CMD.STRING.SUSPENDED THEN
CALL *UVPRINTMSG(001242,"")
CALL *UVPRINTMSG(001210,"")
END
END
GOSUB INPUT.LINE
GET.CMD.1:
COMMAND.SUCCESSFUL = TRUE
STACK.MODE = FALSE
CMD = INPUT.LINE
ORIGINAL.CMD = CMD
IF CMD = '.?' THEN CMD = 'HELP .'
IF CMD # '?' AND CMD [LEN(CMD), 1] = '?' THEN
CMD = CMD [1, LEN(CMD) - 1] ; GOSUB STASH.IT ; GOTO GET.CMD
END
CMD = REPLACE(CMD, 1, 1, 1, TRIMF(CMD <1, 1, 1>))
GOSUB PUT.ON.STACK
GET.CMD.2:
IF LEN(CMD) = 0 THEN
IF BOT = 0 THEN GOTO GET.CMD ; * BOT = 0 MEANS RECORD IS NULL
LNUM = IF LNUM < BOT THEN LNUM + 1 ELSE 0
GOTO END.NOCHANGE
END
NULL.CTR = 0
IF NUM(CMD) THEN GOTO SET.LNUM
IF CMD = "-" OR CMD = "+" THEN GOTO END.NOCHANGE
*---- Convert lower case to upper case for command processing.
UPCMD = UPCASE(CMD) ;
*---- Look for 'OOPS' command to restore; else, save record if necessary.
IF UPCMD = 'OOPS' THEN
IF ED.CMD.STRING.ACTIVE THEN
J = 0 ; * KILL ACTIVE CMD STRING
ED.CMD.STRING.ACTIVE = FALSE
ED.CMD.STRING.SUSPENDED = FALSE
IF CHANGE.DURING.CMD.STRING THEN
GOSUB OOPS.AFTER.CHANGE.CMD
CHANGE.DURING.CMD.STRING = FALSE
END
END
IF LEN(SAVED.CMD) = 0 THEN
CALL *UVPRINTMSG(001249,"")
GOTO GET.CMD
END
J = 0 ; * KILL ANY ACTIVE EDIT CMD STRING
ED.CMD.STRING.ACTIVE = FALSE
GOSUB OOPS.RESTORE ; * SET UP FOR OOPS <====
GOTO END.CMD
END ELSE
IF NOT(ED.CMD.STRING.ACTIVE) THEN GOSUB OOPS.BEFORE.EACH.CMD ; * SET UP FOR OOPS <====
END
CMDN = 1
*---- Look for 1-letter commands.
IF LEN(UPCMD) = 1 THEN
CMDX = INDEX('ABCDFILMNPQRTX<>^?', UPCMD, 1)
ON CMDX + 1 GOTO CMD.ERR, A, B, C, D, F, I, L, M, N, P, QUIT, R,
T, X, MFROM, MTHRU, UP.ARROW.TOGGLE, QUESTION.MARK
END
*---- Look for a letter and a space, followed by any string.
IF UPCMD MATCHES '1A" "0X' THEN
ANY = CMD [3, 9999]
CMDX = INDEX('ABCFILMR', UPCMD [1, 1], 1)
ON CMDX + 1 GOTO CMD.ERR, A.ANY, B.ANY, C.ANY, F.ANY,
I.ANY, L.ANY, M.ANY, R.ANY
END
*---- Look for 'Fnnn' --- a column-restricted FIND.
IF UPCMD [1, 1] = "F" THEN
IF CMD [2, 9999] MATCHES '0N" "0X' THEN
ST.COLUMN = FIELD(CMD [2, 9999], " ", 1)
ANY = CMD [LEN(ST.COLUMN) + 3, 9999]
GO TO F.COL
END
END
*---- Look for a letter followed by a number.
IF UPCMD MATCHES '1A0N' THEN
CMDN = CMD [2, 99]
IF CMDN > BOT THEN CMDN = BOT
CMDX = INDEX('DGLP', UPCMD [1, 1], 1)
ON CMDX + 1 GOTO CMD.ERR, D, G.N, P.N, P.N
END
*---- Look for command words.
UPCMD1 = UPCMD [1, 1] ; UPCMD2 = UPCMD [1, 2]
UPCMD3 = UPCMD [1, 3] ; UPCMD4 = UPCMD [1, 4]
UPCMD5 = UPCMD [1, 5] ; UPCMD6 = UPCMD [1, 6]
UPCMD8 = UPCMD [1, 8]
IF UPCMD = 'ABORT' THEN GOTO ABORT:
IF UPCMD = 'BLOCK' THEN GOTO BLOCK.VERIFY:
IF UPCMD3 = 'CAT' THEN GOTO CAT.ANY:
IF UPCMD = 'COL' THEN GOTO COL:
IF UPCMD = 'COPY' THEN GOTO COPY:
IF UPCMD = 'DELETE' THEN GOTO DELETE:
IF UPCMD2 = 'DE' THEN GOTO DE.N:
IF UPCMD = 'DROP' THEN GOTO DROP:
IF UPCMD3 = 'DUP' THEN GOTO DUP.ANY:
IF UPCMD = 'EX' THEN GOTO QUIT:
IF UPCMD = 'FD' THEN GOTO DELETE:
IF UPCMD = 'FI' THEN GOTO FILE.ANY:
IF UPCMD = 'FILE' THEN GOTO FILE.ANY:
* GTAR 10785
* Fake editor into thich user typed 'FILE file record'
*
IF UPCMD3 = 'FI ' THEN
CMD = 'FILE ':CMD[4,9999]
UPCMD = UPCASE(CMD)
UPCMD3 = UPCMD[1,3]
UPCMD4 = UPCMD[1,4]
UPCMD5 = UPCMD[1,5]
UPCMD6 = UPCMD[1,6]
UPCMD7 = UPCMD[1,7]
UPCMD8 = UPCMD[1,8]
GOTO FILE.ANY
END
IF UPCMD5 = 'FILE ' THEN GOTO FILE.ANY:
IF UPCMD = 'FORMAT' THEN FORMAT.TYPE = TRUE ; GOTO FORMAT:
IF UPCMD = 'FANCY.FORMAT' THEN FORMAT.TYPE = FALSE ; GOTO FORMAT:
IF UPCMD = 'G<' THEN GOTO G.BEGIN.BLOCK:
IF UPCMD = 'G>' THEN GOTO G.END.BLOCK:
IF UPCMD4 = 'HELP' THEN GOTO HELP.ANY:
IF UPCMD2 = 'IB' THEN GOTO I.BEFORE
IF UPCMD5 = 'LOAD ' THEN GOTO LOAD.ANY:
IF UPCMD = 'MOVE' THEN GOTO MOVE:
IF UPCMD = 'PB' THEN GOTO PRINT.BLOCK:
IF UPCMD2 = 'PL' THEN GOTO PL.CMD:
IF UPCMD2 = 'PO' THEN GOTO PO.N:
IF UPCMD2 = 'PP' THEN GOTO PP.CMD:
IF UPCMD = 'QUIT' THEN GOTO QUIT:
IF UPCMD = 'RELEASE' THEN GOTO RELEASE:
IF UPCMD = 'SAVE' THEN GOTO SAVE.ANY:
IF UPCMD5 = 'SAVE ' THEN GOTO SAVE.ANY:
IF UPCMD3 = 'SEQ' THEN GOTO SEQ.ANY:
IF UPCMD = 'SIZE' THEN COMMAND.SUCCESSFUL = FALSE ; DISPLAY.CURRENT.LINE = FALSE ; GOTO SIZE:
IF UPCMD = 'SPOOLHELP' THEN GOTO SPOOL.HELP:
IF UPCMD5 = 'SPOOL' THEN GOTO SPOOL.N:
IF UPCMD5 = 'STAMP' THEN GOTO STAMP:
IF UPCMD6 = 'UNLOAD' THEN GOTO UNLOAD.ANY:
IF UPCMD4 = 'XEQ ' THEN GOTO XEQ.ANY:
IF UPCMD3 = 'PE ' THEN GOTO XEQ.ANY:
IF UPCMD8 = 'PERFORM ' THEN GOTO XEQ.ANY:
IF UPCMD = "<>" THEN GOTO MFROM:
IF UPCMD = UP.ARROW.UNIC.UP THEN GOTO UP.ARROW.TOGGLE ;* NLS Unicode ^x cmd
*---- Look for EDITOR STACK and STRING commands.
IF UPCMD1 = '.' OR UPCMD4 = 'LOOP' OR UPCMD5 = 'PAUSE' THEN GOTO STACK.PROCESSOR:
IF UPCMD1 = 'C' OR UPCMD1 = 'R' THEN GOTO C.ANY: ; * CHANGE command.
CMD.ERR:
UNLOAD.FLAG = FALSE ; * RESET FLAGS ON LOAD/UNLOAD ERROR CONDITIONS
L.SELECT.FLAG = FALSE
* IF UPCMD4 = 'LOOP' THEN ED.CMD.STRING.ACTIVE = FALSE
* ELSE
IF NOT(ED.CMD.STRING.SUSPENDED) AND ED.CMD.STRING.ACTIVE THEN
CALL *UVPRINTMSG(001272,J:@FM:ED.CMD.STRING (J))
CALL *UVPRINTMSG(001273,"")
ERROR.FORMAT = TRUE
GOSUB PRINT.CMD.STRING
MSG.TEXT = UVREADMSG(001274,"")
IF NOT(@SYS.BELL) THEN
MSG.TEXT = CONVERT(CHAR(07),"",MSG.TEXT)
END
PRINT MSG.TEXT<1>
PRINT
CALL *UVPRINTMSG(001275,"")
CALL *UVPRINTMSG(001276,"")
INPUT COMMAND ; ANS = COMMAND ; ANS = UPCASE(ANS)
IF ANS # 'Q' THEN
ED.CMD.STRING (J) = COMMAND
J -= 1
END ELSE ED.CMD.STRING.ACTIVE = FALSE
GOTO GET.CMD
END
* END
IF NOT(STACK.MODE) THEN CALL *UVPRINTMSG(001245,"")
GOTO GET.CMD
NUMBER.ERR:
PRINT 'A non-numeric parameter was encountered where a number was expected.'
GOTO CMD.ERR
END.NOCHANGE: ; * End of command that did not change record.
CHANGE.FLAG = FALSE
GOTO END.CMD
END.CHANGE: ; * End of command that changed record.
CHANGE.FLAG = TRUE
END.CMD: ; * Set up to save record prior to change for 'OOPS'.
IF CHANGE.FLAG OR CHANGE.DURING.CMD.STRING THEN
IF NOT(ED.CMD.STRING.ACTIVE) THEN
GOSUB OOPS.AFTER.CHANGE.CMD ; * SET UP FOR OOPS <====
CHANGE.DURING.CMD.STRING = FALSE
END ELSE CHANGE.DURING.CMD.STRING = TRUE
END
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD.0
DONE.WITH.RECORD:
IF RECORD.NAME.LOCKED THEN
RELEASE EDIT.FILE, RECORD.NAME ; * RELEASE RECORD LOCK
RECORD.NAME.LOCKED = FALSE
END
IF ONLY.ONE.RECORD.FLAG THEN GOTO STOP ELSE GOTO GET.NEXT.RECORD
!
* Command processing routines.
!
*---- Conventions used in command processors:
*
* 1. Entered from a 'GOTO' in the routine 'GET.CMD'.
*
* 2. Exit with a 'GOTO' to one of the following labels:
* A. 'GET.CMD', to get the next command.
* B. 'END.CMD', to print the current line before going to 'GET.CMD'.
* C. 'END.CHANGE' to set 'CHANGE.FLAG' to 'TRUE' after changing
* the record; control proceeds through 'END.CMD', to print
* the current line before going to 'GET.CMD'.
* D. 'CMD.ERR', to print standard error message.
*
* 3. Use these standard 'GOSUB' routines:
* A. 'GET.LINE', to get the line numbered 'LNUM' into 'LINE'.
* B. 'PRINT.LINE', to print the string in 'LINE'.
* C. 'INPUT.LINE', to input a line of text from the CRT.
*
* 4. Each processor should maintain these variables as necessary:
* A. 'MEMORY' matrix contains 'LPC' lines of record in each cell.
* B. 'LNUM' is the line number being displayed/processed.
* C. 'LINE' contains the current line from record at line 'LNUM'.
* D. 'LPC' matrix defines number of lines per cell in 'MEMORY'.
* E. 'CELL' is the cell number in 'MEMORY' containing line 'LNUM'.
* F. 'CELL.FIRST.LINE' is the real line number of the first
* line of the current cell.
* G. 'CHANGE.FLAG' must be set to 'TRUE' if record is changed.
* H. 'BOT' should be set to the bottom line number if
* the number of lines is changed.
A.ANY: ; * APPEND command.
APPEND = ANY
A:
IF LNUM < 1 THEN
CALL *UVPRINTMSG(970007,LNUM)
GOTO CMD.ERR
END
LINE := APPEND
MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE)
GOTO END.CHANGE
ABORT: ; * Toggle command ABORT flag.
ABORT.FLAG = NOT(ABORT.FLAG)
IF ABORT.FLAG THEN
CALL *UVPRINTMSG(001267,ENABLED)
END ELSE
CALL *UVPRINTMSG(001267,DISABLED)
END
GOTO END.NOCHANGE
BLOCK.VERIFY: ; * Toggle command BLOCK.VERIFY flag.
BLOCK.VERIFY.FLAG = NOT(BLOCK.VERIFY.FLAG)
IF BLOCK.VERIFY.FLAG THEN
CALL *UVPRINTMSG(001268,ENABLED)
END ELSE
CALL *UVPRINTMSG(001268,DISABLED)
END
GOTO END.NOCHANGE
B.ANY: ; * Break a line into two lines.
IF LNUM < 1 THEN
CALL *UVPRINTMSG(970008,LNUM)
GOTO CMD.ERR
END
X = INDEX(LINE, ANY, 1)
IF X = 0 THEN GOTO CMD.ERR
X += LEN(ANY)
MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE [1, X - 1]:@FM:LINE [X, 999999])
LPC (CELL) += 1 ; BOT += 1
BLOCK.TRACK.LNUM = LNUM + 1 ; BLOCK.TRACK.CHANGE = 1 ; GOSUB BLOCK.TRACK
GOTO END.CHANGE
B: ; * Go to BOTTOM of record.
LNUM = BOT ; GOTO END.NOCHANGE
CAT.ANY: ; * Catenate two lines together.
IF LNUM < 1 OR LNUM = BOT THEN
CALL *UVPRINTMSG(970006,LNUM)
GOTO CMD.ERR
END
LINEX = LINE
LNUM += 1
GOSUB GET.LINE ; * GET NEXT LINE
LINEY = LINE
NUM.OF.LINES.TO.DELETE = 1
GOSUB DELETE.MEMORY
MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINEX:CMD [5, 99]:LINEY)
BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = -1 ; GOSUB BLOCK.TRACK
GOTO END.CHANGE
COL: ; * Column display command.
CALL *UVPRINTMSG(001212,"")
CALL *UVPRINTMSG(001213,"")
GOTO END.NOCHANGE
C: ; * Change command.
CMD = OLD.CHANGE.CMD
IF LEN(CMD) = 0 THEN
PRINT 'No previous CHANGE command in effect ; must have parameters.'
GOTO CMD.ERR
END
C.ANY: ; * Look for first non-space, non-alphanumeric character as delimiter.
X = 2
LOOP DELIM = CMD [X, 1] WHILE DELIM = ' ' DO X += 1 REPEAT
IF NOT(INDEX(DELIM.STRING, DELIM, 1)) THEN
PRINT 'Valid delimiters are ':DELIM.STRING
GOTO CMD.ERR
END
IF COUNT(CMD, DELIM) > 3 THEN
PRINT 'Too many delimiters (3 max.).' ; GOTO CMD.ERR
END
OLD.CHANGE.CMD = CMD
FROM.FIELD = FIELD(CMD, DELIM, 2)
LEN.FROM.FIELD = LEN(FROM.FIELD)
TO.FIELD = FIELD(CMD, DELIM, 3)
IF COL2() = 0 THEN
PRINT 'Missing required TO field (for "CHANGE/FROM/TO").'
GOTO CMD.ERR
END
GLOBAL = FIELD(CMD, DELIM, 4) ; GLOBAL = UPCASE(GLOBAL) ; GLOBAL.FLAG = FALSE
IF GLOBAL [1, 1] = 'G' THEN GLOBAL = GLOBAL [2, 99] ; GLOBAL.FLAG = TRUE
IF GLOBAL [LEN(GLOBAL), 1] = 'G' THEN GLOBAL = GLOBAL [1, LEN(GLOBAL) - 1] ; GLOBAL.FLAG = TRUE
BLOCK.LOGIC = FALSE
IF GLOBAL = 'B' THEN
IF MFROM # 0 AND MTHRU # 0 THEN LNUM = MFROM ; * IF BLOCK SET, MOVE LNUM TO FRONT OF BLOCK
GOSUB BLOCK.CHECK
BLOCK.LOGIC = TRUE
END
N = IF NUM(GLOBAL) AND GLOBAL => 1 THEN GLOBAL ELSE 1
IF LNUM <= 0 THEN LNUM = 1
IF BLOCK.LOGIC THEN LNUM = MFROM ; LEND = MTHRU ; N = LEND - LNUM + 1
ELSE LEND = LNUM + N - 1 ; IF LEND > BOT THEN LEND = BOT
X.CHANGE.FLAG = FALSE ; * RESET LOCAL CHANGE FLAG
FOR LNUM = LNUM TO LEND
GOSUB GET.LINE
IF LEN(FROM.FIELD) = 0 THEN LINE = TO.FIELD:LINE ; GOTO C.REPLACE.LINE
X = INDEX(LINE, FROM.FIELD, 1)
IF X = 0 THEN GOTO C.NEXT.LINE
NEW.LINE = ''
LOOP
NEW.LINE := LINE [1, X - 1] :TO.FIELD
LINE = LINE [X + LEN.FROM.FIELD, 999999]
X = INDEX(LINE, FROM.FIELD, 1)
WHILE GLOBAL.FLAG AND X DO REPEAT
LINE = NEW.LINE:LINE
C.REPLACE.LINE:
MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE)
GOSUB PRINT.LINE
CHANGE.FLAG = TRUE
X.CHANGE.FLAG = TRUE ; * SET LOCAL CHANGE FLAG
C.NEXT.LINE:
GOSUB ABORT.CHECK
IF ABORT = 'Q' THEN
CALL *UVPRINTMSG(001228,"")
GOTO C.ABORT
END
NEXT LNUM
C.ABORT:
IF LNUM = 0 THEN CALL *UVPRINTMSG(001190,"")
ELSE IF N > 1 AND LNUM # BOT THEN PRINT 'At line ':LNUM
CHANGE.FLAG = X.CHANGE.FLAG ; * SET UP FLAG FOR OOPS SINCE GET.LINE
; * COULD HAVE RESET IT AFTER LAST LINE ACTUALLY CHANGED
GOTO GET.CMD
COPY: ; * Copy a BLOCK (i.e., duplicate the lines).
MOVE.FLAG = FALSE ; GOTO MOVE.COPY
DELETE: ; * Delete the entire record from the file.
IF (NOT(SYSTEM(62)) AND (EDITING.VOC.FPTR))
THEN
CALL *UVPRINTMSG(020553,"")
GOTO GET.CMD
END
CALL *UVPRINTMSG(001214,"")
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS # 'Y' THEN CALL *UVPRINTMSG(001215,"") ; GOTO GET.CMD
DELETE EDIT.FILE, RECORD.NAME ELSE
* DELETEU EDIT.FILE, RECORD.NAME ON ERROR
PRINT @SYS.BELL:'Failed to delete "':DISPLAY.RECORD.NAME:'" from file "':DICT:FILE.NAME:'". STATUS = ':STATUS()
GOTO GET.CMD
END
CALL *UVPRINTMSG(001246,DISPLAY.RECORD.NAME)
CALL *UVPRINTMSG(001286,DICT.TEXT:FILE.NAME)
GOTO DONE.WITH.RECORD
DE.N: ; * Delete a line or lines.
CMDN = CMD [3, 99]
IF NOT(NUM(CMDN)) THEN
PRINT 'Command requires number of lines to DELETE.'
GOTO CMD.ERR
END
IF CMDN <= 0 THEN CMDN = 1
D:
IF LNUM <= 0 THEN LNUM = 1
IF CMDN > (BOT - LNUM + 1) THEN CMDN = BOT - LNUM + 1
NUM.OF.LINES.TO.DELETE = CMDN
GOSUB DELETE.MEMORY
BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = -CMDN ; GOSUB BLOCK.TRACK
GOTO GET.CMD
DROP: ; * Delete a BLOCK of lines.
IF MFROM # 0 AND MTHRU # 0 THEN LNUM = MFROM ; * IF BLOCK SET, MOVE LNUM TO FRONT OF BLOCK
GOSUB BLOCK.CHECK ; GOSUB GET.LINE
NUM.OF.LINES.TO.DELETE = MTHRU - MFROM + 1
GOSUB DELETE.MEMORY
MTHRU = 0 ; * KILL BLOCK POINTERS
MFROM = 0
GOTO END.CMD
DUP.ANY: ; * Duplicate the current line.
IF LNUM < 1 THEN
CALL *UVPRINTMSG(970009,LNUM)
GOTO CMD.ERR
END
CMDN = CMD [4, 99]
IF NOT(NUM(CMDN)) THEN
PRINT 'Command requires number of lines to DUPLICATE.'
GOTO CMD.ERR
END
IF CMDN <= 0 THEN CMDN = 1
IF CMDN = 1 THEN
* LNUM += 1
* MEMORY (CELL) = INSERT(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE)
* The following code replaces the above 2 lines, which fail when
* inserting data before the last field if the last field is null.
X = LNUM - CELL.FIRST.LINE
IF X < 0 THEN
IF LEN(MEMORY (CELL)) = 0 THEN MEMORY (CELL) = LINE
ELSE MEMORY (CELL) = LINE:@FM:MEMORY (CELL)
END ELSE
Y = FIELD(MEMORY (CELL), @FM, 1, X + 1):@FM:LINE
X = MEMORY (CELL) [COL2(), 99999999]
IF LEN(X) = 0 THEN MEMORY (CELL) = Y
ELSE MEMORY (CELL) = Y:X
END
LNUM += 1
*---- End of special code.
LPC (CELL) += 1 ; BOT += 1 ; CHANGE.FLAG = TRUE
END ELSE
NEW.MEMORY.LINE = LINE
FOR X = 1 TO CMDN ; * BUILD A BLOCK OF NEW LINES
GOSUB APPEND.NEW.MEMORY
IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84
NEXT X
GOSUB INSERT.MEMORY ; * INSERT THE NEW BLOCK
IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84
GOSUB CLEAR.NEW.MEMORY
LNUM += 1
END
BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = CMDN ; GOSUB BLOCK.TRACK
GOTO END.CMD
FILE.ANY: ; * File the record; finished with it.
GOSUB FILE.IT
IF WRITEERROR THEN GOTO END.NOCHANGE ; *026
GOTO DONE.WITH.RECORD
F.COL: ; * A column-restricted FIND.
FIND.STRING = ANY ; GO TO F
F.ANY: ; * Find a line starting with string 'any'.
FIND.STRING = ANY ; ST.COLUMN = 1
F:
FLEN = LEN(FIND.STRING) ; SEARCH.X = 1 ; GOTO L.AGAIN
FORMAT: ; * Format INFO/BASIC program.
DISPLAY.CURRENT.LINE = FALSE
COMMAND.SUCCESSFUL = FALSE
IF BOT = 0 THEN GOTO END.NOCHANGE ; * EXIT IF NO LINES TO FORMAT
*
* Move the current lines of the program into the PROGRAM array ready
* for formatting, 1 line per field.
*
PROGRAM = ''
FOR LNUM = 1 TO BOT
GOSUB GET.LINE ; PROGRAM<-1> = LINE
NEXT LNUM
BOTX = BOT ; * SAVE BOT
LNUM = 1
GOSUB GET.LINE
NUM.OF.LINES.TO.DELETE = BOT
GOSUB DELETE.MEMORY ; * CLEAR ALL OF MEMORY, RETURN DMR SPACE
BOT = BOTX ; * RESTORE BOT WHICH WAS RESET BY DELETE.MEMORY
*
* Now do the actual format of this record.
* Depending on the value of FORMAT.TYPE do a FORMAT or FANCY.FORMAT
*
IF FORMAT.TYPE THEN
MAT FORMAT.OPTIONS = '' ; * Initialize the default FORMAT
FORMAT.MARGIN = 6 ; * options.
FORMAT.INDENT = 3 ; *
FORMAT.CASE = 'MCU' ; * Treat all keywords in upper case
FORMAT.LABELS = 0 ; * Do not place labels on a separate line
FORMAT.COMMENT = 0 ; * Do not format comments
FORMAT.BRIEF = 0 ; * Indicate progess with *'s
FORMAT.SURROUND = 0 ; * Do not surround special characters
FORMAT.ALIGN = 0 ; * Do not align within statements
END ELSE
MAT FORMAT.OPTIONS = '' ; * Initialize the default FORMAT
FORMAT.MARGIN = 6 ; * options.
FORMAT.INDENT = 3 ; *
FORMAT.CASE = 'MCU' ; * Treat all keywords in upper case
FORMAT.LABELS = 1 ; * Do not place labels on a separate line
FORMAT.COMMENT = 1 ; * Do not format comments
FORMAT.BRIEF = 0 ; * Indicate progess with *'s
FORMAT.SURROUND = 1 ; * Do not surround special characters
FORMAT.ALIGN = 0 ; * Do not align within statements
END
CALL @FORMAT.BASIC(PROGRAM, BOT, MAT FORMAT.OPTIONS)
*
X = INT((BOT - 1) / LINES.PER.CELL) ; * DETERMINE NUMBER OF FULL CELLS
LNUM = 0
PROGRAM = PROGRAM ; * Reset remove pointer
FOR XX = 1 TO X
LPC (XX) = LINES.PER.CELL
LNUM += 1
PROGRAM.LINE = ''
LOOP
REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK
UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK)
REPEAT
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT
MEMORY (XX) = PROGRAM.LINE
FOR XXX = 2 TO LINES.PER.CELL ; * MOVE LINES INTO CELL
LNUM += 1
PROGRAM.LINE = ''
LOOP
REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK
UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK)
REPEAT
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT
MEMORY (XX) := @FM:PROGRAM.LINE
NEXT XXX
NEXT XX
XX = X + 1 ; * CELL NUMBER OF LAST CELL
X = MOD(BOT - 1, LINES.PER.CELL) + 1 ; * DETERMINE NUM OF LINES IN LAST CELL
IF X THEN
LPC (XX) = X
LNUM += 1
PROGRAM.LINE = ''
LOOP
REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK
UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK)
REPEAT
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT
MEMORY (XX) = PROGRAM.LINE
FOR XXX = 2 TO X ; * MOVE LINES INTO LAST CELL
LNUM += 1
PROGRAM.LINE = ''
LOOP
REMOVE LINE.SEGMENT FROM PROGRAM SETTING LINE.SEGMENT.MARK
UNTIL(LINE.SEGMENT.MARK = 2 OR LINE.SEGMENT.MARK = 0) DO
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT:CHAR(256 - LINE.SEGMENT.MARK)
REPEAT
IF ISNULL(LINE.SEGMENT) THEN LINE.SEGMENT = @NULL.STR
PROGRAM.LINE := LINE.SEGMENT
MEMORY (XX) := @FM:PROGRAM.LINE
NEXT XXX
END
LAST.CELL = XX
CELL.FIRST.LINE = 1 ; CELL = 1 ; LNUM = 0
PROGRAM = '' ; * RETURN DMR STRING SPACE
GOTO END.CHANGE
G.N: ; * Goto a line (by number).
LNUM = CMDN ; GOTO CK.NUM
G.BEGIN.BLOCK: ; * 'G<': goto beginning of a BLOCK.
IF MFROM = 0 THEN GOSUB BLOCK.CHECK
LNUM = MFROM ; GOTO END.NOCHANGE
G.END.BLOCK: ; * 'G>': goto end of a BLOCK.
IF MTHRU = 0 THEN GOSUB BLOCK.CHECK
LNUM = MTHRU ; GOTO END.NOCHANGE
HELP.ANY: ; * Display HELP information.
GOSUB READ.HELP.RECORD
ANY = UPCMD [5, 99]
IF LEN(ANY) = 0 THEN
CALL *UVPRINTMSG(001248,"")
GOSUB INPUT.LINE ; ANY = INPUT.LINE
END
*---- Upcase the keywords or letter.
ANY = TRIM(ANY) ; ANY = UPCASE(ANY) ; XX = 0 ; PRINT
HELP.COUNT = COUNT(HELP.RECORD, @FM) + 1
FOR X = 1 TO HELP.COUNT
LINEX = HELP.RECORD <X>
IF (IF LEN(ANY) # 1 THEN INDEX(LINEX, ANY, 1) ELSE LINEX [1, 1] = ANY) THEN
LOOP
REMOVE LINEXX FROM LINEX SETTING DELIM
PRINT LINEXX ; XX += 1
IF XX => (@CRTHIGH - 2) THEN
CALL *UVPRINTMSG(001142,"")
INPUT Q, 1 ; Q = UPCASE(Q)
IF Q = 'Q' THEN GOTO HELP.END
XX = 0 ; PRINT
END
WHILE DELIM
REPEAT
END
NEXT X
HELP.END:
LINEX = '' ; PRINT ; GOTO END.NOCHANGE
I.ANY: ; * Insert a new line of text.
IF ANY = ' ' THEN ANY = ' ' ; * ANY = ''
* LNUM += 1
* MEMORY (CELL) = INSERT(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, ANY)
* The following code replaces the above 2 lines, which fail when
* inserting data before the last field if the last field is null.
X = LNUM - CELL.FIRST.LINE
IF X < 0 THEN
IF LEN(MEMORY (CELL)) = 0 THEN MEMORY (CELL) = ANY
ELSE MEMORY (CELL) = ANY:@FM:MEMORY (CELL)
END ELSE
Y = FIELD(MEMORY (CELL), @FM, 1, X + 1):@FM:ANY
X = MEMORY (CELL) [COL2(), 99999999]
IF LEN(X) = 0 THEN MEMORY (CELL) = Y
ELSE MEMORY (CELL) = Y:X
END
LNUM += 1
*---- End of special code.
LPC (CELL) += 1
IF BOT = 0 THEN LAST.CELL = 1
BOT += 1
BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = 1 ; GOSUB BLOCK.TRACK
CHANGE.FLAG = TRUE
GOTO END.CMD
I.BEFORE: ; * Insert before current line.
ANY = CMD [4, 9999]
LNUM -= 1 ; * Back up one line.
IF LNUM < 0 THEN LNUM = 0
IF ANY THEN GOTO I.ANY ELSE GOTO I
I: ; * Put editor into INPUT mode.
LNUM.INPUT = LNUM
LNUM += 1
PRINT STR('0', 4 - LEN(LNUM)):LNUM:'=':
LOOP
INPUT.MODE = TRUE
GOSUB INPUT.LINE
IF LEN(INPUT.LINE) = 0 THEN
LNUM = LNUM.INPUT
GOSUB INSERT.MEMORY
IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84
LNUM = LNUM.INPUT + NEW.BOT
BLOCK.TRACK.LNUM = LNUM ; BLOCK.TRACK.CHANGE = NEW.BOT ; GOSUB BLOCK.TRACK
GOSUB CLEAR.NEW.MEMORY
GOTO GET.CMD
END
LNUM += 1 ; * PRINT NEXT LINE NUM ASAP
PRINT STR('0', 4 - LEN(LNUM)):LNUM:'=':
IF INPUT.LINE = ' ' THEN INPUT.LINE = '' ; * INPUT A NULL LINE
NEW.MEMORY.LINE = INPUT.LINE
GOSUB APPEND.NEW.MEMORY
IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84
REPEAT
L.ANY: ; * Locate a line containing the string 'any'.
LOCATE.STRING = ANY
L:
SEARCH.X = 2
L.AGAIN:
IF LNUM => BOT THEN LNUM = 0
L.NEXT:
COMMAND.SUCCESSFUL = FALSE
GOSUB ABORT.CHECK
IF ABORT = 'Q' THEN
CALL *UVPRINTMSG(001228,"")
GOTO END.NOCHANGE
END
LNUM += 1
IF LNUM > BOT THEN LNUM = BOT ; GOTO END.NOCHANGE
GOSUB GET.LINE
ON SEARCH.X GOTO FINDX, LOCATEX, MATCHX
FINDX:
IF LINE [ST.COLUMN, FLEN] = FIND.STRING THEN
COMMAND.SUCCESSFUL = TRUE
GOTO END.NOCHANGE
END ELSE
GOTO L.NEXT
END
LOCATEX:
IF INDEX(LINE, LOCATE.STRING, 1) THEN
COMMAND.SUCCESSFUL = TRUE
GOTO END.NOCHANGE
END ELSE
GOTO L.NEXT
END
MATCHX:
IF LEN(LINE) => 188 THEN
PRINT 'Line ':LNUM:' is longer than 188 characters, MATCH NOT DONE, line skipped.'
GOTO L.NEXT
END
IF LINE MATCHES MATCH.STRING THEN
COMMAND.SUCCESSFUL = TRUE
GOTO END.NOCHANGE
END ELSE
GOTO L.NEXT
END
LOAD.ANY: ; * Load lines from another record.
IF UPCMD1 = '.' THEN SENT = TRIM(CMD [4, 99])
ELSE SENT = TRIM(CMD [6, 99])
IF COUNT(SENT, ' ') > 2 THEN
PRINT 'Too many parameters. Expected (at most) a file name and record name.'
GOTO CMD.ERR
END
IF COUNT(SENT, ' ') THEN
PROMPT.FOR.FILE = FALSE ; NO.SELECT.LIST = TRUE ; SINGLE.FILE.ONLY = TRUE
LOAD.FILE.NAME = '' ; LOAD.DICT = '' ; LOAD.DICT.TEXT = ''
CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, LOAD.DICT,
LOAD.FILE.NAME, PROMPT.FOR.FILE, SINGLE.FILE.ONLY)
IF LOAD.DICT = '' ELSE LOAD.DICT.TEXT = LOAD.DICT:' '
IF LEN(LOAD.FILE.NAME) = 0 OR LOAD.FILE.NAME # LOAD.FILE.NAME <1> THEN
PRINT 'Invalid file name (not found in VOC, or not FILE DEFINITION record).'
GOTO CMD.ERR
END
LOAD.REC.NAME = SENT
*
* Open file to load data from. Carry on if partially successful open
* of distributed file.
*
OPENCHECK LOAD.DICT, LOAD.FILE.NAME TO LOAD.FILE ELSE
ErrorCode = STATUS()
READL FileRec FROM DEVSYS.VOC.FILE,LOAD.FILE.NAME THEN
IF LOAD.DICT = "" THEN
PathName = FileRec<2>
END ELSE
PathName = FileRec<3>
END
RELEASE DEVSYS.VOC.FILE,LOAD.FILE.NAME
END ELSE
PathName = ""
END
IF LOAD.DICT = "" THEN
FileName = LOAD.FILE.NAME
END ELSE
FileName = "DICT,":LOAD.FILE.NAME
END
CALL @OpenError(ErrorCode,FileName,PathName)
GOTO CMD.ERR
END
END ELSE
LOAD.FILE.NAME = FILE.NAME ; LOAD.DICT = DICT ; LOAD.FILE = EDIT.FILE
LOAD.DICT.TEXT = DICT.TEXT
IF UPCMD1 = '.' THEN
IF L.SELECT.FLAG AND LEN(SENT) # 0 THEN
OPENCHECK '', SENT TO LOAD.FILE ELSE
ErrorCode = STATUS()
READL FileRec from DEVSYS.VOC.FILE,SENT THEN
PathName = FileRec<2>
RELEASE DEVSYS.VOC.FILE,SENT
END ELSE
PathName = ""
END
FileName = SENT
CALL @OpenError(ErrorCode,FileName,PathName)
GOTO CMD.ERR
END
LOAD.FILE.NAME = SENT ; GOTO SL.3
END
LOAD.FILE.NAME = '&ED&'
LOAD.DICT = '' ; LOAD.DICT.TEXT = ''
OPENCHECK LOAD.DICT,LOAD.FILE.NAME TO LOAD.FILE ELSE
ErrorCode = STATUS()
READL FileRec FROM DEVSYS.VOC.FILE,LOAD.FILE.NAME THEN
PathName = FileRec<2>
RELEASE DEVSYS.VOC.FILE,LOAD.FILE.NAME
END ELSE
PathName = ""
END
FileName = LOAD.FILE.NAME
CALL @OpenError(ErrorCode,FileName,PathName)
GOTO CMD.ERR
END
END
LOAD.REC.NAME = SENT
END
IF L.SELECT.FLAG THEN GOTO SL.3
IF LEN(SENT) = 0 THEN GOTO CMD.ERR
IF UPCMD1 = '.' THEN GOTO READ.1
IF ED.CMD.STRING.ACTIVE THEN
PRINT STARS:' Loading "':LOAD.DICT.TEXT:LOAD.FILE.NAME:'" "':LOAD.REC.NAME:'"':'.'
END
CALL *UVPRINTMSG(001193,"")
GOSUB INPUT.LINE ; START = INPUT.LINE
IF NOT(NUM(START)) THEN
PRINT 'Starting line/field must be numeric ; you entered "':START:'".'
GOTO CMD.ERR
END
IF START < 1 THEN
CALL *UVPRINTMSG(001231,"")
GOTO CMD.ERR
END
CALL *UVPRINTMSG(001195,"")
GOSUB INPUT.LINE ; ENDING = INPUT.LINE
IF NOT(NUM(ENDING)) THEN
PRINT 'Ending line/field must be numeric ; you entered "':ENDING:'".'
GOTO CMD.ERR
END
IF ENDING < START THEN
CALL *UVPRINTMSG(001233,ENDING:@FM:START)
GOTO CMD.ERR
END
READ.1:
READ BLOCK FROM LOAD.FILE, LOAD.REC.NAME
ELSE
* Record %s does not exist
IF STACK.MODE THEN
CALL *UVPRINTMSG(970004,LOAD.REC.NAME:@FM:LOAD.FILE.NAME)
PRINT
GOSUB DISPLAY.CURRENT.LINE
END ELSE
CALL *UVPRINTMSG(001196,LOAD.REC.NAME)
END
GOTO CMD.ERR
END
IF UPCMD1 = '.' THEN GOTO GET.CMD.FROM.BLOCK
IF ENDING - START + 1 > 32767 THEN ; *015
FIELDS = 32767 ; *015
BLOCK1 = FIELD(BLOCK, @FM, START, FIELDS) ; *015
LOOP ; *015
START += 32767 ; *015
IF ENDING - START + 1 <= 32767 THEN ; *015
FIELDS = ENDING - START + 1 ; *015
END ; *015
WHILE FIELDS > 0 DO ; *015
TEMPBLOCK = FIELD(BLOCK, @FM, START, FIELDS) ; *015
IF TEMPBLOCK # '' THEN ; *015
BLOCK1 = BLOCK1:@FM:TEMPBLOCK ; *015
END ELSE ; *015
START = ENDING + 1 ; *015
END ; *015
REPEAT ; *015
BLOCK = BLOCK1 ; *015
END ELSE ; *015
BLOCK = FIELD(BLOCK, @FM, START, ENDING - START + 1)
END ; *015
LINES.READ = IF LEN(BLOCK) = 0 THEN 0 ELSE COUNT(BLOCK, @FM) + 1
IF LINES.READ = 0 THEN GOTO LOAD.3
X = INT((LINES.READ - 1) / LINES.PER.CELL) ; * DETERMINE NUM OF CELLS REQUIRED
IF X + 1 > NEW.MEMORY.DIM THEN
NEW.MEMORY.DIM = X + 10
DIM NEW.MEMORY (NEW.MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; GOTO END.CMD ; * SJE 23 Apr 84
DIM NEW.LPC (NEW.MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; GOTO END.CMD ; * SJE 23 Apr 84
END
*---- The following code sets up
* to make a BLOCK of each element of the array. The size of the
* BLOCK is defined by LINES.PER.CELL.
*** MATBLOCK NEW.MEMORY FROM BLOCK, @FM, LINES.PER.CELL
CALL @MATBLOCK(MAT NEW.MEMORY,BLOCK,@FM,LINES.PER.CELL)
FOR XX = 1 TO X
NEW.LPC (XX) = LINES.PER.CELL
NEXT XX
NEW.LAST.CELL = X + 1
NEW.LPC (NEW.LAST.CELL) = MOD(LINES.READ - 1, LINES.PER.CELL) + 1
NEW.BOT = LINES.READ
GOSUB INSERT.MEMORY
IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84
GOSUB CLEAR.NEW.MEMORY
LNUM += 1
BLOCK = '' ; * RETURN STRING SPACE
LOAD.3:
* %i lines/fields loaded.
CALL *UVPRINTMSG(001280,LINES.READ)
BLOCK.TRACK.LNUM = LNUM + LINES.READ - 1
BLOCK.TRACK.CHANGE = LINES.READ ; GOSUB BLOCK.TRACK
GOTO END.CMD
M.ANY: ; * Locate a line that matches pattern 'any'.
MATCH.STRING = ANY
M:
SEARCH.X = 3 ; GOTO L.AGAIN
MOVE: ; * Move a BLOCK of lines (deleting source lines).
MOVE.FLAG = TRUE
MOVE.COPY:
GOSUB BLOCK.CHECK
INSERT.LNUM = LNUM ; * SAVE LNUM
FOR LNUM = MFROM TO MTHRU ; * COPY THE DESIRED LINES INTO NEW MEMORY
GOSUB GET.LINE
NEW.MEMORY.LINE = LINE
GOSUB APPEND.NEW.MEMORY
IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84
NEXT LNUM
IF MOVE.FLAG THEN
LNUM = MFROM
GOSUB GET.LINE
NUM.OF.LINES.TO.DELETE = MTHRU - MFROM + 1
GOSUB DELETE.MEMORY ; * DELETE THE BLOCK IF CMD IS A MOVE
LNUM = INSERT.LNUM ; * RESTORE LNUM
IF LNUM => MTHRU THEN LNUM -= MTHRU - MFROM + 1
MTHRU += LNUM - MFROM + 1
MFROM = LNUM + 1
END ELSE
LNUM = INSERT.LNUM ; * RESTORE LNUM
IF LNUM < MFROM THEN
X = MTHRU - MFROM + 1 ; MTHRU += X ; MFROM += X
END
END
GOSUB INSERT.MEMORY
IF OVERFLOW.FLAG THEN GOTO END.CMD ; * SJE 23 Apr 84
GOSUB CLEAR.NEW.MEMORY
LNUM += 1
GOTO END.CMD
N: ; * Move on to next record (if SELECT list is active).
IF SELECT.LIST.FLAG THEN
IF NOT(RECORD.CHANGE.FLAG) THEN GOTO DONE.WITH.RECORD
* Record changed --- OK to go to next record (Y)
CALL *UVPRINTMSG(001222,"")
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS = 'Y' THEN GOTO DONE.WITH.RECORD
ELSE GOTO END.NOCHANGE
END ELSE GOTO X.2
P: ; * Print lines on the CRT.
CMDN = PNUM ; GOTO P.N.1
P.N:
CMDN = CMD [2, 99] ; * GET ORIGINAL NUMBER
P.N.1:
IF LNUM <= 0 THEN LNUM = 1
LINE1 = LNUM
IF CMDN > 1 AND UPCMD[1,1] = "P" THEN PNUM = CMDN
LINE2 = LNUM + CMDN - 1
IF LINE2 > BOT THEN LINE2 = BOT
GOSUB PRINT.GROUP
GOTO GET.CMD
PRINT.BLOCK: ; * Print BLOCK on the CRT.
IF MFROM = 0 OR MTHRU = 0 THEN
* BLOCK not set up.
CALL *UVPRINTMSG(001219,"")
GOTO CMD.ERR
END
IF MFROM > MTHRU THEN
* BLOCK from %i through %i is in the wrong order.
CALL *UVPRINTMSG(001201,MFROM:@FM:MTHRU)
GOTO CMD.ERR
END
LINE1 = MFROM ; LINE2 = MTHRU ; LNUMX = LNUM
GOSUB PRINT.GROUP
LNUM = LNUMX ; PRINT ; GOTO END.NOCHANGE
PRINT.GROUP: ; * GOSUB routine for above PRINT routines.
FOR LNUM = LINE1 TO LINE2
GOSUB GET.LINE ; GOSUB PRINT.LINE
GOSUB ABORT.CHECK
IF ABORT = 'Q' THEN
CALL *UVPRINTMSG(001228,"")
RETURN
END
NEXT LNUM
RETURN
PO.N: ; * Set line number pointer to line 'n'.
CMD = CMD [3, 99]
IF NOT(NUM(CMD)) THEN
PRINT 'A line number is required ; you entered ':CMD:'.'
GOTO CMD.ERR
END
GOTO SET.LNUM
QUIT: ; * Quit this edit session.
* IF SELECT.LIST.FLAG THEN
* CALL *UVPRINTMSG(001216,"")
* PRINT 'Use "X" to exit EDITOR or "N" to see next selected ':REC:'.'
* GOTO CMD.ERR
* END
IF NOT(RECORD.CHANGE.FLAG) THEN GOTO DONE.WITH.RECORD
* Record changed, OK to Quit (Y)
CALL *UVPRINTMSG(001218,"")
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS = 'Y' THEN GOTO DONE.WITH.RECORD
GOTO END.NOCHANGE
QUESTION.MARK: ; * '?': display current STATUS.
COMMAND.SUCCESSFUL = FALSE
DISPLAY.CURRENT.LINE = FALSE
CALL *UVPRINTMSG(970011,@ACCOUNT)
CALL *UVPRINTMSG(001262,"")
PRINT DICT.TEXT:FILE.NAME:
IF EDIT.READ.ONLY THEN CALL *UVPRINTMSG(001263,"")
PRINT
LINEX = DISPLAY.RECORD.NAME
IF NLS.ON.FLAG AND UP.ARROW.FLAG THEN ;* in NLS mode, only display ID
GOSUB CONV.LINEX.TO.UP.ARROW ;* as ^xxx if ^ mode is on
END
CALL *UVPRINTMSG(001264,LINEX) ;* record name = nnnnnn
CALL *UVPRINTMSG(001265,LNUM)
IF UP.ARROW.FLAG THEN
IF UP.ARROW.UNIC.FLAG THEN
CALL *UVPRINTMSG(001266,ENABLED:UNICODE) ;* NLS Unicode ^x mode on
END ELSE
CALL *UVPRINTMSG(001266,ENABLED) ;* standard ^ mode on
END
END ELSE
CALL *UVPRINTMSG(001266,DISABLED)
END
IF ABORT.FLAG THEN
CALL *UVPRINTMSG(001267,ENABLED)
END ELSE
CALL *UVPRINTMSG(001267,DISABLED)
END
IF BLOCK.VERIFY.FLAG THEN
CALL *UVPRINTMSG(001268,ENABLED)
END ELSE
CALL *UVPRINTMSG(001268,DISABLED)
END
IF MTHRU = 0 OR MFROM = 0 THEN
* No BLOCK currently defined.
CALL *UVPRINTMSG(001269,"")
IF MFROM # 0 THEN
* Block FROM set to line %i.
CALL *UVPRINTMSG(001226,MFROM)
END
IF MTHRU # 0 THEN
* Block THROUGH set to line %i.
CALL *UVPRINTMSG(001225,MTHRU)
END
END ELSE
* BLOCK is from line %i through %i.
CALL *UVPRINTMSG(001270,MFROM:@FM:MTHRU)
END
IF CURR.CMD.NAME THEN
PRINT 'Last Pre-store executed = "':CURR.CMD.NAME:'".':
IF ED.CMD.STRING.SUSPENDED THEN PRINT ' Command is at a PAUSE.'
ELSE PRINT ' Command is not active.'
END ELSE
PRINT 'No ':PRE.STORE:' has been executed this session.'
END
RESTORE.CMD = IF ED.CMD.STRING.ACTIVE AND CHANGE.DURING.CMD.STRING THEN PRIOR.CMD ELSE SAVED.CMD
IF RESTORE.CMD THEN
CALL *UVPRINTMSG(001271,RESTORE.CMD)
END ELSE
CALL *UVPRINTMSG(001249,"")
END
GOTO END.CMD
R.ANY: ; * Replace line with new text.
REPLACE.STRING = CMD [3, 999999]
R:
IF LNUM < 1 THEN
CALL *UVPRINTMSG(970010,LNUM)
GOTO CMD.ERR
END
MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, REPLACE.STRING)
GOTO END.CHANGE
RELEASE: ; * Release record lock.
IF RECORD.NAME.LOCKED THEN
RELEASE EDIT.FILE, RECORD.NAME
RECORD.NAME.LOCKED = FALSE
CALL *UVPRINTMSG(001252,"")
END ELSE PRINT UREC:' was not locked.'
GOTO END.NOCHANGE
SAVE.ANY: ; * Save a copy of this record.
COMMAND.SUCCESSFUL = FALSE
DISPLAY.CURRENT.LINE = FALSE
IF RECORD.CHANGE.FLAG OR UPCMD # 'SAVE' THEN
GOSUB FILE.IT
IF NOT(WRITEERROR) THEN RECORD.CHANGE.FLAG = FALSE ; * RESET ;*026
END ELSE
PRINT UREC:' has not been changed, or you already have done a SAVE.'
END
GOTO END.NOCHANGE
SEQ.ANY: ; * Generate a sequential number.
X = 4
LOOP DELIM = CMD [X, 1] WHILE DELIM = ' ' DO X += 1 REPEAT
IF NOT(INDEX(DELIM.STRING, DELIM, 1)) THEN
PRINT 'Valid delimiters are ':DELIM.STRING
GOTO CMD.ERR
END
IF COUNT(CMD, DELIM) > 4 THEN
PRINT 'Too many delimiters (4 maximum).'
GOTO CMD.ERR
END
FROM.FIELD = FIELD(CMD, DELIM, 2)
LEN.FROM.FIELD = LEN(FROM.FIELD)
TO.FIELD = FIELD(CMD, DELIM, 3)
INC.FIELD = FIELD(CMD, DELIM, 5)
IF NOT(NUM(INC.FIELD)) OR LEN(TO.FIELD) = 0 OR NOT(NUM(TO.FIELD)) THEN
GOTO NUMBER.ERR
END
IF LEN(INC.FIELD) = 0 THEN INC.FIELD = 1
EXTEND = 0
N = FIELD(CMD, DELIM, 4)
N = UPCASE(N)
IF N = 'B' THEN
GOSUB BLOCK.CHECK ; LNUM = MFROM ; LEND = MTHRU
END ELSE
IF LEN(N) = 0 OR NOT(NUM(N)) THEN GOTO NUMBER.ERR
IF LNUM <= 0 THEN LNUM = 1
LEND = LNUM + N - 1
EXTEND = 0
IF FROM.FIELD THEN
IF LEND > BOT THEN LEND = BOT
END ELSE
IF LEND > BOT THEN EXTEND = LEND ; LEND = BOT
END
END
X.CHANGE.FLAG = FALSE ; * RESET LOCAL CHANGE FLAG
FOR LNUM = LNUM TO LEND
GOSUB GET.LINE
IF LEN(FROM.FIELD) = 0 THEN LINE = TO.FIELD:LINE ; GOTO S.REPLACE.LINE
X = INDEX(LINE, FROM.FIELD, 1)
IF X = 0 THEN GOTO S.NEXT.LINE
LINE = LINE [1, X - 1]:TO.FIELD:LINE [X + LEN.FROM.FIELD, 999999]
S.REPLACE.LINE:
MEMORY (CELL) = REPLACE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0, LINE)
GOSUB PRINT.LINE
CHANGE.FLAG = TRUE
X.CHANGE.FLAG = TRUE ; * SET LOCAL CHANGE FLAG
TO.FIELD += INC.FIELD
S.NEXT.LINE:
NEXT LNUM
IF EXTEND THEN
FOR LNUM = BOT + 1 TO EXTEND
LINE = TO.FIELD
GOSUB PRINT.LINE
NEW.MEMORY.LINE = LINE
GOSUB APPEND.NEW.MEMORY
IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84
TO.FIELD += INC.FIELD
NEXT LNUM
LNUM = BOT
GOSUB INSERT.MEMORY
IF OVERFLOW.FLAG THEN GOTO GET.CMD ; * SJE 23 Apr 84
GOSUB CLEAR.NEW.MEMORY
LNUM = EXTEND
GOTO GET.CMD
END
CHANGE.FLAG = X.CHANGE.FLAG ; * SET UP FLAG FOR OOPS SINCE GET.LINE
; * COULD HAVE RESET IT AFTER LAST LINE ACTUALLY CHANGED
GOTO GET.CMD
SIZE: ; * Display information about SIZE of record.
LENGTH = 0
FOR X = 1 TO LAST.CELL
LENGTH += LEN(MEMORY (X)) ; * ADD LENGTH OF LINES
NEXT X
IF LAST.CELL > 1 THEN LENGTH += LAST.CELL - 1
CALL *UVPRINTMSG(001255,DISPLAY.RECORD.NAME:@FM:BOT:@FM:LENGTH)
GOTO END.NOCHANGE
SPOOL.HELP: ; * Spool the HELP file on line printer.
GOSUB READ.HELP.RECORD
PRINTER ON
HEADING 'EDITOR H E L P LIST OF COMMANDS ':TIMEDATE():"'LLL'"
LOOP
REMOVE LINEX FROM HELP.RECORD SETTING DELIM
PRINT LINEX ; PRINT ' '
WHILE DELIM REPEAT
PRINTER OFF
DUMMY = @(0) ; * TURN OFF CRT PAGING
PRINT 'HELP listing spooled to printer.'
GOTO HELP.END
SPOOL.N: ; * Spool the record on line printer.
CMDN = CMD [6, 99]
IF NOT(NUM(CMDN)) THEN GOTO NUMBER.ERR
IF CMDN > 0 THEN
IF LNUM <= 0 THEN LNUM = 1
IF LNUM + CMDN - 1 > BOT THEN CMDN = BOT - LNUM + 1
LEND = LNUM + CMDN - 1
END ELSE LNUM = 1 ; LEND = BOT
BREAK KEY OFF
PRINTER ON ;* send output to lptr 0 via channel 0.
LPTR.WIDTH = @LPTRWIDE
LPTR.MODE = 0 ; CODE = 0
CALL @GETPU(PU$MODE,0,LPTR.MODE,CODE)
IF LPTR.MODE # 3 THEN
* save banner
LPTR.BANNER = SPACE(32)
CODE = 0
CALL @GETPU(PU$BANNER,0,LPTR.BANNER,CODE)
* set banner
RECORD.BANNER = FMT(DISPLAY.RECORD.NAME, 'L#32')
CALL @SETPU(PU$BANNER,0,RECORD.BANNER,CODE)
END
HEADING UREC:' - ':DISPLAY.RECORD.NAME:' File - ':FILE.NAME:' Account - ':@ACCOUNT:' ':TIMEDATE():"'LL'"
LINE.LENGTH = LPTR.WIDTH - 7
FOR LNUM = LNUM TO LEND
GOSUB GET.LINE ; GOSUB PRINT.LINE
NEXT LNUM
PRINTER CLOSE ;* Flush printer buffer (GTAR 12556)
PRINTER OFF
PRINTER CLOSE
IF LPTR.MODE # 3 THEN
* reset banner
PRINTER ON
CALL @SETPU(PU$BANNER,0,LPTR.BANNER,CODE)
PRINTER CLOSE ;* Flush printer buffer (GTAR 12556)
PRINTER OFF
END
BREAK KEY ON
DUMMY = @(0) ; * TURN OFF CRT PAGING
LINE.LENGTH = CRT.WIDTH - 7
IF CMDN > 0 THEN PRINT 'Lines ':LEND - CMDN + 1:' to ':LEND:' of ':
PRINT '"':DISPLAY.RECORD.NAME:'" spooled to the printer.'
T: ; * Goto TOP of record.
LNUM = 0 ; GOTO END.NOCHANGE
STAMP:
CMD = 'I '
BEGIN CASE
CASE RECORD.NAME [4] = '.CBL' OR RECORD.NAME [6] = '.COBOL'
CMD := SPACE(6):'*'
CASE RECORD.NAME [4] = '.CPL'
CMD := '/*'
CASE RECORD.NAME [4] = '.F77' OR RECORD.NAME [4] = '.FTN'
CMD := 'C'
CASE RECORD.NAME [7] = '.PASCAL'
CMD := '{'
CASE RECORD.NAME [4] = '.PL1' OR RECORD.NAME [5] = '.PL1G' OR RECORD.NAME [4] = '.PLP' OR RECORD.NAME [4] = '.SPL'
CMD := '/*'
CASE RECORD.NAME [5] = '.RUNI'
CMD := '.*'
CASE TRUE
CMD := '*'
END CASE
CMD := ' Last updated by ':@WHO
IF @WHO # @LOGNAME THEN CMD := ' (':@LOGNAME:')'
CMD := ' at ':OCONV(TIME(), 'MTS')
CMD := ' on ':OCONV(DATE(), 'D4/'):'.'
BEGIN CASE
CASE RECORD.NAME [7] = '.PASCAL'
CMD := ' }'
CASE RECORD.NAME [4] = '.PL1' OR RECORD.NAME [5] = '.PL1G' OR RECORD.NAME [4] = '.PLP' OR RECORD.NAME [4] = '.SPL'
CMD := ' */'
CASE TRUE
NULL
END CASE
STACK.MODE = FALSE
GOTO GET.CMD.2
UNLOAD.ANY: ; * Unload lines to another record.
COMMAND.SUCCESSFUL = FALSE
DISPLAY.CURRENT.LINE = FALSE
SV.LNUM = LNUM ; UNLOAD.FLAG = TRUE
GOSUB STRING.WRITE
UNLOAD.FLAG = FALSE ; LNUM = SV.LNUM
GOTO END.NOCHANGE
SET.LNUM: ; * '+n', '-n', 'n': set line number.
IF CMD [1, 1] = '+' OR CMD [1, 1] = '-' THEN LNUM += INT(CMD)
ELSE LNUM = INT(CMD)
CK.NUM:
IF LNUM < 0 THEN LNUM = 0
IF LNUM > BOT THEN LNUM = BOT ; COMMAND.SUCCESSFUL = FALSE
GOTO END.NOCHANGE
MFROM: ; * '<': set BLOCK 'from' pointer.
COMMAND.SUCCESSFUL = FALSE
DISPLAY.CURRENT.LINE = FALSE
IF LNUM = 0 THEN
CLEAR.BLOCK:
MFROM = 0 ; MTHRU = 0
* The current BLOCK pointers have been cleared.
CALL *UVPRINTMSG(001224,"")
END ELSE
MFROM = LNUM
* Block FROM set to line %i.
CALL *UVPRINTMSG(001226,MFROM)
END
IF UPCMD # '<>' OR LNUM = 0 THEN GOTO END.NOCHANGE
MTHRU: ; * '>': set BLOCK 'to' pointer.
COMMAND.SUCCESSFUL = FALSE
DISPLAY.CURRENT.LINE = FALSE
IF LNUM = 0 THEN GOTO CLEAR.BLOCK
MTHRU = LNUM
* Block THROUGH set to line %i.
CALL *UVPRINTMSG(001225,MTHRU)
GOTO END.NOCHANGE
UP.ARROW.TOGGLE: ; * '^': Up arrow display mode toggle.
* Controls the display/printing of special characters.
* There are two modes:
* - Straight '^' mode, in which unprintable characters are displayed as
* ^ddd (3-digit decimals) (UP.ARROW.FLAG AND NOT(UP.ARROW.UNIC.FLAG))
* unless the characters is > 255, in which case same as ^X mode.
* - NLS '^X' mode, in which unprintable characters are displayed as
* ^hhhh (4-digit hex) (UP.ARROW.FLAG AND UP.ARROW.UNIC.FLAG).
IF UPCMD = UP.ARROW.UNIC.UP THEN
* ^X means force Unicode ^ mode on regardless of previous state, but
* is only recognized if Unicode (NLS) mode is on:
IF NOT(NLS.ON.FLAG) THEN
* 'The %s command is not allowed unless NLS support is ON.'
* CALL *UVPRINTMSG('970014',UP.ARROW.UNIC.UP)
GOSUB PRINT.INVALID.UP.ARROW ;* replace with line above after 8.3.3
GOTO END.NOCHANGE
END
UP.ARROW.UNIC.FLAG = TRUE
UP.ARROW.FLAG = TRUE
END ELSE
* ^ on its own toggles standard mode, always sets Unicode ^ mode off:
UP.ARROW.FLAG = NOT(UP.ARROW.FLAG)
UP.ARROW.UNIC.FLAG = FALSE
END
IF UP.ARROW.FLAG THEN
IF UP.ARROW.UNIC.FLAG THEN
CALL *UVPRINTMSG(001266,ENABLED:UNICODE) ;* NLS Unicode ^x mode on
END ELSE
CALL *UVPRINTMSG(001266,ENABLED) ;* standard ^ mode on
END
END ELSE
CALL *UVPRINTMSG(001266,DISABLED)
END
GOTO END.NOCHANGE
***********************************************************************
* exit edit session and close common VOC file.
*
STOP:
IF ASSIGNED(DEVSYS.VOC.FILE) THEN
CLOSE DEVSYS.VOC.FILE
END
DEVSYS.DICT.SWITCH = 0
IF ASSIGNED(DEVSYS.DICT.FILE) THEN
CLOSE DEVSYS.DICT.FILE
END
DEVSYS.DICT.FILE.NAME = ""
IF ASSIGNED(DEVSYS.DATA.FILE) THEN
CLOSE DEVSYS.DATA.FILE
END
DEVSYS.DATA.FILE.NAME = ""
IF ASSIGNED(DEVSYS.R.FILE) THEN
CLOSE DEVSYS.R.FILE
END
DEVSYS.R.FILE.NAME = ""
PRINT:
STOP.POP:
RETURN TO STOP.POP
X: ; * Exit from editor when SELECT list is active.
IF SELECT.LIST.FLAG THEN
*---- PCC was here 11/04/83. Now releases locked record before stoppping.
IF RECORD.CHANGE.FLAG THEN
*------- See if we want to file first.
* Record changed --- OK to EXIT (Y)
CALL *UVPRINTMSG(001223,"")
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS # 'Y' THEN GOTO END.NOCHANGE ; * file it maybe
END
*------- We're stopping, but first may need to release current record.
IF RECORD.NAME.LOCKED THEN
RELEASE EDIT.FILE, RECORD.NAME ; * RELEASE RECORD LOCK
RECORD.NAME.LOCKED = FALSE
END
GOTO STOP
END
X.2:
* This command can only be used when a SELECT list is active.
CALL *UVPRINTMSG(001221,"")
GOTO CMD.ERR
*
* 007 - This section of code has replaced the old section completely.
* Note: the @variable @LINE is a special case, as it is the current
* line being edited, and must be allocated dynamically as
* the xeq sentence is being 'parsed';
* Note: tokens are strings delimited by blanks, thus to pass a legal
* @variable name to xeq without replacing it, the sentence must
* be of the form:
* XEQ ..... '@variable' ..... or
* XEQ ..... "@variable" .....
*
* Note the blanks before and after the dots
*
XEQ.ANY: ; * 007 Execute any PERFORM statement.
NEW.XEQ=''
*
* Get the PERFORM sentence to execute
*
XEQ.POS = INDEX(CMD, ' ', 1)
XEQ = CMD[XEQ.POS+1, 999999]
*
BLK=' '
XEQ.LEN=LEN(XEQ)
IF XEQ.LEN > 0 THEN ; * if there is anything after XEQ
NT=COUNT(XEQ,BLK)+1 ; * COUNT NUMBER OF TOKENS(>0)
FOR I=1 TO NT
TOKEN=FIELD(XEQ,BLK,I) ; * EXTRACT CURRENT TOKEN
C1=TOKEN[1,1]
C2='' ; * 013
IF C1 = '*' OR C1 = '-' THEN ; * 013
C2=C1 ; * 013
TOKEN=TOKEN[2,999999] ; * 013
C1=TOKEN[1,1] ; * 013
END ; * 013
L.TOK=LEN(TOKEN)
CL=TOKEN[L.TOK,1]
IF C1 = '@' THEN ; * CHECK FOR LEGAL @VARIABLE NAME
LOCATE TOKEN IN AT.LIST <1> BY 'AL' SETTING AT.LOC ELSE AT.LOC=''
IF AT.LOC THEN ; * LEGAL NAME FOUND,SPEC.CASE FOR @LINE
IF TOKEN='@LINE' THEN AT.SUB=REPLACE(AT.SUB,AT.LOC,0,0,LINE)
TOKEN = AT.SUB <AT.LOC>
END
END
IF TOKEN = '@FM' THEN TOKEN = @FM ; * CONVERT @FM TO ~
*
* NOW PROCESS QUOTED STRINGS, CHECKING THAT DATA INSIDE QUOTES IS A LEGAL
* @ VARIABLE NAME. NOTE THAT WE DO NOT NEED A SPECIAL CASE FOR @LINE, BUT
* THAT WE DO NEED ONE FOR @FM AS IT IS NOT IN AT.SUB
* SUB.TOKEN IS TOKEN STRIPPED OF QUOTES
*
IF (C1=CHAR(34) OR C1=CHAR(39)) AND CL = C1 THEN
SUB.TOKEN = TOKEN[2,L.TOK-2]
LOCATE SUB.TOKEN IN AT.LIST <1> BY 'AL' SETTING AT.LOC ELSE AT.LOC=''
IF AT.LOC OR SUB.TOKEN='@FM' THEN TOKEN=SUB.TOKEN
END
*
*IN ALL CASES ADD WHATEVER IS IN TOKEN TO NEW.XEQ
*
NEW.XEQ=NEW.XEQ:C2:TOKEN:BLK ; * 013 ;* ADD TOKEN TO NEW.XEQ IN ALL CASES
NEXT I ; * END OF DO LOOP
END ; * END OF IF PRECEEDING DO LOOP
NEW.XEQ = NEW.XEQ[1,LEN(NEW.XEQ)-1] ; * 014 ;* 018
CALL *UVPRINTMSG(001259,NEW.XEQ)
*
* (GTAR 12556) Reset terminal using uniVerse PRINTER RESET
*
PFLAG = SYSTEM(1)
IF PFLAG THEN PRINTER OFF
PRINTER RESET
IF PFLAG THEN PRINTER ON
SAVE.DEVSYS.VOC.FILE = DEVSYS.VOC.FILE
SAVE.DEVSYS.DICT.SWITCH = DEVSYS.DICT.SWITCH
SAVE.DEVSYS.DICT.FILE = DEVSYS.DICT.FILE
SAVE.DEVSYS.DICT.FILE.NAME = DEVSYS.DICT.FILE.NAME
SAVE.DEVSYS.DATA.FILE = DEVSYS.DATA.FILE
SAVE.DEVSYS.DATA.FILE.NAME = DEVSYS.DATA.FILE.NAME
SAVE.DEVSYS.R.FILE = DEVSYS.R.FILE
SAVE.DEVSYS.R.FILE.NAME = DEVSYS.R.FILE.NAME
EXECUTE NEW.XEQ ; * EXECUTE THE COMMAND LINE
DEVSYS.VOC.FILE = SAVE.DEVSYS.VOC.FILE
DEVSYS.DICT.SWITCH = SAVE.DEVSYS.DICT.SWITCH
DEVSYS.DICT.FILE = SAVE.DEVSYS.DICT.FILE
DEVSYS.DICT.FILE.NAME = SAVE.DEVSYS.DICT.FILE.NAME
DEVSYS.DATA.FILE = SAVE.DEVSYS.DATA.FILE
DEVSYS.DATA.FILE.NAME = SAVE.DEVSYS.DATA.FILE.NAME
DEVSYS.R.FILE = SAVE.DEVSYS.R.FILE
DEVSYS.R.FILE.NAME = SAVE.DEVSYS.R.FILE.NAME
PRINTER CLOSE ;* Flush printer buffer (GTAR 12556)
DUMMY = @(0) ; * DISABLE CRT PAGING AGAIN
CALL *UVPRINTMSG(001260,"")
PROMPT ' '
GOTO END.NOCHANGE
!
* General GOSUB routines.
!
GET.LINE: ; * Get specified line from record. GOSUB routine.
*---- The record being editted is maintained in a matrix called MEMORY.
* Each element of the matrix contains NUMBER.LINES.PER.CELL of source
* lines when the record is originally read into MEMORY.
* The actual number of lines in each cell is kept in a parallel matrix
* called LPC (Lines Per Cell).
*---- As MEMORY is modified, LPC must also be changed to reflect the correct
* number of lines in the changed cells. The current line, called LNUM,
* is in the current cell called CELL. The effective line number of the
* first line in the current cell is called CELL.FIRST.LNUM. The last
* line number is called BOT (bottom) and is in the last active cell
* called LAST.CELL. The variable LNUM.SAVE is used to indicate the
* previous line number that was being pointed to.
*---- The primary goal of the MEMORY accessing is speed. It is necessary
* to know if the current cell has been changed (since this reset any
* REMOVE pointers). The variable CHANGE.FLAG must be set to TRUE by any
* routine that changes any cell of MEMORY. If a cell has been changed
* then the REMOVE pointers must be rescanned.
*---- When accessing a line, the logic will determine if the line LNUM is
* in the current cell. If so, then it determines if the remove pointers
* can be used or if they have to be reset. If the line is not in the
* current cell, then the logic determines the fastest access
* to one of the four possible quadrants of MEMORY by
* scanning LPC forward from the first cell or the current cell or by
* scanning LPC backward from the last cell or the current cell.
* Once the correct cell is located, the desired line is REMOVEd.
* Subsequent accesses to get the next sequential line will use the REMOVE
* pointers until either a line is changed or the next line is in the
* next cell.
*---- GET.LINE should not be called with LNUM <= 0 or LNUM > BOT, or when the memory
* matrix is null !!!
*---- BOT line number of the last line (bottom)
* CELL current cell of MEMORY containing line LNUM
* CELL.FIRST.LINE line number of first line in this cell
* CHANGE.FLAG set to TRUE whenever a routine changes MEMORY (set by user)
* LAST.CELL last cell (matrix element) used in MEMORY and LPC
* LINE text line from record at line number LNUM
* LNUM line number of current line (set by user)
* LNUM.SAVE line number of previously accessed line
* LPC matrix, number of Lines Per Cell in MEMORY (set by user)
* MEMORY matrix of record being editted, LPC lines in each cell (set by user)
IF CHANGE.FLAG THEN
CHANGE.FLAG = FALSE ; RECORD.CHANGE.FLAG = TRUE
END ELSE
IF LNUM = LNUM.SAVE + 1 THEN
IF LNUM < CELL.FIRST.LINE + LPC (CELL) THEN GOTO GET.LINE.7 ; * GET NEXT SEQUENTIAL LINE
ELSE GOTO GET.LINE.2 ; * MUST GOTO TO NEXT CELL
END
IF (LNUM => CELL.FIRST.LINE) AND (LNUM < LPC (CELL) + CELL.FIRST.LINE) THEN
IF LNUM = LNUM.SAVE THEN RETURN ; * ALREADY HAVE IT
IF LNUM > LNUM.SAVE THEN GOTO GET.LINE.6 ; * IN THIS CELL AFTER LNUM.SAVE
ELSE GOTO GET.LINE.5 ; * IN THIS CELL BEFORE LNUM.SAVE
END
END
*---- Not in current cell, or cell changed; find cell containing LNUM.
IF LNUM => CELL.FIRST.LINE THEN
IF LNUM > (CELL.FIRST.LINE + BOT) / 2 THEN GOTO GET.LINE.3 ; * SCAN BACK FROM BOT
ELSE GOTO GET.LINE.2 ; * SCAN UP FROM CELL
END ELSE
IF LNUM > CELL.FIRST.LINE / 2 THEN GOTO GET.LINE.4 ; * SCAN BACK FROM CELL
ELSE GOTO GET.LINE.1 ; * SCAN UP FROM START (TOP)
END
GET.LINE.1: ; * Initialize scan forward from first line.
CELL = 1 ; CELL.FIRST.LINE = 1
IF LNUM = 0 THEN
LINE = '' ; LNUM.SAVE = 0
MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, DO NOT REMOVE !!!
RETURN
END
GET.LINE.2: ; * Scan forward to locate desired cell containing line LNUM.
LOOP WHILE LNUM => CELL.FIRST.LINE + LPC (CELL)
CELL.FIRST.LINE += LPC (CELL)
MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, DO NOT REMOVE !!!
CELL += 1
REPEAT
GOTO GET.LINE.5:
GET.LINE.3: ; * Initialize to scan backward from last cell.
CELL = LAST.CELL
CELL.FIRST.LINE = BOT + 1 - LPC (CELL)
GET.LINE.4: ; * Scan backward to locate desired cell containing line LNUM.
LOOP WHILE LNUM < CELL.FIRST.LINE
MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, DO NOT REMOVE !!!
CELL -= 1 ; CELL.FIRST.LINE -= LPC (CELL)
REPEAT
GET.LINE.5: ; * Reset to start remove from first line of cell.
LNUM.SAVE = CELL.FIRST.LINE - 1
MEMORY (CELL) = MEMORY (CELL) ; * RESET REMOVE POINTER, KEEP THIS LINE !!!
GET.LINE.6: ; * Remove lines up to the line before the desired one.
FOR X = LNUM.SAVE TO LNUM - 2
LOOP
REMOVE LINE FROM MEMORY (CELL) SETTING DX
UNTIL DX = 2 OR DX = 0 REPEAT
NEXT X
GET.LINE.7: ; * Remove the desired line.
LNUM.SAVE = LNUM
REMOVE LINE FROM MEMORY (CELL) SETTING DX
IF ISNULL(LINE) THEN LINE = @NULL.STR
IF DX = 2 OR DX = 0 THEN RETURN
LOOP
LINE := CHAR(256 - DX)
REMOVE LX FROM MEMORY (CELL) SETTING DX
IF ISNULL(LX) THEN LX = @NULL.STR
LINE := LX
UNTIL DX = 2 OR DX = 0 REPEAT
RETURN
DELETE.MEMORY: ; * Delete 1 or more lines from record memory. GOSUB routine.
*---- This subroutine deletes lines from the blocked memory. It is assumed
* that GET.LINE has been called with LNUM set to the first line to be
* deleted (this sets up variables used here). Also, the variable
* NUM.OF.LINES.TO.DELETE should be set by the caller to the number of lines to
* be deleted.
* It is assumed that LNUM + NUM.OF.LINES.TO.DELETE - 1 is not greater than BOT.
* If during the deleting process, one or more cells of memory are
* completely cleared (LPC (CELL) = 0), then they will be squeezed out of
* the matrices MEMORY and LPC.
* The most probable delete case is to delete a single line. This case
* is optimized to be the fastest. When deleting lines out of a cell
* the logic will check to see if the entire cell will be cleared so that
* it may be squeezed out of the matrices. If two cells are partially
* deleted, they will not be recombined.
* The subroutine exits with MEMORY and LPC set up to reflect the new
* record content. CHANGE.FLAG will be set, LNUM will be backed up
* one line, and BOT and LAST.CELL will be properly adjusted.
* Two variables, CELLX and CELLY are used to count the cell to squeeze.
* CELLX points to the first cell that may be squeezable.
* CELLY points to the cell after the last one that may be squeezed.
*---- Initialize:
IF NUM.OF.LINES.TO.DELETE = 0 THEN RETURN
CHANGE.FLAG = TRUE
BOT -= NUM.OF.LINES.TO.DELETE
*---- Check if first cell will be totally deleted; if so, squeeze out cell.
IF LNUM = CELL.FIRST.LINE AND NUM.OF.LINES.TO.DELETE => LPC (CELL) THEN
CELLX = CELL ; GOTO DELETE.MEMORY.1
END
*---- Check if only one line (but not all of cell) to be deleted.
IF NUM.OF.LINES.TO.DELETE = 1 THEN
MEMORY (CELL) = DELETE(MEMORY (CELL), LNUM - CELL.FIRST.LINE + 1, 0, 0)
LPC (CELL) -= 1
GOTO DELETE.MEMORY.2
END
*---- Determine number of lines to delete from the first cell.
NUM.TO.DELETE = IF LNUM + NUM.OF.LINES.TO.DELETE > CELL.FIRST.LINE + LPC (CELL)
THEN LPC (CELL) - (LNUM-CELL.FIRST.LINE)
ELSE NUM.OF.LINES.TO.DELETE
*---- Delete some lines from the current cell.
SENT = FIELD(MEMORY (CELL), @FM, LNUM - CELL.FIRST.LINE + 1, NUM.TO.DELETE) ; * SET COL1() AND COL2()
SENT = '' ; * RETURN DMR SPACE
MEMORY (CELL) = MEMORY (CELL) [1, COL1() - 1]:MEMORY (CELL) [COL2() + IF COL1() THEN 0 ELSE 1, 999999]
LPC (CELL) -= NUM.TO.DELETE
*---- Check if all done; if not, go to next cell.
IF NUM.TO.DELETE = NUM.OF.LINES.TO.DELETE THEN GOTO DELETE.MEMORY.2
CELLX = CELL + 1
NUM.OF.LINES.TO.DELETE -= NUM.TO.DELETE
DELETE.MEMORY.1: ; * Scan cell line count to see if they can be squeezed.
CELLY = CELLX
LOOP WHILE IF CELLY <= LAST.CELL THEN NUM.OF.LINES.TO.DELETE => LPC (CELLY) ELSE 0
NUM.OF.LINES.TO.DELETE -= LPC (CELLY)
CELLY += 1 ; * ON EXIT, CELLY CONTAINS FIRST LINE AFTER DELETED BLOCK
REPEAT
*---- Calculate number of cells to shift and abandon.
XX = CELLY - CELLX ; * XX IS THE NUMBER OF CELLS TO SQUEEZE OUT
IF XX THEN
*---- Shift end of memory down unless there are no cells left to shift.
IF CELLY <= LAST.CELL THEN
FOR X = CELLX TO LAST.CELL-XX
MEMORY (X) = MEMORY (CELLY)
LPC (X) = LPC (CELLY)
CELLY += 1
NEXT X
END
LAST.CELL -= XX ; * SET UP LAST.CELL TO CORRECT FINAL VALUE
*---- Clear out abandoned cells.
FOR X = LAST.CELL + 1 TO LAST.CELL + XX
MEMORY (X) = '' ; LPC (X) = 0
NEXT X
END
*---- Delete unwanted lines from next cell, if any.
IF NUM.OF.LINES.TO.DELETE THEN
MEMORY (CELLX) = FIELD(MEMORY (CELLX), @FM, NUM.OF.LINES.TO.DELETE+1, 999999)
LPC (CELLX) -= NUM.OF.LINES.TO.DELETE
END
DELETE.MEMORY.2: ; * Exit with LNUM backed up one line.
IF LNUM = CELL.FIRST.LINE THEN
IF LNUM # 1 THEN
CELL -= 1 ; * BACKUP TO LAST LINE OF PREVIOUS CELL
CELL.FIRST.LINE -= LPC (CELL)
END
END
LNUM -= 1
RETURN
INSERT.MEMORY:
* Insert a new block into record memory. GOSUB routine.
* This subroutine inserts blocks of lines into the blocked record memory.
* New lines from NEW.MEMORY will be inserted after the current line LNUM.
* The block of new lines is contained in matrices called NEW.MEMORY
* and NEW.LPC in the same format as the main matrices MEMORY and LPC.
* They contain the number of lines specified by NEW.BOT (new bottom)
* and contain NEW.LAST.CELL active cells (matrix elements).
* The strategy of insertion is to push the new memory cells into the
* memory matrices without altering or combining any cells. If the
* insertion requires splitting the current cell (that is, the current
* line LNUM is not the last line of the cell) then that cell will
* be split into two cells and the new memory cells will be pushed
* in between.
* If LNUM=0 then insertion will be made in front of all lines.
* The new memory matrices and associated variables will not be altered.
* The subroutine exits with all key memory variables correctly set up.
IF NEW.BOT = 0 THEN RETURN
GOSUB GET.LINE ; * INITIALIZE POINTERS TO MEMORY FOR CURRENT LNUM
CHANGE.FLAG = TRUE
IF BOT = 0 THEN LAST.CELL = 0 ; * RESET IF RECORD IS NULL
BOT += NEW.BOT
*---- Check size of memory matrices & re-dimension if necessary.
IF NEW.LAST.CELL + LAST.CELL + 1 > MEMORY.DIM THEN
MEMORY.DIM = NEW.LAST.CELL + LAST.CELL + 20
DIM MEMORY (MEMORY.DIM) ; * RE-DIMEMSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM LPC (MEMORY.DIM) ; * RE-DIMEMSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM PRIOR.MEMORY (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM PRIOR.LPC (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM SAVED.MEMORY (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM SAVED.LPC (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
FOR X = LAST.CELL + 1 TO MEMORY.DIM
MEMORY (X) = '' ; * INITIALIZE MEMORY
LPC (X) = 0 ; * INITIALIZE LINES.PER.CELL MATRIX
PRIOR.MEMORY (X) = '' ; SAVED.LPC (X) = 0
PRIOR.LPC (X) = 0 ; SAVED.MEMORY (X) = ''
NEXT X
END
*---- Is insert at front (LNUM = 0).
IF LNUM = 0 THEN
START.CELL = 1
CELLX = LAST.CELL + NEW.LAST.CELL
GOTO INSERT.MEMORY.1
END
*---- Is insert after end (LNUM = BOT).
IF LNUM = BOT THEN
CELLX = LAST.CELL + NEW.LAST.CELL
GOTO INSERT.MEMORY.2
END
*---- Set up to insert after the current cell.
START.CELL = CELL + 1
*---- Allow 1 extra if splitting current cell (LNUM not at cell end
* and LNUM # 0).
CELLX = LAST.CELL + NEW.LAST.CELL + ((LNUM < CELL.FIRST.LINE + LPC (CELL) - 1) AND LNUM # 0)
INSERT.MEMORY.1: ; * Spread memory cells to allow for new cells.
CELLY = CELLX ; * SAVE NEW LAST.CELL
FOR X = LAST.CELL TO START.CELL STEP -1
MEMORY (CELLX) = MEMORY (X)
LPC (CELLX) = LPC (X)
CELLX -= 1
NEXT X
*---- Split cell into two if LNUM not at cell end and LNUM # 0.
IF LNUM THEN
X = LPC (CELL) - (LNUM - CELL.FIRST.LINE + 1)
IF X THEN
MEMORY (CELLX) = FIELD(MEMORY (CELL), @FM, LNUM - CELL.FIRST.LINE + 2, X)
LPC (CELLX) = X
MEMORY (CELL) = MEMORY (CELL) [1, COL1() - 1]
LPC (CELL) -= X
CELLX -= 1 ; * SKIP OVER EXTRA CELL
END
END
INSERT.MEMORY.2: ; * Insert the cells of the new memory blocks.
FOR X = NEW.LAST.CELL TO 1 STEP -1
MEMORY (CELLX) = NEW.MEMORY (X)
LPC (CELLX) = NEW.LPC (X)
CELLX -= 1
NEXT X
LAST.CELL = CELLY
RETURN
APPEND.NEW.MEMORY: ; * Append new line to memory.
* This routine will append the line in NEW.MEMORY.LINE to the end of
* the NEW.MEMORY matrix. This routine will leave all key new memory
* variables set up for a subsequent call to INSERT.MEMORY.
NEW.BOT += 1
NEW.LAST.CELL = INT((NEW.BOT - 1) / LINES.PER.CELL) + 1
IF NEW.LAST.CELL > NEW.MEMORY.DIM THEN
NEW.MEMORY.DIM += 10
DIM NEW.MEMORY (NEW.MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM NEW.LPC (NEW.MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
FOR Y = NEW.MEMORY.DIM-9 TO NEW.MEMORY.DIM
NEW.MEMORY (Y) = '' ; * CLEAR NEW MEMORY
NEW.LPC (Y) = 0
NEXT Y
END
NEW.MEMORY (NEW.LAST.CELL) := (IF NEW.LPC (NEW.LAST.CELL) THEN @FM ELSE '') :NEW.MEMORY.LINE
NEW.LPC (NEW.LAST.CELL) += 1
RETURN
CLEAR.NEW.MEMORY: ; * Clear out new memory variables.
MAT NEW.MEMORY = '' ; MAT NEW.LPC = 0
NEW.BOT = 0 ; NEW.LAST.CELL = 0
RETURN
OOPS.INITIAL.SAVE: ; * Memory restore routines: for OOPS command.
PRIOR.BLOCK.MFROM = MFROM ; PRIOR.BLOCK.MTHRU = MTHRU
PRIOR.BOT = BOT ; PRIOR.CELL = CELL
PRIOR.CELL.FIRST.LINE = CELL.FIRST.LINE
PRIOR.LAST.CELL = LAST.CELL ; PRIOR.LNUM = LNUM
MAT PRIOR.LPC = MAT LPC ; MAT PRIOR.MEMORY = MAT MEMORY
RETURN
OOPS.BEFORE.EACH.CMD:
PRIOR.BLOCK.MFROM = MFROM ; PRIOR.BLOCK.MTHRU = MTHRU
PRIOR.CELL = CELL ; PRIOR.CMD = CMD
IF CMD.STACK (1) = 'STAMP' THEN PRIOR.CMD = CMD.STACK (1)
PRIOR.CELL.FIRST.LINE = CELL.FIRST.LINE
PRIOR.LNUM = LNUM
RETURN
OOPS.AFTER.CHANGE.CMD:
SAVED.BLOCK.MFROM = PRIOR.BLOCK.MFROM
SAVED.BLOCK.MTHRU = PRIOR.BLOCK.MTHRU
SAVED.BOT = PRIOR.BOT ; SAVED.CELL = PRIOR.CELL
SAVED.CELL.FIRST.LINE = PRIOR.CELL.FIRST.LINE
SAVED.LAST.CELL = PRIOR.LAST.CELL
SAVED.LNUM = PRIOR.LNUM ; SAVED.CMD = PRIOR.CMD
MAT SAVED.LPC = MAT PRIOR.LPC
MAT SAVED.MEMORY = MAT PRIOR.MEMORY
PRIOR.BLOCK.MFROM = MFROM ; PRIOR.BLOCK.MTHRU = MTHRU
PRIOR.BOT = BOT ; PRIOR.LAST.CELL = LAST.CELL
MAT PRIOR.LPC = MAT LPC ; MAT PRIOR.MEMORY = MAT MEMORY
RETURN
OOPS.RESTORE:
MFROM = SAVED.BLOCK.MFROM ; MTHRU = SAVED.BLOCK.MTHRU
BOT = SAVED.BOT ; CELL = SAVED.CELL
CELL.FIRST.LINE = SAVED.CELL.FIRST.LINE
LAST.CELL = SAVED.LAST.CELL ; LNUM = SAVED.LNUM
MAT LPC = MAT SAVED.LPC ; MAT MEMORY = MAT SAVED.MEMORY
* Record restored to condition prior to Command %s.
OLD.LINEX = LINEX
LINEX = SAVED.CMD
GOSUB CONV.LINEX.TO.UP.ARROW
CALL *UVPRINTMSG(001250,LINEX)
LINEX = OLD.LINEX
PRIOR.CMD = '' ; CHANGE.FLAG = TRUE
RETURN
BLOCK.TRACK: ; * Move BLOCK pointers.
*---- Entered with the following variables set up:
* BLOCK.TRACK.LNUM (line before lines deleted, or last line inserted)
* BLOCK.TRACK.CHANGE (+lines inserted, or -lines deleted)
* Check if deletion crossed BLOCK pointer.
IF BLOCK.TRACK.CHANGE < 0 THEN
BLOCK.TRACK.END = BLOCK.TRACK.LNUM - BLOCK.TRACK.CHANGE
IF MFROM => BLOCK.TRACK.LNUM + 1 AND MFROM <= BLOCK.TRACK.END THEN GOTO BLOCK.KILL
IF MTHRU => BLOCK.TRACK.LNUM + 1 AND MTHRU <= BLOCK.TRACK.END THEN GOTO BLOCK.KILL
END
*---- If an INSERT, calculate line before doing inserts.
IF BLOCK.TRACK.CHANGE > 0 THEN BLOCK.TRACK.LNUM -= BLOCK.TRACK.CHANGE
*---- Check if change affects both pointers.
IF BLOCK.TRACK.LNUM < MFROM THEN
MFROM += BLOCK.TRACK.CHANGE ; MTHRU += BLOCK.TRACK.CHANGE
RETURN
END
*---- Check if change affects just MTHRU (change inside BLOCK).
IF BLOCK.TRACK.LNUM < MTHRU THEN
MTHRU += BLOCK.TRACK.CHANGE
RETURN
END
*---- Change must have been after BLOCK; no effect on pointers.
RETURN
BLOCK.KILL: ; * Kill BLOCK pointers.
MFROM = 0 ; MTHRU = 0 ; RETURN
BLOCK.CHECK: ; * Check BLOCK pointers ('<' and '>').
IF MFROM = 0 OR MTHRU = 0 THEN
* BLOCK not set up
CALL *UVPRINTMSG(001219,"")
RETURN TO CMD.ERR
END
IF UPCMD1 = "G" THEN RETURN ; * DO NOT DISPLAY MESSAGE ON 'G< OR G>' COMMAND
IF MTHRU < MFROM THEN
* BLOCK from %i through %i is in the wrong order.
CALL *UVPRINTMSG(001201,MFROM:@FM:MTHRU)
RETURN TO CMD.ERR
END
IF MFROM < LNUM AND LNUM < MTHRU THEN
PRINT ' encloses the destination line.'
RETURN TO CMD.ERR
END
IF MTHRU > BOT THEN
PRINT ' extends beyond the bottom.'
RETURN TO CMD.ERR
END
IF BLOCK.VERIFY.FLAG THEN
* BLOCK from %i through %i. OK (Y)
CALL *UVPRINTMSG(001202,MFROM:@FM:MTHRU)
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS # 'Y' THEN
* Command not done!^G\n\r
CALL *UVPRINTMSG(001203,"")
RETURN TO GET.CMD
END
END ELSE
* BLOCK from %i through %i.
CALL *UVPRINTMSG(001204,MFROM:@FM:MTHRU)
END
RETURN
INPUT.LINE: ; * Input a line, convert '^' to character.
IF ED.CMD.STRING.ACTIVE AND NOT(ED.CMD.STRING.SUSPENDED) THEN
GOSUB ABORT.CHECK
IF ABORT = 'Q' THEN
ED.CMD.STRING.ACTIVE = FALSE
J = 0
PRINT STARS:' Aborted ':PRE.STORE:' execution.'
PRINT
RETURN TO END.CMD
END
J += 1
IF ED.CMD.STRING (J) = '$' THEN
ED.CMD.STRING.ACTIVE = FALSE
J = 0
CALL *UVPRINTMSG(001227,"")
RETURN TO END.CMD
END
INPUT.LINE = ED.CMD.STRING (J)
END ELSE
IF INPUT.LINE = ERROR.COND THEN
PRINT STR('0',4 - LEN(LNUM)):LNUM:'=':
INPUT.LINE = ''
END
INPUT INPUT.LINE
END
GOSUB CONV.FROM.UP.ARROW
IF INPUT.LINE = ERROR.COND THEN GOTO INPUT.LINE
INPUT.MODE = FALSE
RETURN
CONV.FROM.UP.ARROW: ; * Convert 'INPUT.LINE' from '^' to the specified characters.
X = INDEX(INPUT.LINE, UP.ARROW, 1)
IF X = 0 THEN RETURN
IF LEN(INPUT.LINE) =< LEN.UP.ARROW.UNIC THEN
IF INPUT.LINE = UP.ARROW OR UPCASE(INPUT.LINE) = UP.ARROW.UNIC.UP THEN
* Allow ^ and ^X through if in command mode (for speed, don't
* UPCASE the line unless a possible match is there):
IF INPUT.MODE = TRUE THEN
GOSUB PRINT.INVALID.UP.ARROW ;* error message
INPUT.LINE = ERROR.COND
END
RETURN
END
END
II = INPUT.LINE [1, X - 1]
LOOP
X += 1
IF INPUT.LINE [X, 1] = UP.ARROW THEN
* ^^ replaced by single ^:
II := UP.ARROW
X += 1
END ELSE
IF UPCASE(INPUT.LINE[X - 1, 2]) = UP.ARROW.UNIC.UP THEN
* Attempt to enter 4-digit hex unicode string - check it's allowed:
IF NOT(NLS.ON.FLAG) THEN
* '%s UP ARROW mode is not allowed unless NLS support is ON.'
* CALL *UVPRINTMSG('970015',UP.ARROW.UNIC.UP)
GOSUB PRINT.INVALID.UP.ARROW ;* replace with line above after 8.3.3
GOTO CONV.FROM.UP.ARROW.ERR.EXIT
END
* Check 4 hex digits actually entered:
X += 1
CX = INPUT.LINE[X, 4]
DEC.CX = ICONV(CX, 'MX')
IF STATUS() # 0 OR LEN(CX) # 4 OR DEC.CX = UNI$FM THEN
* '%s must be followed by 4 hex digits.'
* Also, can't allow field mark though (equivalent to ^254).
CALL *UVPRINTMSG('970016',UP.ARROW.UNIC.UP)
GOTO CONV.FROM.UP.ARROW.ERR.EXIT
END
* Convert character to UTF and insert back into line:
II := UNICHAR(DEC.CX)
X += 4
END ELSE
CX = INPUT.LINE [X, 3]
*******************************************************************************
*
* Old code read as follows:
*---------- PCC. Make sure we get ALL numbers!
* IF NOT(NUM(CX)) OR CX<0 OR CX>255 OR CX = 254 OR LEN(CX) NE 3 THEN
* Changed to check for '3N' to not allow things like '^-001' to pass the
* NUM() test.
*******************************************************************************
IF NOT(CX MATCHES '3N') OR CX>255 OR CX = 254 THEN
GOSUB PRINT.INVALID.UP.ARROW
GOTO CONV.FROM.UP.ARROW.ERR.EXIT
END
* In NLS mode, note that ^248-^250 go in as the pseudo-mark
* characters below @TM, which is what CHAR(248) etc. returns.
* If you want to enter the Unicode characters with values
* >= 248 decimal, you must use ^X00F8 etc.
II := CHAR(CX)
X += 3
END
END
INPUT.LINE = INPUT.LINE [X, 999999]
X = INDEX(INPUT.LINE, UP.ARROW, 1)
IF X = 0 THEN
INPUT.LINE = II:INPUT.LINE
RETURN
END
II := INPUT.LINE [1, X - 1]
REPEAT
* Never falls through!
CONV.FROM.UP.ARROW.ERR.EXIT: ;* common way out of above routine with error
IF INPUT.MODE THEN
INPUT.LINE = ERROR.COND ; * SET ERROR CONDITIONS
END ELSE
INPUT.LINE = ''
RETURN TO CMD.ERR
END
RETURN
PRINT.INVALID.UP.ARROW: ;* Message about use of "^" command
* (Illegal up-arrow character code. )
* (Range is "000" through "255", excluding "254".)
MSG.TEXT = UVREADMSG(001192,"")
IF NOT(@SYS.BELL) THEN
MSG.TEXT = CONVERT(CHAR(7),"",MSG.TEXT)
END
PRINT MSG.TEXT<1>
PRINT MSG.TEXT<2>
RETURN
PRINT.LINE: ; * Print the current line.
LINEX = LINE
IF UP.ARROW.FLAG THEN GOSUB CONV.LINEX.TO.UP.ARROW
IF LEN(LINEX) <= LINE.LENGTH THEN
PRINT STR('0', 4 - LEN(LNUM)):LNUM:': ':LINEX
END ELSE
PRINT STR('0', 4 - LEN(LNUM)):LNUM:': ':
PRINT LINEX [1, LINE.LENGTH]
LOOP
LINEX = LINEX [LINE.LENGTH + 1, 999999]
UNTIL LEN(LINEX) = 0
PRINT ' ':LINEX [1, LINE.LENGTH]
REPEAT
END
RETURN
PL.CMD:
IF LEN(UPCMD) > 2 THEN
X = TRIM(UPCMD [3, 9999])
IF NOT(NUM(X)) THEN GOTO PL.ERROR
IF X # INT(X) THEN GOTO PL.ERROR
PL.LINES = X
END ELSE X = PL.LINES ; * Use last value for PL command.
IF X > 0 THEN
LINE1 = LNUM
LINE2 = LNUM + X
IF LINE2 > BOT THEN LINE2 = BOT
END ELSE
LINE1 = LNUM + X
IF LINE1 < 1 THEN LINE1 = 1
LINE2 = LNUM
END
LNUMX = LNUM
GOSUB PRINT.GROUP ; PRINT
LNUM = LNUMX
GOTO END.NOCHANGE
PL.ERROR:
PRINT LINES.MESSAGE:'n integer.'
GOTO END.NOCHANGE
PP.CMD: ; * Print a page enclosing current line.
IF LEN(UPCMD) > 2 THEN
X = TRIM(UPCMD [3, 9999])
IF NOT(NUM(X)) THEN GOTO PP.ERROR
IF X # INT(X) THEN GOTO PP.ERROR
IF X < 1 THEN GOTO PP.ERROR
PP.LINES = X
END ELSE X = PP.LINES ; * Use last value for PP command.
IF MOD(X, 2) # 0 THEN X += 1
LINE1 = LNUM - (X / 2)
IF LINE1 < 1 THEN LINE1 = 1
LINE2 = LNUM + (X / 2)
IF LINE2 > BOT THEN LINE2 = BOT
LNUMX = LNUM
GOSUB PRINT.GROUP ; PRINT
LNUM = LNUMX
GOTO END.NOCHANGE
PP.ERROR:
PRINT LINES.MESSAGE:' positive integer.'
GOTO END.NOCHANGE
CONV.LINEX.TO.UP.ARROW: ; * Convert 'LINEX' to '^' format.
LL = '' ; X = 0
* In NLS mode, check all characters on line are valid UTF, otherwise
* you can't trust the ^nnnn output (usually see ^x0000 for bad UTF):
IF NLS.ON.FLAG THEN
BAD.CHARS.IN.LINEX = FALSE
DUMMY = OCONV(LINEX, 'NLSUTF8')
IF STATUS() # 0 THEN
* WARNING: Line has invalid internal characters, and may
* display incorrectly.
CALL *UVPRINTMSG(970017,'')
BAD.CHARS.IN.LINEX = TRUE
END
END
IF LINEX = @NULL.STR THEN
* Print line as ^128 on its own:
LINEX = UP.ARROW:SEQ(@NULL.STR)
END ELSE
LOOP
X += 1
CX = LINEX [X, 1]
UNTIL LEN(CX) = 0 AND NOT(ISNULL(CX)) DO
IF NLS.ON.FLAG THEN
* Don't convert unless ^ mode is actually set - may be displayable:
IF NOT(UP.ARROW.FLAG)
THEN RETURN
* In NLS mode:
* - The "^" character and the marks 248-255 always print as ^ddd.
* - If Unicode ^x mode is on, all non-ASCII-printable chars
* (127 upwards) will print as ^xhhhh.
* - If Unicode ^x mode is off, 127-247 print as ^ddd,
* 248 upwards print as ^xhhhh (but note that single-byte
* marks 248-255 are still printed as ^xxx).
* Note that a null line already got printed as ^128 above.
BEGIN CASE
CASE CX = UP.ARROW ;* "^"
GOSUB PRINT.UP.ARROW.DEC
CASE UNISEQ(CX) = UNI$SQLNULL OR (UNISEQ(CX) >= UNI$SYSDEL AND UNISEQ(CX) =< UNI$IM) ;* 128, 248-255
* Check whether it's really a mark, or the Unicode value
* that UNISEQ returns for a mark - note we can't use SEQ()
* for this, as it may give a runtime warning with NLS on:
IF BYTELEN(CX) = 1 THEN
GOSUB PRINT.UP.ARROW.DEC ;* genuinely a mark
END ELSE
GOSUB PRINT.UP.ARROW.HEX ;* actually Unicode F8Fx char
END
CASE UNISEQ(CX) < 32 OR UNISEQ(CX) > 126 ;* non-ASCII-printing chars
BAD.CHAR.IN.LINEX.FOUND = FALSE
IF BAD.CHARS.IN.LINEX THEN
* NLS mode - check if we got an invalid character here,
* which SEQ() cannot print - display something else instead:
DUMMY = OCONV(CX, 'NLSUTF8')
IF STATUS() # 0
THEN BAD.CHAR.IN.LINEX.FOUND = TRUE
END
BEGIN CASE
CASE BAD.CHAR.IN.LINEX.FOUND
GOSUB PRINT.UP.ARROW.BAD.UTF
CASE UP.ARROW.UNIC.FLAG OR UNISEQ(CX) > 247
GOSUB PRINT.UP.ARROW.HEX
CASE 1
GOSUB PRINT.UP.ARROW.DEC
END CASE
END CASE
END ELSE
***************************************************************************
*
* THIS WAS THE OLD DEFINITION OF NON-PRINTING CHARACTERS UNDER PI
*
* A non-printing char is defined as:
* - char in C0 set excluding the 5 chars where the displaced
* graphics (clashed with the mark chars) are mapped to.
* ( CX < CHAR(28) AND CX # CHAR(26))
* - the DEL char ( CHAR(127) ) or chars in C1 set.
* ( CX > CHAR(126) AND CX < CHAR(160) )
* - the 5 mark chars or the up arrow
* ( CX >= @TM )
*
* NON.PRINTING = ((CX < CHAR(28) AND CX # CHAR(26)) OR (CX >= @TM) OR (CX = UP.ARROW) OR (CX > CHAR(126) AND CX < CHAR(160)))
*
***************************************************************************
*
* THIS HAS BEEN CHANGED TO BE COMPATIBLE WITH THE RELEASE 6
* VERSION OF THE UNIVERSE EDITOR
* (Change was agreed to by Len Greenwood and Jim T.)
*
* A non-printing character is defined as:
* - CHAR(0) thru CHAR(31)
* - CHAR(127) thru CHAR(255), but not CHAR(254) or UP.ARROW
*
* NON.PRINTING = (CX < CHAR(32)) OR (CX > CHAR(126))
* Note: don't compare CHARs, since may be localized - use SEQs instead.
*
***************************************************************************
NON.PRINTING = (SEQ(CX) < 32) OR (SEQ(CX) > 126) OR (CX = UP.ARROW)
IF NON.PRINTING THEN
GOSUB PRINT.UP.ARROW.DEC
END
END
REPEAT
LINEX = LL:LINEX
END
RETURN
PRINT.UP.ARROW.BAD.UTF:
* No input: always print a recognizable string for a "bad" utf character:
LL := LINEX[1, X - 1]:UP.ARROW:'!!!!'
LINEX = LINEX [X + 1, 999999]
X = 0
RETURN
PRINT.UP.ARROW.DEC:
* Input: CX is character to be printed
CX = SEQ(CX)
LL := LINEX [1, X - 1] :UP.ARROW:STR('0', 3 - LEN(CX)) :CX
LINEX = LINEX [X + 1, 999999]
X = 0
RETURN
PRINT.UP.ARROW.HEX:
* Input: CX is character to be printed
HEX.CX = OCONV(UNISEQ(CX), 'MX')
LL := LINEX [1, X - 1] :UP.ARROW.UNIC:STR('0', 4 - LEN(HEX.CX)) :HEX.CX
LINEX = LINEX [X + 1, 999999]
X = 0
RETURN
GET.RECORD: ; * Get record name and read the record.
RECORD.NAME = RECORD.LIST <1>
RECORD.LIST = DELETE(RECORD.LIST, 1, 0, 0)
IF RECORD.NAME = '' AND NUM.REMAINING NE '' AND NUM.REMAINING GT 0 THEN NULL.ID.INLIST=TRUE ELSE NULL.ID.INLIST=FALSE
IF NUM.REMAINING # '' THEN NUM.REMAINING=NUM.REMAINING-1
IF (LEN(RECORD.NAME) # 0 OR (NULL.ID.INLIST) OR (FIRST.RECORD AND (NULL.ID OR SELECT.LIST.FLAG))) THEN
LINEX = RECORD.NAME
GOSUB CONV.LINEX.TO.UP.ARROW
DISPLAY.RECORD.NAME = LINEX
IF SELECT.LIST.FLAG AND NOT(ONLY.ONE.RECORD.FLAG) THEN
CALL *UVPRINTMSG(001291,DISPLAY.RECORD.NAME)
END
GOTO INITIALIZE
END
SELECT.LIST.FLAG = FALSE
ONLY.ONE.RECORD.FLAG = FALSE
ED.CMD.STRING.ACTIVE = FALSE
ED.CMD.STRING.SUSPENDED = FALSE
J = 0
IF NOT(FIRST.RECORD) THEN
PRINT
CALL *UVPRINTMSG(001018,"")
PRINT DICT.TEXT:FILE.NAME
END
FIRST.RECORD = FALSE
CALL *UVPRINTMSG(001290,"")
GOSUB INPUT.LINE
FIRST.CHAR = INPUT.LINE [1, 1]
IF FIRST.CHAR = '"' OR FIRST.CHAR = "'" THEN
INPUT.LINE = INPUT.LINE [2, INDEX(INPUT.LINE, FIRST.CHAR, 2) - 2]
END ELSE
INPUT.LINE = TRIM(INPUT.LINE)
END
RECORD.NAME = INPUT.LINE
LINEX = RECORD.NAME
GOSUB CONV.LINEX.TO.UP.ARROW
DISPLAY.RECORD.NAME = LINEX
IF LEN(RECORD.NAME) = 0 THEN GOTO STOP
INITIALIZE: ; * Initialize for each record.
FIRST.RECORD = FALSE
X = '@ID' ; Y = RECORD.NAME ; GOSUB AT.INSERT
BLOCK.LOGIC = FALSE ; * BLOCK LOGIC FLAG
BOT = 0 ; * BOTTOM LINE NUMBER
CELL = 1 ; * CURRENT CELL OF MEMORY
CELL.FIRST.LINE = 1 ; * LINE NUM OF 1ST LINE IN CURRENT CELL
CHANGE.FLAG = FALSE ; * RECORD CHANGED FLAG
CHANGE.DURING.CMD.STRING = FALSE ; * RECORD CHANGED DURING CMD STRING XEQ
LAST.CELL = 0 ; * LAST ACTIVE CELL IN MEMORY
LINE = '' ; * CURRENT LINE
LINE.LENGTH = CRT.WIDTH - 7 ; * LENGTH OF LINE TO FOLD ON
LNUM = 0 ; * CURRENT LINE NUMBER
LNUM.SAVE = 0 ; * SAVE OF LNUM
MAT LPC = 0 ; * MATRIX OF LINES PER CELL OF MEMORY
MAT MEMORY = '' ; * BLOCKED MEMORY OF RECORD BEING EDITTED
MAT PRIOR.MEMORY = '' ; * OOPS MEMORY
MAT PRIOR.LPC = 0 ; * OOPS MEMORY
MAT SAVED.MEMORY = '' ; * OOPS MEMORY
MAT SAVED.LPC = 0 ; * OOPS MEMORY
MFROM = 0 ; * BLOCK 'FROM' POINTER
MTHRU = 0 ; * BLOCK 'THRU' POINTER
RECORD.CHANGE.FLAG = FALSE ; * SET TO TRUE IF RECORD CHANGED
SAVED.CMD = '' ; * LAST CMD THAT CHANGED THE RECORD
GOSUB CLEAR.NEW.MEMORY ; * CLEAR NEW MEMORY AND KEY VARIABLES
I.TYPE.EXPR = ''
READ.2: ; * Try to read record from file.
RECORD.NAME.LOCKED = TRUE
EDITING.VOC.FPTR = FALSE
READU RECORD FROM EDIT.FILE, RECORD.NAME
* ON ERROR
* CALL *UVPRINTMSG(STATUS(),"")
* RETURN TO DONE.WITH.RECORD
* END
LOCKED
RECORD.NAME.LOCKED = FALSE
CALL *UVPRINTMSG(001191,"")
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS = 'Y' THEN GOTO READ.2 ELSE RETURN TO DONE.WITH.RECORD
END
THEN
IF EDIT.READ.ONLY THEN
CALL *UVPRINTMSG(001398,DICT.TEXT:FILE.NAME)
END
ELSE IF ((FILE.NAME = 'VOC') AND (RECORD[1,1]='F' OR RECORD[1,1]='f'))
THEN
EDITING.VOC.FPTR = TRUE
END
END
ELSE
DF.ERROR = STATUS()
IF DF.ERROR = 1 OR DF.ERROR = 2 THEN
STATUS TEMP.INFO FROM EDIT.FILE ELSE TEMP.INFO = ""
IF TEMP.INFO<21> = 27 THEN
CALL *UVPRINTMSG(970013,RECORD.NAME)
END ELSE
CALL *UVPRINTMSG(970012,RECORD.NAME)
END
RETURN TO DONE.WITH.RECORD
END
ELSE IF DF.ERROR = 3 THEN
CALL *UVPRINTMSG(47007,RECORD.NAME)
RETURN TO DONE.WITH.RECORD
END
ELSE IF DF.ERROR = 4 THEN
* Warning message already issued - no need to repeat ourselves
* CALL *UVPRINTMSG(47006,RECORD.NAME)
RETURN TO DONE.WITH.RECORD
END
IF EDIT.READ.ONLY THEN
CALL *UVPRINTMSG(001396,DICT.TEXT:FILE.NAME:@FM:RECORD.NAME)
RETURN TO DONE.WITH.RECORD
END ELSE
GOTO NEW.RECORD
END
END
*---- Check if reading an I-TYPE record from a DICTIONARY.
IF DICT AND RECORD [1, 1] = 'I' THEN
I.TYPE.EXPR = RECORD <2>
I.TYPE.DATE = OCONV(RECORD <OBJ.FMC - 2>, 'D2/')
IF LEN(I.TYPE.DATE) # 0 THEN
PRINT 'This is a Type "I" Descriptor last compiled on ':
PRINT I.TYPE.DATE:' at ':OCONV(RECORD <OBJ.FMC - 1>, 'MT:'):'.'
END ELSE PRINT 'This Type "I" Descriptor must be compiled before use.'
END
*---- Record already exists.
BOT = IF LEN(RECORD) = 0 THEN 0 ELSE COUNT(RECORD, @FM) + 1
X = INT((BOT - 1) / LINES.PER.CELL) ; * DETERMINE NUM OF FULL CELLS REQUIRED
IF X + 1 > MEMORY.DIM THEN
MEMORY.DIM = X + 20
DIM MEMORY (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM LPC (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM PRIOR.MEMORY (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM PRIOR.LPC (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM SAVED.MEMORY (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
DIM SAVED.LPC (MEMORY.DIM) ; * RE-DIMENSION
IF INMAT() THEN RECORD = '' ; GOSUB OVERFLOW ; RETURN ; * SJE 23 Apr 84
FOR XX = MEMORY.DIM - 19 TO MEMORY.DIM
SAVED.LPC (XX) = 0 ; MEMORY (XX) = '' ;
LPC (XX) = 0 ; PRIOR.LPC (XX) = 0
PRIOR.MEMORY (XX) = '' ; SAVED.MEMORY (XX) = ''
NEXT XX
END
*---- The following code sets up
* to make a BLOCK of each element of the array. The size of the
* BLOCK is defined by LINES.PER.CELL.
*** MATBLOCK MEMORY FROM RECORD, @FM, LINES.PER.CELL
CALL @MATBLOCK(MAT MEMORY,RECORD,@FM,LINES.PER.CELL)
FOR XX = 1 TO X
LPC (XX) = LINES.PER.CELL
NEXT XX
LAST.CELL = X + (BOT > 0) ; * =0 IF BOT = 0
IF LAST.CELL > 0 THEN
LPC (LAST.CELL) = MOD(BOT - 1, LINES.PER.CELL) + 1
END
RECORD = '' ; * RETURN DMR SPACE
* %i lines long
CALL *UVPRINTMSG(001207,BOT)
RETURN
NEW.RECORD:
* New record.
CALL *UVPRINTMSG(001206,"")
RETURN
FILE.IT: ; * File the record. GOSUB routine.
WRITEERROR = FALSE ; *026
OUT.DICT = DICT ; OUT.FILE.NAME = FILE.NAME ; OUT.FILE = EDIT.FILE
IF (NOT(SYSTEM(62)) AND (EDITING.VOC.FPTR))
THEN
CALL *UVPRINTMSG(020553,"")
RETURN TO GET.CMD
END
************************************************************************
* 'READU LOCK.AGAIN FROM EDIT.FILE,RECORD.NAME THEN NULL' BELOW IS DONE
* TO RESET READLOCK INITIALLY SET BY FIRST TCL EDIT. THIS IS IN PLACE TO
* FIX PROBLEM OF LOCK BEING RELEASED WHEN ACTIVE FILE VARIABLE 'OUT.FILE'
* GETS REASSIGNED MULTIPLE TIMES (ABOVE).
************************************************************************
READU LOCK.AGAIN FROM EDIT.FILE,RECORD.NAME
* ON ERROR
* CALL *UVPRINTMSG(STATUS(),"")
* RETURN TO GET.CMD
* END
THEN
NULL ;*SEE ABOVE
END
OUT.DICT.TEXT = DICT.TEXT
IF LEN(CMD [6, 99]) = 0 THEN
OUT.REC.NAME = RECORD.NAME
IF EDIT.READ.ONLY THEN
CALL *UVPRINTMSG(001398,OUT.DICT.TEXT:OUT.FILE.NAME)
RETURN TO GET.CMD
END
END ELSE
SENT = TRIM(CMD [6,99])
IF COUNT(SENT, ' ') > 2 THEN RETURN TO CMD.ERR
IF COUNT(SENT, ' ') THEN
PROMPT.FOR.FILE = FALSE ; NO.SELECT.LIST = TRUE
OUT.FILE.NAME = '' ; OUT.DICT = '' ; OUT.DICT.TEXT = ''
SINGLE.FILE.ONLY = TRUE
CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, OUT.DICT,
OUT.FILE.NAME, PROMPT.FOR.FILE, SINGLE.FILE.ONLY)
IF OUT.DICT = '' ELSE OUT.DICT.TEXT = OUT.DICT:' '
IF LEN(OUT.FILE.NAME) = 0 THEN RETURN TO CMD.ERR
IF OUT.FILE.NAME # OUT.FILE.NAME <1> THEN RETURN TO CMD.ERR
OUT.REC.NAME = SENT
OPENCHECK OUT.DICT, OUT.FILE.NAME TO OUT.FILE ELSE
ErrorCode = STATUS()
READL FileRec FROM DEVSYS.VOC.FILE,OUT.FILE.NAME THEN
IF OUT.DICT = "" THEN
PathName = FileRec<2>
END ELSE
PathName = FileRec<3>
END
RELEASE DEVSYS.VOC.FILE,OUT.FILE.NAME
END ELSE
PathName = ""
END
IF OUT.DICT = "" THEN
FileName = OUT.FILE.NAME
END ELSE
FileName = "DICT,":OUT.FILE.NAME
END
CALL @OpenError(ErrorCode,FileName,PathName)
RETURN TO CMD.ERR
END
END ELSE OUT.REC.NAME = FIELD(SENT, ' ', 1)
IF LEN(OUT.REC.NAME) = 0 THEN
PRINT 'Too many parameters. Expected (at most) a file name and record name.'
RETURN TO CMD.ERR
END
READ.3:
OUT.PERM.MODE = 1
OUT.PERM.IN = 6
OUT.PERM.OUT = ''
CALL @PERMISSIONS(OUT.FILE,OUT.PERM.MODE,OUT.PERM.IN,OUT.PERM.OUT)
IF NOT(OUT.PERM.OUT) THEN
CALL *UVPRINTMSG(001398,OUT.DICT.TEXT:OUT.FILE.NAME)
RETURN TO GET.CMD
END
READU SENT FROM OUT.FILE, OUT.REC.NAME
* ON ERROR
* CALL *UVPRINTMSG(STATUS(),"")
* GOTO GET.CMD
* END
LOCKED
CALL *UVPRINTMSG(001191,"")
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS = 'Y' THEN GOTO READ.3 ELSE GOTO GET.CMD
END ELSE
DF.ERROR = STATUS()
IF DF.ERROR = 1 OR DF.ERROR = 2 THEN
STATUS TEMP.INFO FROM OUT.FILE ELSE TEMP.INFO = ""
IF TEMP.INFO<21> = 27 THEN
CALL *UVPRINTMSG(970013,OUT.REC.NAME)
END ELSE
CALL *UVPRINTMSG(970012,OUT.REC.NAME)
END
GOTO GET.CMD
END
ELSE IF DF.ERROR = 3 THEN
CALL *UVPRINTMSG(47007,OUT.REC.NAME)
GOTO GET.CMD
END
ELSE IF DF.ERROR = 4 THEN
* Warning message already issued - no need to repeat ourselves
* CALL *UVPRINTMSG(47006,OUT.REC.NAME)
GOTO GET.CMD
END
GOTO FILE.IT.2
END
SENT = '' ; * RETURN DMR STRING SPACE
* already exists
IF STACK.MODE THEN
CALL *UVPRINTMSG(001197,"")
END ELSE
CALL *UVPRINTMSG(001110,"")
END
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS # 'Y' THEN
CALL *UVPRINTMSG(001220,"")
GOSUB RELEASE.IF.OK
RETURN TO GET.CMD
END
END
FILE.IT.2:
LNUMX = LNUM ; * SAVE LNUM
LINE1 = '' ; LINE2 = '' ; LINE.OBJ.FMC = ''
IF BOT => 1 THEN
LNUM = 1 ; GOSUB GET.LINE ; LINE1 = LINE
END
IF BOT => 2 THEN
LNUM = 2 ; GOSUB GET.LINE ; LINE2 = LINE
END
IF BOT => OBJ.FMC THEN
LNUM = OBJ.FMC ; GOSUB GET.LINE ; LINE.OBJ.FMC = LINE
END
IF OUT.DICT AND LINE1 [1, 1] = 'I' AND (I.TYPE.EXPR # LINE2 OR LEN(LINE.OBJ.FMC) = 0) THEN
IF BOT => OBJ.FMC - 4 THEN
LNUM = OBJ.FMC - 4 ; * DELETE EXPRESSION OBJECT CODE
GOSUB GET.LINE
NUM.OF.LINES.TO.DELETE = BOT - LNUM + 1
GOSUB DELETE.MEMORY
END
PRINT 'This Type "I" Descriptor must be compiled before use.'
END
SQL.ERROR = FALSE
NLS.ERROR = FALSE
MATWRITEU MEMORY ON OUT.FILE, OUT.REC.NAME ON ERROR
WRITEERROR = TRUE
STATUS.CODE = STATUS()
IF STATUS.CODE = 47006 OR STATUS.CODE = 47007 THEN
CALL *UVPRINTMSG(STATUS.CODE,OUT.REC.NAME)
NLS.ERROR = TRUE
END
END
ELSE
WRITEERROR = TRUE ;
STATUS.CODE = STATUS()
IF STATUS.CODE = IntegrityViolation THEN
SQL.ERROR = TRUE
IO.VAR = 2
MATBUILD DYN.ARRAY FROM MEMORY
CALL @SQLINTCHK(DYN.ARRAY,OUT.FILE,OUT.REC.NAME,OUT.DICT.TEXT:OUT.FILE.NAME,IO.VAR)
END
END
IF NOT(WRITEERROR) AND (UPCMD4 <> 'SAVE' OR LEN(CMD [6, 99]) <> 0) THEN ; *026
GOSUB RELEASE.IF.OK ; *REPLACED *026 UNCONDITIONAL RELEASE
*
* Convert numeric string to character to prevent the problem
* when the key string is 15+ byte numeric.
*
TEMP.OUT.REC.NAME = 'N':OUT.REC.NAME
TEMP.RECORD.NAME = 'N':RECORD.NAME
IF TEMP.OUT.REC.NAME = TEMP.RECORD.NAME THEN RECORD.NAME.LOCKED = FALSE
*
END ; *026
LINEX = OUT.REC.NAME
GOSUB CONV.LINEX.TO.UP.ARROW
IF WRITEERROR THEN ; *026
IF NOT(SQL.ERROR) AND NOT(NLS.ERROR) THEN
PRINT @SYS.BELL:'Failed to file "':LINEX:'"':IN.FILE:OUT.DICT.TEXT:OUT.FILE.NAME:'". STATUS = ':STATUS.CODE
END
END ELSE ; *026
CALL *UVPRINTMSG(001238,LINEX)
CALL *UVPRINTMSG(001286,OUT.DICT.TEXT:OUT.FILE.NAME)
END ; *026
LNUM = LNUMX ; * RESTORE LNUM
RETURN
RELEASE.IF.OK:
IF UPCMD5 = 'SAVE ' AND (OUT.REC.NAME = RECORD.NAME) AND (OUT.DICT = DICT) THEN
REL.OUTREC=0
IF OUT.FILE.NAME # '' AND OUT.FILE.NAME # FILE.NAME THEN
STATUS OUTFLSTAT FROM OUT.FILE THEN
STATUS ORIGFLSTAT FROM EDIT.FILE THEN
IF (OUTFLSTAT<10> = ORIGFLSTAT<10>) AND (OUTFLSTAT<11> = ORIGFLSTAT<11>) THEN NULL ELSE REL.OUTREC=1
END
END
END
IF REL.OUTREC THEN RELEASE OUT.FILE, OUT.REC.NAME
END ELSE
RELEASE OUT.FILE, OUT.REC.NAME
END
RETURN
!
* Command stack and pre-stored command routines.
!
STACK.PROCESSOR:
STACK.MODE = TRUE
SV.CMD = CMD
CMD = TRIM(CMD)
IF UPCMD3 = '.XK' OR UPCMD3 = '.XR' THEN GOTO STACK.EXECUTE
IF UPCMD4 = 'LOOP' THEN GOTO STRING.LOOP
IF UPCMD5 = 'PAUSE' THEN GOTO STRING.PAUSE
TOKEN1 = FIELD(CMD, ' ', 2)
TOKEN2 = FIELD(CMD, ' ', 3)
TOKEN3 = FIELD(CMD, ' ', 4)
TOKEN4 = FIELD(CMD, ' ', 5)
GOSUB SET.UP.NN
IF UPCMD2 = '.A' THEN GOTO STACK.APPEND
IF UPCMD2 = '.C' THEN GOTO STACK.CHANGE
IF UPCMD2 = '.D' THEN GOTO STACK.DELETE
IF UPCMD2 = '.X' THEN GOTO STACK.EXECUTE
IF UPCMD2 = '.I' THEN GOTO STACK.INSERT
IF UPCMD2 = '.L' THEN GOTO STACK.LIST
IF UPCMD2 = '.R' THEN GOTO STACK.RECALL
IF UPCMD2 = '.S' THEN GOTO STACK.SAVE
IF UPCMD2 = '.U' THEN GOTO STACK.UPCASE
GOTO CMD.ERR
DISPLAY.CURRENT.LINE:
IF UNASSIGNED(DISPLAY.CURRENT.LINE) THEN DISPLAY.CURRENT.LINE = TRUE
IF UNASSIGNED(COMMAND.SUCCESSFUL) THEN COMMAND.SUCCESSFUL = TRUE
IF DISPLAY.CURRENT.LINE OR COMMAND.SUCCESSFUL THEN
IF LNUM = 0 THEN
CALL *UVPRINTMSG(001190,"")
END ELSE
IF BOT THEN
GOSUB GET.LINE
IF COMMAND.SUCCESSFUL THEN
GOSUB PRINT.LINE
END
END
END
END
DISPLAY.CURRENT.LINE = TRUE
COMMAND.SUCCESSFUL = TRUE
RETURN
STACK.APPEND: ; * '.A': append to a stack command.
CMD.STACK (NN) := SV.CMD [INDEX(SV.CMD, ' ', 1) + 1, 9999]
PRINT NN "R%2":" ":CMD.STACK (NN)
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
STACK.CHANGE: ; * '.C': change a stack command.
DELIM = CMD [LEN(NN) + 3, 1]
FROM.STRING = FIELD(SV.CMD [2, 9999], DELIM, 2)
LEN.FROM = LEN(FROM.STRING)
TO.STRING = FIELD(SV.CMD [2, 9999], DELIM, 3)
IF COL2() = 0 THEN
PRINT 'Missing required TO field (for "CHANGE/FROM/TO").'
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO CMD.ERR
END
IF LEN(FROM.STRING) = 0 THEN
CMD.STACK (NN) = TO.STRING:CMD.STACK (NN)
PRINT NN "R%2":" ":CMD.STACK (NN)
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
END
GLOBAL = FIELD(SV.CMD[2,9999], DELIM, 4) ; GLOBAL = UPCASE(GLOBAL) ; GLOBAL.FLAG = FALSE
IF GLOBAL[1,1] = "G" THEN GLOBAL = GLOBAL[2,99] ; GLOBAL.FLAG = TRUE
STACK.CHANGED = FALSE
STACK.CHANGE.1:
START.POS = INDEX(CMD.STACK (NN), FROM.STRING, 1)
IF START.POS NE 0 THEN
STACK.CHANGED = TRUE
CMD.STACK (NN) [START.POS, LEN.FROM] = ''
CMD.STACK (NN) = CMD.STACK (NN) [1, START.POS - 1]:TO.STRING:CMD.STACK (NN) [START.POS + LEN.FROM, 9999]
IF GLOBAL.FLAG THEN GOTO STACK.CHANGE.1
END
IF STACK.CHANGED THEN
PRINT NN "R%2":" ":CMD.STACK (NN)
PRINT
GOSUB DISPLAY.CURRENT.LINE
END
GOTO GET.CMD
STACK.DELETE: ; * '.D': delete a stack command or a pre-stored command string.
IF TOKEN1 THEN GOTO STRING.DELETE
CALL *UVPRINTMSG(001077,NN)
PRINT
NN -= 1
GOSUB PUSH.DOWN
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
STRING.DELETE:
GOSUB STRING.WRITE
SD.1:
IF REC.TYPE.CODE # 'E' THEN
CALL *UVPRINTMSG(001108,WRITE.REC.NAME)
GOTO CMD.ERR
END
DELETE WRITE.FILE, WRITE.REC.NAME
CALL *UVPRINTMSG(970003,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME)
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
STACK.EXECUTE: ; * '.X': execute one stack command, or load (not into the stack) and
* execute a pre-stored string.
IF UPCMD3 = '.XK' THEN
IF NOT(ED.CMD.STRING.ACTIVE) THEN GOTO CMD.ERR
ED.CMD.STRING.ACTIVE = FALSE
ED.CMD.STRING.SUSPENDED = FALSE
J = 0
ED.CMD.STRING (1) = '$'
GOTO GET.CMD
END
IF UPCMD3 = '.XR' THEN
IF ED.CMD.STRING.SUSPENDED THEN
ED.CMD.STRING.SUSPENDED = FALSE
GOTO GET.CMD
END ELSE GOTO CMD.ERR
END
IF TOKEN1 THEN GOTO STRING.EXECUTE
PRINT NN "R%2":" ":CMD.STACK (NN + 1)
INPUT.LINE = CMD.STACK (NN + 1)
IF NN = 1 THEN
FOR IJ = 1 TO 2
NN = 0
GOSUB PUSH.DOWN
NEXT IJ
END ELSE
NN = 0
GOSUB PUSH.DOWN
END
GOTO GET.CMD.1
STRING.EXECUTE:
J = 0
IF ED.CMD.STRING.SUSPENDED THEN
IF CHANGE.DURING.CMD.STRING THEN
GOSUB OOPS.AFTER.CHANGE.CMD
CHANGE.DURING.CMD.STRING = FALSE
END
GOSUB OOPS.BEFORE.EACH.CMD
ED.CMD.STRING.SUSPENDED = FALSE
END
MAT ED.CMD.STRING = '$'
GOTO LOAD.ANY
STACK.INSERT: ; * '.I': insert one or more commands into the stack.
IF TOKEN1 OR LEN(SV.CMD) > 4 THEN GOTO SI.3
NUM.CMDS = 0 ; NEW.CMD = ''
SI.1:
PRINT ' =':
GOSUB INPUT.LINE
ED.CMD = INPUT.LINE
IF LEN(ED.CMD) = 0 THEN GOTO SI.2
IF ED.CMD = ' ' THEN ED.CMD = ''
NEW.CMD := ED.CMD:@FM
NUM.CMDS += 1
IF NN + NUM.CMDS => STACK.LIMIT THEN
PRINT @SYS.BELL:'Can only accept 99 commands.'
GOTO SI.2
END
GOTO SI.1
SI.2:
BLOCK.END = NN
GOSUB POP.UP
FIELD.CTR = 1
FOR I = NN + NUM.CMDS - 1 TO NN STEP -1
CMD.STACK (I) = FIELD(NEW.CMD, @FM, FIELD.CTR)
FIELD.CTR += 1
NEXT I
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
SI.3:
BLOCK.END = NN
NUM.CMDS = 1
GOSUB POP.UP
IF LEN(TOKEN1) = 0 THEN
IF SV.CMD [LEN(NN) + 4, 9999] = ' ' THEN
CMD.STACK (NN) = ''
END ELSE
CMD.STACK (NN) = SV.CMD [LEN(NN) + 4, 9999]
END
END ELSE CMD.STACK (NN) = SV.CMD [INDEX(SV.CMD, ' ', 1) + 1, 9999]
PRINT NN "R%2":" ":CMD.STACK(NN)
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
STACK.LIST: ; * '.L': list all or part of the stack, pre-stored string, or
* pre-stored record names.
IF TOKEN1 THEN GOTO STRING.LIST
IF NN => END.STACK THEN NN = END.STACK - 1
NUM.LINES = 0
FOR I = NN TO 1 STEP -1
PRINT I "R%2":" ":CMD.STACK (I)
GOSUB PN.1
NEXT I
PRINT
GOTO END.NOCHANGE
STRING.LIST:
LEN.CMD = LEN(CMD)
IF CMD [LEN.CMD - 1, 2] = ' *' THEN GOTO SL.2
GOTO LOAD.ANY
SL.1:
PRINT
PRINT SPACE(5):LOAD.REC.NAME
ERROR.FORMAT = FALSE
GOSUB PRINT.CMD.STRING
PRINT
GOTO END.NOCHANGE
SL.2:
L.SELECT.FLAG = TRUE
CMD = CMD [1, LEN.CMD - 2]
GOTO LOAD.ANY
SL.3:
L.SELECT.FLAG = FALSE
MAT CMD.NAME = ''
SELECT LOAD.FILE
NUM.LINES = 0
PRINT ; PRINT 'File is "':DICT:LOAD.FILE.NAME:'".' ; PRINT
SL.3A:
FOR K = 1 TO 5
SL.3B:
READNEXT CMD.NAME (K) ELSE GOTO SL.4
READ COMMAND.RECORD FROM LOAD.FILE, CMD.NAME (K) ELSE
PRINT 'Selected ':REC:' "':CMD.NAME (K):'"':IN.FILE:DICT:LOAD.FILE.NAME:'" not found.'
GOTO SL.3B
END
IF COMMAND.RECORD <1> [1, 1] # 'E' THEN GOTO SL.3B
NEXT K
GOSUB PRINT.NAMES
GOTO SL.3A
SL.4:
GOSUB PRINT.NAMES ; GOTO END.NOCHANGE
STACK.RECALL: ; * '.R': recall a stack command to the bottom of the stack.
; * or load a pre-stored string into the stack.
IF TOKEN1 THEN GOTO LOAD.ANY
IF END.STACK = 1 THEN
CALL *UVPRINTMSG(001071,1)
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO CMD.ERR
END
BLOCK.END = 1 ; NUM.CMDS = 1
GOSUB POP.UP
CMD.STACK (1) = CMD.STACK (NN + 1)
PRINT NN "R%2":" ":CMD.STACK (1)
** retain copy of command
** GOSUB PUSH.DOWN
PRINT
GOTO END.NOCHANGE
SR.1:
FWD.PTR = 1 ; BLOCK.END = 1
NUM.CMDS = BOT.STRING - 2
GOSUB POP.UP
FOR I = NUM.CMDS TO 1 STEP -1
CMD.STACK (I) = ED.CMD.STRING (FWD.PTR)
FWD.PTR += 1
NEXT I
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
STACK.SAVE: ; * '.S': save one or more commands as a pre-stored string.
IF LEN(CMD) = 2 THEN
CALL *UVPRINTMSG(020072,"")
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO CMD.ERR
END
IF END.STACK = 1 THEN
CALL *UVPRINTMSG(001071,1)
GOSUB DISPLAY.CURRENT.LINE
GOTO CMD.ERR
END
COMMA = INDEX(CMD, ',', 1)
IF COMMA THEN
IF COUNT(CMD, ' ') < 2 THEN
CALL *UVPRINTMSG(020073,"")
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO CMD.ERR
END
FIRST.CMD = CMD [COMMA-2, 2]
IF NOT(NUM(FIRST.CMD)) THEN
CALL *UVPRINTMSG(020073,"")
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO CMD.ERR
END
LAST.CMD = CMD [COMMA + 1, 2]
IF NOT(NUM(LAST.CMD)) THEN
CALL *UVPRINTMSG(020073,"")
GOTO CMD.ERR
END
IF FIRST.CMD < LAST.CMD THEN
SWAP.CMD = FIRST.CMD
FIRST.CMD = LAST.CMD
LAST.CMD = SWAP.CMD
END
CMD = CMD [1, COMMA-3]
END ELSE FIRST.CMD = NN ; LAST.CMD = 1
GOSUB STRING.WRITE
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
STACK.UPCASE:
CMD.STACK (NN) = UPCASE( CMD.STACK (NN) )
PRINT NN "R%2":" ":CMD.STACK (NN)
PRINT
GOSUB DISPLAY.CURRENT.LINE
GOTO GET.CMD
STRING.LOOP: ; * LOOP: loop within a pre-stored command string.
IF NOT(ED.CMD.STRING.ACTIVE) THEN GOTO CMD.ERR ; * DON'T TAKE 'LOOP' FROM KEYBOARD
IF LOOP.FLAG THEN GOTO TEST.LOOP.CTR
SETUP.LOOP:
SAVE.J = J
LOOP.FLAG = TRUE
STMT.NR = FIELD(TRIM(UPCMD), ' ', 2)
IF STMT.NR = '' THEN STMT.NR = 1
IF NOT(NUM(STMT.NR)) THEN
LOOP.FLAG = FALSE
GOTO CMD.ERR
END
STMT.NR = STMT.NR - 1
IF STMT.NR < 0 OR STMT.NR > SAVE.J - 1 THEN
LOOP.FLAG = FALSE
GOTO CMD.ERR
END
NR.TIMES = FIELD(TRIM(UPCMD), ' ', 3)
IF NR.TIMES = '' THEN NR.TIMES = 1
IF NOT(NUM(NR.TIMES)) THEN
LOOP.FLAG = FALSE
GOTO CMD.ERR
END
IF NR.TIMES < 1 THEN NR.TIMES = 1
IF STMT.NR > 0 THEN STMT.NR = STMT.NR - 1
J = STMT.NR
GOTO GET.CMD
TEST.LOOP.CTR:
NR.TIMES -= 1
IF NR.TIMES = 0 THEN
LOOP.FLAG = FALSE ; J = SAVE.J ; GOTO GET.CMD
END
J = STMT.NR
GOTO GET.CMD
STRING.PAUSE: ; * PAUSE: suspend execution of a pre-stored command string.
IF ED.CMD.STRING (1) = '$' THEN GOSUB SP.2 ; GOTO END.CMD
IF NOT(ED.CMD.STRING.ACTIVE) THEN GOTO CMD.ERR
ED.CMD.STRING.SUSPENDED = TRUE
CALL *UVPRINTMSG(001261,J)
GOTO END.CMD
!
* Command stack and pre-stored command subroutines.
!
GET.CMD.FROM.BLOCK: ; * Get pre-stored commands from record block into string.
IF BLOCK <1> [1, 1] = 'E' AND UPCMD2 # '.L' THEN
BLOCK = DELETE(BLOCK, 1, 0, 0)
END ELSE
IF UPCMD2 # '.L' THEN
CALL *UVPRINTMSG(001108,LOAD.REC.NAME)
GOTO CMD.ERR
END
END
DIM.SIZE = COUNT(BLOCK, @FM)
DIM ED.CMD.STRING (DIM.SIZE + 2)
IF INMAT() THEN GOSUB OVERFLOW ; GOTO GET.CMD ; * SJE 23 Apr 84
MATPARSE ED.CMD.STRING FROM BLOCK, @FM
ED.CMD.STRING (INMAT() + 1) = '$'
BOT.STRING = INMAT() + 2
BLOCK = ''
IF UPCMD2 = '.L' THEN GOTO SL.1
IF INMAT() > 99 THEN
PRINT 'This ':PRE.STORE:' string exceeds 99 commands.'
GOTO CMD.ERR
END
IF UPCMD2 = '.R' THEN
PRINT ; PRINT STARS:' Loaded ':INMAT():' command(s).' ; PRINT
GOTO SR.1
END
CURR.CMD.NAME = LOAD.REC.NAME
ED.CMD.STRING.ACTIVE = TRUE
GOTO GET.CMD
POP.UP: ; * Move stack commands up a given number of slots.
IF END.STACK + NUM.CMDS > 100 THEN
END.STACK = 100
ES = 101-NUM.CMDS
CMD.STACK (END.STACK) = '$'
END ELSE
ES = END.STACK
END.STACK = END.STACK + NUM.CMDS
END
FOR I = ES TO BLOCK.END STEP -1
CMD.STACK (I + NUM.CMDS) = CMD.STACK (I)
NEXT I
RETURN
PRINT.CMD.STRING: ; * Print a pre-stored string on the CRT.
JJ = 1 ; KK = 20
SP.1:
FOR INDEX = JJ TO KK UNTIL ED.CMD.STRING (INDEX) = '$'
IF ERROR.FORMAT THEN
PRINT " ":INDEX "R%2":": ":ED.CMD.STRING(INDEX)
END ELSE
PRINT FMT(INDEX, 'R%3'):' ':ED.CMD.STRING (INDEX)
END
NEXT INDEX
IF ED.CMD.STRING (1) # '$' THEN GOTO SP.3
SP.2: ; * NOTE: 'SP.2' also used via GOSUB.
PRINT STARS:'The ':PRE.STORE:' string is empty.'
RETURN
SP.3:
IF ED.CMD.STRING (INDEX) = '$' THEN
RETURN
END
JJ += 20 ; KK += 20
CALL *UVPRINTMSG(001142,"")
INPUT Q, 1 ; Q = UPCASE(Q)
IF Q = 'Q' THEN RETURN
GOTO SP.1
PRINT.NAMES: ; * Print pre-stored record names in a given file.
PRINT CMD.NAME (1), CMD.NAME (2), CMD.NAME (3), CMD.NAME (4), CMD.NAME (5)
MAT CMD.NAME = ''
PN.1:
NUM.LINES += 1
IF NUM.LINES > (@CRTHIGH - 4) THEN
NUM.LINES = 0
CALL *UVPRINTMSG(001142,"")
INPUT Q, 1 ; Q = UPCASE(Q)
IF Q = 'Q' THEN RETURN TO END.NOCHANGE
END
RETURN
PUSH.DOWN: ; * Push stack commands down a given number of slots.
FOR I = NN + 1 TO END.STACK
CMD.STACK (I) = CMD.STACK (I + 1)
NEXT I
END.STACK -= 1
RETURN
PUT.ON.STACK: ; * Put commands onto the command stack.
IF LEN(CMD) = 0 AND NULL.CTR THEN
NULL.CTR += 1
CMD.STACK (1) = '+':NULL.CTR
RETURN
END
IF UPCASE(CMD [1, 3]) = '.XR' THEN RETURN
IF UPCASE(CMD [1, 3]) = '.XK' THEN RETURN
IF UPCASE(CMD [1, 2]) = '.X' THEN GOTO STASH.IT
IF UPCASE(CMD [1, 4]) = 'HELP' THEN RETURN
IF CMD [1, 1] = '.' THEN RETURN
IF CMD [1, 1] = '?' THEN RETURN
IF ED.CMD.STRING.ACTIVE AND NOT(ED.CMD.STRING.SUSPENDED) THEN RETURN
STASH.IT:
NUM.CMDS = 1 ; BLOCK.END = 1
GOSUB POP.UP
IF LEN(CMD) = 0 THEN NULL.CTR = 1 ; CMD.STACK (1) = '+':1
ELSE CMD.STACK (1) = ORIGINAL.CMD
RETURN
SET.UP.NN: ; * Find which stack command is to be operated on.
MATCH.CHAR = MATCHFIELD(UPCMD [3, 1], '1N', 1)
IF LEN(MATCH.CHAR) # 0 THEN
NN = UPCMD [3, 1]
MATCH.CHAR = MATCHFIELD(UPCMD [4, 1], '1N', 1)
IF LEN(MATCH.CHAR) # 0 THEN
NN := UPCMD [4, 1]
MATCH.CHAR = MATCHFIELD(UPCMD [5, 1], '1N', 1)
IF LEN(MATCH.CHAR) # 0 THEN NN := UPCMD [5, 1]
END
END ELSE
IF UPCMD2 # '.C' THEN
IF CMD [3, 1] # ' ' AND LEN(CMD [3, 1]) # 0 THEN RETURN TO CMD.ERR
END
IF UPCMD2 = '.L' THEN NN = 9 ELSE NN = 1
IF UPCMD2 = '.C' THEN CMD = CMD [1, 2]:1:CMD [3, 9999]
IF UPCMD2 = '.I' THEN SV.CMD = SV.CMD [1, 2]:1:SV.CMD [3, 9999]
IF END.STACK = 1 THEN
IF UPCMD2 = '.D' AND TOKEN1 THEN RETURN
IF UPCMD2 = '.I' OR UPCMD2 = '.R' OR UPCMD2 = '.X' THEN RETURN
END
END
IF NN = 0 THEN RETURN TO CMD.ERR
IF NN => END.STACK - 1 AND UPCMD2 = '.X' AND NOT(TOKEN1) THEN
CALL *UVPRINTMSG(001071,NN)
PRINT
NN = 0
GOSUB PUSH.DOWN
GOSUB DISPLAY.CURRENT.LINE
RETURN TO CMD.ERR
END
IF NN = STACK.LIMIT AND UPCMD2 # '.L' THEN RETURN TO CMD.ERR
IF NN = END.STACK AND UPCMD2 = '.I' THEN RETURN
IF NN => END.STACK AND UPCMD2 # '.L' THEN
CALL *UVPRINTMSG(001071,NN)
PRINT
GOSUB DISPLAY.CURRENT.LINE
RETURN TO CMD.ERR
END
RETURN
STRING.WRITE: ; * Write stack to a pre-stored command record, or unload lines.
WRITE.FILE.DICT = ''
IF NOT(COUNT(CMD, ' ')) THEN RETURN TO CMD.ERR
SENT = TRIM(CMD [INDEX(CMD, ' ', 1) + 1, 99])
IF COUNT(SENT, ' ') > 2 THEN RETURN TO CMD.ERR
IF COUNT(SENT, ' ') THEN
PROMPT.FOR.FILE = FALSE ; NO.SELECT.LIST = TRUE
WRITE.FILE.NAME = '' ; WRITE.FILE.DICT = ''
SINGLE.FILE.ONLY = TRUE
CALL @GET.FILE.NAME (NO.SELECT.LIST, SENT, WRITE.FILE.DICT,
WRITE.FILE.NAME, PROMPT.FOR.FILE, SINGLE.FILE.ONLY)
IF LEN(WRITE.FILE.NAME) = 0 THEN RETURN TO CMD.ERR
IF WRITE.FILE.NAME # WRITE.FILE.NAME <1> THEN RETURN TO CMD.ERR
LOAD.REC.NAME = SENT
OPENCHECK WRITE.FILE.DICT, WRITE.FILE.NAME TO WRITE.FILE ELSE
ErrorCode = STATUS()
READL FileRec FROM DEVSYS.VOC.FILE,WRITE.FILE.NAME THEN
IF WRITE.FILE.DICT = "" THEN
PathName = FileRec<2>
END ELSE
PathName = FileRec<3>
END
RELEASE DEVSYS.VOC.FILE,WRITE.FILE.NAME
END ELSE
PathName = ""
END
IF WRITE.FILE.DICT = "" THEN
FileName = WRITE.FILE.NAME
END ELSE
FileName = "DICT,":WRITE.FILE.NAME
END
CALL @OpenError(ErrorCode,FileName,PathName)
RETURN TO CMD.ERR
END
WRITE.REC.NAME = SENT
END ELSE
IF UNLOAD.FLAG THEN
WRITE.FILE.NAME = FILE.NAME ; WRITE.FILE.DICT = DICT
WRITE.FILE = EDIT.FILE
END ELSE
WRITE.FILE.NAME = '&ED&' ; WRITE.FILE.DICT = ''
OPENCHECK WRITE.FILE.DICT, WRITE.FILE.NAME TO WRITE.FILE ELSE
ErrorCode = STATUS()
READL FileRec FROM DEVSYS.VOC.FILE,WRITE.FILE.NAME THEN
PathName = FileRec<2>
RELEASE DEVSYS.VOC.FILE,WRITE.FILE.NAME
END ELSE
IF ErrorCode = -1 THEN
AcctFlavor = SYSTEM(1001)
IF AcctFlavor = 2 OR AcctFlavor = 8 OR AcctFlavor = 16 THEN
CreateArgs = "1,1,3 1,1,1"
END ELSE
CreateArgs ="1 0 0"
END
EXECUTE "CREATE-FILE &ED& ":CreateArgs
OPENCHECK WRITE.FILE.DICT, WRITE.FILE.NAME TO WRITE.FILE THEN
GOTO WRITE.OKAY
END ELSE
ErrorCode = STATUS()
READL FileRec FROM DEVSYS.VOC.FILE,WRITE.FILE.NAME THEN
PathName = FileRec<2>
RELEASE DEVSYS.VOC.FILE,WRITE.FILE.NAME
END ELSE
PathName = ""
END
END
END ELSE
PathName = ""
END
END
FileName = WRITE.FILE.NAME
CALL @OpenError(ErrorCode,FileName,PathName)
RETURN TO CMD.ERR
END
END
WRITE.OKAY:
WRITE.REC.NAME = FIELD(SENT, ' ', 1)
END
IF LEN(SENT) = 0 THEN RETURN TO CMD.ERR
IF LEN(WRITE.REC.NAME) = 0 THEN RETURN TO CMD.ERR
IF UNLOAD.FLAG THEN
* Starting line/field number -
CALL *UVPRINTMSG(001193,"")
GOSUB INPUT.LINE
START = INPUT.LINE
IF NOT(NUM(START)) THEN
PRINT 'Starting line/field must be numeric ; you entered "':START:'".'
RETURN TO CMD.ERR
END
IF START < 1 THEN
CALL *UVPRINTMSG(001231,"")
RETURN TO CMD.ERR
END
IF START > BOT THEN
CALL *UVPRINTMSG(001230,BOT:@FM:START)
RETURN TO CMD.ERR
END
* Ending line/field number -
CALL *UVPRINTMSG(001195,"")
GOSUB INPUT.LINE
ENDING = INPUT.LINE
IF NOT(NUM(ENDING)) THEN
PRINT 'Ending line/field must be numeric ; you entered "':ENDING:'".'
RETURN TO CMD.ERR
END
IF ENDING < START THEN
CALL *UVPRINTMSG(001233,ENDING:@FM:START)
RETURN TO CMD.ERR
END
END
CHECK.FOR.LOCK:
READU COMMAND.RECORD FROM WRITE.FILE, WRITE.REC.NAME
* ON ERROR
* CALL *UVPRINTMSG(STATUS(),"")
* RETURN TO GET.CMD
* END
LOCKED
CALL *UVPRINTMSG(001191,"")
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS = 'Y' THEN GOTO CHECK.FOR.LOCK ELSE RETURN TO GET.CMD
END ELSE
IF UPCMD2 = '.D' THEN
CALL *UVPRINTMSG(970004,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME)
PRINT
GOSUB DISPLAY.CURRENT.LINE
RETURN TO GET.CMD
END
DF.ERROR = STATUS()
IF DF.ERROR = 1 OR DF.ERROR = 2 THEN
STATUS TEMP.INFO FROM WRITE.FILE ELSE TEMP.INFO = ""
IF TEMP.INFO<21> = 27 THEN
CALL *UVPRINTMSG(970013,WRITE.REC.NAME)
END ELSE
CALL *UVPRINTMSG(970012,WRITE.REC.NAME)
END
RETURN TO GET.CMD
END
ELSE IF DF.ERROR = 3 THEN
CALL *UVPRINTMSG(47007,WRITE.REC.NAME)
RETURN TO GET.CMD
END
ELSE IF DF.ERROR = 4 THEN
* Warning message already issued - no need to repeat ourselves
* CALL *UVPRINTMSG(47006,WRITE.REC.NAME)
RETURN TO GET.CMD
END
GOTO WRITE.IT.OUT
END
REC.TYPE.CODE = COMMAND.RECORD <1> [1, 1]
COMMAND.RECORD = '' ; * RETURN STRING SPACE
IF UPCMD2 = '.D' THEN RETURN TO SD.1
* already exists overwrite
IF STACK.MODE THEN
CALL *UVPRINTMSG(001110,"")
CALL *UVPRINTMSG(001200,"")
END ELSE
CALL *UVPRINTMSG(001197,"")
END
GOSUB INPUT.LINE ; ANS = INPUT.LINE ; ANS = UPCASE(ANS)
IF ANS # 'Y' THEN
IF STACK.MODE THEN
CALL *UVPRINTMSG(001111,WRITE.REC.NAME)
END ELSE
CALL *UVPRINTMSG(001198,"")
DISPLAY.CURRENT.LINE = FALSE
END
RETURN
END
WRITE.IT.OUT:
WRITE.PERM.MODE = 1
WRITE.PERM.IN = 2
WRITE.PERM.OUT = ''
CALL @PERMISSIONS(WRITE.FILE,WRITE.PERM.MODE,WRITE.PERM.IN,WRITE.PERM.OUT)
IF NOT(WRITE.PERM.OUT) THEN
CALL *UVPRINTMSG(001398,WRITE.FILE.DICT:WRITE.FILE.NAME)
RETURN TO GET.CMD
END
IF UNLOAD.FLAG THEN GOTO UNLOAD
CMD.STRING = UVREADMSG(010239,"")
CMD.STRING = 'E':CMD.STRING:TIMEDATE():@FM
IF NN = 1 AND NOT(COMMA) THEN LAST.CMD = 1
ELSE
IF CMD.STACK (FIRST.CMD) [1, 1] = 'E' THEN CMD.STRING = '' ; * USER PUT OWN 'E' FIELD
FOR JJ = FIRST.CMD TO LAST.CMD + 1 STEP -1
CMD.STRING := CMD.STACK (JJ):@FM
NEXT JJ
END
CMD.STRING := CMD.STACK (LAST.CMD)
WRITE CMD.STRING TO WRITE.FILE, WRITE.REC.NAME ELSE
WRITE.STATUS = STATUS()
IF WRITE.STATUS = IntegrityViolation THEN
IO.VAR = 2
CALL @SQLINTCHK(CMD.STRING,WRITE.FILE,WRITE.REC.NAME,WRITE.FILE.DICT:" ":WRITE.FILE.NAME,IO.VAR)
END ELSE
CALL *UVPRINTMSG(001236,WRITE.STATUS)
END
END
IF STACK.MODE THEN
CALL *UVPRINTMSG(970005,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME)
END ELSE
CALL *UVPRINTMSG(001112,WRITE.REC.NAME)
END
RETURN
UNLOAD:
IF ENDING > BOT THEN ENDING = BOT
UN.RECORD = ''
FOR LNUM = START TO ENDING - 1
GOSUB GET.LINE
UN.RECORD := LINE:@FM
NEXT LNUM
LNUM = ENDING
GOSUB GET.LINE
UN.RECORD := LINE
WRITE UN.RECORD TO WRITE.FILE, WRITE.REC.NAME
ELSE
WRITE.STATUS = STATUS()
IF WRITE.STATUS = IntegrityViolation THEN
IO.VAR = 2
CALL @SQLINTCHK(UN.RECORD,WRITE.FILE,WRITE.REC.NAME,WRITE.FILE.DICT:" ":WRITE.FILE.NAME,IO.VAR)
END ELSE
CALL *UVPRINTMSG(001236,WRITE.STATUS)
END
RETURN
END
* IF STACK.MODE THEN
* CALL *UVPRINTMSG(970005,WRITE.REC.NAME:@FM:WRITE.FILE.DICT:WRITE.FILE.NAME)
* END
UN.RECORD = ''
* %i lines/fields unloaded.
CALL *UVPRINTMSG(001199,ENDING - START + 1)
DISPLAY.CURRENT.LINE = FALSE
RETURN
READ.HELP.RECORD:
IF LEN(HELP.RECORD) = 0 THEN
READ HELP.RECORD FROM SYS.MESSAGE,970000 ELSE
CALL *UVPRINTMSG(970002,"")
RETURN TO HELP.END
END
READ HELP.RECORD.2 FROM SYS.MESSAGE,970001 ELSE
CALL *UVPRINTMSG(970002,"")
RETURN TO HELP.END
END
HELP.RECORD = HELP.RECORD:@FM:HELP.RECORD.2
HELP.RECORD = CHANGE(HELP.RECORD,'_':@FM,@VM)
* Ignore standard header (top three lines) of help file.
* HELP.RECORD = FIELD(HELP.RECORD, @FM, 4, 9999) ;* not on uniVerse!
* Following code to be removed post-8.3.3.
* Remove references to NLS and Unicode functionality if NLS mode is off.
NUM.HELP.LINES = DCOUNT(HELP.RECORD, @FM)
HELP.RECORD.ORIG = HELP.RECORD
HELP.RECORD = ''
SKIP.HELP.LINE = @FALSE
FOR N = 1 TO NUM.HELP.LINES
HELP.LINE = HELP.RECORD.ORIG<N>
IF NLS.ON.FLAG THEN ;* just remove the NLS marker lines
IF HELP.LINE[1,3] # 'NLS'
THEN HELP.RECORD<-1> = HELP.LINE
END ELSE ;* remove all lines between as well
BEGIN CASE
CASE HELP.LINE = 'NLSBEGIN'
SKIP.HELP.LINE = @TRUE
CASE HELP.LINE = 'NLSEND'
SKIP.HELP.LINE = @FALSE
CASE SKIP.HELP.LINE = @FALSE
HELP.RECORD<-1> = HELP.LINE
END CASE
END
NEXT N
* End 8.3.3 special - remove NLSBEGIN/NLSEND lines from messages 970000/970001
END
RETURN
ABORT.CHECK:
ABORT = FALSE
IF NOT(ABORT.FLAG) THEN RETURN
INPUT ABORT, -1
IF NOT(ABORT) THEN RETURN
INPUT ABORT, 1
ABORT = UPCASE(ABORT)
IF ABORT = 'Q' THEN RETURN
* Stopped at line %i
CALL *UVPRINTMSG(001229,LNUM)
INPUT ABORT, 1
ABORT = UPCASE(ABORT)
IF ABORT = 'Q' THEN RETURN
ABORT = FALSE
RETURN
AT.INSERT:
LOCATE X IN AT.LIST <1> BY 'AL' SETTING AT.LOC ELSE
AT.LIST = INSERT(AT.LIST, AT.LOC, 0, 0, X)
AT.SUB = INSERT(AT.SUB, AT.LOC, 0, 0, Y)
RETURN
END
AT.SUB = REPLACE(AT.SUB, AT.LOC, 0, 0, Y)
RETURN
* SJE SPARs 3002891 and 3004396 23 Apr 84
* Give warning message and return to caller who will return to GET.CMD ASAP.
OVERFLOW:
PRINT
PRINT @SYS.BELL:'Memory overflow, one line of data may be lost. FILE as soon'
PRINT 'as possible to prevent further loss and re-EDit.'
OVERFLOW.FLAG = 1
RETURN
*
END
Reference in New Issue View Git Blame Copy Permalink