1460 lines
54 KiB
Brainfuck
Executable File
1460 lines
54 KiB
Brainfuck
Executable File
******************************************************************************
|
|
*
|
|
* PI/open COPY verb
|
|
*
|
|
* 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.........................................
|
|
* 08/13/99 25455 DTM Fixed to work with Type1/Type 19 files
|
|
* 10/14/98 23801 SAP Change copyrights.
|
|
* 11/18/97 20220 GMH Correct destination check method
|
|
* 05/24/96 18194 KAM Generalized Fptr checks when MODFPTRS tunable set
|
|
* 04/12/96 18194 KAM Disallow COPYing F-ptrs when MODFPTRS tunable set
|
|
* 02/28/96 16661 DJL Fixed problem with no items entered or in SELECT
|
|
* 02/13/96 16661 DJL removed READLIST statements
|
|
* 02/09/96 17580 DJL Added TRIM to input of dest.sentence
|
|
* 07/13/95 16907 EAP Use UNISEQ() for NLS support
|
|
* 05/03/95 14315 FTW Dont conv '\n' and @AM in type1/19 to type1/19 COPY
|
|
* 04/28/95 16448 LDG Added support for UNICODE keyword variant of HEX.
|
|
* 04/14/95 14671 WSM Added flag for restricting position of TO keyword
|
|
* as in PI/open. (Customer must assign TO.CHECKING
|
|
* flag to TRUE and recompile to get this behavior.)
|
|
* 03/17/95 15190 SAP Fix CP to use printer width instead of term width.
|
|
* 07/20/94 13952 WLG Fix copying to an id contained in quotes
|
|
* 10/25/93 12022 DPB Fix problem with single item in select list.
|
|
* 09/08/93 12153 WLG Fix write failure for distributed files to print
|
|
* 970013 error when READVU is done as in ED.B
|
|
* 08/03/93 11919 WLG Fix SQLINTCHK error to print "n records copied."
|
|
* 08/30/93 11914 WLG Fix record-id list manipulation to handle ^T, ^N,
|
|
* VMC and SMC as part of record-id.
|
|
* 08/04/93 10871 WLG Fix GET.NAME to print more meaningful error msg.
|
|
* 07/27/93 10871 WLG Fix NEW.PAGE to recognize FIRST.PAGE and not FF.
|
|
* 07/27/93 10871 WLG Fix ID.SUP option.
|
|
* 07/16/93 10871 EAP Minor changes for Universe compatibility
|
|
* 06/25/93 10871 EAP Ported PI/open COPY verb to Universe
|
|
*******************************************************************************
|
|
*
|
|
* START-DESCRIPTION:
|
|
*
|
|
* The syntax for the PI COPY verb is:
|
|
*
|
|
* COPY FROM [DICT] source.file [TO [DICT] target.file]
|
|
*
|
|
* [ rec1[,rec2] [rec3[,rec4]]... ] [ SQUAWK ]
|
|
* ALL OVERWRITING
|
|
* DELETING
|
|
* UPDATING
|
|
* CRT
|
|
* ID.SUP
|
|
* NEW.PAGE
|
|
* FIRST n
|
|
* NOPAGE
|
|
* LPTR n
|
|
* NUM.SUP
|
|
* HEX
|
|
* UNICODE
|
|
*
|
|
*
|
|
* SMA COPY verb outputs a 'TO:' prompt if the copy is to a file.
|
|
* For this reason, the parsing of the SMA COPY verb is in two
|
|
* parts. All the destination tokens are optional so the CCP
|
|
* cannot prompt for itself.
|
|
*
|
|
* The source tokens are parsed by this program in the usual way
|
|
* but COPY.IBAS prompts for the destination tokens, puts them in
|
|
* @SENTENCE and then calls this program again. The literal string
|
|
* 'TO: ' is prepended to @SENTENCE which ensures the second pass
|
|
* hits the destination rule. The localizable 'TO:' prompt is in
|
|
* the COPY.IMSG file.
|
|
*
|
|
* The parser prog uses the special SMA scanner to handle the source
|
|
* option list. Unfortunately, the destination token list requires
|
|
* a left hand parenthesis but not as an option list delimeter.
|
|
* COPY.IBAS will convert the destination left hand parenthesis to
|
|
* a percent sign ('%') before calling this program a second time.
|
|
* The destination tokens will not then be confused for an SMA
|
|
* option list.
|
|
*
|
|
* The syntax for the SMA COPY verb is:
|
|
*
|
|
* COPY [DICT] file-name item-list [(options[)]]
|
|
* TO: [([DICT] filename)] [item-list]
|
|
*
|
|
* Note: Source record tokens can never be prompted for since they are
|
|
* optional
|
|
*
|
|
*
|
|
* END-DESCRIPTION
|
|
*
|
|
* START-DESIGN:
|
|
*
|
|
* No design as of yet.
|
|
*
|
|
* END-DESIGN
|
|
*
|
|
* START-FUTURES:
|
|
*
|
|
* 1. Message saying N records displayed or printed if LPTR or CRT
|
|
*
|
|
* END-FUTURES
|
|
*
|
|
* START-CODE:
|
|
*
|
|
*
|
|
$OPTIONS INFORMATION
|
|
|
|
$INCLUDE UNIVERSE.INCLUDE VERBINSERT.H
|
|
$INCLUDE UNIVERSE.INCLUDE SYMBOL.TBL.H
|
|
$INCLUDE UNIVERSE.INCLUDE UV.COM
|
|
$INCLUDE UNIVERSE.INCLUDE KEYWORD.H
|
|
$INCLUDE UNIVERSE.INCLUDE YESNO.H
|
|
$INCLUDE UNIVERSE.INCLUDE COPY.H
|
|
|
|
|
|
@SYSTEM.SET = 0
|
|
STRIPSTRINGS = '-STRIPSTRINGS'
|
|
EXPAND = '-EXPAND'
|
|
PERMISSIONS = '-PERMISSIONS'
|
|
* Ported the PRINT.RECORD subroutine from PI/open
|
|
*
|
|
PRINT.RECORD = '-PRINT.RECORD'
|
|
SQLINTCHK = '-SQLINTCHK'
|
|
DIM SYMBOLS (VALSTART + MAXTOKENS)
|
|
PRINTER OFF
|
|
SENTENCE = @SENTENCE
|
|
* Convert any Tab characters to whitespace
|
|
CONVERT CHAR(9) TO ' ' IN SENTENCE
|
|
IF SYSTEM(11) THEN PRE.LIST = 1 ELSE PRE.LIST = 0
|
|
HOLD.FROM.ID=""
|
|
HOLD.FROM.ID.FLAG=0
|
|
ID.LIST=0
|
|
MAT SYMBOLS = ''
|
|
ASSIGN TRUE TO SYSTEM(1005)
|
|
SYMBOLS (NEXT.TKN.VALUE) = VALSTART
|
|
SYMBOLS (ORIGINAL.SENTENCE) = 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
|
|
|
|
OPEN "VOC" TO DEVSYS.VOC.FILE ELSE
|
|
CALL *UVPRINTMSG(001752,"")
|
|
STOP
|
|
END
|
|
|
|
DEVSYS.STRIPSTRS.MODE = "Copy"
|
|
DEVSYS.FILE.FOUND = 0
|
|
|
|
IF INDEX(SENTENCE,'"',1) + INDEX(SENTENCE,"'",1) THEN
|
|
CALL @STRIPSTRINGS (SENTENCE, MAT SYMBOLS)
|
|
END
|
|
|
|
HOLD.SENTENCE = SENTENCE
|
|
ERROR.CODE = 0
|
|
*
|
|
* Set up the VERB entry in SYMBOLS, just for completeness
|
|
*
|
|
POS = SYMBOLS (NEXT.TKN.VALUE)
|
|
SYMBOLS (VERB) = FIELD(SENTENCE,' ',1):@VM:POS
|
|
READ VERB.VOC.RECORD FROM DEVSYS.VOC.FILE, SYMBOLS(VERB)<1,1> ELSE
|
|
* Unable to read verb entry from VOC file
|
|
MESSAGE.NO = 1072;ARGS = SYMBOLS(VERB)<1,1>
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
SYMBOLS (NEXT.TKN.VALUE) += 1
|
|
SYMBOLS (POS) = FIELD(VERB.VOC.RECORD,@FM,2,9)
|
|
OUTBUF = CHAR(VERB):POS
|
|
*
|
|
* tokenize the command line and resolve all keywords and file names
|
|
* through the VOC
|
|
*
|
|
HOLD.SENTENCE = FIELD(HOLD.SENTENCE, ' ', 2, 9999)
|
|
IF HOLD.SENTENCE # '' THEN
|
|
CALL @EXPAND (HOLD.SENTENCE, OUTBUF, MAT SYMBOLS, ERROR.CODE)
|
|
IF ERROR.CODE THEN GO EXIT.COPY
|
|
SENTENCE = OUTBUF
|
|
END
|
|
|
|
*
|
|
* Since the COPY engine has been ported from PI/open we will use
|
|
* the RESULTS array to hold the command line parsing information
|
|
* as does the CCP.
|
|
*
|
|
DIMENSION RESULTS(COPY$ELEMENTS+20)
|
|
*
|
|
@SYSTEM.SET = 0
|
|
*
|
|
ISATTY = (@TTY NE 'phantom')
|
|
DIRECTORY = FALSE
|
|
FIRST.DIR = TRUE
|
|
SMA.FLAG = FALSE
|
|
ID.ONLY = FALSE
|
|
TO.CHECKING = FALSE
|
|
MAT RESULTS = ''
|
|
CODE = 0
|
|
STATUS = 0
|
|
PROMPT ''
|
|
RECORD.COUNT = 0
|
|
PRINT.WIDTH = 0
|
|
ORIG.FILE = ''
|
|
DEST.FILE.TYPE = ''
|
|
ORIG.FILE.TYPE = ''
|
|
SRC.TYPE.FLAG = ''
|
|
DEST.TYPE.FLAG = ''
|
|
SET.1017 = 0
|
|
NEW.TO.ID = ''
|
|
FIRST.PAGE = TRUE
|
|
BINARY = 0 ;* GTAR 25455
|
|
|
|
IF VERB.VOC.RECORD<6> # 'INFORMATION.FORMAT' THEN
|
|
SMA.FLAG = TRUE
|
|
END
|
|
DO.SMA.PARSE = SMA.FLAG
|
|
*
|
|
* How many tokens in the command line
|
|
NO.WDS = COUNT(SENTENCE," ")+1
|
|
* Check minimum No. of args depeneding on flavour
|
|
IF (SMA.FLAG AND NO.WDS LT 2) OR (NOT(SMA.FLAG) AND NO.WDS LT 3) THEN
|
|
MESSAGE.NO = 20228
|
|
ARGS = ""
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
WDN = 1
|
|
SNO = 0
|
|
LAST.WD = ""
|
|
* Start the parse
|
|
GOSUB GET.NEXT.WD
|
|
IF NOT(SMA.FLAG) THEN
|
|
* PI flavour requires the FROM keyword
|
|
IF TYPE NE KEYWORD OR SYMBOLS(SNO)<1> NE KW$FROM THEN
|
|
* Second token must be the required keyword, "FROM".
|
|
MESSAGE.NO = 20222
|
|
ARGS = ""
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
IF TYPE EQ KEYWORD AND SYMBOLS(SNO)<1> EQ KW$DICT THEN
|
|
* Optional DICT keyword
|
|
ORIG.DICT = 'DICT '
|
|
GOSUB GET.NEXT.WD
|
|
END ELSE IF TYPE EQ KEYWORD AND SYMBOLS(SNO)<1> EQ KW$PDICT THEN
|
|
* Optional PDICT keyword
|
|
ORIG.DICT = 'PDICT '
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
* Must have a source file name
|
|
GOSUB GET.NAME
|
|
* IF TYPE NE FILE THEN
|
|
* MESSAGE.NO = '86000' ; ARGS = GOT.NAME
|
|
* * "token" is not a valid file name!
|
|
* GOTO EXIT.ERROR.COPY
|
|
* END
|
|
|
|
ORIG.FILE.NAME = GOT.NAME
|
|
GOSUB GET.NEXT.WD
|
|
|
|
IF NOT(SMA.FLAG) AND TYPE EQ KEYWORD AND SYMBOLS(SNO)<1> EQ KW$TO THEN
|
|
* PI flavour optional phrase "TO [DICT] dest.file"
|
|
GOSUB GET.NEXT.WD
|
|
IF TYPE EQ KEYWORD AND SYMBOLS(SNO)<1> EQ KW$DICT THEN
|
|
* Optional DICT keyword
|
|
DEST.DICT = 'DICT '
|
|
GOSUB GET.NEXT.WD
|
|
END ELSE IF TYPE EQ KEYWORD AND SYMBOLS(SNO)<1> EQ KW$PDICT THEN
|
|
* Optional PDICT keyword
|
|
DEST.DICT = 'PDICT '
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
* Must be a destination file name
|
|
GOSUB GET.NAME
|
|
* IF TYPE NE FILE THEN
|
|
* * Missing destination file name
|
|
* MESSAGE.NO = '86000' ; ARGS = GOT.NAME
|
|
* * "token" is not a valid file name!
|
|
* GOTO EXIT.ERROR.COPY
|
|
* END
|
|
DEST.FILE.NAME = GOT.NAME
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
*
|
|
* main parse loop for all keywords and record id list
|
|
* Non-PI flavour parenthesized options will have been converted to
|
|
* '-' prefixed keywords by clexec.c
|
|
*
|
|
LOOP
|
|
WHILE WDN <= NO.WDS
|
|
IF TYPE EQ KEYWORD THEN
|
|
OP.CODE = SYMBOLS(SNO)<1>
|
|
BEGIN CASE
|
|
CASE SMA.FLAG AND OP.CODE = KW$MULTIPLY
|
|
* Non PI flavours uses '*' instead of ALL keyword
|
|
* This must be first in case statement because it doesn't
|
|
* have a '-' prefix
|
|
IF ALL.SW THEN
|
|
* Duplication of '*' keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
ALL.SW = OP.CODE
|
|
CASE SMA.FLAG AND PREFIX = ''
|
|
* In SMA flavour all keywords must be prefixed by '-'
|
|
GOTO ADD.TO.LIST
|
|
CASE OP.CODE = KW$ID.ONLY
|
|
ID.ONLY = TRUE
|
|
CASE OP.CODE = KW$OVERWRITING
|
|
IF OVERWRITING.SW THEN
|
|
* Duplication of OVERWRITING keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
OVERWRITING.SW = OP.CODE
|
|
CASE OP.CODE = KW$DELETING
|
|
IF DELETING.SW THEN
|
|
* Duplication of DELETING keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
DELETING.SW = OP.CODE
|
|
CASE NOT(SMA.FLAG) AND OP.CODE = KW$ALL
|
|
* Only use the ALL keyword in PI flavour
|
|
IF ALL.SW THEN
|
|
* Duplication of ALL keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
ALL.SW = OP.CODE
|
|
CASE OP.CODE = KW$SQUAWK
|
|
IF SQUAWK.SW THEN
|
|
* Duplication of SQUAWK keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
IF HUSHED.SW THEN
|
|
* can't have both HUSHED and SQUAWK
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
SQUAWK.SW = OP.CODE
|
|
CASE OP.CODE = KW$NO.NEW AND NOT(SMA.FLAG)
|
|
* UPDATING or NO.NEW definitely means UPDATING in PI flavour
|
|
IF UPDATING.SW THEN
|
|
* Duplication of UPDATING keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
UPDATING.SW = OP.CODE
|
|
CASE OP.CODE = KW$NO.PAGE OR (SMA.FLAG AND OP.CODE = KW$NO.NEW)
|
|
* PICK flavour passes (N) as NO.NEW but it means NO.PAGE
|
|
* unless its a file to file copy and is combined with the
|
|
* overwriting option. We store it in NOPAGE.SW and check for
|
|
* this later.
|
|
IF NOPAGE.SW THEN
|
|
* Duplication of NO.PAGE keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
NOPAGE.SW = OP.CODE
|
|
CASE OP.CODE = KW$FORM.FEED
|
|
IF NEW.PAGE.SW THEN
|
|
* Duplication of NEW.PAGE keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
NEW.PAGE.SW = OP.CODE
|
|
CASE OP.CODE = KW$NUM.SUP
|
|
IF NUM.SUP.SW THEN
|
|
* Duplication of NUM.SUP keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
NUM.SUP.SW = OP.CODE
|
|
CASE OP.CODE = KW$LPTR
|
|
IF LPTR.SW NE "" THEN
|
|
* Duplication of LPTR keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
LPTR.SW = '0'
|
|
IF NOT(SMA.FLAG) THEN
|
|
GOSUB GET.NEXT.WD
|
|
* needs to look ahead for possible print unit number
|
|
GOSUB GET.NAME
|
|
IF TYPE EQ VALUE THEN
|
|
LPTR.SW = GOT.NAME
|
|
END
|
|
ELSE WDNO -= 1
|
|
END
|
|
CASE OP.CODE = KW$NO.WARN
|
|
* this should only be used for non-PI (S) option
|
|
IF HUSHED.SW THEN
|
|
* Duplication of HUSHED keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
IF SQUAWK.SW THEN
|
|
* can't have both HUSHED and SQUAWK
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
HUSHED.SW = OP.CODE
|
|
CASE OP.CODE = KW$CRT
|
|
IF CRT.SW THEN
|
|
* Duplication of CRT keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
CRT.SW = OP.CODE
|
|
CASE OP.CODE = KW$ID.SUP
|
|
IF ID.SUP.SW THEN
|
|
* Duplication of ID.SUP keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
ID.SUP.SW = OP.CODE
|
|
CASE OP.CODE = KW$HEX
|
|
IF HEX.SW THEN
|
|
* Duplication of HEX keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
HEX.SW = OP.CODE
|
|
CASE OP.CODE = KW$UNICODE
|
|
IF SYSTEM(100) = 0 THEN
|
|
* UNICODE keyword not allowed if NLS mode is off:
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
IF HEX.SW THEN
|
|
* Duplication of HEX / UNICODE keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
HEX.SW = -1 ;* indicates UNICODE rather than HEX
|
|
CASE OP.CODE = KW$SAMPLE
|
|
IF FIRST.SW THEN
|
|
* Duplication of SAMPLE keyword
|
|
GOSUB GET.NAME
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
GOSUB GET.NEXT.WD
|
|
* store sample size in FIRST.SW
|
|
GOSUB GET.NAME
|
|
IF TYPE EQ VALUE THEN
|
|
FIRST.SW = GOT.NAME
|
|
END
|
|
ELSE
|
|
* missing sample size
|
|
MESSAGE.NO = '20227';ARGS = GOT.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
CASE TRUE
|
|
* Not a recognisable keyword so add it to the record id list
|
|
GOTO ADD.TO.LIST
|
|
END CASE
|
|
* get next token and go around again
|
|
GOSUB GET.NEXT.WD
|
|
|
|
END
|
|
ELSE
|
|
ADD.TO.LIST:
|
|
* Everything that is not recognised as a valid keyword for the
|
|
* COPY verb comes here.
|
|
* All flavours add the first token to the FROM.LIST
|
|
GOSUB GET.NAME
|
|
*
|
|
* Hack to get around bug/feature of Universe version of EXPAND
|
|
* If command line is of the form token1,token2 and token1 is
|
|
* found in the VOC then a single token is returned with the
|
|
* type of token1 but a name of the form 'token1,token2'.
|
|
*
|
|
IF NOT(SMA.FLAG) AND INDEX(GOT.NAME,',',1) AND TYPE NE LITERAL THEN
|
|
ID.LIST=1
|
|
FROM.LIST<-1> = FIELD(GOT.NAME,',',1)
|
|
TO.LIST<-1> = FIELD(GOT.NAME,',',2)
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
ELSE
|
|
IF TO.CHECKING AND NOT(SMA.FLAG) AND GOT.NAME = 'TO' THEN
|
|
* "TO" not expected
|
|
MESSAGE.NO = '86009'; ARGS = FIELD(TRIM(HOLD.SENTENCE), ' ', WDN - 2)
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
ID.LIST=1
|
|
FROM.LIST<-1> = GOT.NAME
|
|
GOSUB GET.NEXT.WD
|
|
*
|
|
* If PI flavour and next token is comma then we are changing
|
|
* the name on the COPY
|
|
IF NOT(SMA.FLAG) AND WD = ',' THEN
|
|
GOSUB GET.NEXT.WD
|
|
GOSUB GET.NAME
|
|
TO.LIST<-1> = GOT.NAME
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
ELSE
|
|
TO.LIST<-1> = GOT.NAME
|
|
END
|
|
END
|
|
END
|
|
REPEAT
|
|
|
|
*
|
|
* comes here when GET.NEXT.WD runs out of tokens on command line
|
|
*
|
|
END.OF.PARSE:
|
|
|
|
*........................................................................
|
|
* Parse the SMA flavour.
|
|
*........................................................................
|
|
IF DO.SMA.PARSE THEN
|
|
*
|
|
* reset the DO.SMA.PARSE so that we skip the SMA parse when
|
|
* GET.NEXT.WD returns to END.OF.PARSE
|
|
*
|
|
DO.SMA.PARSE = FALSE
|
|
*
|
|
* Decide whether to request destination arguments.
|
|
* Do not if CRT or LPTR options taken.
|
|
IF NOT(CRT.SW) AND LPTR.SW = '' THEN
|
|
*
|
|
GOSUB OPEN.SOURCE.FILE
|
|
*
|
|
MESSAGE.NO = '1333';ARGS = ''
|
|
CALL *UVPRINTMSG(MESSAGE.NO,ARGS)
|
|
* * 'TO: ':
|
|
|
|
*
|
|
* If COPY, to a file, is being executed from a PROC then echo the DEST.SENTENCE
|
|
* and turn off pagination. This makes the output from the EXCHANGE proc look
|
|
* right. Also does the echo if the DATA stack is active.
|
|
* We have to test the DATA stack before we do the INPUT.
|
|
*
|
|
INPUT DEST.SENTENCE
|
|
DEST.SENTENCE=TRIM(DEST.SENTENCE)
|
|
IF SYSTEM(10) OR SYSTEM(16) OR NOT(ISATTY) THEN
|
|
PRINT " ":DEST.SENTENCE
|
|
END
|
|
* Check existance of source records
|
|
IF NOT(ALL.SW) AND NOT(FIRST.SW) THEN
|
|
IF LEN(DEST.SENTENCE)=0 THEN CRT.SW = KW$CRT
|
|
GOSUB CHECK.SOURCE.RECORDS
|
|
END
|
|
CLOSE ORIG.FILE
|
|
|
|
IF LEN(DEST.SENTENCE) > 0 THEN
|
|
DEST.SENTENCE = TRIM(DEST.SENTENCE)
|
|
*
|
|
* tokenize the command line and resolve the file name
|
|
* through the VOC
|
|
*
|
|
IF INDEX(DEST.SENTENCE,'"',1) + INDEX(DEST.SENTENCE,"'",1) THEN
|
|
CALL @STRIPSTRINGS (DEST.SENTENCE, MAT SYMBOLS)
|
|
END
|
|
CALL @EXPAND (DEST.SENTENCE, OUTBUF, MAT SYMBOLS, ERROR.CODE)
|
|
IF ERROR.CODE THEN GO EXIT.COPY
|
|
SENTENCE = OUTBUF
|
|
* The new tokens have been added to the end so we need to
|
|
* adjust the token count and our current position.
|
|
NO.WDS = COUNT(SENTENCE," ")+1
|
|
WDN -= 1
|
|
SNO = 0
|
|
*
|
|
* Now we parse the TO: command line
|
|
GOSUB GET.NEXT.WD
|
|
* we only come here if there is at least one token
|
|
ACCEPT.RPAREN = FALSE
|
|
IF WD NE '(' THEN
|
|
* first token must be '('
|
|
GO GET.TO.LIST
|
|
END
|
|
ACCEPT.RPAREN = TRUE
|
|
GOSUB GET.NEXT.WD
|
|
IF TYPE EQ KEYWORD AND SYMBOLS(SNO)<1> EQ KW$DICT THEN
|
|
* Optional DICT keyword
|
|
DEST.DICT = 'DICT '
|
|
GOSUB GET.NEXT.WD
|
|
END ELSE IF TYPE EQ KEYWORD AND SYMBOLS(SNO)<1> EQ KW$PDICT THEN
|
|
* Optional DICT keyword
|
|
DEST.DICT = 'PDICT '
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
GOSUB GET.NAME
|
|
* Must have a destination file name
|
|
* IF TYPE NE FILE THEN
|
|
* * Missing destination file name
|
|
* MESSAGE.NO = '86000' ; ARGS = GOT.NAME
|
|
* * "token" is not a valid file name!
|
|
* GOTO EXIT.ERROR.COPY
|
|
* END
|
|
DEST.FILE.NAME = GOT.NAME
|
|
GOSUB GET.NEXT.WD
|
|
|
|
IF WD EQ ')' THEN
|
|
ACCEPT.RPAREN = FALSE
|
|
* Don't worry if the closing parenthesis is missing
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
*
|
|
* finally we accept a list of destination record ids
|
|
*
|
|
GET.TO.LIST:
|
|
TO.LIST = ''
|
|
LOOP
|
|
WHILE WDN <= NO.WDS
|
|
GOSUB GET.NAME
|
|
TO.LIST<-1> = GOT.NAME
|
|
GOSUB GET.NEXT.WD
|
|
IF WD EQ ')' AND ACCEPT.RPAREN THEN
|
|
* For caompatibility with Universe we will accept
|
|
* the closing parenthesis anywhere on the line
|
|
ACCEPT.RPAREN = FALSE
|
|
GOSUB GET.NEXT.WD
|
|
END
|
|
REPEAT
|
|
END ELSE
|
|
CRT.SW = KW$CRT ;* SMA defaults to CRT if null response
|
|
END
|
|
END
|
|
END
|
|
*
|
|
*........................................................................
|
|
* Process NOPAGE option
|
|
*........................................................................
|
|
IF NOPAGE.SW OR (NOT(ISATTY) AND LPTR.SW = "") THEN
|
|
DUMMY = @(0,0)
|
|
END
|
|
*
|
|
* Suppress ID listing in REALITY flavour unless copying to
|
|
* terminal, printer or the -ID.ONLY switch was used.
|
|
*
|
|
IF VERB.VOC.RECORD<6> = "REALITY.FORMAT" AND NOT(ID.ONLY) THEN
|
|
IF NOT(CRT.SW) and NOT(LPTR.SW) THEN
|
|
ID.SUP.SW = KW$ID.SUP
|
|
END
|
|
END
|
|
*
|
|
* PRINT
|
|
*
|
|
* Open the source file. The CCP will ensure that we have one of these.
|
|
GOSUB OPEN.SOURCE.FILE
|
|
*
|
|
* We do not need to open the destination file if CRT or LPTR is specified
|
|
IF (LPTR.SW = '' AND NOT(CRT.SW)) THEN
|
|
* If destination file name and destination dictionary are both null
|
|
* set to the source file name and dictionary.
|
|
IF NOT(DEST.FILE.NAME) THEN
|
|
DEST.FILE.NAME = ORIG.FILE.NAME
|
|
DEST.FILE.TYPE = ORIG.FILE.TYPE
|
|
DEST.DICT = ORIG.DICT
|
|
END
|
|
*
|
|
* We do not need to open the destination file if its the same as the source file
|
|
IF DEST.DICT:DEST.FILE.NAME # ORIG.DICT:ORIG.FILE.NAME THEN
|
|
OPENCHECK DEST.DICT,DEST.FILE.NAME TO DEST.FILE ELSE
|
|
* failed to open destination file
|
|
IF SMA.FLAG THEN MESSAGE.NO = 1322 ELSE MESSAGE.NO = 20013
|
|
ARGS=DEST.DICT:DEST.FILE.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
DEST.TYPE.FLAG = STATUS()
|
|
*
|
|
END ELSE
|
|
DEST.FILE = ORIG.FILE
|
|
DEST.TYPE.FLAG = SRC.TYPE.FLAG
|
|
END
|
|
*
|
|
* Check that destination file is writeable before we try to
|
|
* copy anything otherwise the error reporting is a little
|
|
* messy.
|
|
*
|
|
WRITEABLE = FALSE
|
|
CALL @PERMISSIONS(DEST.FILE, 1, 6, WRITEABLE)
|
|
IF NOT(WRITEABLE) THEN
|
|
* `The file "':DEST.DICT:DEST.FILE.NAME:'" is read-only and cannot be COPIED.'
|
|
MESSAGE.NO = '20223';ARGS=DEST.DICT:DEST.FILE.NAME
|
|
GOTO EXIT.ERROR.COPY
|
|
END
|
|
*
|
|
NUM.SUP.SW = ''
|
|
* If SMA then '(ON' means UPDATING if copying to file.
|
|
IF SMA.FLAG AND (NOPAGE.SW = KW$NO.NEW) AND OVERWRITING.SW THEN
|
|
UPDATING.SW = KW$NO.NEW
|
|
END
|
|
END ELSE
|
|
* Sort out the command line options by re-setting those to be ignored.
|
|
* IF LPTR THEN reset CRT option (ie. LPTR takes precidence over CRT).
|
|
* The parser will have taken S to mean HUSHED. It really
|
|
* means NUM.SUP if T or P specified
|
|
DELETING.SW = ''; OVERWRITING.SW = ''; UPDATING.SW = ''; SQUAWK.SW = ''
|
|
IF HUSHED.SW THEN
|
|
HUSHED.SW = ''; NUM.SUP.SW = KW$NUM.SUP
|
|
END
|
|
*
|
|
IF LPTR.SW # '' THEN
|
|
CRT.SW = ''
|
|
* Obtain current print width setting
|
|
PRINTER ON ;* change from terminal output to printer.
|
|
PRINT.WIDTH = @LPTRWIDE
|
|
PRINTER OFF
|
|
END ELSE
|
|
* Obtain current CRT width setting.
|
|
PRINT.WIDTH = @CRTWIDE
|
|
END
|
|
END
|
|
*
|
|
*.......................................................................
|
|
*---- Process the ALL option.
|
|
*.......................................................................
|
|
IF ALL.SW THEN
|
|
TO.LIST = ''
|
|
* ALL therefore overrides existing SELECT list and user input ID list.
|
|
SELECT ORIG.FILE
|
|
END
|
|
*...................................................................
|
|
*----- Process the FIRST.SW option
|
|
*...................................................................
|
|
IF FIRST.SW THEN
|
|
TO.LIST = ''
|
|
SELECT ORIG.FILE
|
|
END
|
|
*
|
|
*.......................................................................
|
|
*---- Process the SQUAWK option.
|
|
*.......................................................................
|
|
IF SQUAWK.SW THEN
|
|
MESSAGE.NO = '10032'; ARGS = ORIG.DICT:ORIG.FILE.NAME
|
|
* 'Source file name = "':ORIG.DICT:ORIG.FILE.NAME:'".'
|
|
GOSUB DISPLAY.MESSAGE
|
|
MESSAGE.NO = '10033'; ARGS = DEST.DICT:DEST.FILE.NAME
|
|
* 'Destination file name = "':DEST.DICT:DEST.FILE.NAME:'".'
|
|
GOSUB DISPLAY.MESSAGE
|
|
|
|
MESSAGE.NO = '10034'
|
|
IF OVERWRITING.SW THEN
|
|
ARGS = 'TRUE'
|
|
END ELSE
|
|
ARGS = 'FALSE'
|
|
END
|
|
* 'Overwriting option = ':
|
|
* IF OVERWRITING.SW THEN 'TRUE.' ELSE 'FALSE.'
|
|
GOSUB DISPLAY.MESSAGE
|
|
*
|
|
MESSAGE.NO = '86001' ;* New Message
|
|
IF UPDATING.SW THEN
|
|
ARGS = 'TRUE'
|
|
END ELSE
|
|
ARGS = 'FALSE'
|
|
END
|
|
* 'Updating option = ':
|
|
* IF UPDATING.SW THEN 'TRUE.' ELSE 'FALSE.'
|
|
GOSUB DISPLAY.MESSAGE
|
|
|
|
MESSAGE.NO = '10035'
|
|
IF DELETING.SW THEN
|
|
ARGS = 'TRUE'
|
|
END ELSE
|
|
ARGS = 'FALSE'
|
|
END
|
|
* 'Deleting option = ':
|
|
* IF DELETING.SW THEN 'TRUE.' ELSE 'FALSE.'
|
|
GOSUB DISPLAY.MESSAGE
|
|
*
|
|
END
|
|
*
|
|
* Set up condition flags outside loop so that main loop runs faster.
|
|
READ.FLAG = FALSE
|
|
IF LPTR.SW # '' OR CRT.SW OR NOT(DIRECTORY) THEN
|
|
READ.FLAG = TRUE
|
|
END
|
|
*
|
|
ID.FLAG = FALSE
|
|
IF (SQUAWK.SW AND NOT(ID.SUP.SW)) OR (SMA.FLAG AND NOT(ID.SUP.SW)) THEN
|
|
IF NOT(HUSHED.SW) THEN
|
|
ID.FLAG = TRUE
|
|
END
|
|
END
|
|
*
|
|
*........................................................................
|
|
* Process user supplied SELECT list
|
|
*........................................................................
|
|
IF ID.LIST = 0 AND NOT(ALL.SW) AND NOT(FIRST.SW) THEN
|
|
IF SYSTEM(11) THEN
|
|
IF NOT(SMA.FLAG) THEN
|
|
READNEXT HOLD.FROM.ID THEN
|
|
FROM.ID=HOLD.FROM.ID
|
|
HOLD.FROM.ID.FLAG=1
|
|
END ELSE
|
|
FROM.ID=""
|
|
END
|
|
MESSAGE.NO = '10036'; ARGS = FROM.ID
|
|
GOSUB DISPLAY.MESSAGE
|
|
* 'You have an active SELECT list.'
|
|
* 'Do you wish to copy the records previously selected?'
|
|
* 'The first record id = "':FROM.ID:'".'
|
|
PROMPT.MESS = ""
|
|
* 'Enter Y or N: ':
|
|
IF YESNO(PROMPT.MESS, YN$YES+YN$NO, YN$NO) # YN$YES THEN
|
|
GOTO END.OF.COPY
|
|
* MESSAGE.NO = '20303'; ARGS = ''
|
|
* * @SYS.BELL:'Processing aborted.'
|
|
* GOTO EXIT.ERROR.COPY
|
|
END
|
|
* PRINT
|
|
END
|
|
ELSE
|
|
* 'You have an active SELECT list.'
|
|
MESSAGE.NO = '1334'; ARGS = ''
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
* Convert the SELECT list to a dynamic array outside the MAIN
|
|
* loop so that we do not have to decide whether to do a REMOVE
|
|
* or a READNEXT for every ID.
|
|
END
|
|
END
|
|
*
|
|
*.......................................................................
|
|
* Process LPTR or LPTR 0 option.
|
|
* Do this here so that the SELECT and SQUAWK message appear on screen.
|
|
*.......................................................................
|
|
IF LPTR.SW # '' THEN
|
|
PRINTER ON
|
|
END
|
|
*
|
|
*##############################################################################
|
|
*---- Main COPY loop.
|
|
*##############################################################################
|
|
|
|
FROM.DELIM = -1
|
|
TO.DELIM = -1
|
|
*
|
|
* IF WE ARE COPYING *FROM* A TYPE 1 OR TYPE 19 FILE *TO* A TYPE 1 OR
|
|
* TYPE 19 FILE, THEN SET SYSTEM(1017) SO THAT @FM CHARS **DO NOT**
|
|
* GET CONVERTED TO NEWLINES ('\n') IN DBwrite1() (GTAR 14315)
|
|
*
|
|
IF (SRC.TYPE.FLAG = 19) OR (SRC.TYPE.FLAG = 1) THEN
|
|
IF (DEST.TYPE.FLAG = 19) OR (DEST.TYPE.FLAG = 1) THEN
|
|
ASSIGN 1 TO SYSTEM(1017)
|
|
BINARY = 1 ;* GTAR 25455
|
|
SET.1017 = 1
|
|
END
|
|
END
|
|
*
|
|
LOOP
|
|
* Check FIRST option conditions. We may wish to exit COPY if we
|
|
* we processing the FIRST n ID in the source ID list.
|
|
IF FIRST.SW # '' AND RECORD.COUNT = FIRST.SW THEN
|
|
CLEARSELECT 0 ;* clear the select list of all remaining items.
|
|
EXIT
|
|
END
|
|
IF ALL.SW OR FIRST.SW OR (PRE.LIST AND NOT(ID.LIST)) THEN
|
|
IF HOLD.FROM.ID.FLAG=1 THEN
|
|
FROM.ID=HOLD.FROM.ID
|
|
HOLD.FROM.ID.FLAG=0
|
|
END ELSE
|
|
READNEXT FROM.ID ELSE
|
|
EXIT
|
|
END
|
|
END
|
|
CONTINUE.PROCESS.FLAG=TRUE
|
|
DELETE.RECORD.FLAG=TRUE
|
|
END ELSE
|
|
IF ID.LIST=0 THEN EXIT
|
|
CONTINUE.PROCESS.FLAG = TRUE ;* 011
|
|
DELETE.RECORD.FLAG = TRUE ;* 010
|
|
*
|
|
* Get a source ID from list.
|
|
IF FROM.DELIM = 0 THEN EXIT
|
|
FROM.ID = ''
|
|
LOOP
|
|
REMOVE FROM.TEXT FROM FROM.LIST SETTING FROM.DELIM
|
|
IF ISNULL(FROM.TEXT) THEN FROM.TEXT = @NULL.STR
|
|
IF FROM.DELIM > 2 THEN
|
|
FROM.ID := FROM.TEXT:CHAR(256-FROM.DELIM)
|
|
END ELSE
|
|
FROM.ID := FROM.TEXT
|
|
END
|
|
WHILE FROM.DELIM > 2 DO
|
|
REPEAT
|
|
END
|
|
*
|
|
* Get a destination ID from list else set to source ID. We may not
|
|
* have a destination ID if a SELECT list was active prior to the
|
|
* COPY command. Note: The loop control is on the REMOVE source ID.
|
|
IF TO.DELIM = 0 OR TO.LIST = "" THEN
|
|
TO.ID = FROM.ID
|
|
END ELSE
|
|
TO.ID = ''
|
|
LOOP
|
|
REMOVE TO.TEXT FROM TO.LIST SETTING TO.DELIM
|
|
IF ISNULL(TO.TEXT) THEN TO.TEXT = @NULL.STR
|
|
IF TO.DELIM > 2 THEN
|
|
TO.ID := TO.TEXT:CHAR(256-TO.DELIM)
|
|
END ELSE
|
|
TO.ID := TO.TEXT
|
|
END
|
|
WHILE TO.DELIM > 2 DO
|
|
REPEAT
|
|
END
|
|
|
|
*
|
|
* If we are writing from a PI file to a type one file then check the
|
|
* ID so that the message, 'Record ID x is invalid, using ID y instead'
|
|
* does not appear twice.
|
|
** IF DEST.FILE.TYPE = FILETYPE$TYPE1 AND NOT(DIRECTORY) THEN
|
|
** CALL @CHECK.TYPE1.ID(NEW.TO.ID, TO.ID)
|
|
** IF NEW.TO.ID # TO.ID THEN
|
|
** MESSAGE.NO = 'PI-11608'; ARGS = TO.ID:@FM:NEW.TO.ID
|
|
** GOSUB DISPLAY.MESSAGE
|
|
** * Record ID "<1>" is invalid, using ID "<2>" instead.
|
|
** TO.ID = NEW.TO.ID
|
|
** END
|
|
** END
|
|
*.......................................................................
|
|
*---- Copy involving a PI type file.
|
|
* We now read the FROM.ID record for PI files and for TYPE1 files if
|
|
* CRT or LPTR was specified. Previously we did not read type one records
|
|
* at all because this was done by by RMCOPY. We now read type one
|
|
* records if we wish to display them.
|
|
*.......................................................................
|
|
IF READ.FLAG THEN
|
|
IF BINARY THEN ASSIGN 1 TO SYSTEM(1017) ;* GTAR 25455
|
|
READ RECORD FROM ORIG.FILE, FROM.ID
|
|
** ON ERROR
|
|
** @SYSTEM.SET = -1
|
|
** MESSAGE.NO = 'PI-11595'; ARGS = FROM.ID:@FM:ORIG.DICT:@FM:ORIG.FILE.NAME:@FM:STATUS()
|
|
** GOSUB DISPLAY.MESSAGE
|
|
** * @SYS.BELL:' Failed to read "':FROM.ID:'" from "':
|
|
** * ORIG.DICT:ORIG.FILE.NAME:'"! Status = ':STATUS()
|
|
** CONTINUE.PROCESS.FLAG = FALSE ;* 011
|
|
** END
|
|
THEN
|
|
* Print record if CRT or LPTR specified.
|
|
IF CRT.SW OR LPTR.SW # '' THEN
|
|
GOSUB DISPLAY.RECORD
|
|
CONTINUE.PROCESS.FLAG = FALSE
|
|
END
|
|
ELSE IF NOT(SYSTEM(62)) AND ((ORIG.FILE.NAME = 'VOC') OR (DEST.FILE.NAME = 'VOC'))
|
|
THEN
|
|
IF RECORD[1,1] = 'F' OR RECORD[1,1] = 'f'
|
|
THEN
|
|
*
|
|
* Can't copy an Fptr from the VOC or to the VOC
|
|
*
|
|
CALL *UVPRINTMSG(020553,"")
|
|
CALL *UVPRINTMSG(020225,FROM.ID)
|
|
CONTINUE.PROCESS.FLAG = FALSE
|
|
END
|
|
END
|
|
END ELSE
|
|
@SYSTEM.SET = -1
|
|
MESSAGE.NO = '20224'; ARGS = FROM.ID:@FM:ORIG.DICT:ORIG.FILE.NAME
|
|
IF NOT(HUSHED.SW) THEN
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
* @SYS.BELL:'Record "':FROM.ID:'" not found on file "':
|
|
* ORIG.DICT:ORIG.FILE.NAME:'"!'
|
|
CONTINUE.PROCESS.FLAG = FALSE ;* 011
|
|
END
|
|
END
|
|
*
|
|
*.....................................................................
|
|
*---- PI file copy.
|
|
*.....................................................................
|
|
IF CONTINUE.PROCESS.FLAG THEN ;* 011
|
|
IF NOT(DIRECTORY) THEN
|
|
GOSUB CHECK.DEST.RECORD ;* 011
|
|
IF CONTINUE.PROCESS.FLAG THEN ;* 011
|
|
IF BINARY THEN ASSIGN 1 TO SYSTEM(1017) ;* GTAR 25455
|
|
WRITE RECORD ON DEST.FILE, TO.ID
|
|
** ON ERROR
|
|
ELSE
|
|
IF STATUS() = -3 THEN
|
|
* Use SQLINTCHK subroutine to report any SQL Integrity
|
|
* Checking violations.
|
|
IOVAR = 2
|
|
CALL @SQLINTCHK(RECORD,DEST.FILE,TO.ID,DEST.DICT:DEST.FILE.NAME,IOVAR)
|
|
MESSAGE.NO = ''
|
|
END
|
|
ELSE
|
|
* This is a unexpected condition since most things should
|
|
* have been checked before hand.
|
|
MESSAGE.NO = '86008'; ARGS = TO.ID:@FM:DEST.DICT:DEST.FILE.NAME:@FM:STATUS()
|
|
* @SYS.BELL:'Failed to write record "':TO.ID:'" to file "':DEST.DICT:DEST.FILE.NAME:'"! Status = STATUS().'
|
|
END
|
|
@SYSTEM.SET = -1
|
|
GOSUB DISPLAY.MESSAGE
|
|
*
|
|
* RESET THE SYSTEM(1017) FLAG THAT PREVENTS @FM's FROM BEING
|
|
* CONVERTED TO NEWLINES ('\n') (IF ITS CURRENTLY SET...)
|
|
*
|
|
IF (SET.1017) THEN
|
|
ASSIGN 0 TO SYSTEM(1017)
|
|
SET.1017 = 0
|
|
END
|
|
GOTO NO.RECDS
|
|
END
|
|
END ;* 011
|
|
END
|
|
END
|
|
*
|
|
* 010, 011, LJA 04-06-87, If we are not allowed to delete the record,
|
|
* then print the appropriate message. ALSO NOTE, the we nolonger
|
|
* clear the file with DELETING, ALL because by definition, we will
|
|
* delete all records except the one we could not copy. Therefore
|
|
* 008 change was not 100% accurate.
|
|
IF CONTINUE.PROCESS.FLAG THEN
|
|
IF DELETING.SW THEN
|
|
READVU DUMMY FROM ORIG.FILE, FROM.ID, 0 LOCKED
|
|
@SYSTEM.SET = -1
|
|
MESSAGE.NO = '86003'; ARGS = FROM.ID:@FM:ORIG.DICT:ORIG.FILE.NAME:@FM:STATUS()
|
|
IF NOT(HUSHED.SW) THEN
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
* @SYS.BELL:'Record "':FROM.ID:'" in file "':
|
|
* ORIG.DICT:ORIG.FILE.NAME:'" is locked by ':
|
|
* 'User number ':STATUS():'.'
|
|
* 'DELETE was not done for this record!'
|
|
* LJA 04-07-87, Make sure that we do not delete the
|
|
* Record if it is LOCKED
|
|
DELETE.RECORD.FLAG = FALSE ;* 010
|
|
END ELSE NULL
|
|
*
|
|
IF DELETE.RECORD.FLAG THEN
|
|
DELETE ORIG.FILE,FROM.ID
|
|
IF SQUAWK.SW AND NOT(ALL.SW) THEN
|
|
MESSAGE.NO = '86004'; ARGS = FROM.ID:@FM:ORIG.DICT:ORIG.FILE.NAME
|
|
GOSUB DISPLAY.MESSAGE
|
|
* '"':FROM.ID:'" deleted from "':
|
|
* ORIG.DICT:ORIG.FILE.NAME:'".'
|
|
END
|
|
END
|
|
RELEASE ORIG.FILE, FROM.ID ;* 005
|
|
END
|
|
RECORD.COUNT += 1
|
|
IF ID.FLAG THEN
|
|
IF SMA.FLAG THEN
|
|
MESSAGE.NO = '1325'; ARGS = RECORD.COUNT:@FM:FROM.ID
|
|
GOSUB DISPLAY.MESSAGE
|
|
MESSAGE.NO = '1326'; ARGS = TO.ID:@FM:DEST.DICT:DEST.FILE.NAME
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
ELSE
|
|
MESSAGE.NO = '10031'; ARGS = FROM.ID:@FM:TO.ID
|
|
GOSUB DISPLAY.MESSAGE
|
|
* '"':FROM.ID:'" copied to "':TO.ID:'".'
|
|
END
|
|
END
|
|
END
|
|
REPEAT
|
|
*
|
|
* RESET THE SYSTEM(1017) FLAG THAT PREVENTS @FM's FROM BEING
|
|
* CONVERTED TO NEWLINES ('\n') (IF ITS CURRENTLY SET...)
|
|
*
|
|
*
|
|
IF (SET.1017) THEN
|
|
ASSIGN 0 TO SYSTEM(1017)
|
|
SET.1017 = 0
|
|
END
|
|
*
|
|
IF @SYSTEM.SET = 0 THEN
|
|
@SYSTEM.SET = RECORD.COUNT
|
|
END
|
|
*
|
|
* 010, LJA 04-06-87, If deleting flag and squawk flag and all records
|
|
* were deleted, then display the following message.
|
|
IF DELETING.SW AND ALL.SW AND @SYSTEM.SET AND SQUAWK.SW THEN
|
|
MESSAGE.NO = '86005'; ARGS = ORIG.DICT:ORIG.FILE.NAME
|
|
GOSUB DISPLAY.MESSAGE
|
|
* 'All records deleted from "':ORIG.DICT:ORIG.FILE.NAME:'".'
|
|
END
|
|
* 010, 011, LJA, End of section
|
|
*
|
|
* PRINT
|
|
|
|
END.OF.COPY:
|
|
*
|
|
* Universe returns number of records copied in @SYSTEM.RETURN.CODE
|
|
* even if there were non-fatal errors.
|
|
*
|
|
@SYSTEM.SET = RECORD.COUNT
|
|
NO.RECDS:
|
|
IF (LPTR.SW = "") AND NOT (CRT.SW) THEN
|
|
IF RECORD.COUNT # 1 THEN
|
|
ARGS = RECORD.COUNT
|
|
MESSAGE.NO = '10038'
|
|
END ELSE
|
|
IF SMA.FLAG THEN
|
|
* for some reason the pick copy generates an extra new line
|
|
ARGS = ''
|
|
MESSAGE.NO = '1132'
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
MESSAGE.NO = '10037'
|
|
END
|
|
GOSUB DISPLAY.MESSAGE
|
|
* RECORD.COUNT:' record(s)':' copied.'
|
|
END
|
|
*
|
|
GOTO EXIT.COPY
|
|
*
|
|
*##############################################################################
|
|
* Common exit point for COPY
|
|
*##############################################################################
|
|
EXIT.ERROR.COPY:
|
|
@SYSTEM.SET = -1
|
|
GOSUB DISPLAY.MESSAGE
|
|
*
|
|
EXIT.COPY:
|
|
IF LPTR.SW # '' THEN
|
|
PRINTER CLOSE ON LPTR.SW
|
|
PRINTER OFF
|
|
* *
|
|
* * Display the reason we stopped on the CRT as well
|
|
* * This either N records copied or the final error message.
|
|
* *
|
|
* GOSUB DISPLAY.MESSAGE
|
|
END
|
|
*
|
|
RETURN
|
|
*
|
|
* Subroutines
|
|
|
|
GET.NAME:
|
|
I = 1
|
|
X = UNISEQ(WD)
|
|
IF X > MAX.TYPE THEN
|
|
GOT.NAME = WD
|
|
RETURN
|
|
END
|
|
LOOP Q = SYMBOLS(X)<I,2> UNTIL Q='' DO
|
|
IF Q = SNO THEN
|
|
GOT.NAME=PREFIX:SYMBOLS(X)<I,1>
|
|
RETURN
|
|
END
|
|
I+=1
|
|
REPEAT
|
|
@SYSTEM.SET = -1
|
|
PRINT "COPY.Symbol Table error. Token =>":WDN:"<= not found in Type =>":UNISEQ(WD):"<="
|
|
RETURN TO EXIT.COPY
|
|
|
|
GET.NEXT.WD:
|
|
WDN+=1
|
|
IF WDN GT NO.WDS THEN RETURN TO END.OF.PARSE
|
|
WD=FIELD(SENTENCE,' ',WDN)
|
|
TYPE=UNISEQ(WD)
|
|
SNO=WD[2,99]
|
|
COMMA.POS = INDEX(SNO,",",1)
|
|
IF SMA.FLAG AND WD = '-' THEN
|
|
PREFIX = WD
|
|
WDN+=1
|
|
IF WDN GT NO.WDS THEN RETURN TO END.OF.PARSE
|
|
WD=FIELD(SENTENCE,' ',WDN)
|
|
TYPE=UNISEQ(WD)
|
|
SNO=WD[2,99]
|
|
END
|
|
ELSE PREFIX = ''
|
|
RETURN
|
|
***##############################################################################
|
|
**DIRINIT:
|
|
***##############################################################################
|
|
*** pick up ORIG.TREE & DEST.TREE
|
|
**
|
|
** FIRST.DIR = FALSE
|
|
** ACTION = OSK$RECORD
|
|
** IF (OVERWRITING.SW OR UPDATING.SW) THEN
|
|
** ACTION += OSK$OVERWRITING ;* when OS.COPY available
|
|
** END
|
|
***
|
|
** ORIG.TREE = ''
|
|
** DEST.TREE = ''
|
|
**
|
|
** IF ORIG.DICT THEN DD = 'DICT'
|
|
** ELSE DD = ''
|
|
**
|
|
** CALL @VOC.PATHNAME( DD, ORIG.FILE.NAME, ORIG.TREE, STATUS)
|
|
** IF STATUS THEN
|
|
** MESSAGE.NO = "PI-11595";ARGS = ORIG.FILE.NAME:'VOC':STATUS()
|
|
** CONTINUE.PROCESS.FLAG = FALSE
|
|
** RETURN TO EXIT.ERROR.COPY
|
|
** END
|
|
***
|
|
** IF DEST.DICT THEN DD = 'DICT'
|
|
** ELSE DD = ''
|
|
**
|
|
** CALL @VOC.PATHNAME( DD, DEST.FILE.NAME, DEST.TREE, STATUS)
|
|
** IF STATUS THEN
|
|
** MESSAGE.NO = "PI-11595"; ARGS = DEST.FILE.NAME:'VOC':STATUS()
|
|
** CONTINUE.PROCESS.FLAG = FALSE
|
|
** RETURN TO EXIT.ERROR.COPY
|
|
** END
|
|
**
|
|
** RETURN
|
|
*
|
|
*##############################################################################
|
|
CHECK.DEST.RECORD:
|
|
* 011, LJA, 04-07-87, This chunk of code is used for UFD to UFD copies
|
|
* as for copies using PI structured files. We will set the
|
|
* CONTINUE.PROCESS.FLAG to FALSE if we have problems copying the
|
|
* record to the Destination file. Also, set DELETE.RECORD.FLAG to false
|
|
* and display an error message stating that the record was not deleted
|
|
* if DELETING.SW = TRUE.
|
|
* PVL, Added UPDATING case and set CONTINUE.PROCESS.FLAG to FALSE if
|
|
* copy with LPTR or CRT, these do not perform file copy.
|
|
* Subroutines.
|
|
*##############################################################################
|
|
*
|
|
IF NOT(CRT.SW) AND LPTR.SW = '' THEN
|
|
REC.EXISTS = TRUE; REC.LOCKED = FALSE
|
|
* READVU DUMMY FROM DEST.FILE, TO.ID, 0
|
|
READU TARGET.REC FROM DEST.FILE, TO.ID
|
|
** ON ERROR
|
|
** @SYSTEM.SET = -1
|
|
** MESSAGE.NO = 'PI-11601'
|
|
** ARGS = TO.ID:@FM:DEST.DICT:@FM:DEST.FILE.NAME:@FM:STATUS()
|
|
** GOSUB DISPLAY.MESSAGE
|
|
** * @SYS.BELL:'Record "':TO.ID:'" on file "':DEST.DICT:DEST.FILE.NAME:
|
|
** * '" is inaccessible! Status = ':STATUS()
|
|
** CONTINUE.PROCESS.FLAG = FALSE
|
|
** DELETE.RECORD.FLAG = FALSE
|
|
** REC.EXISTS = FALSE
|
|
** END
|
|
LOCKED REC.LOCKED = TRUE
|
|
ELSE
|
|
REC.EXISTS = FALSE
|
|
DF.ERROR = STATUS()
|
|
IF DF.ERROR = 1 OR DF.ERROR = 2 THEN
|
|
STATUS TEMP.INFO FROM DEST.FILE ELSE TEMP.INFO = ""
|
|
IF TEMP.INFO<21> = 27 THEN
|
|
* 'Record "':TO.ID:' is not valid for this Distributed File.'
|
|
MESSAGE.NO = '970013'
|
|
ARGS = TO.ID
|
|
GOSUB DISPLAY.MESSAGE
|
|
END ELSE
|
|
* 'Record "':TO.ID:' is not valid for this partfile.'
|
|
MESSAGE.NO = '970012'
|
|
ARGS = TO.ID
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
CONTINUE.PROCESS.FLAG = FALSE
|
|
DELETE.RECORD.FLAG = FALSE
|
|
END
|
|
END
|
|
*
|
|
IF REC.LOCKED THEN
|
|
@SYSTEM.SET = -1
|
|
MESSAGE.NO = '86003'
|
|
ARGS = TO.ID:@FM:DEST.DICT:DEST.FILE.NAME:@FM:STATUS()
|
|
GOSUB DISPLAY.MESSAGE
|
|
* @SYS.BELL:'Record "':TO.ID:'on file "':DEST.DICT:DEST.FILE.NAME
|
|
* '" is locked by User number ':STATUS():'; not copied!'
|
|
CONTINUE.PROCESS.FLAG = FALSE
|
|
DELETE.RECORD.FLAG = FALSE ;* 010
|
|
END
|
|
*
|
|
IF ((NOT(SYSTEM(62))) AND (DEST.FILE.NAME= 'VOC'))
|
|
THEN
|
|
IF REC.EXISTS AND OVERWRITING.SW AND (TARGET.REC[1,1] = 'F' OR TARGET.REC[1,1] = 'f')
|
|
*
|
|
* Can't overwrite an Fptr in the VOC!
|
|
*
|
|
THEN
|
|
CALL *UVPRINTMSG(020553,"")
|
|
CALL *UVPRINTMSG(020225,TO.ID)
|
|
CONTINUE.PROCESS.FLAG = FALSE
|
|
END
|
|
END
|
|
|
|
IF REC.EXISTS AND NOT(OVERWRITING.SW OR UPDATING.SW) THEN
|
|
@SYSTEM.SET = -1
|
|
MESSAGE.NO = '20226'
|
|
ARGS = TO.ID:@FM:DEST.DICT:DEST.FILE.NAME
|
|
IF NOT(HUSHED.SW) THEN
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
* @SYS.BELL:'Record "':TO.ID:'" already exists on file "':
|
|
* DEST.DICT:DEST.FILE.NAME:'" not copied!'
|
|
DELETE.RECORD.FLAG = FALSE ;* 010
|
|
CONTINUE.PROCESS.FLAG = FALSE ;* 011
|
|
RELEASE DEST.FILE, TO.ID
|
|
END
|
|
*......................................................................
|
|
* UPDATING - Very similar to the OVERWRITING case in that we do not
|
|
* want to delete the original (unless DELETING) but we do want to copy
|
|
* if desitination exists and without OVERWRITING specified.
|
|
*......................................................................
|
|
IF NOT(REC.EXISTS) AND UPDATING.SW THEN
|
|
@SYSTEM.SET = -1
|
|
MESSAGE.NO = '86006'
|
|
ARGS = TO.ID:@FM:DEST.DICT:DEST.FILE.NAME:@FM:STATUS()
|
|
IF NOT(HUSHED.SW) THEN
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
* @SYS.BELL:'Record "':TO.ID: '" does not exist on file "'
|
|
* DEST.DICT:DEST.FILE.NAME:'" not updated!'
|
|
CONTINUE.PROCESS.FLAG = FALSE
|
|
DELETE.RECORD.FLAG = FALSE ;* 010
|
|
IF DELETING.SW THEN
|
|
DELETE.RECORD.FLAG = TRUE ;* 010
|
|
END
|
|
RELEASE DEST.FILE, TO.ID
|
|
END
|
|
*
|
|
** 010, LJA, 04-06-87 - Tell the user that the record was not deleted
|
|
IF DELETING.SW AND NOT(DELETE.RECORD.FLAG) THEN
|
|
MESSAGE.NO = '86007'; ARGS = FROM.ID:@FM:ORIG.DICT:ORIG.FILE.NAME
|
|
IF NOT(HUSHED.SW) THEN
|
|
GOSUB DISPLAY.MESSAGE
|
|
END
|
|
* 'DELETE was not done for Record "':
|
|
* FROM.ID:'" in file "': ORIG.DICT:ORIG.FILE.NAME :'!"'
|
|
END
|
|
** 010, 011, LJA, 04-06-87 - End of section
|
|
END ELSE
|
|
CONTINUE.PROCESS.FLAG = FALSE
|
|
END
|
|
RETURN
|
|
*
|
|
*##############################################################################
|
|
DISPLAY.RECORD:
|
|
* Interface to PRINT.RECORD subroutine. Also handles page throw.
|
|
*##############################################################################
|
|
|
|
IF NEW.PAGE.SW AND NOT(FIRST.PAGE) THEN
|
|
PAGE ON LPTR.SW
|
|
END
|
|
IF FIRST.PAGE THEN FIRST.PAGE = FALSE
|
|
PRINT ON LPTR.SW
|
|
CALL @PRINT.RECORD(FROM.ID, RECORD, LPTR.SW, PRINT.WIDTH,
|
|
NUM.SUP.SW, ID.SUP.SW, HEX.SW)
|
|
RECORD.COUNT +=1
|
|
RETURN
|
|
*
|
|
*##############################################################################
|
|
CHECK.SOURCE.RECORDS:
|
|
* SMA flavour only. If all specified source record IDs do not exist then
|
|
* do not issue 'TO:' prompt, display error messages and quit COPY.
|
|
*##############################################################################
|
|
*
|
|
*
|
|
* We may have a SELECT list active, the CCP will have ensured that we
|
|
* have something.
|
|
* On Universe we may not have a select list or record id list
|
|
IF ALL.SW OR PRE.LIST OR FIRST.SW THEN RETURN
|
|
IF ID.LIST EQ 0 THEN
|
|
RETURN TO END.OF.COPY
|
|
END
|
|
|
|
MESSAGE.NO = '20224'
|
|
I = 1
|
|
NOT.FOUND.COUNT = 0
|
|
* Check that all source records exist in source file.
|
|
DELIM = 1
|
|
LOOP
|
|
WHILE DELIM > 0
|
|
REMOVE ITEM FROM FROM.LIST SETTING DELIM
|
|
READ RECORD FROM ORIG.FILE, ITEM ELSE
|
|
NOT.FOUND.COUNT += 1
|
|
END
|
|
I += 1
|
|
REPEAT
|
|
*
|
|
IF NOT.FOUND.COUNT = I-1 THEN
|
|
* No records were found on source file.
|
|
I = 1
|
|
FOR I = 1 TO NOT.FOUND.COUNT
|
|
ARGS = FROM.LIST<I>:@FM:ORIG.DICT:ORIG.FILE.NAME
|
|
GOSUB DISPLAY.MESSAGE
|
|
* @SYS.BELL:'Record "':FROM.LIST<I>:'" not found on "':ORIG.DICT:ORIG.FILE.NAME:'.'
|
|
NEXT
|
|
*
|
|
RETURN TO END.OF.COPY
|
|
END
|
|
*
|
|
FROM.LIST = FROM.LIST
|
|
*
|
|
RETURN
|
|
*
|
|
*##############################################################################
|
|
OPEN.SOURCE.FILE:
|
|
* This has now become a subroutine because SMA COPY validates the source file
|
|
* before it issues the 'TO:' prompt. PI COPY opens the source file after the
|
|
* command line has been parsed.
|
|
*##############################################################################
|
|
*
|
|
** CALL @OPEN.HANDLER(ORIG.DICT, ORIG.FILE.NAME, OPEN.HANDLER$WARN,
|
|
** ORIG.FILE.TYPE, ORIG.FILE, CODE)
|
|
***
|
|
** * If we got a file type from the open handler then the file opened OK.
|
|
** IF NOT(ORIG.FILE.TYPE) THEN
|
|
** @SYSTEM.SET = -1
|
|
** RETURN TO EXIT.COPY
|
|
** END
|
|
OPENCHECK ORIG.DICT, ORIG.FILE.NAME TO ORIG.FILE ELSE
|
|
IF SMA.FLAG THEN MESSAGE.NO = 1322 ELSE MESSAGE.NO = 20013
|
|
ARGS=ORIG.DICT:ORIG.FILE.NAME
|
|
RETURN TO EXIT.ERROR.COPY
|
|
END
|
|
SRC.TYPE.FLAG = STATUS()
|
|
*
|
|
** * If type was DIRECTORY then set flag.
|
|
** IF ORIG.FILE.TYPE = FILETYPE$TYPE1 THEN
|
|
** IF FILEINFO(ORIG.FILE,FINFO$IS.PI50S.FILE) THEN
|
|
** DIRECTORY = FALSE
|
|
** END
|
|
** ELSE
|
|
** DIRECTORY = TRUE
|
|
** END
|
|
** END ELSE
|
|
** DIRECTORY = FALSE
|
|
** END
|
|
*
|
|
RETURN
|
|
*
|
|
*##############################################################################
|
|
DISPLAY.MESSAGE:
|
|
* REQUIRES CALLER TO SET, MESSAGE.NO AND ARGS.
|
|
*##############################################################################
|
|
** MESSAGE ON LPTR.SW DEVSYS.MESSAGES, MESSAGE.NO, ARGS
|
|
IF MESSAGE.NO THEN
|
|
CALL *UVPRINTMSG(MESSAGE.NO, ARGS)
|
|
END
|
|
RETURN
|
|
*
|
|
END
|
|
*
|
|
* END-CODE
|
|
|
|
|