****************************************************************************** * * 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) UNTIL Q='' DO IF Q = SNO THEN GOT.NAME=PREFIX:SYMBOLS(X) 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:@FM:ORIG.DICT:ORIG.FILE.NAME GOSUB DISPLAY.MESSAGE * @SYS.BELL:'Record "':FROM.LIST:'" 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