Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/reserv.bli
There are no other files named reserv.bli in the archive.
MODULE RESERV (
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:
!
! Get a file from the specified library and place it in the user's
! area along with any corrections or changes that are current.
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: D. Knight , CREATION DATE: 20-Apr-79
!
!--
!++
! General Description
!
! RESERV is the module which controls the processing of the RESERVE,
! FETCH, and ANNOTATE commands. The function of RESERVE and FETCH
! are identical except that FETCH makes no reservation marks in
! the library. ANNOTATE works similarly, except that its output
! is a formatted text file showing the history of an element.
!
! The execution of this code is essentially the same for any of the
! above commands. Under normal circumstances,! RESERVE is entered
! which sets up the world and calls RES_MRG repetitively for each file
! in the element. RES_MRG, using PRC_HDR, gets the necessary information
! about the exact generations being processed. It then calls RESFIL once
! or twice, depending whether a merge is being done or not. (If a merge
! is being done, RESFIL is called for each of the two generations being
! merged). At this point, if no merge is being performed, RES_MRG returns
! to the calling routine RESERVE. If a merge was requested, CMPMRG is
! called to merge the result of the two temporary generation files
! produced by RESFIL. After RES_MRG has been called for each file in the
! element, RESERVE cleans up, logs the result and goes away.
!
! File Structures
!
! The source files as stored in the library have the following
! characteristics.
!
! 1. A series of information records start the file. These records
! start with the character "+" and contain the generation number,
! user name, date, time, and a comment field. The last record
! in this group ALWAYS has a generation number of 1.
!
! 2. Any records containing original user supplied data have
! a blank in the first column.
!
! 3. The CMS control records have an "*" in column 1. There
! are three kinds of control records, insertion (I), deletion (D),
! and end (E). Each control record consists of the "*" followed
! by a generation number, followed by an I, D, or E. Every I or
! D record always has a matching E record which is used to
! delimit a range of lines that is controlled by the record.
! Nesting of these ranges is allowed. The final result of
! any such nesting is a direct result of which generation of
! an element the user asks for.
!
! Note that the purpose of these control records is to allow storing
! only a single copy of any source file in the library. The insertion
! and deletion records are used to store the information about successive
! changes to the file without duplicating the invariant information.
!
! For reliability and debugging purposes, CMS always makes sure that
! the generation number attached to any end record always matches the
! generation on the corresponding insertion or deletion record, even
! though the repetition of this information is technically redundant.
!
! Eventually there may be more complex expressions allowed in place
! of the generation numbers in the files.
!
!--
!
! TABLE OF CONTENTS
!
FORWARD ROUTINE
RESERVE, !Main entry for RESERVE, FETCH, and ANNOTATE
PRC_HDR, !Get the correct generation information from
! the element header.
RES_MRG, !Coordinate the calling of RESFIL and CMPMRG
SETUP : NOVALUE; !File setup used by PRC_HDR
!
! INCLUDE FILES:
!
%if
%bliss(bliss32)
%then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
LIBRARY 'XPORT:';
REQUIRE 'SCONFG:';
REQUIRE 'BLISSX:';
REQUIRE 'COMUSR:';
REQUIRE 'LOGUSR:';
REQUIRE 'HOSUSR:';
REQUIRE 'RESV:';
REQUIRE 'SHRUSR:';
!
! MACROS:
!
MACRO
STG(L,M) = OUTSTG(CH$PTR(UPLIT(L)),%CHARCOUNT(L),M) %;
!
! EQUATED SYMBOLS:
!
GLOBAL BIND
NO_MRG = 0, !No merge is being performed
MRG_MAIN = NO_MRG+1, !The merge main branch is being performed
MRG_BRNCH = MRG_MAIN+1; !The merge branch is being performed
!
! OWN STORAGE:
!
OWN
CONFLICT, !flag to tell if a conflict existed
! when merge occurred
G_BUF: VECTOR[CH$ALLOCATION(GEN_SIZE)], !This buffer and the following
!two pointers is used to store
!the main line generation which
!is to be processed.
G_LEN, !Length of main line generation
G_PTR, !Text pointer to main line generation
$io_block(INP), !Input file IOB used by PRC_HDR
MRG_BUF: VECTOR[CH$ALLOCATION(GEN_SIZE)], !This buffer and the
!following two pointers are
!used to remember the merge
!generation.
MRG_LEN, !Length of generation to be merged
MRG_PTR; !Pointer to generation to be merged
GLOBAL
CHRONO, !Chronology switch
! if set, the element chronology will
! be appended to the source file
! delivered to the user.
CMD, !Command name which called this routine
FETSTS, ! Return status used typically for
! warning or alternate success
MERGE, !Set to NO_MRG, MRG_MAIN, or
!MRG_BRNCH as described above
NAME_PTR, !Element name pointer
NAME_SIZ, ! and its size which includes the
! original generation reference
NOTES, !Source audit switch
PLUS_GET, !(TRUE)Plus sign seen for normal generation reference
PLUS_MRG; !(TRUE)Plus sign seen in merge generation
!
! EXTERNAL REFERENCES:
!
external literal
s_annotated, !annotated
s_biggen, !generation string too long
s_doanoopen, !can't open default o file 4 append
s_elresr, !element reserved
s_errfile, !file has the wrong attributes
s_enotincls, !element doesn't exist in class
s_fetched, !fetched
s_noclassf, !class does not exist
s_noelem, !elem does not exist in library
s_nogen, !generation does not exist
s_noopen, !not able to be opened
s_oanoopen, !can't open output file 4 append
s_onoopen, !can't open output file
s_reserved, !reserved
s_wfetched, !fetched with merge conflicts
s_wreserved; !reserved with merge conflicts
external literal
max_lines; !number of lines per page - 3
EXTERNAL
CHRLEN, !Length of chronology string
L_CNTR, !Line counter used by HDR
MAX_G_LGT,
OUTPUT_IOB : $XPO_IOB(),
res_head; !pointer to reservation text area
EXTERNAL ROUTINE
BADLIB, !something is wrong with the library
BADXPO, !something is wrong with the library
!(includes XPORT status code in error)
BEGTRN, !Mark start of transaction
BUG, !Bug in the code was seen
CANTRN, !Cancel transaction
CHKRES, !Check file reservation
CMPGEN, !Compare two file generation expressions
CMPMRG, !Merge the result of two fetches
COMAND, !Process the command string
DELRES, !delete old reservation file
dirdes, !is generation direct descendant?
DONLIB, !Unlock the library
ENDTRN, !Mark end of transaction
ERS, !User error call
ERSIOB, !XPORT IOB problem
ERSXPO, !User error with XPORT status
exits, !exit silently
FIND_NEXT_WORDS, !Break string into substrings
filtyp, !determines file attributes
G_COMN_NODE, !Find common ancestor node
GETACT, !Get user's name
GETATR, !Get attribute entry
GETELM, !Process element lists
GET_LXM, !Get a substring piece
HDR, !Output an ANNOTATE header line
LOCALF, !Report if file spec. uses network.
LOGTRN, ! write record to log
MRKRES, !Mark file as being reserved
OUTINI, !Initialize output buffer control
OUT_CHR, !Append history to user's file
OUTSTG, !Output a string of text
REPRES, !Report reservations
RESFIL, !Pick up the file contents from the library
SAFLIB, !Lock the library
syslp, !Output a message to the terminal
SETATR, !Set up for attribute calls
trnlog, ! translate a logical name
YES; !Ask for response to a query
GLOBAL ROUTINE RESERVE =
!++
! FUNCTIONAL DESCRIPTION:
!
! top level routine for RESERVE, FETCH, ANNOTATE and merge.
! This routine processes the user's command, checks the library
! for a legal transaction, and then executes the desired
! command.
!
! FORMAL PARAMETERS:
!
! NONE.
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! Normal message values.
!
! SIDE EFFECTS:
!
! The requested file(s) are delivered to the user's area.
!
!--
BEGIN
LOCAL
F_UNUSUAL, ! set when unusual occurance
P_QUAL : REF QUALIFIER_BLOCK, !parameter qualifiers
LIST_PTR: REF BLOCK FIELD(RES_FLD),
MSG_BUF : VECTOR[CH$ALLOCATION(100)],
MSG_PTR,
msg_val,
PAR: REF PARAMETER_BLOCK,
QUAL : REF QUALIFIER_BLOCK,
RESULT,
STS,
SUB_CMD,
TERM,
TREE : REF NODE_BLOCK,
USR_REM : REF DESC_BLOCK;
! set initial value of flags
F_UNUSUAL = FALSE ;
FETSTS = 0 ;
!Parse the command line
IF
NOT COMAND(CMD,SUB_CMD,QUAL,PAR,USR_REM)
THEN
RETURN K_SILENT_ERROR;
!Initialize output buffers, etc.
OUTINI(OUTPUT_IOB);
!Lock the library
IF
NOT(IF
.CMD EQL K_ANNOTATE_COM
THEN
SAFLIB(K_READ_LIB)
ELSE
SAFLIB(K_UPDATE_LIB))
THEN
RETURN K_SILENT_SEVERE;
!initialize qualifiers
NOTES=TRUE;
CHRONO=TRUE;
MERGE=NO_MRG;
PLUS_GET=FALSE;
PLUS_MRG=FALSE;
MRG_LEN=0;
MRG_PTR=0;
G_PTR=0;
G_LEN=0;
!Pointer to qualifier list
P_QUAL=.PAR[PAR_A_QUAL];
WHILE
.P_QUAL NEQ K_NULL
DO
BEGIN
SELECTONE .P_QUAL[QUA_CODE] OF
SET
[K_GEN_QUAL,K_MERGE_QUAL]:
BEGIN
LOCAL
MRG_FLG,
T_LEN,
T_PTR;
IF
.P_QUAL[QUA_CODE] EQL K_GEN_QUAL
THEN
BEGIN
MRG_FLG=FALSE;
T_PTR=CH$PTR(G_BUF)
END
ELSE
BEGIN
MERGE=MRG_MAIN;
!/NONOTES must be automatically set for first release
NOTES=FALSE;
MRG_FLG=TRUE;
T_PTR=CH$PTR(MRG_BUF)
END;
IF
.P_QUAL[QUA_A_TREE] EQL K_NULL
THEN
!No plus operator exists
BEGIN
if
.p_qual[qua_value_len] gtr gen_size
then
begin
donlib();
ers(s_biggen,lit('Generation string is too long'));
return k_silent_error
end;
T_LEN=.P_QUAL[QUA_VALUE_LEN];
CH$MOVE(.T_LEN,.P_QUAL[QUA_VALUE_PTR],.T_PTR)
END
ELSE
!Plus operator was seen
BEGIN
IF
.MRG_FLG
THEN
PLUS_MRG=TRUE
ELSE
PLUS_GET=TRUE;
TREE=.P_QUAL[QUA_A_TREE];
T_LEN=.TREE[NOD_DESC_1_LEN];
if
.t_len gtr gen_size
then
begin
donlib();
ers(s_biggen,lit('Generation string is too long'));
return k_silent_error
end;
CH$MOVE(.T_LEN,.TREE[NOD_DESC_1_PTR],.T_PTR)
END;
!Check for user specified generation or attribute
IF
CH$RCHAR(.T_PTR) GEQ %C'A'
THEN
!This must be an attribute, try to find its value
BEGIN
!Make sure attribute exists
IF
NOT SETATR(.T_LEN,.T_PTR)
THEN
BEGIN
DONLIB();
ERS(s_noclassf,CAT(('Class '),(.T_LEN,.T_PTR),
(' does not exist')));
RETURN K_SILENT_ERROR
END;
IF
NOT GETATR(.PAR[PAR_TEXT_LEN],.PAR[PAR_TEXT_PTR],T_LEN,.T_PTR)
THEN
BEGIN
IF
GETELM(.PAR[PAR_TEXT_PTR],.PAR[PAR_TEXT_LEN],0)
EQL G_NO_ELM
THEN
BEGIN
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 '),PAR[PAR_TEXT],
(' does not exist in the CMS library '),d_log_trn));
END
ELSE
ERS(s_enotincls,CAT(('Element '),
PAR[PAR_TEXT],
(' does not exist in class '),
(.T_LEN,.T_PTR)));
DONLIB();
RETURN K_SILENT_ERROR
END
END;
IF
.MRG_FLG
THEN
BEGIN
MRG_LEN=.T_LEN;
MRG_PTR=.T_PTR
END
ELSE
BEGIN
G_LEN=.T_LEN;
G_PTR=.T_PTR
END
END;
[K_NONOTES_QUAL]:
NOTES=FALSE;
[K_NOHISTORY_QUAL]:
CHRONO=FALSE;
[K_NOMERGE_QUAL]:
MERGE=NO_MRG;
TES;
P_QUAL=.P_QUAL[QUA_A_NEXT]
END;
!If annotate, open master output file
IF .CMD EQL K_ANNOTATE_COM
THEN
BEGIN
LOCAL AFLAG, !"Append seen" flag
OUT_LEN,
OUT_PTR,
OPTR, !Pointer
OPTR2, !Pointer
OLEN; !Length of output file spec.
!Initialize "append seen" flag
AFLAG = FALSE;
!Initialize Output "descriptor"
OUT_LEN = 0;
OUT_PTR = K_NULL;
WHILE .QUAL NEQ K_NULL
DO
BEGIN
SELECTONE .QUAL[QUA_CODE] OF
SET
[K_APPEND_QUAL]: AFLAG = TRUE;
[K_OUTPUT_QUAL]: BEGIN
OUT_LEN = .QUAL[QUA_VALUE_LEN];
OUT_PTR = .QUAL[QUA_VALUE_PTR];
END;
[K_NOAPPEND_QUAL]: AFLAG = FALSE;
[K_NOOUTPUT_QUAL]: BEGIN
OUT_LEN = 0;
OUT_PTR = K_NULL;
END;
TES;
QUAL = .QUAL[QUA_A_NEXT]
END;
!Point to element name (which can't be a logical name)
OPTR = .PAR[PAR_TEXT_PTR];
OLEN = .PAR[PAR_TEXT_LEN];
!Strip off "file type"
IF CH$FAIL(OPTR2 = CH$FIND_CH(.OLEN, .OPTR, %C'.'))
THEN
BUG(CAT('RESERV found no period in "', PAR[PAR_TEXT], '"')) ;
!Now let OPTR2 point to buffer
OLEN = CH$DIFF(.OPTR2,.OPTR);
!get the file name and add the extension explicitly
$XPO_GET_MEM(CHARACTERS=.OLEN+%charcount(anndef),RESULT=OPTR2);
CH$COPY(.OLEN,.OPTR,
len_comma_ptr(anndef),
0,
.OLEN+%charcount(anndef),.OPTR2);
olen=.olen+%charcount(anndef);
IF (.OUT_LEN EQL 0) AND (.OUT_PTR EQL K_NULL)
THEN !No output qualifier given.
BEGIN
! Prevent network access
IF NOT LOCALF(.OLEN,.OPTR2)
THEN
BEGIN
DONLIB() ;
RETURN K_SILENT_ERROR ;
END ;
IF .AFLAG
THEN
BEGIN !Try opening for append
IF
NOT (STS = $STEP_OPEN(IOB=OUTPUT_IOB,
FILE_SPEC=(.OLEN,.OPTR2),
options=append,FAILURE=0))
THEN
ERSIOB(s_doanoopen,OUTPUT_IOB,CAT('Cannot open ',
'default output file ',(.olen,.optr2),
' for append '));
!+
! Make sure the file has the correct attributes
!-
IF
filtyp(output_iob) NEQ 1
THEN
BEGIN
ers(s_errfile,cat('File ',output_iob[iob$t_resultant],
' is not a sequential, variable length, non-sequenced file'));
END;
END
ELSE
BEGIN !Try opening for output
IF
NOT (STS = $STEP_OPEN(IOB=OUTPUT_IOB,
FILE_SPEC=(.OLEN,.OPTR2),
OPTIONS=OUTPUT,FAILURE=0))
THEN
ERSIOB(s_noopen,OUTPUT_IOB,
cat('Cannot open default output file ',
(.olen,.optr2)))
END
!Don't attempt to open output file
END
ELSE !Output qualifier given
BEGIN
! Prevent network operations.
IF NOT LOCALF(.OUT_LEN,.OUT_PTR)
THEN
BEGIN
DONLIB() ;
RETURN K_SILENT_ERROR ;
END ;
IF .AFLAG
THEN
BEGIN !Try opening for append
STS=$STEP_OPEN(IOB=OUTPUT_IOB,FILE_SPEC=(.OUT_LEN,.OUT_PTR),
DEFAULT=(.OLEN,.OPTR2),OPTIONS=APPEND,FAILURE=0);
IF NOT .STS
THEN
ERSIOB(s_oanoopen,OUTPUT_IOB,CAT('Cannot open ',
'output file ',(.out_len,.out_ptr),' for append'));
!+
! Make sure the file has the correct attributes
!-
IF
filtyp(output_iob) NEQ 1
THEN
BEGIN
ers(s_errfile,cat('File ',output_iob[iob$t_resultant],
' is not a sequential, variable length, non-sequenced file'));
END;
END
ELSE
BEGIN !Try opening for output
STS=$STEP_OPEN(IOB=OUTPUT_IOB,FILE_SPEC=(.OUT_LEN,.OUT_PTR),
DEFAULT=(.OLEN,.OPTR2),OPTIONS=OUTPUT,FAILURE=0);
IF NOT .STS
THEN
ERSIOB(s_onoopen,OUTPUT_IOB,
cat('Cannot open output file ',(.out_len,.out_ptr)))
END;
END;
END;
!Remember whether output is the terminal or not
TERM = .OUTPUT_IOB[IOB$V_TERMINAL];
!Check for reservation or FETCH only
IF
.CMD EQL K_RESERVE_COM AND
CHKRES(.PAR[PAR_TEXT_PTR],.PAR[PAR_TEXT_LEN],LIST_PTR)
THEN
!Element already reserved by someone
BEGIN
LOCAL
LIST_SAV,
U_NAME : VECTOR[CH$ALLOCATION(40)], !Save user's name here
U_NAM_LGT; !Length of user's name
LIST_SAV=.LIST_PTR;
!Pick up name of user who is running this routine
U_NAM_LGT=GETACT(U_NAME);
!See if user is among the reservers
REPEAT
BEGIN
LOCAL
RES_NAM : VECTOR[CH$ALLOCATION(40)],
RES_N_LGT,
RES_PTR,
STG_LGT,
STG_PTR;
IF
.LIST_PTR[CUR_RES] AND
NOT .LIST_PTR[REP_MKR]
THEN
BEGIN
!Length of this reservation line
STG_LGT=.LIST_PTR[STG_SIZ];
!String pointer to the line
STG_PTR=ch$plus(.res_head,.LIST_PTR[STG_ADR]);
!Advance over known element name
STG_PTR=CH$PLUS(.STG_PTR,.PAR[PAR_TEXT_LEN]+2);
STG_LGT=.STG_LGT-.PAR[PAR_TEXT_LEN]-2;
!Skip over generation reserved.
RES_PTR=CH$PTR(RES_NAM);
RES_N_LGT=GET_LXM(STG_PTR,%C' ',.STG_LGT,RES_PTR);
STG_LGT=.STG_LGT-.RES_N_LGT-1;
!Pick up reserver's name
RES_PTR=CH$PTR(RES_NAM);
RES_N_LGT=GET_LXM(STG_PTR,%C' ',.STG_LGT,RES_PTR);
!Compare the two names
IF
CH$EQL(.U_NAM_LGT,CH$PTR(U_NAME),.RES_N_LGT,CH$PTR(RES_NAM))
THEN
!The names match, this reservation is not legal
BEGIN
DONLIB();
ERS(s_elresr,CAT(('Element '),PAR[PAR_TEXT],
(' is already reserved by you')));
RETURN K_SILENT_ERROR
END
END;
!Advance to the next element in the list
LIST_PTR=.LIST_PTR[LINK_ADR];
!Have we reached the end of the list?
IF
.LIST_PTR EQL 0
THEN
EXITLOOP
END;
!Report the reservations
REPRES(.LIST_SAV,0);
!Ask user if he wishes to reserve it anyway
IF
NOT YES(LIT('Proceed'))
THEN
BEGIN
DONLIB();
RETURN K_SILENT_ERROR;
END;
! set flag for unusual
F_UNUSUAL = TRUE ;
END;
!Mark start of transaction
IF
.CMD NEQ K_ANNOTATE_COM
THEN
BEGTRN();
!If this is an ANNOTATE command, then inhibit appendage of history
IF
.CMD EQL K_ANNOTATE_COM
THEN
CHRONO = FALSE ;
!Process element list, calling RES_MRG once for each file in the element
NAME_PTR=.PAR[PAR_TEXT_PTR];
NAME_SIZ=.PAR[PAR_TEXT_LEN];
RESULT=GETELM(.NAME_PTR,.NAME_SIZ,RES_MRG);
IF
.CMD EQL K_ANNOTATE_COM
THEN
$step_close(IOB=OUTPUT_IOB,OPTIONS=REMEMBER);
IF
.RESULT EQL G_OK
THEN
!Success, mark the element reserved
BEGIN
!If this is a FETCH or ANNOTATE, don't mark the element reserved
IF
.CMD EQL K_RESERVE_COM
THEN
BEGIN
IF
.NOTES
THEN
MRKRES(.NAME_PTR,.NAME_SIZ,
CH$PTR(G_BUF),.G_LEN,.USR_REM[DESC_PTR],.USR_REM[DESC_LEN],0,0)
ELSE
MRKRES(.NAME_PTR,.NAME_SIZ,
CH$PTR(G_BUF),.G_LEN,.USR_REM[DESC_PTR],
.USR_REM[DESC_LEN],CH$PTR(UPLIT('/NONOTES')),8)
END
END
ELSE
!Find out what kind of failure occurred
IF
.RESULT EQL G_NO_ELM
THEN
!No such element
BEGIN
local
d_log_nam : $str_desc(),
d_log_trn : $str_desc(),
log_trn_buf : vector[ch$allocation(log_nam_value_size)];
!Unlock the library
$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 '),PAR[PAR_TEXT],
(' does not exist in the CMS library '),d_log_trn));
END
ELSE
IF
.RESULT EQL G_ERMSG
THEN
!User error which was reported
BEGIN
!Cancel the transaction
IF
.CMD NEQ K_ANNOTATE_COM
THEN
CANTRN();
!Unlock the library
DONLIB();
RETURN K_SILENT_ERROR
END
ELSE
!We don't know what happened!
BUG(LIT('Error in element processing (RESERVE)'));
!Remember what went on here
IF
.CMD NEQ K_ANNOTATE_COM
THEN
BEGIN ! write log entry
IF
.F_UNUSUAL
THEN
BEGIN ! unusual record
IF
NOT LOGTRN(K_UNUSUAL_LOG,.G_LEN,CH$PTR(G_BUF))
THEN
BUG(CAT('Unable to write log record.')) ;
END ! unusual record
ELSE
BEGIN ! normal record
IF
NOT LOGTRN(K_NORMAL_LOG,.G_LEN,CH$PTR(G_BUF))
THEN
BUG(CAT('Unable to write log record.')) ;
END ; ! normal record
END ; ! write log entry
!Mark end of transaction
IF
.CMD NEQ K_ANNOTATE_COM
THEN
ENDTRN();
DONLIB();
!Remove old reservation file
IF
.CMD EQL K_RESERVE_COM
THEN
DELRES();
!Prepare message for output
MSG_PTR=CH$PTR(MSG_BUF);
MSG_PTR=CH$MOVE(8,CH$PTR(UPLIT('Element ')),.MSG_PTR);
MSG_PTR=CH$MOVE(.NAME_SIZ,.NAME_PTR,.MSG_PTR);
MSG_PTR=CH$MOVE(13,CH$PTR(UPLIT(', Generation ')),.MSG_PTR);
MSG_PTR=CH$MOVE(.G_LEN,CH$PTR(G_BUF),.MSG_PTR);
IF
.MERGE NEQ NO_MRG
THEN
BEGIN
MSG_PTR=CH$MOVE(13,CH$PTR(UPLIT(' merged with ')),.MSG_PTR);
MSG_PTR=CH$MOVE(.MRG_LEN,CH$PTR(MRG_BUF),.MSG_PTR);
MSG_PTR=CH$MOVE(4,CH$PTR(UPLIT(' and')),.MSG_PTR)
END;
IF
.CMD EQL K_RESERVE_COM
THEN
!CONFLICT is zero when no conflicts have occurred. If at least
!one conflict occurred with the reserv, then CONFLICT is gtr 0.
IF .CONFLICT GTR 0
THEN
begin
msg_val=s_wreserved;
MSG_PTR=CH$MOVE(24,CH$PTR(UPLIT(' reserved with conflicts')),.MSG_PTR);
end
ELSE
begin
msg_val=s_reserved;
MSG_PTR=CH$MOVE(9,CH$PTR(UPLIT(' reserved')),.MSG_PTR)
end
ELSE
IF
.CMD EQL K_FETCH_COM
THEN
!CONFLICT is zero when no conflicts have occurred. If at least
!one conflict occurred with the fetch, then CONFLICT holds a
!value gtr 0.
IF .CONFLICT GTR 0
THEN
begin
msg_val=s_wfetched;
MSG_PTR=CH$MOVE(23,CH$PTR(UPLIT(' fetched with conflicts')),.MSG_PTR);
end
ELSE
begin
msg_val=s_fetched;
MSG_PTR=CH$MOVE(8,CH$PTR(UPLIT(' fetched')),.MSG_PTR);
end
ELSE
begin
msg_val=s_annotated;
MSG_PTR=CH$MOVE(10,CH$PTR(UPLIT(' annotated')),.MSG_PTR)
end;
syslp(.msg_val,CH$DIFF(.MSG_PTR,CH$PTR(MSG_BUF)),CH$PTR(MSG_BUF),0);
IF
.FETSTS NEQ 0
THEN
exits(.FETSTS)
ELSE
exits(.msg_val)
END; !End of RESERVE
GLOBAL ROUTINE PRC_HDR (FIL_NAM_LGT,FIL_NAM_STR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Find the correct generation to be processed (check both the
! normal generation requested and the merge request, if any)
!
! FORMAL PARAMETERS:
!
! FIL_NAM_LGT - length of file name to be processed
! FIL_NAM_STR - pointer to file name to be processed
!
! IMPLICIT INPUTS:
!
! G_LEN - length of main generation expression
! G_PTR - pointer to main generation expression
! MRG_LEN - length of merge generation expression
! MRG_PTR - pointer to merge generation expression
!
! IMPLICIT OUTPUTS:
!
! G_LEN - length of actual main generation to be used
! G_PTR - pointer to actual main generation to be used
! MRG_LEN - length of actual merge generation to be used
! MRG_PTR - pointer to actual merge generation to be used
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! TRUE - success
! FALSE - failure
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
END_MST_HDR,
END_MRG_HDR,
TG_BUF: VECTOR[CH$ALLOCATION(gen_size)],
TG_LGT;
SETUP(.FIL_NAM_LGT,.FIL_NAM_STR);
MAX_G_LGT=0;
END_MST_HDR=FALSE;
END_MRG_HDR=FALSE;
IF
.CMD EQL K_ANNOTATE_COM
THEN
!Set up for header records if annotate
BEGIN
HDR(.NAME_PTR,.NAME_SIZ,.FIL_NAM_STR,.FIL_NAM_LGT)
END;
!Find a header record on the main line of descent
REPEAT
BEGIN
LOCAL
S_L_PTR,
S_SIZ;
!Get a header record
$step_get(IOB=INP_IOB);
S_SIZ=.INP_IOB[IOB$H_STRING];
!make sure size is non-zero
if
.s_siz eql 0
then
!something is wrong in the library
badlib(lit('Illegal Library file format'));
S_L_PTR=.INP_IOB[IOB$A_STRING];
!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
BADLIB(LIT('Illegal Library file format'))
ELSE
!Pick up generation data
BEGIN
LOCAL
TG_PTR;
TG_PTR=CH$PTR(TG_BUF);
TG_LGT=GET_LXM(S_L_PTR,%C' ',.S_SIZ-1,TG_PTR);
if
.tg_lgt gtr gen_size
then
badlib(cat('Generation field too large in element file ',
(.fil_nam_lgt,.fil_nam_str)));
IF
.TG_LGT LEQ 0
THEN
BADLIB(LIT('Illegal header record.'));
!Set up master generation value
IF
.G_PTR NEQ 0 AND
NOT .END_MST_HDR
THEN
!User specified which generation
!See if it matches a legal generation
BEGIN
!Did the user ask for the latest generation of a series?
IF
(.PLUS_GET AND
dirdes(.G_len,.G_ptr,.TG_LGT,CH$PTR(TG_BUF)))
THEN
!We have a legal form (bug - it gets any latest generation)
BEGIN
CH$MOVE(.TG_LGT,CH$PTR(TG_BUF),CH$PTR(G_BUF));
G_LEN=.TG_LGT;
END_MST_HDR=TRUE
END
ELSE
!Did he ask for a specific generation?
IF
CH$EQL(.G_LEN,.G_PTR,.TG_LGT,CH$PTR(TG_BUF))
THEN
!He found it
END_MST_HDR=TRUE
END;
!Set up merge generation
IF
.MRG_PTR NEQ 0 AND
NOT .END_MRG_HDR
THEN
!User specified which generation
!See if it matches a legal generation
BEGIN
!Did the user ask for the latest generation of a series?
IF
(.PLUS_MRG AND
dirdes(.mrg_len,.mrg_ptr,.TG_LGT,CH$PTR(TG_BUF)))
THEN
!We have a legal form (bug - it gets any latest generation)
BEGIN
CH$MOVE(.TG_LGT,CH$PTR(TG_BUF),CH$PTR(MRG_BUF));
MRG_LEN=.TG_LGT;
END_MRG_HDR=TRUE
END
ELSE
!Did he ask for a specific generation?
IF
CH$EQL(.MRG_LEN,.MRG_PTR,.TG_LGT,CH$PTR(TG_BUF))
THEN
!He found it
END_MRG_HDR=TRUE
END
END;
!See if master entry is on the main line
! and the user did not specify which generation
!(The merge generation will always be specified)
IF
.G_PTR EQL 0 AND
NOT .END_MST_HDR
THEN
BEGIN
LOCAL
CHAR,
CHAR_CNT,
PTR;
PTR=CH$PTR(TG_BUF);
CHAR_CNT=0;
!Skip all leading numerics
REPEAT
BEGIN
CHAR=CH$RCHAR_A(PTR);
CHAR_CNT=.CHAR_CNT+1;
IF
.CHAR LSS %C'0' OR
.CHAR GTR %C'9'
THEN
EXITLOOP
END;
!If we have passed over the entire expression without seeing
!a non-numeric, we are on the main line.
IF
.CHAR_CNT GTR .TG_LGT
THEN
BEGIN
CH$MOVE(.TG_LGT,CH$PTR(TG_BUF),CH$PTR(G_BUF));
G_LEN=.TG_LGT;
MAX_G_LGT=.TG_LGT;
END_MST_HDR=TRUE
END
END;
IF
.CMD EQL K_ANNOTATE_COM
THEN
!Output generation control record
BEGIN
LOCAL FIRST_LOOP, !flag
LNSIZE, !size of output line
LOOP_AGAIN, !loop again if true
REMARK: $STR_DESCRIPTOR(), !points to string
R_SUBLINE: $STR_DESCRIPTOR(); !points to substring
STG(' ',FALSE); !7 spaces
!Mark the actual line of descent with an "*"
IF
.END_MST_HDR AND
CMPGEN(CH$PTR(TG_BUF),.TG_LGT,CH$PTR(G_BUF),.G_LEN)
THEN
STG('*',FALSE) !the 8th "space"
ELSE
STG(' ',FALSE); !the 8th "space"
!Skip the "+" so it won't be printed
$STR_DESC_INIT(DESCRIPTOR=REMARK);
$STR_DESC_INIT(DESCRIPTOR=R_SUBLINE);
REMARK[STR$A_POINTER] = CH$PLUS(.INP_IOB[IOB$A_STRING],1);
REMARK[STR$H_LENGTH] = .INP_IOB[IOB$H_STRING]-1;
LNSIZE = 132; !delete this line if line-size of
! output ever provided
LNSIZE = .LNSIZE - 8; !subtract 8 spaces
LOOP_AGAIN = TRUE;
FIRST_LOOP = TRUE;
WHILE .LOOP_AGAIN
DO
BEGIN
LOOP_AGAIN = NOT FIND_NEXT_WORDS(REMARK,.LNSIZE,R_SUBLINE);
l_cntr=.l_cntr+1;
OUTSTG(.R_SUBLINE[STR$A_POINTER],.R_SUBLINE[STR$H_LENGTH],TRUE);
if
.l_cntr geq max_lines
then
hdr(.name_ptr,.name_siz,.fil_nam_str,.fil_nam_lgt);
IF
.LOOP_AGAIN
THEN
INCR I FROM 1 TO 8+ANNINDENT DO STG(' ',FALSE);
IF .FIRST_LOOP
THEN
BEGIN
FIRST_LOOP = FALSE;
LNSIZE = .LNSIZE - ANNINDENT;
END
END
END;
!See if there are no more header records
IF
.TG_LGT EQL 1 AND
CH$EQL(1,CH$PTR(UPLIT('1')),.TG_LGT,CH$PTR(TG_BUF))
THEN
BEGIN
LOCAL
ER_FLG;
ER_FLG=FALSE;
IF
.G_PTR NEQ 0 AND
NOT .END_MST_HDR
THEN
!No such generation in master
BEGIN
ERS(s_nogen,CAT(('Generation '),(.G_LEN,CH$PTR(G_BUF)),
(' does not exist')));
ER_FLG=TRUE
END;
!No such generation in merge value
IF
.MRG_PTR NEQ 0 AND
NOT .END_MRG_HDR
THEN
BEGIN
ERS(s_nogen,CAT(('Generation '),(.MRG_LEN,CH$PTR(MRG_BUF)),
(' does not exist')));
ER_FLG=TRUE
END;
!If either error occurred, quit now
IF
.ER_FLG
THEN
BEGIN
$step_close(IOB=INP_IOB);
RETURN FALSE
END;
!Start text proper on new page
!Use a big number to force a page break
L_CNTR=500;
EXITLOOP
END
END;
!If user specified generation, use his generation as max. length
IF
.G_PTR NEQ 0
THEN
MAX_G_LGT=.G_LEN;
$step_close(IOB=INP_IOB);
TRUE
END; !End of PRC_HDR
ROUTINE RES_MRG (FIL_NAM_LGT,FIL_NAM_STR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Process the actual test files to be obtained
!
! FORMAL PARAMETERS:
!
! FIL_NAM_LGT - length of file name
! FIL_NAM_PTR - pointer to file name
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! G_ERMSG
! G_OK
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
MRG_VAL,
RES_VAL;
MRG_VAL=.MERGE;
!Get desired generation for master
IF
NOT PRC_HDR(.FIL_NAM_LGT,.FIL_NAM_STR)
THEN
RETURN G_ERMSG;
!If merging, process the merge branch
IF
.MERGE NEQ NO_MRG
THEN
BEGIN
!If merging, get the common ancestor
!Pass the name of the file for clarity as well as the generation
! numbers
IF
NOT G_COMN_NODE(.G_LEN,CH$PTR(G_BUF),.MRG_LEN,CH$PTR(MRG_BUF),
.fil_nam_lgt,.fil_nam_str)
THEN
RETURN G_ERMSG;
MERGE=MRG_BRNCH;
RES_VAL=RESFIL(.FIL_NAM_LGT,.FIL_NAM_STR,.MRG_LEN,CH$PTR(MRG_BUF));
IF
.RES_VAL NEQ G_OK
THEN
RETURN .RES_VAL
END;
MERGE=.MRG_VAL;
!Generate the primary line of descent
RES_VAL=RESFIL(.FIL_NAM_LGT,.FIL_NAM_STR,.G_LEN,CH$PTR(G_BUF));
IF
.RES_VAL NEQ G_OK
THEN
RETURN .RES_VAL ;
IF
.MERGE EQL NO_MRG
THEN
IF
.CHRONO AND .CHRLEN NEQ 0
THEN
BEGIN
OUT_CHR(.FIL_NAM_LGT, .FIL_NAM_STR, .G_LEN, CH$PTR(G_BUF));
RETURN .RES_VAL;
END
ELSE
RETURN .RES_VAL ;
!STORE value of cmpmrg in CONFLICT so
!that we know whether conflicts occurred
!in merge. TRUE if no conflict, FALSE
!if conflict exists.
!Now merge the two temporaries together
CONFLICT = .CONFLICT + (CMPMRG(%CHARCOUNT(TM1),CH$PTR(UPLIT(TM1)),
%CHARCOUNT(TM2),CH$PTR(UPLIT(TM2)),.FIL_NAM_LGT,.FIL_NAM_STR));
IF
.CHRONO AND .CHRLEN NEQ 0
THEN
OUT_CHR(.FIL_NAM_LGT, .FIL_NAM_STR, .G_LEN, CH$PTR(G_BUF));
G_OK
END; !End of RES_MRG
ROUTINE SETUP (LGT,STR) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! Open an input file and do any required initialization.
!
! FORMAL PARAMETERS:
!
! LGT - length of file name to be processed
! STR - pointer to file name to be processed
!
! IMPLICIT INPUTS:
!
! NONE.
!
! IMPLICIT OUTPUTS:
!
! NONE.
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE.
!
! SIDE EFFECTS:
!
! NONE.
!
!--
BEGIN
LOCAL
FIL: VECTOR[CH$ALLOCATION(EXTENDED_FILE_SPEC)],
FIL_PTR,
FIL_SIZ,
STS;
FIL_PTR=CH$PTR(FIL);
FIL_PTR=CH$MOVE(%CHARCOUNT(LIB),CH$PTR(UPLIT(LIB)),.FIL_PTR);
FIL_PTR=CH$MOVE(.LGT,.STR,.FIL_PTR);
FIL_SIZ=CH$DIFF(.FIL_PTR,CH$PTR(FIL));
STS=$STEP_OPEN(IOB=INP_IOB,FILE_SPEC=(.FIL_SIZ,CH$PTR(FIL)),
OPTIONS=INPUT,FAILURE=0);
IF
NOT .STS
THEN
BADXPO(.STS,CAT(('Cannot open input file '),(.FIL_SIZ,CH$PTR(FIL))));
END; !End of SETUP
END !End of Module RESERVE
ELUDOM