Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/copy.bli
There are no other files named copy.bli in the archive.
MODULE COPY (
IDENT = '1',
%IF
%BLISS(BLISS32)
%THEN
LANGUAGE(BLISS32),
ADDRESSING_MODE(EXTERNAL=LONG_RELATIVE,
NONEXTERNAL=LONG_RELATIVE)
%ELSE
LANGUAGE(BLISS36)
%FI
) =
BEGIN
!
! COPYRIGHT (C) 1982, 1983 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!
!++
! FACILITY: CMS Library Processor
!
! ABSTRACT:
!
! This module contains copy command processing code.
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: Robert Wheater, CREATION DATE: 20-Mar-80
!
!--
!++
! General Description
!
! This command permits copying of an existing element to a new
! element name and changing the name of the files contained in
! the element.
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
CHKLIB, ! check master control directory
COPY, ! Main copy routine
COPYFL, ! file to file copy
DEL_OUT_FIL, ! deletes output files after an error
ELMCNT, ! count number of files for this elm in library
MRKLIB, ! put entry in master control directory
VALFIL, ! does validation checks on filenames
indef; ! is file in library
!
! INCLUDE FILES:
!
%if %bliss(bliss32) %then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
LIBRARY 'XPORT:' ;
REQUIRE 'SCONFG:' ;
REQUIRE 'BLISSX:' ;
REQUIRE 'COMUSR:' ;
REQUIRE 'COPUSR:' ;
REQUIRE 'HOSUSR:' ;
REQUIRE 'LOGUSR:' ;
REQUIRE 'SHRUSR:' ;
!
! MACROS:
!
MACRO
BLD_LOG_NAM(S,L,P) = ! S = logical name string
! L = length of filename
! P = pointer to filename string
P_LOG_NAM = CH$PTR(M_LOG_NAM) ;
P_LOG_NAM = CH$MOVE(%CHARCOUNT(S),
CH$PTR(UPLIT(S)),.P_LOG_NAM);
P_LOG_NAM = CH$MOVE(L,P,.P_LOG_NAM) ;
L_LOG_NAM = CH$DIFF(.P_LOG_NAM,CH$PTR(M_LOG_NAM)) ;
P_LOG_NAM = CH$PTR(M_LOG_NAM); %,
STG(L,M) = OUTSTG(CH$PTR(UPLIT(L)),%CHARCOUNT(L),M) %;
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
OWN
A_CUR_FIL, ! address of parameter block that contains
! the filename currently being processed
A_1ST_FIL, ! address of parameter block that contains
! the first filename for this command
A_1ST_PROP: INITIAL(K_NULL), ! address of first property block
COM_FIL_CNT, ! number of filenames in this command
EXISTING_CRC, ! File count already in file
FOUND_CRC, ! If true, found a previous file count
L_LOG_NAM, ! length of logical name
LIB_FIL_CNT, ! number of filenames for this element in
! the library
LIB_EOF, ! set at end of control directory
$io_block(LLIB), ! control directory input iob
$io_block(LIB_W), ! control directory output iob
M_LOG_NAM: VECTOR[CH$ALLOCATION(EXTENDED_FILE_SPEC)],
! storage area for logical name
NEW_CRC, ! File count of output file
OLD_CRC, ! File count of input file
P_LOG_NAM, ! pointer to logical name
$io_block(RD), ! input IOB
$io_block(WR); ! output IOB
!
! EXTERNAL REFERENCES:
!
external literal
s_copyok, !successful copy
s_duplname, !duplicate file name
s_errcount, !no files spec equal to elem # in library
s_flinlib, !file is already in library
s_inlib, !element is already in library
s_inoopen, !cannot open input file
s_invcksum, !defn file has invalid checksum
s_nocksum, !no checksum in defn file
s_noelem, !no such element name in library
s_onoopen, !cannot open output file
s_paramlim, !not enough parameters
s_resrname, !reserved file name
s_treeinv; !tree not allowed
EXTERNAL
CALC_CRC, ! CRC calculated by OUTSTG
F_PERF_CRC, ! If on, OUTSTG will calculate CRC
IGNORE_CONTROL, ! If on, OUTSTG will ignore the control line
PATLGT, ! properties pattrn length(GETELM)
PATPTR; ! properties pattrn pointer(GETELM)
EXTERNAL ROUTINE
aschex,
BADLIB, ! print bad library message(TERMIO)
badxpo,
BEGTRN, ! begin transaction(TRANSA)
BUG, ! terminate and print message(TERMIO)
BUGXPO, ! terminate and print XPORT message(TERMIO)
CANTRN, ! cancel transaction(TRANSA)
CHKRES, ! check for reservation(CHKRES)
COMAND, ! parse command line(COMAND)
crctable:novalue,
crccalc,
DELVRS, ! delete files(FILOPS)
DONLIB, ! release library(TRANSA)
ENDTRN, ! end of tranaction(TRANSA)
ERS, ! print error message(TERMIO)
exits, ! exit silently
GETELM, ! find element filenames and call(GETELM)
! specified routine.
GET_LXM, ! get next lexeme in string(GETLXM)
hexasz,
LOGTRN, ! write log record(IOLOG)
OUTINI, ! initialize output(TXTIO)
OUTSTG, ! output string to file(TXTIO)
REPRES, ! report reservation(CHKRES)
SAFLIB, ! request access to library(TRANSA)
sysmsg,
trnlog, ! translate a logical name
TRNFIL, ! register output file for crash
! recovery(TRANSA)
ERSXPO, ! print XPORT error message(TERMIO)
YES ; ! message to terminal-yes or no
! answer(TERMIO)
ROUTINE CHKLIB (ELM,SIZE) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Check for existence of element
!
! FORMAL PARAMETERS:
!
! ELM - string pointer to element name to be found
! SIZE - length of element name
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! INSRT_POS - points to position where new element can be inserted
! (0 if end of text).
! MARK - Contains pointer to element control record (0 if none)
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - element found
! FALSE - element not found
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
LAST_LINE,
status;
!Open reservation control files
if
(status=$STEP_OPEN(IOB=LLIB_IOB,FILE_SPEC=(%STRING(LIB,CDIR)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,lit('Cannot open definition file'));
if
(status=$STEP_OPEN(IOB=LIB_W_IOB,FILE_SPEC=(%STRING(LIB,CDIR)),
OPTIONS=OUTPUT,failure=0)) neq step$_created
then
badxpo(.status,lit('Cannot open new definition file'));
TRNFIL(LIB_W_IOB);
!Search for the correct name
UNTIL
$step_get(IOB=LLIB_IOB) EQL STEP$_EOF
DO
BEGIN
LOCAL
ELM_NAM : VECTOR[CH$ALLOCATION(EL_NAM_SIZE)],
ELM_PTR,
ELM_SIZ,
TMP_PTR;
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.llib_iob[iob$a_string])
then
begin
local
len,
ptr;
found_crc = true;
len=.llib_iob[iob$h_string]- 4;
ptr = ch$plus(.llib_iob[iob$a_string], 4) ;
existing_crc = aschex(ptr,len);
exitloop;
end;
! Calculate CRC
old_crc = .old_crc +
crccalc(.llib_iob[iob$h_string], .llib_iob[iob$a_string]);
!Get the element name from the control line
TMP_PTR=.llib_iob[IOB$A_STRING];
ELM_PTR=CH$PTR(ELM_NAM);
ELM_SIZ=GET_LXM(TMP_PTR,%C' ',.llib_iob[IOB$H_STRING],ELM_PTR);
IF
CH$EQL(.SIZE,.ELM,.ELM_SIZ,CH$PTR(ELM_NAM))
THEN
!The element already exists, it cannot be loaded
BEGIN
$step_close(IOB=LIB_W_IOB,OPTIONS=REMEMBER);
RETURN TRUE
END
ELSE
IF
CH$LSS(.SIZE,.ELM,.ELM_SIZ,CH$PTR(ELM_NAM))
THEN
!We are at the correct position for an insertion
RETURN FALSE;
new_crc = .new_crc +
crccalc(.llib_iob[iob$h_string], .llib_iob[iob$a_string]);
!Write out the line
$step_put(IOB=LIB_W_IOB,STRING=llib_iob[IOB$T_STRING])
END;
LIB_EOF=TRUE;
!The line goes at the bitter end
FALSE
END; !End of CHKLIB
GLOBAL ROUTINE COPY =
!++
! FUNCTIONAL DESCRIPTION:
!
! This is the main routine for copy command processing.
!
! FORMAL PARAMETERS:
!
! none.
!
! IMPLICIT INPUTS:
!
!
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! K_SUCCESS = Copy sucessfully completed in it entirety.
! K_SILENT_ERROR = Copy failed.
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LOCAL
A_RES_LIS, ! address of reservation list
CMD,
COPY_TO: REF DESC_BLOCK, ! from and to element that copy
! was performed on
D_FIL_SPC: DESC_BLOCK, ! desc for file spec
F_UNUSUAL, ! set when an unusual event occurs
GETELM_STAT, ! status returned by GETELM routine
SUB_CMD,
QUAL: REF QUALIFIER_BLOCK,
PARM: REF PARAMETER_BLOCK,
PARM2: REF PARAMETER_BLOCK,
USR_REM:REF DESC_BLOCK ;
! initialize flag
F_UNUSUAL = FALSE ;
! inspect the command
IF
NOT COMAND(CMD,SUB_CMD,QUAL,PARM,USR_REM)
THEN
RETURN K_SILENT_ERROR ;
! initialize parameter pointers
IF
.PARM[PAR_A_NEXT] EQL K_NULL
THEN
BEGIN ! not enough parameters
ERS(S_PARAMLIM,CAT('Not enough parameters')) ;
RETURN K_SILENT_ERROR ;
END ! not enough parameters
ELSE
BEGIN ! initialize pointers
A_1ST_FIL = .PARM[PAR_A_NEXT] ;
A_CUR_FIL = .PARM[PAR_A_NEXT] ;
END ; ! initialize pointers
! initialize checksums
COM_FIL_CNT = 0 ;
LIB_FIL_CNT = 0 ;
! Initialize CRC stuff
new_crc = 0;
old_crc = 0;
existing_crc = 0;
found_crc = false;
! request access to library
IF
NOT SAFLIB(K_UPDATE_LIB)
THEN
RETURN K_SILENT_SEVERE ;
! check for reservations on this element
IF
CHKRES(.PARM[PAR_TEXT_PTR],.PARM[PAR_TEXT_LEN],
A_RES_LIS)
THEN
BEGIN ! element reserved
! report reservations
REPRES(.A_RES_LIS,0) ;
IF
NOT YES(LIT('PROCEED'))
THEN
BEGIN ! stop processing
DONLIB();
RETURN K_SILENT_ERROR ;
END ; ! stop processing
! set flag for unusual logging
F_UNUSUAL = TRUE ;
END ; ! element reserved
! examine filename for validity
IF
NOT VALFIL(.A_1ST_FIL,COM_FIL_CNT)
THEN
BEGIN
DONLIB() ;
RETURN K_SILENT_ERROR ;
END ;
! count the number of files for this element in library
GETELM_STAT = GETELM(.PARM[PAR_TEXT_PTR],.PARM[PAR_TEXT_LEN],ELMCNT) ;
IF
.GETELM_STAT NEQ G_OK
THEN
BEGIN ! error in GETELM call
IF
.GETELM_STAT EQL G_NO_ELM
THEN
BEGIN ! element not in library
local
d_log_nam : $str_desc(),
d_log_trn : $str_desc(),
log_trn_buf : vector[ch$allocation(log_nam_value_size)];
$str_desc_init(descriptor = d_log_nam,
string=(len_comma_ptr(lib)));
$str_desc_init(descriptor = d_log_trn,
string=(log_nam_value_size,ch$ptr(log_trn_buf)));
trnlog(d_log_nam,d_log_trn);
ERS(s_noelem,CAT(('Element '),PARM[PAR_TEXT],
(' does not exist in the CMS library '),d_log_trn));
END ; ! element not in library
END ; ! error in GETELM call
! make sure count of files on command match count in library
IF
.LIB_FIL_CNT NEQ .COM_FIL_CNT
THEN
BEGIN ! checksum mismatch
ERS(s_errcount,CAT('Number of files specified on this command is ',
'different from the number for the element in the library')) ;
DONLIB() ;
RETURN K_SILENT_ERROR ;
END ; ! checksum mismatch
! begin transaction
BEGTRN() ;
! open and copy files
GETELM_STAT = GETELM(.PARM[PAR_TEXT_PTR],.PARM[PAR_TEXT_LEN],COPYFL) ;
IF
.GETELM_STAT NEQ G_OK
THEN
BEGIN ! error return
CANTRN();
DONLIB();
RETURN K_SILENT_ERROR ;
END ; ! error return
! write element entry to definition file
PARM2 = .A_1ST_FIL ;
IF
CHKLIB(.PARM2[PAR_TEXT_PTR],.PARM2[PAR_TEXT_LEN])
THEN
BEGIN ! element already in the def file
ERS(S_inlib,CAT('Element ',(.PARM2[PAR_TEXT_LEN],.PARM2[PAR_TEXT_PTR]),
' already exists in the library')) ;
CANTRN() ;
DONLIB() ;
RETURN K_SILENT_ERROR ;
END ; ! element already in the def file
MRKLIB(.PARM2) ;
! close input definition file
$step_close(IOB=llib_iob,OPTIONS=REMEMBER,FAILURE=0) ;
$STR_DESC_INIT(DESCRIPTOR=D_FIL_SPC,
STRING=(%STRING(LIB,CDIR))) ;
! log transaction
IF
.F_UNUSUAL
THEN
BEGIN ! write unusual log
IF
NOT LOGTRN(K_UNUSUAL_LOG,0,K_NULL)
THEN
BUG(CAT('Unable to write unusual log entry; Error occurred in ',
'routine COPY of module COPY')) ;
END ! write unusual log
ELSE
BEGIN ! write normal log record
IF
NOT LOGTRN(K_NORMAL_LOG,0,K_NULL)
THEN
BUG(CAT('Unable to write log entry; Error occurred in routine ',
'COPY of module COPY')) ;
END ; ! write normal log record
! Check checksums
if not .found_crc
then
sysmsg(s_nocksum,cat('The definition file has no checksum'),0)
else
if .existing_crc neq .old_crc
then
sysmsg(s_invcksum,cat('The definition file ',
'has an invalid checksum'),0);
! normal exit and cleanup
ENDTRN();
DONLIB();
! delete the input def file
DELVRS(FILVRS,.D_FIL_SPC[DESC_LEN],.D_FIL_SPC[DESC_PTR]) ;
! send user completion message
sysmsg(s_copyok,CAT('Element ',PARM[PAR_TEXT],' copied to ',
PARM2[PAR_TEXT]),0) ;
exits(s_copyok)
END ; !end of routine COPY
ROUTINE COPYFL(L_FIL_NAM,P_FIL_NAM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine takes the filename string provided on input and
! copies it to the filename from the parameter block(s). After
! completing this task the pointer to the parameter block is
! advanced to the next.
!
! FORMAL PARAMETERS:
!
! L_FIL_NAM Length of filename string
!
! P_FIL_NAM Pointer to filename string
!
! IMPLICIT INPUTS:
!
! A_1ST_FIL Address of first parameter containing a filename
!
! A_CUR_FIL Address of current parameter containing a filename
!
! IMPLICIT OUTPUTS:
!
! A_CUR_FIL Address of current parameter containing a filename
! after updating.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! G_OK = Copy completed successfully
! G_ERROR = Copy failed to complete
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
OWN
A_LST_BLK, ! Address of last property block
A_SAV_MEM, ! Save memory address
F_NO_MORE: INITIAL(FALSE) ; ! set when no more parameters
LOCAL
B_PARM: REF PARAMETER_BLOCK,
new_lib_crc,
old_lib_crc,
R_PROP_BLK: REF BLOCK[K_COPY_PROP_SIZE] FIELD(D_COPY_PROP),
! File properties block
XPO_STAT ; ! XPORT status return
! check to see if run out of parameter blocks
IF
.F_NO_MORE
THEN
BEGIN ! checksum mismatch
ERS(s_errcount,CAT('Number of files specified on this command',
' is different from the number for the element in',
' the library')) ;
RETURN G_ERROR ;
END ; ! checksum mismatch
! concatentate filename with library name
BLD_LOG_NAM(LIB,.L_FIL_NAM,.P_FIL_NAM) ;
! open input file
XPO_STAT = $STEP_OPEN(IOB=RD_IOB,FILE_SPEC=(.L_LOG_NAM,.P_LOG_NAM),
OPTIONS=INPUT,FAILURE=0) ;
IF
.XPO_STAT NEQ STEP$_NORMAL
THEN
BEGIN ! unable to open input lib file
ERSXPO(s_inoopen,.XPO_STAT,(CAT('Cannot open input file ',
(.L_FIL_NAM,.P_FIL_NAM)))) ;
DEL_OUT_FIL(.A_1ST_FIL,.A_CUR_FIL,FALSE) ;
RETURN G_ERROR
END ; ! unable to open input lib file
! set up parameter block pointer
B_PARM = .A_CUR_FIL ;
! concatenate parameter block filename with library logical name
BLD_LOG_NAM(LIB,.B_PARM[PAR_TEXT_LEN],.B_PARM[PAR_TEXT_PTR]) ;
! open new filename in library
XPO_STAT = $STEP_OPEN(IOB=WR_IOB,FILE_SPEC=(.L_LOG_NAM,.P_LOG_NAM),
OPTIONS=OUTPUT,FAILURE=0) ;
IF
NOT (.XPO_STAT EQL STEP$_NORMAL
OR .XPO_STAT EQL STEP$_CREATED)
THEN
BEGIN ! unable to open output file
ERSXPO(s_onoopen,.XPO_STAT,(CAT('Cannot open output file ',
(.L_LOG_NAM,.P_LOG_NAM)))) ;
DEL_OUT_FIL(.A_1ST_FIL,.A_CUR_FIL,FALSE) ;
RETURN G_ERROR ;
END ; ! unable to open output file
! register file for possible crash recovery
TRNFIL(WR_IOB) ;
! Initialize
old_lib_crc = 0;
new_lib_crc = 0;
! copy input to output
UNTIL
$step_get(IOB=RD_IOB) EQL STEP$_EOF
DO
BEGIN
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.rd_iob[iob$a_string])
then
begin
local
crc_len,
crc_buf:vector[ch$allocation(max_num_size + 5)],
crc_ptr,
len,
lib_crc,
ptr;
len=.rd_iob[iob$h_string]- 4;
ptr = ch$plus(.rd_iob[iob$a_string], 4) ;
lib_crc = aschex(ptr,len);
if .lib_crc neq .old_lib_crc
then
sysmsg(s_invcksum,cat((.l_log_nam,.p_log_nam),
' has an invalid checksum'),0);
!Write out good checksum
crc_ptr = ch$move(4,ch$ptr(uplit('*/C:')),ch$ptr(crc_buf));
crc_len = hexasz(.old_lib_crc, .crc_ptr, 8 );
crc_ptr = ch$plus(.crc_ptr,.crc_len);
ch$wchar(%c' ', .crc_ptr);
crc_len = .crc_len + 5;
$step_put( iob = wr_iob, string = (.crc_len, ch$ptr(crc_buf)),
failure= 0);
exitloop;
end;
old_lib_crc = .old_lib_crc +
crccalc(.RD_IOB[IOB$H_STRING],.RD_IOB[IOB$A_STRING]);
! main copy loop
$step_put(IOB=WR_IOB,STRING=(.RD_IOB[IOB$H_STRING],
.RD_IOB[IOB$A_STRING])) ;
end; !Main copy loop
! close input and output
$step_close(IOB=RD_IOB) ;
$step_close(IOB=WR_IOB) ;
! advance parameter block pointer
IF
.B_PARM[PAR_A_NEXT] EQL K_NULL
THEN
F_NO_MORE = TRUE
ELSE
A_CUR_FIL = .B_PARM[PAR_A_NEXT] ;
!+
! Now save properties
!+
! get memory for block
$XPO_GET_MEM(FULLWORDS=K_COPY_PROP_SIZE,RESULT=R_PROP_BLK) ;
IF
.A_1ST_PROP EQL K_NULL
THEN
BEGIN ! first block
A_1ST_PROP = .R_PROP_BLK ;
! setup descriptor
$STR_DESC_INIT(DESCRIPTOR=R_PROP_BLK[PROP_STR],
STRING=(.PATLGT,.PATPTR)) ;
R_PROP_BLK[FWD_LK] = K_NULL ;
A_LST_BLK = .R_PROP_BLK ;
END ! first block
ELSE
BEGIN ! subsequent blocks
A_SAV_MEM = .R_PROP_BLK ;
R_PROP_BLK = .A_LST_BLK ;
R_PROP_BLK[FWD_LK] = .A_SAV_MEM ;
R_PROP_BLK = .A_SAV_MEM ;
! set up pattrn descriptor
$STR_DESC_INIT(DESCRIPTOR=R_PROP_BLK[PROP_STR],
STRING=(.PATLGT,.PATPTR)) ;
R_PROP_BLK[FWD_LK] = K_NULL ;
A_LST_BLK = .R_PROP_BLK ;
END ; ! subsequent blocks
G_OK
END;
ROUTINE DEL_OUT_FIL(A_1ST_BLK,A_CUR_BLK,DEL_CUR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! The purpose of this routine is to delete any output files
!
! FORMAL PARAMETERS:
!
! A_1ST_BLK Address of first parameter block containing a
! filename.
!
! A_CUR_BLK Address of current parameter block.
!
! DEL_CUR Option of deleting current file.
!
! TRUE = file specified by current block was created
! and is to be deleted.
! FALSE = file specified by current block was not
! created and only the filenames in the prior
! blocks are to be deleted.
!
! IMPLICIT INPUTS:
!
!
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE = files deleted properly.
! FALSE = failure to delete files properly.
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LOCAL
B_PARM: REF PARAMETER_BLOCK,
XPO_STAT ; ! XPORT return status
! set up starting parameter block
B_PARM = .A_1ST_BLK ;
! verify that files are closed
$step_close(IOB=WR_IOB,FAILURE=0) ;
$step_close(IOB=RD_IOB,FAILURE=0) ;
! delete all output files
UNTIL
.B_PARM EQL K_NULL
DO
BEGIN ! delete loop
IF
(.B_PARM EQL .A_CUR_BLK)
AND NOT .DEL_CUR
THEN
EXITLOOP ;
! build filename to be deleted
BLD_LOG_NAM(LIB,.B_PARM[PAR_TEXT_LEN],.B_PARM[PAR_TEXT_PTR]) ;
! delete file
XPO_STAT = $STEP_DELETE(IOB=WR_IOB,FILE_SPEC=(.L_LOG_NAM,
.P_LOG_NAM),FAILURE=0) ;
IF
.XPO_STAT NEQ STEP$_NORMAL
THEN
BUGXPO(.XPO_STAT,(CAT('Unable to delete file ',
(.L_LOG_NAM,.P_LOG_NAM),' during cleanup after ',
'aborted copy command'))) ;
IF
.B_PARM EQL .A_CUR_BLK
THEN
EXITLOOP ; ! end of files created
B_PARM = .B_PARM[PAR_A_NEXT] ;
END ; ! delete loop
TRUE
END ; ! end of routine DEL_OUT_FIL
ROUTINE ELMCNT(LEN,PTR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will count the number of filenames in the specified
! element.
!
! FORMAL PARAMETERS:
!
! LEN Length of filename string
!
! PTR Pointer to filename string
!
! IMPLICIT INPUTS:
!
! LIB_FIL_CNT Count of number of filenames in element
!
! IMPLICIT OUTPUTS:
!
! LIB_FIL_CNT Updated count of number of filenames in element
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! G_OK = counting performed
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LIB_FIL_CNT = .LIB_FIL_CNT + 1;
G_OK
END;
ROUTINE MRKLIB (ELM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Make entry in definition file table corresponding
! to specified element.
!
! FORMAL PARAMETERS:
!
! ELM - Address of element name list as set up in CRELM
!
! IMPLICIT INPUTS:
!
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
OWN
A_SAV_MEM ; ! save block address
LOCAL
crc,
control_len,
control_buf:vector[ch$allocation(max_num_size+5)],
control_ptr,
COUNT,
ELMPTR : REF PARAMETER_BLOCK,
R_PROP_BLK: REF BLOCK[K_COPY_PROP_SIZE] FIELD(D_COPY_PROP),
! file properties block
TXBUF: VECTOR[CH$ALLOCATION(40)];
ELMPTR=.ELM;
!Set up to do output to new control file
OUTINI(LIB_W_IOB);
! Tell OUTSTG to calculate CRC's
f_perf_crc = true;
ignore_control = true;
calc_crc = 0;
!Enter element into the list
OUTSTG(.ELMPTR[PAR_TEXT_PTR],.ELMPTR[PAR_TEXT_LEN],FALSE);
STG(' ',FALSE);
! pick up start of properties block chain
R_PROP_BLK = .A_1ST_PROP ;
!Now generate the element contents
REPEAT
BEGIN
!Output the file or element name
OUTSTG(.ELMPTR[PAR_TEXT_PTR],.ELMPTR[PAR_TEXT_LEN],FALSE);
! transfer properties
OUTSTG(.R_PROP_BLK[PROP_STR_PTR],.R_PROP_BLK[PROP_STR_LEN],
FALSE ) ;
! save pointer to next block
A_SAV_MEM = .R_PROP_BLK ;
R_PROP_BLK = .R_PROP_BLK[FWD_LK] ;
! free memory block
$XPO_FREE_MEM(BINARY_DATA=(K_COPY_PROP_SIZE,.A_SAV_MEM,FULLWORDS)) ;
!Advance to next entry
ELMPTR=.ELMPTR[PAR_A_NEXT];
IF
.ELMPTR EQL K_NULL
THEN
BEGIN
OUTSTG(0,0,TRUE);
new_crc = .new_crc + .calc_crc ;
EXITLOOP
END;
STG(',',FALSE)
END;
!Now output the remainder of the file
IF
NOT .LIB_EOF
THEN
BEGIN
!(Don't forget the left over line)
$step_put(IOB=LIB_W_IOB,STRING=llib_iob[IOB$T_STRING]);
new_crc = .new_crc + crccalc(.llib_iob[iob$h_string], .llib_iob[iob$a_string]);
UNTIL
$step_get(IOB=llib_iob) EQL STEP$_EOF
DO
begin
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.llib_iob[iob$a_string])
then
begin
local
len,
ptr;
len=.llib_iob[iob$h_string]- 4;
ptr = ch$plus(.llib_iob[iob$a_string], 4) ;
existing_crc = aschex(ptr,len);
found_crc = true;
exitloop;
end;
crc = crccalc(.llib_iob[iob$h_string], .llib_iob[iob$a_string]) ;
new_crc = .new_crc + .crc;
old_crc = .old_crc + .crc;
$step_put(IOB=LIB_W_IOB,STRING=llib_iob[IOB$T_STRING]);
end;
END;
!Write out good check sum
control_ptr = ch$move(4,ch$ptr(uplit('*/C:')),ch$ptr(control_buf));
control_len = hexasz(.new_crc, .control_ptr, 8 );
control_ptr = ch$plus(.control_ptr,.control_len);
ch$wchar(%c' ', .control_ptr);
control_len = .control_len + 5;
$step_put( iob = lib_w_iob, string = (.control_len, ch$ptr(control_buf)),
failure= 0);
$step_close(IOB=LIB_W_IOB)
END; !End of MRKLIB
GLOBAL ROUTINE VALFIL(A_PARM,A_COUNT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! The purpose of this routine is to take the filenames from the
! user command parameter(s) and verify that they satisfy the following
! constraints:
!
! 1. All filenames specified in the parameter(s) are
! different from each other.
!
! 2. The filename must not be one of the reserved
! filenames: 00fac_name-99fac_name.
!
! 3. The filenames do not already exist in the library.
!
! FORMAL PARAMETERS:
!
! A_PARM Address of the first parameter block
!
! A_COUNT Address of location to store count
!
! IMPLICIT INPUTS:
!
!
!
! IMPLICIT OUTPUTS:
!
!
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE All filenames were valid.
! FALSE There was an error in the filenames and the error
! is already printed.
!
! SIDE EFFECTS:
!
!
!
!--
BEGIN
LOCAL
B_PARM: REF PARAMETER_BLOCK,
B_PARM2: REF PARAMETER_BLOCK,
L_FIL_NAM, ! length of filename
NUM_CNT, ! number of numeric chars
P_FIL_NAM, ! pointer to filename
STATUS, ! status returned from indef
name_STR: DESC_BLOCK; ! 'fac_name' string
! set up first parameter block
B_PARM = .A_PARM ;
B_PARM2 = .A_PARM ;
! scanning loop for duplicate filenames
UNTIL
.B_PARM EQL K_NULL
DO
BEGIN ! outer loop of compare
B_PARM2 = .A_PARM;
IF
.B_PARM NEQ .B_PARM2
THEN
BEGIN ! different blocks
UNTIL
.B_PARM2 EQL K_NULL
DO
BEGIN ! inter loop of compare
IF
.B_PARM2 NEQ .B_PARM
THEN
BEGIN ! do not compare same block
IF
.B_PARM2[PAR_A_TREE] NEQ K_NULL
THEN
BEGIN ! tree not allowed
ERS(s_treeinv,CAT(B_PARM2[PAR_TEXT],
(' is not an element reference'))) ;
RETURN FALSE ;
END ; ! tree not allowed
IF
CH$EQL(.B_PARM[PAR_TEXT_LEN],.B_PARM[PAR_TEXT_PTR],
.B_PARM2[PAR_TEXT_LEN],.B_PARM2[PAR_TEXT_PTR],
%C' ')
THEN
BEGIN ! duplicate filenames
ERS(S_DUPLNAME,CAT(B_PARM2[PAR_TEXT],
' is a duplicate file name.')) ;
RETURN FALSE ;
END ;
END ; ! do not compare same block
B_PARM2 = .B_PARM2[PAR_A_NEXT] ;
END ; ! inter loop on compare
END ; ! different blocks
B_PARM = .B_PARM[PAR_A_NEXT] ;
END ; ! outer loop on compare
! initialize string to 'fac_name'
$STR_DESC_INIT(DESCRIPTOR=name_STR,
STRING=(fac_name)) ;
! start at beginning again
B_PARM = .A_PARM ;
! scan filenames for belonging to set 00fac_name-99fac_name
UNTIL
.B_PARM EQL K_NULL
DO
BEGIN ! reserved filenames
LOCAL
CHAR, ! character read
LP_CNT ; ! loop counter
NUM_CNT = 0 ;
LP_CNT = 2;
L_FIL_NAM = .B_PARM[PAR_TEXT_LEN] ;
P_FIL_NAM = .B_PARM[PAR_TEXT_PTR] ;
UNTIL
.LP_CNT EQL 0
DO
BEGIN !numeric check
CHAR = CH$RCHAR_A(P_FIL_NAM) ;
L_FIL_NAM = .L_FIL_NAM - 1 ;
IF
(.CHAR GEQ %C'0') AND
(.CHAR LEQ %C'9')
THEN
NUM_CNT = .NUM_CNT + 1 ;
LP_CNT = .LP_CNT - 1 ;
END ; ! numeric check
IF
.NUM_CNT EQL 2
THEN
BEGIN ! check for 'fac_name' string
IF
CH$EQL(LEN_COMMA_PTR(name_STR),
.name_STR[DESC_LEN],.P_FIL_NAM,%C' ')
THEN
BEGIN ! invalid-reserved name
ERS(S_RESRNAME,CAT(B_PARM[PAR_TEXT],' is a reserved file name.')) ;
RETURN FALSE ;
END ; ! invalid-reserved name
END ; ! check for 'fac_name' string
B_PARM = .B_PARM[PAR_A_NEXT] ;
END ; ! reserved filenames
! check to see if file exists in the library
B_PARM = .A_PARM ;
UNTIL
.B_PARM EQL K_NULL
DO
BEGIN ! check for file existance
!check to see if file already exist in library
IF
NOT indef(.b_parm[par_text_len],.b_parm[par_text_ptr])
THEN
BEGIN ! already exists
ERS(S_flinlib,CAT(B_PARM[PAR_TEXT],
' already exists in the library')) ;
RETURN FALSE ;
END ; ! already exists
B_PARM = .B_PARM[PAR_A_NEXT] ;
! increment checksum
COM_FIL_CNT = .COM_FIL_CNT + 1 ;
END ; ! check for file existance
TRUE
END ; ! end of route VERFIL
ROUTINE indef(L_FIL_STR,P_FIL_STR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will scan the def file for the existance of this file.
!
! FORMAL PARAMETERS:
!
! L_FIL_STR Length of filenames string.
!
! P_FIL_STR Pointer to filenames string.
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! TRUE = deletion performed properly
! No return after error message for bad lib if unable to delete file.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
elm_nam : vector[ch$allocation(42)],
elm_ptr,
tmp_ptr,
F_ODD_QUO, ! set when odd number quote encountered
L_FIL_NAM, ! length of individual filename string
L_TMP, ! length remaining in string
P_FIL_NAM, ! pointer to individual file name string
P_STR_FIL, ! pointer to start of file name
P_TMP , ! temporary work pointer
status; ! status returned by open
!Open reservation control files
if
(status=$STEP_OPEN(IOB=LLIB_IOB,FILE_SPEC=(%STRING(LIB,CDIR)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
badxpo(.status,lit('Cannot open definition file'));
UNTIL
$step_get(IOB=LLIB_IOB) EQL STEP$_EOF
DO
BEGIN
!Get rid of the element name from the control line
TMP_PTR=.llib_iob[IOB$A_STRING];
ELM_PTR=CH$PTR(ELM_NAM);
GET_LXM(TMP_PTR,%C' ',.llib_iob[IOB$H_STRING],ELM_PTR);
! initialize flag
f_odd_quo = false ;
! initialize pointers
L_TMP = .llib_iob[iob$h_string]- ch$diff(.tmp_ptr,.llib_iob[iob$a_string]);
P_TMP = .tmp_ptr;
P_STR_FIL = .tmp_ptr;
UNTIL
.L_TMP EQL 0
DO
BEGIN ! scan filenames string
LOCAL
CHAR ;
CHAR = CH$RCHAR_A(P_TMP) ;
L_TMP = .L_TMP - 1 ;
IF
.CHAR EQL %C'"'
THEN
BEGIN ! set flag
IF
.F_ODD_QUO
THEN
F_ODD_QUO = FALSE
ELSE
F_ODD_QUO = TRUE ;
END ; ! set flag
IF
NOT .F_ODD_QUO
THEN
BEGIN ! not in quoted string
IF
.CHAR EQL %C'/'
THEN
BEGIN ! end of filename
L_FIL_NAM = CH$DIFF(CH$PLUS(.P_TMP,-1),.P_STR_FIL) ;
P_FIL_NAM = .P_STR_FIL ;
IF
$str_eql(string1 = (.l_fil_nam,.p_fil_nam),
string2 = (.l_fil_str,.p_fil_str))
THEN
BEGIN
$step_close(IOB=llib_iob,OPTIONS=REMEMBER,FAILURE=0) ;
RETURN false;
END;
UNTIL
.L_TMP EQL 0
DO
BEGIN ! search for comma
CHAR = CH$RCHAR_A(P_TMP) ;
L_TMP = .L_TMP - 1 ;
IF
.CHAR EQL %C','
THEN
EXITLOOP ;
END ; !search for comma
P_STR_FIL = .P_TMP ;
! prevent further comma processing
CHAR = 0 ;
END ; ! end of filename
IF
.CHAR EQL %C','
THEN
BEGIN ! filename with no properties
L_FIL_NAM = CH$DIFF(CH$PLUS(.P_TMP,-1),.P_STR_FIL) ;
P_FIL_NAM = .P_STR_FIL ;
IF
$str_eql(string1 = (.l_fil_nam,.p_fil_nam),
string2 = (.l_fil_str,.p_fil_str))
THEN
BEGIN
$step_close(IOB=llib_iob,OPTIONS=REMEMBER,FAILURE=0) ;
RETURN false;
END;
P_STR_FIL = .P_TMP ;
END ; ! filename with no properties
END ; ! not in quoted string
END ; ! scan filenames string
IF
(.P_STR_FIL NEQA .P_TMP) AND NOT .F_ODD_QUO
THEN
BEGIN ! only one filename
L_FIL_NAM = CH$DIFF(.P_TMP,.P_STR_FIL) ;
P_FIL_NAM = .P_STR_FIL ;
IF
$str_eql(string1 = (.l_fil_nam,.p_fil_nam),
string2 = (.l_fil_str,.p_fil_str))
THEN
BEGIN
$step_close(IOB=llib_iob,OPTIONS=REMEMBER,FAILURE=0) ;
RETURN false;
END;
END ; ! only one filename
END;
$step_close(IOB=llib_iob,OPTIONS=REMEMBER,FAILURE=0) ;
TRUE
END;
END ! End of module
ELUDOM