Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/stset.bli
There are no other files named stset.bli in the archive.
MODULE STSET (
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:
!
! This module contains the routines for processing the SET Command
! and other service routines related to processing the Master Control
! directory records.
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: R. Wheater CREATION DATE: 1-jul-80
!
! MODIFIED BY:
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
stset, ! Main dispatch routine
s_atr, ! main set attribute processing
parqua, ! parses parameter qualifiers
presel, ! preselect record for modification
prsupd, ! parse and update record
savpar; ! saves parameters and qualifiers
!
! INCLUDE FILES:
!
%if
%bliss(bliss32)
%then
library 'sys$library:starlet';
%else
require 'jsys:';
%fi
library 'xport:';
require 'sconfg:';
require 'blissx:';
require 'comusr:';
require 'hosusr:';
require 'logusr:';
require 'shrusr:';
require 'terusr:';
!
! MACROS:
!
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
global
chrlen, ! length of history string
chrptr, ! pointer to history string
notlen, ! length of note string
notptr, ! pointer to note string
poslen, ! length of position string
posptr; ! pointer to position string
own
$io_block(in), ! input iob
$io_block(out) ; ! output iob
own
d_elmnam: desc_block, ! element name string
d_filnam: desc_block, ! filename string
d_chr_str: desc_block, ! chronology string
d_not_str: desc_block, ! note string
d_pos_str: desc_block, ! position string
f_chr_q: initial(false), ! chronology qual flag
f_nochr_q: initial(false), ! nochronology qual flag
f_not_q: initial(false), ! notes qual flag
f_nonot_q: initial(false), ! nonotes qual flag
f_pos_q: initial(false), ! position qual flag
f_reserved:initial(false), ! set if element reserved
elmnam: vector[ch$allocation(file_spec_size)] ; ! storage for element name
!
! EXTERNAL REFERENCES:
!
external literal
s_atrmod,
s_elresr, !element reserved
s_givefile, !no file specified
s_invcksum, !definition file has invalid checksum
s_inconsis, !inconsistent on position,notes
s_invGs, !invalid # of Gs in string
s_invHs, !invalid # of Hs in string
s_ilposval, !invalid position qualifier value
s_nocksum, !definition file has no checksum
s_nofile; !record not found
external
patlgt, ! length of pattern following filename in def
! file (GETELM)
patptr; ! pointer to pattern following filename in def
! file (GETELM)
external routine
ascdec, ! ASCII to decimal (ASCDEC)
aschex, ! ASCII to hex (ASCDEC)
comand, ! parse command(COMAND)
badlib, ! write bad library message(TERMIO)
badxpo,
begtrn, ! begin tranaction(TRANSA)
bug, ! print bug message(TERMIO)
cantrn, ! cancel tranaction(TRANSA)
chkres, ! check for a reservation(CHKRES)
crccalc, ! Calculate the CRC of a line(CRCOPS)
crctable:novalue, ! Set up the polynomial table (CRCOPS)
delvrs, ! delete files(FILOPS)
dequot, ! dequote the quoted string(QUOTES)
donlib, ! release library(SHARE)
endquo, ! find end of quoted string(STRING)
endtrn, ! end transaction(TRANSA)
enquot, ! enquote the quoted string(QUOTES)
ers, ! print error message(TERMIO)
exits, ! exit silently
findps, ! check pattern string (STRING)
hexasz, ! Hex to ASCII ( DECASC)
librar, ! INITIALIZE and SET LIBRARY
logtrn, ! log transaction(IOLOG)
repres, ! report reservation(chkres)
s_cls, ! SET CLASS
saflib, ! request access to library(SHARE)
sysmsg,
trnfil; ! register file for error recovery(TRANSA)
GLOBAL ROUTINE STSET =
!++
! FUNCTIONAL DESCRIPTION:
!
! This is the main routine that dispatches to the functions of the SET
! Command.
!
! FORMAL PARAMETERS:
!
! None.
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! k_success = successful completion
! k_silent_error = error in processing
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
LOCAL
CMD, !Command
SUB_CMD, !Sub command
FIRST_PAR, !First parameter block address
FIRST_QUA, !First qualifier block address
USR_REM; !User remark descriptor address
!Check command for correctness
IF
NOT COMAND(CMD,SUB_CMD,FIRST_QUA,FIRST_PAR,USR_REM)
THEN
RETURN K_SILENT_ERROR;
!Dispatch to the proper sub-command
IF
.CMD eql K_SET_COM AND
.SUB_CMD EQL K_ATTRIBUTE_SUB
THEN
!Set attribute
RETURN S_ATR(.FIRST_PAR)
ELSE
if
.cmd eql k_set_com and
.sub_cmd eql k_class_sub
then
s_cls(.first_par,.first_qua)
else
IF
.CMD EQL K_INITIALIZE_COM OR
.SUB_CMD EQL K_LIBRARY_SUB
THEN
!INITIALIZE or SET LIBRARY
RETURN LIBRAR(.CMD,.FIRST_PAR)
ELSE
BUG(LIT('Error in SET'))
END; !End of STSET
ROUTINE S_ATR (PARAM) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This is the main routine that performs the functions of the SET ATTRIBUTE
! Command.
!
! FORMAL PARAMETERS:
!
! PARAM - address of first parameter block
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! k_success = successful completion
! k_silent_error = error in processing
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
local
crc_len,
crc_buf: vector[ch$allocation(max_num_size + 5)],
crc_ptr,
existing_crc,
found_crc,
new_crc,
old_crc,
status;
own
d_delfil: desc_block, ! file name delvrs is to delete
f_updated: initial(false), ! set when a record is updated
l_new_rec, ! length of new record
p_new_rec ; ! pointer to new record
!Try for access to the library
IF
NOT SAFLIB(K_UPDATE_LIB)
THEN
RETURN K_SILENT_SEVERE;
! Initialize CRC variables
existing_crc = 0;
found_crc = false;
new_crc = 0;
old_crc = 0;
! Set up polynomial table
crctable();
! initialize deletion descriptor
$str_desc_init(descriptor=d_delfil,string=(%string(lib,cdir))) ;
if
not savpar(.param)
then
return k_silent_error ;
! begin transaction
begtrn() ;
! open input
if
(status=$step_open(iob=in_iob,file_spec=(%string(lib,cdir)),
options=input,failure=0)) neq step$_normal
then
badxpo(.status,lit('Cannot open definition file'));
! open output
if
(status=$step_open(iob=out_iob,file_spec=(%string(lib,cdir)),
options=output,failure=0)) neq step$_created
then
badxpo(.status,lit('Cannot open new definition file'));
! register file for error recovery
trnfil(out_iob) ;
until
$step_get(iob=in_iob) eql step$_eof
do
begin ! main read loop
!Check for control record
if ch$eql(4,ch$ptr(uplit('*/C:')),4,.in_iob[iob$a_string])
then
begin
local
len,
ptr;
len = .in_iob[iob$h_string] - 4;
ptr = ch$plus(.in_iob[iob$a_string], 4) ;
existing_crc = aschex(ptr, len);
found_crc = true;
exitloop;
end;
! Calculate the CRC of the input line
old_crc = .old_crc +
crccalc( .in_iob[iob$h_string], .in_iob[iob$a_string]) ;
if
not .f_updated
then
begin ! check for update
! first pre-scan record
if
presel(.in_iob[iob$h_string],.in_iob[iob$a_string])
then
begin ! process record
l_new_rec = .in_iob[iob$h_string] ;
p_new_rec = .in_iob[iob$a_string] ;
if
prsupd(l_new_rec,p_new_rec)
then
begin ! record updated
if
.l_new_rec eql -1
then
begin ! cancel transaction
$step_close(iob=in_iob,options=remember) ;
$step_close(iob=out_iob,options=remember) ;
cantrn() ;
$step_delete(iob=out_iob) ;
donlib() ;
! error message already printed so return
return k_silent_error ;
end ; ! cancel transaction
f_updated = true ;
! write out new record
new_crc = .new_crc +
crccalc( .l_new_rec, .p_new_rec );
$step_put(iob=out_iob,string=(.l_new_rec,.p_new_rec)) ;
end ! record updated
else
begin
new_crc = .new_crc +
crccalc( .in_iob[iob$h_string], .in_iob[iob$a_string]) ;
$step_put(iob=out_iob,string=(.in_iob[iob$h_string],
.in_iob[iob$a_string])) ;
end
end ! process record
else
begin
new_crc = .new_crc +
crccalc( .in_iob[iob$h_string], .in_iob[iob$a_string]) ;
$step_put(iob=out_iob,string=(.in_iob[iob$h_string],
.in_iob[iob$a_string])) ;
end
end ! check for update
else
! write record out
begin
new_crc= .new_crc +
crccalc( .in_iob[iob$h_string], .in_iob[iob$a_string]) ;
$step_put(iob=out_iob,string=(.in_iob[iob$h_string],
.in_iob[iob$a_string])) ;
end;
end ; ! main read loop
$step_close(iob=in_iob,options=remember) ;
! Write out newly calculated CRC
crc_ptr = ch$move( 4,ch$ptr(uplit('*/C:')), ch$ptr(crc_buf));
crc_len = hexasz( .new_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 = out_iob , string = (.crc_len, ch$ptr(crc_buf)),
failure = 0) ;
$step_close(iob=out_iob,options=remember) ;
! Check validity of file counts
if not .found_crc
then
sysmsg(s_nocksum,cat('Definition file has no checksum'),0)
else
if .existing_crc neq .old_crc
then
sysmsg(s_invcksum,cat('Definition file has an invalid ',
'checksum'),0) ;
if
.f_reserved
then
begin ! element reserved
cantrn();
$step_delete(iob=out_iob) ;
sysmsg(s_elresr,cat('Cannot change attributes of a reserved',
' element'),0) ;
donlib() ;
return k_silent_error ;
end ; ! element reserved
if
not .f_updated
then
begin ! record not found
cantrn();
$step_delete(iob=out_iob) ;
sysmsg(s_nofile,cat('File ',d_filnam,' does not exist'),0);
donlib() ;
return k_silent_error ;
end ! record not found
else
begin ! record updated
! delete old def file
delvrs(filvrs,.d_delfil[desc_len],.d_delfil[desc_ptr]) ;
! write log record
logtrn(k_normal_log,0,K_null);
endtrn() ;
donlib() ;
end ; ! record updated
! write successful completion message
sysmsg(s_atrmod,cat('Attributes of ',d_filnam,' in element ',d_elmnam,
' modified'),0) ;
exits(s_atrmod)
END; ! end of routine S_ATR
GLOBAL ROUTINE parqua(len,ptr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will parse the qualifiers string for each filename
! in the Master Control Directory(def file).
!
! FORMAL PARAMETERS:
!
! len length of qualifier string
!
! ptr pointer to start of string
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! poslen length of position string
!
! posptr pointer to position string
!
! notlen length of note string
!
! notptr pointer to note string
!
! chrlen length of chronology string
!
! chrptr pointer to chronology string
!
! NOTE: these variables are reset to zero each time the routine is called.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! true = successful completion of routine
! or no string was passed
! false = failure occurred in processing
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
own
dequoted:desc_block ;
own
char, ! save character
f_pos_qua, ! position qual present
f_not_qua, ! note qual present
f_chr_qua, ! chronology qual present
f_quo_str, ! set if quoted string
l_diff, ! length difference between string and substring
l_tmp, ! temp length
l_str, ! length of subject string
p_nxt, ! pointer to next character to scan for
p_tmp, ! temp pointer
p_scan, ! pointer used in scan
p_str; ! pointer to subject string
!initialize global variables
poslen = 0;
posptr = k_null;
notlen = 0;
notptr = k_null ;
chrlen = 0;
chrptr = k_null ;
!return if length is zero
if
.len eql 0
then
return true ;
! initialize pointer and length
l_tmp = .len ;
p_tmp = .ptr ;
until
.l_tmp eql 0
do
begin ! individual qualifiers loop
p_nxt = ch$find_ch(.l_tmp,.p_tmp,%c'/') ;
if
ch$fail(.p_nxt) eql 1
then
badlib(cat('The qualifier string ',(.len,.ptr),' does not ',
'contain a "/"')) ;
l_tmp = .l_tmp - ch$diff(.p_nxt,.p_tmp) - 1 ;
p_tmp = ch$plus(.p_nxt,1) ;
char = ch$rchar_a(p_tmp) ;
l_tmp = .l_tmp - 1 ;
selectone .char of
set
[%c'P']:
begin
f_pos_qua = true ;
f_quo_str = false ;
end ;
[%c'N']:
begin
f_not_qua = true ;
f_quo_str = true ;
end ;
[%c'H']:
begin
f_chr_qua = true ;
f_quo_str = true ;
end ;
[otherwise]:
badlib(cat('Qualifiers string in definition file',
'contains illegal qualifiers or bad format')) ;
tes;
if
ch$rchar_a(p_tmp) neq %c'='
then
badlib(cat('The string ',(.len,.ptr),' is missing equals sign',
'in definition file')) ;
l_tmp = .l_tmp - 1 ;
! find extent of string
if
not .f_quo_str
then
begin ! unquoted string
p_scan = .p_tmp ;
until
.l_tmp eql 0
do
begin ! find end of unquoted string
char = ch$rchar_a(p_scan) ;
l_tmp = .l_tmp - 1 ;
if
.char eql %c'/' or
.char eql %c','
then
exitloop ;
end ; ! find end of unquoted string
l_str = ch$diff(ch$plus(.p_scan,-1),.p_tmp) ;
p_str = .p_tmp;
! back up pointer and length of "/"
if
.char eql %c'/'
then
begin
p_tmp = ch$plus(.p_scan,-1) ;
l_tmp = .l_tmp + 1;
end ;
end ! end of unquoted string
else
begin ! find end of quoted string
p_scan = .p_tmp ;
l_str = endquo(.l_tmp,p_scan) ;
if
.l_str eql -1
then
badlib(cat('The string ',(.len,.ptr),' is missing a ',
'quoted string in definition file')) ;
p_str = .p_scan ;
! update string pointers
if
.p_scan neqa .p_tmp
then
begin ! quote doesn't start the string
l_diff = ch$diff(.p_scan,.p_tmp) ;
l_tmp = .l_tmp - .l_str - .l_diff ;
p_tmp = ch$plus(.p_scan,.l_diff+.l_str) ;
end ! quote doesn't start the string
else
begin ! quote starts string
l_tmp = .l_tmp - .l_str ;
p_tmp = ch$plus(.p_tmp,.l_str) ;
end ; ! quote starts string
end ; ! find end of quoted string
if
.f_pos_qua
then
begin
poslen = .l_str ;
posptr = .p_str ;
end ;
if
.f_not_qua
then
begin
notlen = .l_str ;
notptr = .p_str ;
end ;
if
.f_chr_qua
then
begin
chrlen = .l_str ;
chrptr = .p_str ;
end ;
! clear flags
f_pos_qua = false ;
f_not_qua = false ;
f_chr_qua = false ;
end ; !individual qualifiers loop
! now remove quotes from quoted strings if length greater than 2
if
.notlen gtr 2
then
begin ! dequote note
$str_desc_init(descriptor=dequoted,string=(.notlen,.notptr)) ;
dequot(dequoted) ;
notlen = .dequoted[desc_len] ;
notptr = .dequoted[desc_ptr] ;
end ! dequote note
else
begin ! zero note
notlen = 0 ;
notptr = k_null;
end; ! zero note
if
.chrlen gtr 2
then
begin ! dequote chronology
$str_desc_init(descriptor=dequoted,string=(.chrlen,.chrptr)) ;
dequot(dequoted) ;
chrlen = .dequoted[desc_len] ;
chrptr = .dequoted[desc_ptr] ;
end ! dequote chronology
else
begin ! zero chronology
chrlen = 0 ;
chrptr = k_null ;
end ; ! zero chronology
true
END; ! end of routine parqua
ROUTINE presel(len,ptr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine scans a record of the master file directory for the
! filename given in the command line.
!
! FORMAL PARAMETERS:
!
! len length of record.
!
! ptr pointer to start of record.
!
! IMPLICIT INPUTS:
!
! d_filnam: desc_block filename string on command line.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! true = record probably contains correct filename.
! false = record does not contain filename
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
local
char,
l,
p,
p_nxt;
! skip over filename
p_nxt = ch$find_ch(.len,.ptr,%c' ') ;
l = .len - ch$diff(.p_nxt,.ptr) - 1 ;
p = ch$plus(.p_nxt,1) ;
! scan for substring contain filename
p_nxt = ch$find_sub(.l,.p,.d_filnam[desc_len],.d_filnam[desc_ptr]);
if
ch$fail(.p_nxt) eql 1
then
return false ;
! if more of string following filename - look for valid characters
if
(.d_filnam[desc_len] + ch$diff(.p_nxt,.p)) lss .l
then
begin ! string extends past filename
p_nxt = ch$plus(.p,.d_filnam[desc_len] + ch$diff(.p_nxt,.p));
char = ch$rchar(.p_nxt) ;
if not
(.char eql %c'/' or
.char eql %c',')
then
return false ;
end ; ! string extends past filename
true
END; ! end of routine presel
ROUTINE prsupd(a_len,a_ptr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will take a master control directory record and
! parse for the required filename and update its qualifiers where
! appropriate. The new record is returned via the arguments.
!
! FORMAL PARAMETERS:
!
! a_len Address where length of record is to be stored.
!
! a_ptr Address where pointer to the start of record is
! stored.
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! Updated def file record.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! true = record updated, except when first argument (a_len) is returned
! as a -1 and (a_ptr) as k_null, indicating an error has occurred.
! false = record was not updated because it did not contain proper
! filename or element was reserved.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
own
a_res_lis, ! address of reservation list
d_r_file:desc_block,
d_quoted: ref desc_block, ! descripter of enquoted string
d_unquoted: desc_block, ! desc of string when unquoted
f_1st_sla, ! first slash found
f_comma, ! comma found
f_nocomma, ! no comma found
f_no_qual, ! set when no qual present
f_match, ! set on filename match
f_odd_quo, ! set on odd number quote
f_in_odd_quo, ! set on odd number qoute once past slash
l_new, ! length
l_str_rec, ! starting length
l_xfer, ! transfer length
num_found, ! number of #x's found where x= G or H
p_nxt, ! pointer to next lexeme
p_slash, ! pointer to "/"
p_comma, ! pointer to ","
p_new, ! pointer
p_tmp, ! working pointer
l_tmp, ! working length
p_str_rec, ! pointer to start of record
p_str_file, ! pointer to start of filename
p_xfer,
pos_value; ! decimal value of position qualifier
! initialize variables
l_tmp = ..a_len ;
l_str_rec = ..a_len ;
p_tmp = ..a_ptr ;
p_str_rec = ..a_ptr ;
! initialize flags
f_1st_sla = false ;
f_comma = false ;
f_nocomma = false ;
f_no_qual = false ;
f_match = false ;
f_odd_quo = false ;
f_in_odd_quo = false;
! save element name
p_nxt = ch$find_ch(.l_tmp,.p_tmp,%c' ') ;
if
ch$fail(.p_nxt) eql 1
then
badlib(cat('The string ',(.l_tmp,.p_tmp),' is missing',
'a blank delimiter in definition file')) ;
ch$move(ch$diff(.p_nxt,.p_tmp),.p_tmp,ch$ptr(elmnam)) ;
$str_desc_init(descriptor=d_elmnam,string=(ch$diff(.p_nxt,.p_tmp),
ch$ptr(elmnam))) ;
l_tmp = .l_tmp - ch$diff(.p_nxt,.p_tmp) - 1 ;
p_tmp = ch$plus(.p_nxt,1) ;
p_str_file = .p_tmp ;
until
.l_tmp eql 0
do
begin ! scan rest of string
local
char ;
char = ch$rchar_a(p_tmp) ;
l_tmp = .l_tmp - 1 ;
if
.char eql %c'"'
then
begin ! quote mark
if
not .f_odd_quo
then
f_odd_quo = true
else
f_odd_quo = false ;
end ; ! quote mark
if
not .f_odd_quo
then
begin ! not in quoted string (but we may find one)
if
.char eql %c'/' and not .f_1st_sla
then
begin ! / following filename
p_slash = ch$plus(.p_tmp,-1) ;
f_1st_sla = true ;
! now find comma or end
until
.l_tmp eql 0
do
begin ! look for comma
char = ch$rchar_a(p_tmp) ;
l_tmp = .l_tmp - 1 ;
! Check for another quote. Commas are allowed within quoted
! strings
if
.char eql %c'"'
then
if
not .f_in_odd_quo
then
f_in_odd_quo = true
else
f_in_odd_quo = false ;
if
.char eql %c',' and not .f_in_odd_quo
then
begin
p_comma = ch$plus(.p_tmp,-1) ;
f_comma = true ;
exitloop ;
end ;
end ; ! look for comma
! no comma following qualifier
if
not .f_comma
then
begin ! no comma = end of string
p_comma = .p_tmp ;
f_nocomma = true ;
end ; ! no comma = end of string
if
.f_1st_sla and (.f_comma or .f_nocomma)
then
begin ! compare filenames
if
ch$eql(len_comma_ptr(d_filnam),
ch$diff(.p_slash,.p_str_file),.p_str_file,%c' ')
then
begin ! filenames match
f_match = true ;
exitloop ;
end ! filenames match
else
begin ! clear flags
f_1st_sla = false ;
f_comma = false ;
f_nocomma = false ;
end ; ! clear flags
end ; ! compare filenames
! clear out character to prevent further processing in this
! iteration
char = 0 ;
! update start of filename
p_str_file = .p_tmp ;
end ; ! / following filename
!+
! no qualifiers present
!+
if
.char eql %c',' and not .f_comma
then
begin ! "," following filename
p_comma = ch$plus(.p_tmp,-1) ;
f_comma = true ;
if
ch$eql(len_comma_ptr(d_filnam),
ch$diff(.p_comma,.p_str_file),.p_str_file,%c' ')
then
begin ! file match
f_match = true ;
exitloop ;
end ! file match
else
! reset on no match
f_comma = false ;
! update start of file pointer
p_str_file = .p_tmp ;
end ; ! "," following filename
end ; ! not in quoted string
end ; ! scan rest of string
! now check if only one filename without qualifier
if
not .f_1st_sla and not .f_comma
then
begin ! no slash or comma found in string
if
ch$diff(.p_tmp,.p_str_file) gtr 0
then
begin ! length greater than 0
if
ch$eql(len_comma_ptr(d_filnam),
ch$diff(.p_tmp,.p_str_file),.p_str_file,%c' ')
then
begin
f_match = true ;
f_no_qual = true ;
f_nocomma = true ;
p_comma = .p_tmp ;
end ;
end ; ! length greater than 0
end ; ! no slash or comma found in string
if
(not .f_1st_sla and .f_comma)
then
f_no_qual = true ;
! must have match on filename to go further
if
not .f_match
then
return false ;
!+
! match has occurred set up for modification
!+
! check for a reservation
if
chkres(.d_elmnam[desc_ptr],.d_elmnam[desc_len],
a_res_lis)
then
begin ! reservation exists on element
! report reservation
repres(.a_res_lis,0) ;
! notify main routine
f_reserved = true ;
return false ;
end ; ! reservation exist on element
! parse qualifiers string
if
(.f_1st_sla and .f_comma) or (.f_1st_sla and .f_nocomma)
then
parqua(ch$diff(.p_comma,.p_slash),.p_slash)
else
begin ! zero out pointer and length
posptr = k_null ;
notptr = k_null ;
chrptr = k_null ;
poslen = 0 ;
notlen = 0 ;
chrlen = 0 ;
end ; ! zero out pointer and length
!+
! check for inconsistency in position,notes
!+
if
(.notlen lss 1 and .f_pos_q and not .f_not_q) or
(.posptr eql k_null and .f_not_q and not .f_pos_q)
then
ers(s_inconsis,lit('Both /NOTES and /POSITION must be specified')) ;
!+
! now must rebuild the string
!+
l_new = 0 ;
if
.f_pos_q
then
l_new = .l_new + .d_pos_str[desc_len]
else
l_new = .l_new + .poslen ;
if
.f_not_q
then
l_new = .l_new + .d_not_str[desc_len]
else
l_new = .l_new + .notlen ;
if
.f_chr_q
then
l_new = .l_new + .d_chr_str[desc_len]
else
l_new = .l_new + .chrlen ;
! add enough for "/x=" where x=p or n or c
l_new = .l_new + 3 + 3 + 3 ;
! add portion of string before slash
if
.f_1st_sla
then
l_new = .l_new + ch$diff(.p_slash,.p_str_rec) ;
! add portion of string before and following the comma
if
.f_comma or .f_nocomma
then
l_new = .l_new + ch$diff(.p_comma,.p_str_rec) +
ch$diff(ch$plus(.p_str_rec,.l_str_rec),.p_comma) ;
!check /chrono string and /notes string for validity
num_found = 0 ;
if
.d_chr_str[desc_len] neq 0
then
if
not findps(.d_chr_str[desc_len], .d_chr_str[desc_ptr], %c'H', num_found)
then !error in string - user has been notified
begin
.a_len = -1 ;
.a_ptr = k_null ;
return true ;
end
else
if
.num_found neq 1
then !invalid number of #H's in string
ers(s_invHs,cat('Exactly one "#H" required in ',
(.d_chr_str[desc_len], .d_chr_str[desc_ptr]))) ;
!check /notes string for zero or one occurrence of #G
num_found = 0 ;
if
.d_not_str[desc_len] neq 0
then
if
not findps(.d_not_str[desc_len], .d_not_str[desc_ptr], %c'G', num_found)
then !error in string - user has been notified
begin
.a_len = -1 ;
.a_ptr = k_null ;
return true ;
end
else
if
.num_found gtr 1
then !invalid number of #G's in string
ers(s_invGs,cat('Exactly one "#G" required in ',
(.d_not_str[desc_len], .d_not_str[desc_ptr]))) ;
if .f_pos_q
then
begin ! check that the position value is between 0 and 511
pos_value = ascdec(%ref(.d_pos_str[desc_ptr]),.d_pos_str[desc_len]);
if (.pos_value lss 0) or (.pos_value gtr 511)
then
ers(s_ilposval,lit(%string('/POSITION qualifier value must be from',
' 0 to 511')));
end; ! check that the position value is between 0 and 511
! now get memory for new record
$xpo_get_mem(characters=.l_new,result=p_new) ;
! now build record
l_tmp = .l_new ;
p_tmp = .p_new ;
!+
! transfer portion of string up to part to be modified
!+
if
.f_1st_sla and (.f_comma or .f_nocomma)
then
begin
ch$move(ch$diff(.p_slash,.p_str_rec),.p_str_rec,.p_tmp) ;
p_tmp = ch$plus(.p_tmp,ch$diff(.p_slash,.p_str_rec)) ;
l_tmp = .l_tmp - ch$diff(.p_slash,.p_str_rec) ;
end ;
if
not .f_1st_sla and (.f_comma or .f_nocomma) or .f_no_qual
then
begin
ch$move(ch$diff(.p_comma,.p_str_rec),.p_str_rec,.p_tmp) ;
p_tmp = ch$plus(.p_tmp,ch$diff(.p_comma,.p_str_rec)) ;
l_tmp = .l_tmp - ch$diff(.p_comma,.p_str_rec) ;
end ;
!+
! build modified part of string
!+
! build update position qual if required
if
(.f_pos_q or (not .f_pos_q and .poslen neq 0)) and not .f_nonot_q
then
begin ! update or no change position
ch$wchar_a(%c'/',p_tmp) ;
ch$wchar_a(%c'P',p_tmp) ;
ch$wchar_a(%c'=',p_tmp) ;
l_tmp = .l_tmp - 3 ;
if
.f_pos_q
then
begin
l_xfer = .d_pos_str[desc_len] ;
p_xfer = .d_pos_str[desc_ptr] ;
end
else
begin
l_xfer = .poslen ;
p_xfer = .posptr ;
end ;
ch$move(.l_xfer,.p_xfer,.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.l_xfer) ;
l_tmp = .l_tmp - .l_xfer ;
end ; ! update or nochange position
! build update note qual if required
if
(.f_not_q or (not .f_not_q and .notlen neq 0)) and not .f_nonot_q
then
begin ! update or nochange notes
ch$wchar_a(%c'/',p_tmp) ;
ch$wchar_a(%c'N',p_tmp) ;
ch$wchar_a(%c'=',p_tmp) ;
l_tmp = .l_tmp - 3 ;
if
.f_not_q
then
begin
l_xfer = .d_not_str[desc_len] ;
p_xfer = .d_not_str[desc_ptr] ;
end
else
begin
$str_desc_init(descriptor=d_unquoted,string=(.notlen,.notptr)) ;
d_quoted = enquot(d_unquoted) ;
l_xfer = .d_quoted[desc_len] ;
p_xfer = .d_quoted[desc_ptr] ;
end ;
ch$move(.l_xfer,.p_xfer,.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.l_xfer) ;
l_tmp = .l_tmp - .l_xfer ;
end ; ! update or nochange notes
! build updated history qual if required
if
(.f_chr_q or (not f_chr_q and .chrlen neq 0)) and not .f_nochr_q
then
begin ! update or nochange history
ch$wchar_a(%c'/',p_tmp) ;
ch$wchar_a(%c'H',p_tmp) ;
ch$wchar_a(%c'=',p_tmp) ;
l_tmp = .l_tmp - 3 ;
if
.f_chr_q
then
begin
l_xfer = .d_chr_str[desc_len] ;
p_xfer = .d_chr_str[desc_ptr] ;
end
else
begin
$str_desc_init(descriptor=d_unquoted,string=(.chrlen,.chrptr)) ;
d_quoted = enquot(d_unquoted) ;
l_xfer = .d_quoted[desc_len] ;
p_xfer = .d_quoted[desc_ptr] ;
end ;
ch$move(.l_xfer,.p_xfer,.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.l_xfer) ;
l_tmp = .l_tmp - .l_xfer ;
end ; ! update or nochange history
! now transfer character after the comma
if
.f_comma
then
begin
l_xfer = ch$diff(ch$plus(.p_str_rec,.l_str_rec),.p_comma) ;
p_xfer = .p_comma ;
ch$move(.l_xfer,.p_xfer,.p_tmp) ;
l_tmp = .l_tmp - .l_xfer ;
end ;
! validate that length within confines of buffer
if
.l_tmp lss 0
then
bug(cat('Negative remaining length in dynamically allocated ',
'string in routine PRSUPD of module MODIFY')) ;
! update length and output
.a_len = .l_new - .l_tmp ;
.a_ptr = .p_new ;
true
END; ! end of routine prsupd
ROUTINE savpar(a_parm) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will analyze the parameters from the command string
! and save quoted and unquoted strings. Also flags indicating
! which qualifiers are present are set.
!
! FORMAL PARAMETERS:
!
! a_parm Address of first parameter block.
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! d_filnam: desc_block ! filename
!
! d_chr_str:desc_block ! chronology
!
! d_not_str:desc_block ! notes string
!
! d_pos_str:desc_block ! position string
!
! f_chr_q ! chronology flag
!
! f_nochr_q ! nochronology flag
!
! f_not_q ! notes flag
!
! f_nonot_q ! nonotes flag
!
! f_pos_q ! position flag
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! true = successful completion
! false = error in parameters/qualifiers
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
local
b_parm: ref parameter_block,
b_qual: ref qualifier_block ;
! point to address of block
b_parm = .a_parm ;
! parameter must exist
if
.b_parm eql k_null
then
ers(s_givefile,cat('No file specified'));
! save file name
if
.b_parm[par_text_len] eql 0
then
ers(s_givefile,cat('No file specified'));
$str_desc_init(descriptor=d_filnam,string=b_parm[par_text]);
!set up 1st qual
b_qual = .b_parm[par_a_qual] ;
until
.b_qual eql k_null
do
!Added the code to allow /NOTES and /NONOTES
!and to allow /HIST and /NOHIST to appear
!with the same command, processing
!the qualifier of the pair which appears
!LAST on the command line. (previous to this,
!/NOTES and /NONOTES were mutually exclusive.
!/HIST and /NOHIST were also mutually exclu-
!sive). Took out code to make them mutually
!exclusive. example:
!CMS SET ATTRIB x.bli/notes:"*#G"/pos:2/nonotes
!will will set attributes with NONOTES attached
!This section of code is very similar in
!function to code in routine GETQUAL of
!module CRELM.BLI. Modification to this
!area of code should probably be duplicated
!in the CRELM module.
begin ! loop thru qualifiers
selectone .b_qual[qua_code] of
set
[k_history_qual]:
begin
f_chr_q = true ;
f_nochr_q = false;
$str_desc_init(descriptor=d_chr_str,string=b_qual[qua_value]);
end ;
[k_nohistory_qual]:
begin
f_nochr_q = true ;
f_chr_q = false;
end;
[k_notes_qual]:
begin
f_not_q = true ;
f_nonot_q = false;
$str_desc_init(descriptor=d_not_str,string=b_qual[qua_value]) ;
end ;
[k_nonotes_qual]:
begin
f_nonot_q = true ;
f_not_q = false;
end;
[k_position_qual]:
begin
f_pos_q = true ;
$str_desc_init(descriptor=d_pos_str,string=b_qual[qua_value]) ;
end ;
[otherwise]:
! ignore any other qualifiers ;
tes ;
b_qual = .b_qual[qua_a_next] ;
end ; ! loop thru qualifiers
true
END; ! end of routine savpar
END ! End of module
ELUDOM