johnblood/tldm-universe
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
main
tldm-universe/Ardent/UV/BP/COPY.B

1460 lines
54 KiB
Plaintext
Raw Permalink Normal View History

first push of universe files
2024-09-09 21:51:08 +00:00
******************************************************************************
*
* 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
Reference in New Issue Copy Permalink