Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/verify.bli
There are no other files named verify.bli in the archive.
MODULE VERIFY (
IDENT = '1',
%IF
%BLISS(BLISS32)
%THEN
LANGUAGE(BLISS32),
ADDRESSING_MODE(EXTERNAL=LONG_RELATIVE,
NONEXTERNAL=LONG_RELATIVE)
%ELSE
LANGUAGE(BLISS36)
%FI
) =
BEGIN
!
! COPYRIGHT (C) 1982 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:
!
! VERIFY the correctness of a specified library.
!
! ENVIRONMENT: DS-20, VAX/VMS
!
! AUTHOR: D. Knight , CREATION DATE: 10-Jan-80
!
!--
!
! TABLE OF CONTENTS
!
FORWARD ROUTINE
VERIFY,
CHKGEN,
CKCLASS,
CKELEM,
CKFILE,
CKRESRV,
CMPGEN,
GET_LIN,
G_NUM_LGT,
GEN_SETUP : NOVALUE,
VERLIB;
!
! INCLUDE FILES:
!
%if
%bliss(bliss32)
%then
library 'sys$library:starlet' ;
%else
require 'jsys:';
%fi
LIBRARY 'XPORT:';
REQUIRE 'SCONFG:';
REQUIRE 'BLISSX:';
require 'logusr:';
REQUIRE 'COMUSR:';
REQUIRE 'HOSUSR:';
REQUIRE 'SHRUSR:';
require 'filusr:';
!
! MACROS:
!
MACRO
STG(L,M) = OUTSTG(CH$PTR(UPLIT(L)),%CHARCOUNT(L),M) %;
!
! EQUATED SYMBOLS:
!
LITERAL
GEN_S_SIZE = 50, !GET_CUR_MST stack size
INDEX_SIZE = 3; !Size of entry in stack
!
! OWN STORAGE:
!
global
repair : initial(false); !/repair qualifier has been issued
OWN
GEN, !generation
GEN_L, !generation length
GEN_INDEX, !stack pointer
GEN_PTR,
GEN_STATUS: VECTOR[GEN_S_SIZE*INDEX_SIZE],!stack
GEN_STRING: VECTOR[CH$ALLOCATION(GEN_S_SIZE*30)],
LGEN, !generation
LGEN_L, !generation length
LINECT,
LIN_NUM_BUF : VECTOR[CH$ALLOCATION(40)],
LINE_NUM : DESC_BLOCK;
OWN
ELM_NAM: VECTOR[CH$ALLOCATION(EL_NAM_SIZE)],
ELM_N_LN,
ELM_N_PT,
F_NAM : DESC_BLOCK,
S_L_PTR;
!
! EXTERNAL REFERENCES:
!
external literal
s_allfilok,
s_clslstok,
s_cnoopen,
s_dunverif, !cannot verify defn file
s_elmlstok,
s_errentry,
s_ilcntrrec,
s_ilelem,
s_ilgen,
s_ilheader,
s_illibform,
s_ilresr,
s_incmrep,
s_invfile, !File is missing or invalid
s_invcksum, !invalid checksum in res file
s_librepair,
s_libverif,
s_libok,
s_mismatch,
s_multseqfl,
s_mutexcl,
s_nameinv, ! invalid class name
s_noScom,
s_nocksum, !Res file has no checksum
s_nolib, !no CMS library has been set
s_nomatchcc, !cannot open file
s_noopen,
s_notrecog,
s_okanyway,
s_recstart,
s_reslstok,
s_runverif, !cannot verify reserv file
s_setlib, !set the library
s_unverif, !cannot verify class file
s_useverrec,
s_verinval,
s_verstart;
external literal
k_expand_file_size,
k_size_stack ;
external
have_repaired;
EXTERNAL ROUTINE
aschex,
ASCDEC,
begtrn,
BUG,
cantrn,
COMAND,
crccalc,
crctable : novalue,
DECASC,
delvrs,
DONLIB, !Turn off library interlock
endtrn,
err,
ERS,
errsts,
ERSSTS,
errxpo,
ERSXPO,
exits, !exit silently
fixcrc, !Try to fix user's file
FULDIR,
GET_LXM,
ISFILE, ! Does specified file exist?
logtrn, !generate history file entry
OLDTRN, !TRUE means transaction was incomplete.
RECOVR, !Nullify an incomplete transaction.
SAFLIB, !Interlock the library
sysmsg,
TRNLOG,
VCNTRL; ! verify control files(VCNTRL)
GLOBAL ROUTINE VERIFY =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine perform the functions of the VERIFY Command.
!
! It optionally nullifies an incomplete transaction, and
! perform some consistency checks on the library.
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! k_success = verification successful
! k_silent_error = unable to verify library
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
CMD,
ERR_FLG,
NO_RECOVR,
PAR,
QUAL,
R_QUAL : REF QUALIFIER_BLOCK, ! For scanning the qualifiers.
RET_VAL,
RECOVERING, ! /RECOVER qualifier has been given.
SUB_CMD,
USR_REM;
ERR_FLG = NO_RECOVR = FALSE;
!Parse the command line
IF
NOT COMAND(CMD,SUB_CMD,QUAL,PAR,USR_REM)
THEN
RETURN K_SILENT_ERROR;
! Look for the /RECOVER or /REPAIR qualifier.
repair=false;
RECOVERING = FALSE ; ! Initialize.
R_QUAL = .QUAL ; ! Initialize.
WHILE .R_QUAL NEQ K_NULL DO
BEGIN ! Examine one qualifier.
selectone .r_qual[qua_code] of
set
[k_recover_qual]: recovering = true ;
[k_norecover_qual]: recovering = false;
[k_repair_qual]: repair=true;
[k_norepair_qual]: repair = false;
tes;
! Get the next qualifier block.
R_QUAL = .R_QUAL[QUA_A_NEXT] ;
END ; ! Examine one qualifier.
!/REPAIR and /RECOVER are mutually exclusive
if
.repair and .recovering
then
begin
err(s_mutexcl,lit('/REPAIR and /RECOVER are mutually exclusive'));
return k_silent_error
end;
!+
! Lock the library
!-
IF
.recovering or .repair
THEN
BEGIN
IF
NOT SAFLIB(K_RECOVER_LIB)
THEN
RETURN K_SILENT_SEVERE;
END
ELSE
BEGIN
IF
NOT SAFLIB(K_verify_LIB)
THEN
RETURN K_SILENT_SEVERE;
END;
if .repair and oldtrn()
then
begin
err(s_useverrec,lit(%string('The last transaction did not finish; ',
%string(' Use ',fac_name,' VERIFY/RECOVER before issuing ',fac_name,' VERIFY/REPAIR')))) ;
return k_silent_error
end;
!Check initial consistency
RET_VAL=VERLIB(.RECOVERING);
IF
.RET_VAL NEQ K_SUCCESS
THEN
RETURN .RET_VAL;
! Begin the verify process. Lock the library for a recover, a repair, or
! a simple verify. If it is a recover, do the recover.
! Attempt to recover if the user asked for it.
IF
.RECOVERING
THEN
BEGIN ! The user asked to recover.
! Nullify any incomplete transaction.
IF
OLDTRN()
THEN
BEGIN ! Recover the library.
IF
isfile(len_comma_ptr(%string(lib, repr)), k_null)
THEN
!+
! we will recover the library later
!-
sysmsg(s_incmrep,
lit('Previous VERIFY/REPAIR was not completed'),0)
ELSE
BEGIN
IF
NOT RECOVR()
THEN
ERR_FLG = NO_RECOVR = TRUE ; ! RECOVR issues the message.
END ! Recover the library.
END
ELSE
begin
recovering=false;
sysmsg(s_okanyway,
LIT('The last transaction finished, so recovery is unnecessary'),0)
end
END ! The user asked to recover.
ELSE
! Thus the user wished a repair or just a verify.
! Proceed accordingly.
BEGIN ! (The user did not ask to recover.)
! Tell the user if there is an incomplete transaction.
IF
OLDTRN()
THEN
ERR(S_USEVERREC,LIT(%STRING('The last transaction was not finished;',
%string(' Use ',fac_name,' VERIFY/RECOVER')))) ;
END ; ! The user did not ask to recover.
!Check library and put out starting message
IF
.RECOVERING
THEN
BEGIN
RET_VAL=VERLIB(FALSE);
IF
.RET_VAL NEQ K_SUCCESS
THEN
RETURN .RET_VAL
END;
! set up polynomial table for checksum checking
crctable ();
! /Repair will update files, so start a transaction
if .repair
then
begtrn();
! verify control files and header info of element files
IF
NOT VCNTRL()
THEN
BEGIN
ERR(S_VERINVAL,LIT('One or more files not verified correctly'));
ERR_FLG=TRUE
END
ELSE
sysmsg(s_allfilok,LIT('All library files successfully verified'),0);
!Work through the list of elements and verify their accuracy
IF
NOT CKELEM()
THEN
BEGIN
ERR(s_dunverif,LIT('Definition file not verified'));
ERR_FLG=TRUE
END
ELSE
sysmsg(s_elmlstok,LIT('Definition file contents successfully verified'),0);
!Check reservations
IF
NOT CKRESRV()
THEN
BEGIN
ERR(s_runverif,LIT('Reservation list not verified'));
ERR_FLG=TRUE
END
ELSE
sysmsg(s_reslstok,LIT('Reservation list contents successfully verified'),0);
!Check attribute list
IF
NOT CKCLASS()
THEN
BEGIN
ERR(s_unverif,LIT('Class list not verified'));
ERR_FLG=TRUE
END
ELSE
sysmsg(s_clslstok,LIT('Class list contents successfully verified'),0);
!Generate an entry in the history file if /REPAIR or /RECOVER were
! performed. Do NOT make an entry if the recovery failed, this could
! cause additional problems.
if
.repair or
(.recovering and
not .no_recovr)
then
!log it as unusual as well
begin
!fake a transaction to make the logger happy if not already done
!NOTE: if we are recovering from a verify/repair then the actual
!recover is to log the transaction and rename the old bad to fin
!and delete the rep file.
if not .repair
then
begtrn();
if
not logtrn(k_unusual_log,0,0)
then
begin
bug(lit('Could not write history record (VERIFY)'));
cantrn()
end
else
endtrn()
end;
!Unlock the library
DONLIB();
IF
.ERR_FLG
THEN
BEGIN
if
.repair
then
ERS(S_LIBREPAIR,LIT('Error in repair of library'))
else
ERS(S_LIBVERIF,LIT('Error in verification of library'));
K_SILENT_ERROR
END
ELSE
BEGIN
if
.repair
then
sysmsg(s_libok,LIT('Successful repair of library'),0)
else
sysmsg(s_libok,LIT('Successful verification of library'),0);
exits(s_libok)
END
END; !End of VERIFY
ROUTINE CHKGEN (S_L_PTR,S_L_LGT,KEEP,GENERATION,G_LGT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Keep track of any lines in the master file which have been
! inserted or deleted by the respective generations.
! Note that this routine keeps its own stack of information about
! the input data, so don't try to process lines not in sequence, or
! don't try to back up using it.
!
! FORMAL PARAMETERS:
!
! S_L_PTR - Address of character pointer to line
! S_L_LGT - Length of line
! KEEP - Address of keep/discard flag
! GENERATION - master generation pointer
! G_LGT - length of master generation pointer
!
! IMPLICIT INPUTS:
!
! Information is kept about the previous lineage commands which have
! been encountered, this is used to keep overall track of the insertion
! or deletion status.
!
! IMPLICIT OUTPUTS:
!
! The stack is updated to reflect the current insertion or deletion status.
! GEN - current generation of line scanned
! KEEP - keep/discard line flag
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - no errors encountered
! FALSE - errors seen and announced
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
CTL_CHAR,
TMP_GEN,
TMP_G_LGT;
!Get the generation this record applies to
TMP_GEN=.GEN_PTR;
TMP_G_LGT=GET_LXM(.S_L_PTR,%C' ',.S_L_LGT,TMP_GEN)-1;
!Back up over control character
.S_L_PTR=CH$PLUS(..S_L_PTR,-1);
!There must be a value here
IF
.TMP_G_LGT LEQ 0
THEN
BEGIN
ERR(s_ilcntrrec,CAT(('Illegal control record in file '),F_NAM,LINE_NUM));
RETURN FALSE
END;
!Pick up control character
CTL_CHAR=CH$RCHAR_A(.S_L_PTR);
!Check for end of correction entry which matches current generation
IF
.CTL_CHAR EQL %C'E' AND
CH$EQL(.TMP_G_LGT,.GEN_PTR,.GEN_L,.GEN)
THEN
!End of change, pop previous level and continue
BEGIN
IF
.GEN_INDEX EQL -1
THEN
!Something is badly wrong
BEGIN
ERR(S_MISMATCH,CAT(('Mismatched control records in file '),F_NAM,LINE_NUM));
RETURN FALSE
END;
!Pop generation and keep flag from stack
.KEEP=.GEN_STATUS[.GEN_INDEX];
GEN=.GEN_STATUS[.GEN_INDEX-1];
GEN_L=.GEN_STATUS[.GEN_INDEX-2];
LGEN=.GEN;
LGEN_L=.GEN_L;
GEN_PTR=CH$PLUS(.GEN,.GEN_L);
GEN_INDEX=.GEN_INDEX-INDEX_SIZE;
RETURN TRUE
END
ELSE
!Deletion and insertion records are only examined
!if the KEEP switch is TRUE. This makes sure that
!the nesting control is correct.
IF
..KEEP
THEN
BEGIN
IF
.CTL_CHAR EQL %C'D' OR
.CTL_CHAR EQL %C'I'
THEN
!Deletion and insertion control records
BEGIN
LOCAL
ONPATH;
!Push old control record on stack
GEN_INDEX=.GEN_INDEX+INDEX_SIZE;
GEN_STATUS[.GEN_INDEX]=..KEEP;
GEN_STATUS[.GEN_INDEX-1]=.GEN;
GEN_STATUS[.GEN_INDEX-2]=.GEN_L;
!Assume reverse sense for generation counting
LGEN=.GEN;
LGEN_L=.GEN_L;
!Set up new control record
GEN=.GEN_PTR;
GEN_PTR=CH$PLUS(.GEN_PTR,.TMP_G_LGT);
GEN_L=.TMP_G_LGT;
!Keep only those lines that will show up in the final text
ONPATH=CMPGEN(.GEN,.GEN_L,.GENERATION,.G_LGT);
!Catastrophe??
IF
.ONPATH EQL -1
THEN
RETURN FALSE;
IF
.ONPATH AND .CTL_CHAR EQL %C'D' OR
NOT .ONPATH AND .CTL_CHAR EQL %C'I'
THEN
BEGIN
.KEEP=FALSE;
!Normal generation sense
IF
.CTL_CHAR NEQ %C'I'
THEN
BEGIN
LGEN=.GEN;
LGEN_L=.GEN_L
END
END
ELSE
BEGIN
.KEEP=TRUE;
!See if generation is reversed in sense
!(user asked for earlier generation than the latest)
IF
.CTL_CHAR NEQ %C'D'
THEN
!Normal sense, use current generation
BEGIN
LGEN=.GEN;
LGEN_L=.GEN_L
END
ELSE
LGEN_L=0
END;
RETURN TRUE
END
ELSE
!Error
BEGIN
IF
.CTL_CHAR EQL %C'E'
THEN
ERR(S_MISMATCH,CAT(('Mismatched control records in file '),
F_NAM,LINE_NUM))
ELSE
ERR(s_notrecog,CAT(('Unrecognized control character in file'),
F_NAM,LINE_NUM));
RETURN FALSE
END
END;
TRUE
END; !End of CHKGEN
ROUTINE CKCLASS =
!++
! FUNCTIONAL DESCRIPTION:
!
! Do minimal checking of class file to see if contents
! are plausible
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - Class file is OK
! FALSE - error in class file
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
existing_crc,
found_crc,
old_crc,
FIL_OK,
$io_block_decl(RD),
STS;
$IO_block_INIT(RD);
!Find the file, set no such attribute if not found
STS=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=(%STRING(LIB,ATF)),
OPTIONS=INPUT,FAILURE=0);
IF
NOT .STS
THEN
BEGIN
ERRSTS(s_cnoopen,.STS,LIT('Cannot open class file'));
RETURN FALSE
END;
old_crc = 0;
found_crc = false;
FIL_OK=TRUE;
!Find the correct attribute
UNTIL
$step_get(IOB=RD_IOB) EQL step$_EOF
DO
BEGIN
LOCAL
ATRPNT,
CHAR,
CLS_NM_LGT;
! Check for file count control line
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.rd_iob[iob$a_string])
then
begin
local
len,
ptr;
len = .rd_iob[iob$h_string] - 4;
ptr = ch$plus(.rd_iob[iob$a_string],4);
existing_crc = aschex(ptr,len);
found_crc = true;
exitloop;
end;
!Calculate the CRC of this line
old_crc = .old_crc +
crccalc(.rd_iob[iob$h_string], .rd_iob[iob$a_string]);
ATRPNT=.RD_IOB[IOB$A_STRING];
CHAR=CH$RCHAR(.ATRPNT);
IF
.CHAR NEQ %C' '
THEN
!Class name entry
BEGIN
CLS_NM_LGT=0;
!Get length of class name only
UNTIL
CH$RCHAR(CH$PLUS(.RD_IOB[IOB$A_STRING],.CLS_NM_LGT)) EQL %C' ' OR
.CLS_NM_LGT EQL .RD_IOB[IOB$H_STRING]
DO
CLS_NM_LGT=.CLS_NM_LGT+1;
!It must start with an alphabetic
IF
.CHAR LSS %C'A' OR
.CHAR GTR %C'z'
THEN
BEGIN
ERR(s_nameinv,CAT('Error in ',(.CLS_NM_LGT,.ATRPNT),
('; class names must begin with an alphabetic character')));
FIL_OK=FALSE
END
END
ELSE
!Element in class
BEGIN
LOCAL
C_CNT;
!Skip blank character
CH$RCHAR_A(ATRPNT);
C_CNT=1;
!Skip over element name
UNTIL
CH$RCHAR_A(ATRPNT) EQL %C' '
DO
BEGIN
C_CNT=.C_CNT+1;
IF
.C_CNT GEQ .RD_IOB[IOB$H_STRING]
THEN
BEGIN
ERR(s_ilelem,LIT('Illegal element entry format in class file'));
FIL_OK=FALSE;
EXITLOOP
END
END;
CHAR=CH$RCHAR(.ATRPNT);
IF
.CHAR LSS %C'0' OR
.CHAR GTR %C'9'
THEN
BEGIN
FIL_OK=FALSE;
ERR(s_ilgen,LIT('Illegal generation number in class file'))
END
END
END;
!Close the working file
$step_close(IOB=RD_IOB);
!Check CRC counts
if not .found_crc
then
if not .repair
then
begin
erR(s_nocksum,lit('Class list has no checksum'));
fil_ok = false;
end
else
begin
local
file_name : desc_block;
$str_desc_init (descriptor = file_name,
string = lit(%string(lib,atf)));
if not
fixcrc ( file_name ,.old_crc,
lit('***Repaired checksum for Class List') )
then
fil_ok = false;
end
else
if .existing_crc neq .old_crc
then
if not .repair
then
begin
err(s_invcksum,lit('Class list has an invalid checksum'));
fil_ok = false;
end
else
begin
local
file_name : desc_block;
$str_desc_init (descriptor = file_name,
string = lit(%string(lib,atf))) ;
if not
fixcrc ( file_name, .old_crc,
lit('***Repaired checksum for Class List') )
then
fil_ok = false ;
end ;
.FIL_OK
END; !End of CKCLASS
ROUTINE CKELEM =
!++
! FUNCTIONAL DESCRIPTION:
!
! Using the element control list, call the CKFILE
! processor with the names of the files contained in the element.
! CKFILE will be called once for each file in each element.
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! The element control list file.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE = element verified.
! FALSE = element cannot be verified.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
existing_crc,
found_crc,
old_crc,
LEX_LGT,
LINE_LGT,
LINE_PTR,
$io_block_decl(RD),
RT_VAL,
status,
TXT_BUF: VECTOR[CH$ALLOCATION(50)],
TXT_PTR;
RT_VAL=TRUE;
old_crc = 0;
found_crc = false;
!Initialize IOBs
$io_block_INIT(RD);
!Open reservation control file
if
(status=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=(%STRING(LIB,CDIR)),
OPTIONS=INPUT,failure=0)) neq step$_normal
then
begin
errxpo(s_noopen,.status,lit('Cannot open definition file'));
return false
end;
!Use each name in turn
UNTIL
$step_get(IOB=RD_IOB) EQL step$_EOF
DO
BEGIN
! Check for file count control line
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.rd_iob[iob$a_string])
then
begin
local
len,
ptr;
len = .rd_iob[iob$h_string] - 4;
ptr = ch$plus(.rd_iob[iob$a_string],4);
existing_crc = aschex(ptr,len);
found_crc = true;
exitloop;
end;
!Calculate the CRC of this line
old_crc = .old_crc +
crccalc(.rd_iob[iob$h_string], .rd_iob[iob$a_string]);
!Point to the working line
LINE_PTR=.RD_IOB[IOB$A_STRING];
LINE_LGT=.RD_IOB[IOB$H_STRING];
ELM_N_PT=CH$PTR(ELM_NAM);
!Pick up element name
ELM_N_LN=GET_LXM(LINE_PTR,%C' ',.LINE_LGT,ELM_N_PT);
LINE_LGT=.LINE_LGT-.ELM_N_LN-1;
ELM_N_PT=CH$PTR(ELM_NAM);
!Now process files in list
WHILE
.LINE_LGT GTR 0
DO
BEGIN
LOCAL
CHAR,
ERR_FLG,
f_quo,
FIL : VECTOR[CH$ALLOCATION(EXTENDED_FILE_SPEC)],
FIL_PTR,
FIL_LEN,
PATLGT,
PATPTR,
PATTRN : VECTOR[CH$ALLOCATION(50)];
TXT_PTR=CH$PTR(TXT_BUF);
f_quo = false;
!Assemble the file name lexeme
LEX_LGT=0;
WHILE
.LINE_LGT NEQ 0
DO
BEGIN
!Pick up a character for comparison
CHAR=CH$RCHAR_A(LINE_PTR);
LINE_LGT=.LINE_LGT-1;
!Look for end of scan
IF
.CHAR EQL %C'/' OR
.CHAR EQL %C','
THEN
EXITLOOP;
!Save the character seen
CH$WCHAR_A(.CHAR,TXT_PTR);
LEX_LGT=.LEX_LGT+1
END;
!See if a pattern exists also
IF
.CHAR EQL %C'/'
THEN
BEGIN
PATPTR=CH$PTR(PATTRN);
PATLGT=0;
! transfer slash
CH$WCHAR_A(.CHAR,PATPTR) ;
PATLGT = PATLGT + 1 ;
UNTIL
.LINE_LGT EQL 0
DO
BEGIN
!Get a character
CHAR=CH$RCHAR_A(LINE_PTR);
LINE_LGT=.LINE_LGT-1;
IF
.CHAR EQL %C'"'
THEN
IF
.F_QUO
THEN
F_QUO = FALSE
ELSE
F_QUO = TRUE;
!Does it end the pattern?
IF
.CHAR EQL %C',' AND NOT .F_QUO
THEN
EXITLOOP;
!No, place it in the pattern string
CH$WCHAR_A(.CHAR,PATPTR);
PATLGT=.PATLGT+1
END;
PATPTR=CH$PTR(PATTRN)
END
ELSE
PATLGT=0;
!Parse pattern for correctness
!nyi
!File must exist
FIL_PTR=CH$PTR(FIL);
FIL_PTR=CH$MOVE(%CHARCOUNT(LIB),CH$PTR(UPLIT(LIB)),.FIL_PTR);
FIL_PTR=CH$MOVE(.LEX_LGT,CH$PTR(TXT_BUF),.FIL_PTR);
FIL_LEN=CH$DIFF(.FIL_PTR,CH$PTR(FIL));
!note: To check existance of file, ISFILE is called. If
!isfile returns as true, then err_flg is true, and file exists.
!If isfile returns as false, then err_flg can be true or false.
!With err_flg false an errmsg was issued and the file entry in
!the DEF file was invalid. With err_flg true, no errmsg was
!issued because the file was not found or is invalid.
IF
NOT ISFILE(.FIL_LEN,CH$PTR(FIL),ERR_FLG)
THEN
BEGIN
IF
.ERR_FLG
THEN
ERR(s_invfile,CAT(('File '),(.LEX_LGT,CH$PTR(TXT_BUF)),
(' of element '),(.ELM_N_LN,.ELM_N_PT),
(' is missing or invalid')))
ELSE
ERR(s_errentry,CAT(('Invalid entry in def file for file '),
(.LEX_LGT,CH$PTR(TXT_BUF)),(' of element '),(.ELM_N_LN,.ELM_N_PT)));
RT_VAL=FALSE
END
END
!File must exist
END;
$STEP_CLOSE(IOB=RD_IOB);
!Check CRC counts
if not .found_crc
then
if not .repair
then
begin
err(s_nocksum,lit('Definition file has no checksum'));
rt_val = false;
end
else
begin
local
file_name : desc_block;
$str_desc_init (descriptor = file_name,
STRING = lit(%string(lib,cdir))) ;
if not
fixcrc ( file_name , .old_crc,
lit('***Repaired checksum for Master Control File') )
then
rt_val = false;
end
else
if .existing_crc neq .old_crc
then
if not .repair
then
begin
err(s_invcksum,lit('Definition file has an invalid checksum'));
rt_val = false;
end
else
begin
local
file_name : desc_block;
$str_desc_init (descriptor = file_name,
string = lit(%string(lib,cdir))) ;
if not
fixcrc ( file_name ,.old_crc,
lit('***Repaired checksum for Master Control File') )
then
rt_val = false;
end ;
.RT_VAL
END; !End of CKELEM
GLOBAL ROUTINE CKFILE (FIL_NAM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Verify a library file using the master file and a list of corrections.
!
! FORMAL PARAMETERS:
!
! FIL_NAM - descriptor of file name
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - success
! FALSE - failure
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
existing_crc,
found_crc,
GENERATION,
$io_block_decl(INPUT),
KEEP,
NUMBER,
old_crc,
S_SIZ,
SEQ_FLG,
STS,
TG_BUF: VECTOR[CH$ALLOCATION(gen_size+2)],
TG_LGT;
$io_block_INIT(INPUT);
$STR_DESC_INIT(DESCRIPTOR=F_NAM,STRING=.FIL_NAM);
!Open input file
STS=$STEP_OPEN(IOB=INPUT_IOB,FILE_SPEC=F_NAM,
OPTIONS=INPUT,FAILURE=0);
IF
NOT .STS
THEN
BEGIN
ERRXPO(s_noopen,.STS,CAT(('Cannot open '),F_NAM));
RETURN FALSE
END;
LINECT=0;
NUMBER=0;
SEQ_FLG=0;
existing_crc = 0;
found_crc = false;
old_crc = 0;
!Get a header record
S_SIZ=GET_LIN(INPUT_IOB);
! Check for file count control line
if
.s_siz geq 4
then
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.input_iob[iob$a_string])
then
begin
local
len,
ptr;
len = .input_iob[iob$h_string] -4;
ptr= ch$plus(.input_iob[iob$a_string],4) ;
existing_crc = aschex(ptr,len);
found_crc = true;
s_siz = eof;
end;
IF
.S_SIZ EQL EOF
THEN
BEGIN
ERR(s_ilheader,CAT(('Illegal header record in file '),F_NAM,
(' (empty file)')));
$step_close(IOB=INPUT_IOB);
RETURN FALSE
END;
!Look for a required header record
IF
CH$RCHAR_A(S_L_PTR) NEQ %C'+'
THEN
!No generations in file yet, this isn't allowed
BEGIN
ERR(s_illibform,CAT(('Illegal library file format in file '),F_NAM,LINE_NUM));
$step_close(IOB=INPUT_IOB);
RETURN FALSE
END
ELSE
!Pick up generation data
BEGIN
old_crc = .old_crc +
crccalc(.input_iob[iob$h_string], .input_iob[iob$a_string]);
GENERATION=CH$PTR(TG_BUF);
TG_LGT=GET_LXM(S_L_PTR,%C' ',.S_SIZ-1,GENERATION);
!Blank terminate the generation
CH$WCHAR_A(%C' ',GENERATION);
IF
.TG_LGT LEQ 0
THEN
BEGIN
ERR(s_ilheader,CAT(('Illegal header record in file '),F_NAM,LINE_NUM));
$step_close(IOB=INPUT_IOB);
RETURN FALSE
END
END;
!Initialize generation stack
GEN_SETUP(KEEP);
!Now process the complete file
REPEAT
BEGIN
LOCAL
TAG;
!Read a line
S_SIZ=GET_LIN(INPUT_IOB);
! Check for file count control line
IF
.s_siz NEQ eof AND
ch$eql(4,ch$ptr(uplit('*/C:')),4,.input_iob[iob$a_string])
then
begin
local
len,
ptr;
len = .input_iob[iob$h_string] -4;
ptr= ch$plus(.input_iob[iob$a_string],4) ;
existing_crc = aschex(ptr,len);
found_crc = true;
s_siz = eof;
end;
!Quit at end of file
IF
.S_SIZ EQL EOF
THEN
BEGIN
$step_close(IOB=INPUT_IOB);
IF
.GEN_INDEX NEQ -1
THEN
BEGIN
ERR(s_nomatchcc,CAT(('Unmatched control command pair in file '),
F_NAM,LINE_NUM));
RETURN FALSE
END;
IF
.SEQ_FLG GTR 1
THEN
BEGIN
ERR(s_multseqfl,CAT(('Multiple sequence flags in file '),
F_NAM));
RETURN FALSE
END;
if not .found_crc ! Couldn't find a CRC
then
if not .repair
then
begin
err(s_nocksum,CAT(('File '),f_nam,(' has no checksum')));
return false
end
else
begin
if not
fixcrc ( f_nam, .old_crc, k_null)
then
return false;
end
else
if .existing_crc neq .old_crc ! Found an invalid CRC
then
begin
if not .repair
then
begin
err(s_invcksum,CAT(f_nam,' has an invalid checksum'));
return false
end
else
begin
if not
fixcrc ( f_nam, .old_crc, k_null)
then
return false;
end;
end;
RETURN TRUE
END;
! Figure out old crc
old_crc = .old_crc +
crccalc(.input_iob[iob$h_string], .input_iob[iob$a_string]);
!Get tag character
TAG=CH$RCHAR_A(S_L_PTR);
!See if it is a control command
IF
.TAG EQL %C'*'
THEN
!Command
BEGIN
IF
CH$EQL(2,CH$PTR(UPLIT('/S')),.S_SIZ-1,.S_L_PTR)
THEN
SEQ_FLG=.SEQ_FLG+1
ELSE
IF
NOT CHKGEN(S_L_PTR,.S_SIZ-1,KEEP,CH$PTR(TG_BUF),.TG_LGT)
THEN
BEGIN
$step_close(IOB=INPUT_IOB);
RETURN FALSE
END
END
ELSE
!Anything left over in column 1 other than "+" or blank is an error
IF
.TAG NEQ %C'+' AND
.TAG NEQ %C' '
THEN
!Error
BEGIN
ERR(s_ilcntrrec,CAT(('Illegal control record in file '),F_NAM,LINE_NUM));
$step_close(IOB=INPUT_IOB);
RETURN FALSE
END
END;
!Just in case
BUG(LIT('Can''t get here (CKFILE)'))
END; !End of CKFILE
ROUTINE CKRESRV =
!++
! FUNCTIONAL DESCRIPTION:
!
! Do minimal verification of reservation file
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - Reservation file OK
! FALSE - error in reservation file
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
ENT_CNT,
existing_crc,
old_crc,
found_crc,
FIL_OK,
LAST_LINE,
$io_block_decl(RD),
STS;
$io_block_INIT(RD);
FIL_OK=TRUE;
old_crc = 0;
found_crc = false;
!Open reservation control file
STS=$STEP_OPEN(IOB=RD_IOB,FILE_SPEC=(%STRING(LIB,RES)),
OPTIONS=INPUT,FAILURE=0);
IF
NOT .STS
THEN
BEGIN
ERRSTS(s_noopen,.STS,LIT('Cannot open reservation file'));
RETURN FALSE
END;
!Walk the whole file
UNTIL
$step_get(IOB=RD_IOB) EQL step$_EOF
DO
BEGIN
LOCAL
CTL_CHAR,
ELM_NAM : VECTOR[CH$ALLOCATION(EL_NAM_SIZE)],
ELM_PTR,
ELM_SIZ,
TMP_PTR;
! Check for file count control line
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.rd_iob[iob$a_string])
then
begin
local
len,
ptr;
len = .rd_iob[iob$h_string] - 4;
ptr = ch$plus(.rd_iob[iob$a_string],4);
existing_crc = aschex(ptr,len);
found_crc = true;
exitloop;
end;
!Calculate the CRC of this line
old_crc = .old_crc +
crccalc(.rd_iob[iob$h_string], .rd_iob[iob$a_string]);
TMP_PTR=.RD_IOB[IOB$A_STRING];
!Pick up the control character
CTL_CHAR=CH$RCHAR(.TMP_PTR);
!Make sure it is at least plausible
IF
.CTL_CHAR NEQ %C' ' AND
.CTL_CHAR NEQ %C'*'
THEN
FIL_OK=FALSE
END;
!Issue message if needed
IF
NOT .FIL_OK
THEN
ERR(s_ilresr,LIT('Illegal reservation file format'));
!Close file
$step_close(IOB=RD_IOB);
!Check CRC counts
if not .found_crc
then
if not .repair
then
begin
err(s_nocksum,lit('Reservation list has no checksum'));
fil_ok = false;
end
else
begin
local
file_name : desc_block;
$str_desc_init (descriptor = file_name,
STRING = lit(%string(lib,res)));
if not
fixcrc ( file_name, .old_crc,
lit('***Repaired checksum for Reservation List') )
then
fil_ok = false ;
end
else
if .existing_crc neq .old_crc
then
if not .repair
then
begin
err(s_invcksum,cat('Reservation file ',
'has an invalid checksum'));
fil_ok = false;
end
else
begin
local
file_name : desc_block;
$str_desc_init (descriptor = file_name,
STRING = lit(%string(lib,res)));
if not
fixcrc ( file_name , .old_crc,
lit('***Repaired checksum for Reservation List') )
then
fil_ok = false ;
end ;
.FIL_OK
END; !End of CKRESRV
ROUTINE CMPGEN (G1,G1_L,G2,G2_L) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Compare two generalized expressions. G1 is the generation from
! the file or text, G2 is the generation requested by the caller.
! Success is returned if G1 is on a direct path to G2.
!
! FORMAL PARAMETERS:
!
! G1 - pointer to generation in text
! G1_L - length of generation in text
! G2 - pointer to generation requested
! G2_L - length of generation requested
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - Generation is on correct line of descent
! FALSE - Generation is not on correct line of descent
! -1 - BAD ERROR
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
G1_CHR,
G1_LGT,
G1_PTR,
G1_TMP,
G1_VAL,
G2_CHR,
G2_LGT,
G2_PTR,
G2_TMP,
G2_VAL;
!Setup
G1_PTR=.G1;
G1_LGT=.G1_L;
G2_PTR=.G2;
G2_LGT=.G2_L;
!Process entire generation expression
REPEAT
BEGIN
!Get length of integer parts
G1_TMP=G_NUM_LGT(.G1_PTR,.G1_LGT);
G2_TMP=G_NUM_LGT(.G2_PTR,.G2_LGT);
!The lengths of both must be non-zero
IF
.G1_TMP EQL 0 OR
.G2_TMP EQL 0
THEN
BEGIN
ERR(s_ilgen,CAT(('Illegal generation in file '),F_NAM,LINE_NUM));
RETURN -1
END;
!Values
G1_VAL=ASCDEC(G1_PTR,.G1_TMP);
G1_LGT=.G1_LGT-.G1_TMP;
G2_VAL=ASCDEC(G2_PTR,.G2_TMP);
G2_LGT=.G2_LGT-.G2_TMP;
IF
.G1_VAL EQL .G2_VAL
THEN
!Integer parts match
BEGIN
!Pick up which branch for G1
IF
.G1_LGT NEQ 0
THEN
BEGIN
G1_CHR=CH$RCHAR_A(G1_PTR);
G1_LGT=.G1_LGT-1
END
ELSE
G1_CHR=0;
!Pick up which branch for G2
IF
.G2_LGT NEQ 0
THEN
BEGIN
G2_CHR=CH$RCHAR_A(G2_PTR);
G2_LGT=.G2_LGT-1
END
ELSE
G2_CHR=0;
!Quit successfully if we are at the end of the G1 branch
IF
.G1_CHR EQL 0 AND
.G2_CHR NEQ 0
THEN
RETURN TRUE;
!No match if the branches are not the same
IF
.G1_CHR NEQ .G2_CHR
THEN
RETURN FALSE;
!Error if nothing follows branch marker
IF
.G1_LGT EQL 0 AND
.G2_LGT EQL 0 AND
.G1_CHR NEQ 0 AND
.G2_CHR NEQ 0
THEN
!Error, illegal expression
BEGIN
ERR(s_ilgen,CAT(('Illegal generation in file '),
F_NAM,LINE_NUM));
RETURN -1
END
END
ELSE
BEGIN
IF
.G1_VAL GTR .G2_VAL
THEN
!No match
RETURN FALSE;
!Is this the end of G1?
IF
.G1_LGT EQL 0
THEN
RETURN TRUE;
!Can't possibly match
RETURN FALSE
END;
IF
.G1_LGT EQL 0 AND
.G2_LGT EQL 0
THEN
RETURN TRUE
END
END; !End of CMPGEN
ROUTINE GET_LIN (INPUT_IOB) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Get a source line for CKFILE
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! The input file is already open.
!
! IMPLICIT OUTPUTS:
!
! S_L_PTR - Character pointer to start of line
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! length of line, -1 if EOF.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
MAP
INPUT_IOB : REF $XPO_IOB();
LOCAL
COMP,
WRK_LEN,
WRK_PTR;
!Get a line of input and the completion value
COMP=$step_get(IOB=.INPUT_IOB,FAILURE=0);
LINECT=.LINECT+1;
WRK_PTR=CH$PTR(LIN_NUM_BUF);
WRK_PTR=CH$MOVE(6,CH$PTR(UPLIT(' Line ')),.WRK_PTR);
WRK_LEN=6+DECASC(.LINECT,.WRK_PTR);
$STR_DESC_INIT(DESCRIPTOR=LINE_NUM,STRING=(.WRK_LEN,CH$PTR(LIN_NUM_BUF)));
!Point to the line
S_L_PTR=.INPUT_IOB[IOB$A_STRING];
IF
.COMP
THEN
.INPUT_IOB[IOB$H_STRING]
ELSE
-1
END; !End of GET_LIN
ROUTINE G_NUM_LGT (PTR,LGT) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Get the length of a decimal string
!
! FORMAL PARAMETERS:
!
! PTR - pointer to string
! LGT - length of string
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! Size of integer string
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
C_PTR,
CNT;
CNT=0;
C_PTR=.PTR;
INCR I FROM 1 TO .LGT DO
BEGIN
LOCAL
CHAR;
CHAR=CH$RCHAR_A(C_PTR);
IF
.CHAR GEQ %C'0' AND
.CHAR LEQ %C'9'
THEN
CNT=.CNT+1
ELSE
EXITLOOP
END;
.CNT
END; !End of G_NUM_LGT
ROUTINE GEN_SETUP (KEEP) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
!
! FORMAL PARAMETERS:
!
! ??
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
GEN_INDEX=-1;
GEN_PTR=CH$PTR(GEN_STRING);
GEN=.GEN_PTR;
GEN_L=0;
.KEEP=TRUE
END; !End of GEN_SETUP
GLOBAL ROUTINE VERLIB (RECOV_FLG) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine checks the validity of the library.
! The library is compared against
! the logical translation of fac_name$LIB both through the system service
! $TRNLOG and the service $PARSE. If the library was not initialized
! using the SET LIBRARY command the user is notified.
!
! FORMAL PARAMETERS:
!
! RECOV_FLG - true if starting recovery
! - false if starting verification
!
! IMPLICIT INPUTS:
!
! none
!
! IMPLICIT OUTPUTS:
!
! none
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! K_SUCCESS if library is valid,
! K_SILENT_SEVERE if not.
!
! SIDE EFFECTS:
!
! none
!
!--
BEGIN
LOCAL
librar_buf : vector[ch$allocation(256)] , ! buffer containing results of
! logical name translation
librar_desc : desc_block , ! pointer to logical name buffer
log_name_desc : desc_block, ! pointer to source logical name
dir_desc : ref desc_block, ! pointer to buffer of results of FULDIR call
return_status, ! status of FULDIR call
status ; ! status of TRNLOG call
! Use lib macro to generate fac_name$LIB
$STR_DESC_INIT(DESCRIPTOR = log_name_desc,
STRING = lit(lib)) ;
! Initialize descriptor for results of logical name translation
$STR_DESC_INIT(DESCRIPTOR = librar_desc,
STRING = (256, CH$PTR(librar_buf))) ;
! Get translation of logical name
status = TRNLOG ( log_name_desc, librar_desc ) ;
! Check return status
IF
NOT .status ! Problem with logical translation
THEN
BEGIN
err(s_nolib,lit(%string(fac_name,' library not found'))) ;
ers(s_setlib,lit(%string('Use the ',fac_name,
' SET LIBRARY command')));
RETURN k_silent_severe ;
END; ! Problem with logical translation
! Get full directory specification
dir_desc = fuldir(len_comma_ptr(log_name_desc), return_status, k_null) ;
IF
.dir_desc eql k_null
THEN ! Problem with library
BEGIN
err(s_nolib,lit(%string(fac_name,' library not found'))) ;
ers(s_setlib,lit(%string('Use the ',fac_name,
' SET LIBRARY command')));
RETURN k_silent_severe ;
END; ! Problem with library
! Test to see if results of fuldir matches that of $TRNLOG
IF
NOT CH$EQL( len_comma_ptr(.dir_desc), len_comma_ptr( librar_desc) )
THEN
BEGIN ! User did not use library command
ers(s_noScom,lit(%string('Use the ',fac_name,' SET LIBRARY command'))) ;
RETURN k_silent_severe ;
END; ! User did not use library command
IF
.RECOV_FLG
THEN
sysmsg(s_recstart,cat('Starting recovery of ', librar_desc),0)
ELSE
if
not .repair
then
sysmsg(s_verstart,cat('Starting verification of ', librar_desc),0)
else
sysmsg(s_verstart,cat('Starting repair of ', librar_desc),0);
RETURN k_success ;
END; ! End of VERLIB
END !End of Module VERIFY
ELUDOM