Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/filops.b36
There are no other files named filops.b36 in the archive.
module filops ( ! File operations not provided by XPORT.
%if %bliss(bliss36) %then
%if %switches(tops20) %then
language(bliss36)
%else
%error('DS-10 support not implemented')
%fi
%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 provides routines to perform certain file operations
! not currently provided by XPORT. For example, one routine
! sets the protection codes for a file being created.
!
! Environment:TOPS-20
!
! Author: Earl Van Horn Creation Date: December 14, 1979
!
!--
!
! Table of Contents:
!
forward routine
truncate, ! truncate a file (given file name)
jfn_truncate, ! truncate a file specified by a jfn
spcfil, ! Determine if file is "special"
delvrs, ! Keep zero or more versions, delete the rest.
isfile, ! TRUE if a file exists.
jfnstr:novalue, ! Convert a JFN to a string
nateql, ! TRUE if two specs. have same name and type.
mrkrev : novalue, ! Set the revision time of a file.
protec : novalue, ! Set protection codes for XPORT-opened file.
revmrk, ! Get revision time of a file.
vernum, ! Get the version number from a file spec.
wilds ; ! Find the files specified by wild cards.
!
! Include Files:
!
require 'JSYS:' ;
undeclare %quote $chlfd ;
undeclare %quote $chcrt ;
require 'TENDEF:' ;
library 'XPORT:' ;
require 'BLISSX:' ;
require 'SCONFG:' ;
require 'FILUSR:' ;
require 'TIMUSR:' ;
require 'ZONUSR:' ;
!
! Macros:
!
MACRO
fbusw = 20,0,36,0 % , ! user settable word in FDB
fbwrt = 12,0,36,0 %, ! date and time field in FDB
owner = 0,12,6,0 %, ! Owner part of protection
group = 0,6,6,0 %, ! Group part of protection
world = 0,0,6,0 % ; ! World part of protection
!
! Equated Symbols:
!
literal
debug = false; ! do NOT generate debug code
!
! Own Storage:
!
!
! External References:
!
external literal
s_nodelete; ! can't delete file
external routine
badiob : novalue, ! Report library problem involving an IOB.
bug : novalue, ! Report a bug.
bugsts : novalue, ! Report a bug involving a system status code.
bugxpo : novalue, ! Report a bug involving an XPORT status code.
cvtas0 : novalue, ! Convert string to ASCIZ
dirspc : novalue, ! Find the directory portion of a file spec.
err, ! Report a user mistake.
errsts, ! Report a user mistake with a status code.
freas0, ! free memory for asciz string
fresad : novalue, ! Free the storage allocated by the CAT macro.
isdir, ! TRUE means a directory exists.
sysmsg, ! Inform the user.
timcop : novalue ; ! Copy a system time value.
GLOBAL ROUTINE TRUNCATE (a_d_file_spec, a_position, a_err_routine) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Truncate a file to the given position (less than or equal to its
! current size.
!
! FORMAL PARAMETERS:
!
! a_d_file_spec Address of a descriptor for the filename
! string.
!
! a_position Address of system dependent position data.
! For TOPS-20, it is a full-word containing
! a byte_count.
!
! a_err_routine Address of an error routine to be called if
! an error occurs. It is called with two
! parameters:
! status - system status code
! d_msg - descriptor of error msg text
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! true = success
! false = failure
!
! SIDE EFFECTS:
!
!
!--
BEGIN
BIND
d_file_spec = .a_d_file_spec : $str_descriptor(),
position = .a_position;
BIND ROUTINE
err_routine = .a_err_routine;
LOCAL
$oc_block_decl(trn), ! XPORT IOB
jfn, ! job-file-number for operation
status; ! hold return status code
!+
! Use XPORT to allocate and deallocate the JFN needed to do the
! file truncation. XPORT allocates a JFN and opens the file in
! one indivisible step.
!-
$oc_block_init (trn);
status = $cms_open (iob = trn_iob,
file_spec = d_file_spec,
options = append,
failure = 0);
if not .status
then
begin ! Could not open for truncation.
err_routine(.status,
cat('Unable to open file ',d_file_spec,
' for truncation (TRUNCATE)')) ;
return false ;
end ; ! Could not open for truncation.
jfn = .trn_iob[iob$h_channel]; ! pick up JFN from XPORT
if not jfn_truncate (.jfn, 7, .position)
then
begin ! Could not truncate
geter ($fhslf; status);
err_routine(.status,
cat('Unable to truncate the correct record in file',
d_file_spec, ' (TRUNCATE)')) ;
return false ;
end ; ! Could not truncate
status = $cms_close (iob = trn_iob, failure = 0);
if not .status
then
begin ! Could not close after truncation.
err_routine(.status,
cat('Unable to close file ',d_file_spec,
' after truncation (TRUNCATE)')) ;
return false ;
end ; ! Could not close after truncation.
true
END; !(of routine TRUNCATE)
global routine jfn_truncate (jfn, byte_size, byte_count) =
!++
! Functional Description:
!
! Set the byte_size and byte_count for specified file. This can be
! used to perform a truncate operation by specifing a byte_size -
! byte_count product less than the current size.
!
! Is this enough?
!
! Formal Parameters:
!
! jfn - Assigned and opened file jfn
! byte_size - Byte size of data in file (usually 7) or zero.
! byte_count - A count of the number of bytes to be considered part
! of the file.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! true - file truncated
! false - error; File not truncated but some of its characteristics
! may have been changed. The system error code is available
! from the geter jsys.
!
! Side Effects:
!
! The byte_size associated with this JFN is changed for the
! remainder of its lifetime.
!
!--
begin
local
skips, ! number of skips taken by jsys
! or number of effective skips
error_code, ! TOPS-20 standard error number
! if CHFDB jsys fails, GETER must
! be used to get error number.
dummy, ! dummy output param for jsys calls
bytes_per_word, ! number of bytes per 36 bit word
word_count, ! .byte_count measured in words
used_page_count, ! .byte_count measured in pages
fdb_byte_count, ! count from file descriptor block
fdb_page_count; ! count from file descriptor block
! set the byte-size for this opening of file (side effect)
skips = SFBSZ (.jfn, .byte_size; error_code);
if .skips eql 0 ! did jsys fail?
then
return false; ! return failure
! set the file pointer to position we want to truncate to
skips = SFPTR (.jfn, .byte_count; error_code);
if .skips eql 0
then
return false;
! write out a words worth of zero bytes
SOUT (.jfn, ! destination designator
ch$ptr(uplit(0),0,7), ! pointer to string to be written
-(36/.byte_size), ! number of bytes to cover one word
0; ! unused - termination byte
dummy, ! updated pointers not needed
dummy, ! "
dummy); ! "
! set sizes in the file descriptor block
skips = chfdb (hwf($fbbyv,.jfn), fb_bsz, fld(.byte_size,fb_bsz));
if .skips eql 0
then
return false;
skips = chfdb (hwf($fbsiz,.jfn), -1, .byte_count);
if .skips eql 0
then
return false;
! determine if there are pages after the EOF mark
skips = sizef (.jfn; fdb_byte_count, fdb_page_count);
if .skips eql 0
then
return false;
bytes_per_word = 36 / .byte_size;
word_count = (.byte_count+.bytes_per_word-1) / .bytes_per_word;
used_page_count = (.word_count+511) / 512;
%if debug %then ! debug code
$xpo_put_msg (string =
$str_concat ('Used-page-count : FDB-page-count ',
$str_ascii(.used_page_count),
' : ',
$str_ascii(.fdb_page_count)) );
%fi ! end debug code
!+
! Release the disk pages that are no longer in use. This MUST be done
! to avoid strainge error messages when accessing the file. EX:
! [Pages after EOF not copied]
!-
if .used_page_count lss .fdb_page_count
then
begin
! I think the pages are actually deleted when the file is closed.
skips = pmap (-1,
hwf(.jfn,.used_page_count),
pm_cnt or (.fdb_page_count - .used_page_count) );
if .skips eql 0
then
return false;
end;
! normal successfull completion
return true;
end; !(of routine jfn_truncate)
global routine spcfil (jfn) =
!++
! Functional Description:
!
! Determine if file represented by this JFN is "nice", i.e. not a
! not a terminal, not a spooled file, and on a structured
! file-oriented device.
!
! Formal Parameters:
!
! jfn
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! true - if "special" file
! false - if normal file
!
! Side Effects:
!
! None
!
!--
begin
local
dev_chr, ! characteristics word
dev_desig, ! device designator (place holder)
job_and_units; ! job number (place holder)
!+
! Do special test for jfn=0.
! When XPORT opens TTY: it sets [iob$v_terminal] to true and
! [iob$h_channel] to zero. These are then used as flags to force
! special processing for GET and PUT operations. No JFN is actually
! allocated.
!-
if .jfn eql 0
then
return false;
dvchr(.jfn; dev_desig, dev_chr, job_and_units);
!+
! Preform sequence of test for a special device. Return true as soon
! as a test suceeds. Return false if ALL test fail.
!-
! not a disk --> special
if .dev_chr<18,9> neq $dvdsk
then
return true;
! neither single directory or multiple directory device --> special
if .dev_chr and (dv_dir or dv_mdd) eql 0
then
return true;
return false;
end; !(of routine valdev)
global routine delvrs(number_to_keep, spec_len, spec_ptr) =
!++
! Functional Description:
!
! This routine accepts a file specification that has an explicit
! file name component, an explicit file type, no wild cards, no version
! number, and no version number delimiter. It deletes all but the
! first N versions of the file, where N may be zero.
!
! All files to be deleted must be closed.
!
! If a file that would be deleted is protected from deletion, it is
! ignored. The user is informed only if the file is not in the library.
! In any case, processing continues, because this is not considered
! an error.
!
! Formal Parameters:
!
! number_to_keep: The number of versions not to delete. The versions
! not deleted are the ones with the highest version
! numbers. Zero means delete all versions.
! spec_len: The number of characters in the file specification.
! spec_ptr: A character pointer to the first character of the
! file specification. The restrictions on the
! specification are given above.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! The number of files deleted.
!
! Side Effects:
!
! None
!
!--
begin ! DELVRS
local
error, ! error bits
file_z_ptr,
file_desc_block : desc_block,
handle : block[1], ! JFN of file to be deleted
number_deleted, ! number of files deleted
own_num_to_keep, ! just in case
skips, ! check for errjmp
temp: block[1] ; ! for flag bits
! Check the number to keep.
if .number_to_keep lss 0
then
bug(lit('DELVRS was given a negative number to keep')) ;
! Save number for later comparison
own_num_to_keep = .number_to_keep ;
! Make sure there are no wild cards in the specification.
if not ch$fail(ch$find_ch(.spec_len, .spec_ptr, %c'*'))
or not ch$fail(ch$find_ch(.spec_len, .spec_ptr, %c'%'))
then
bug(cat('DELVRS found a wild card in "', (.spec_len, .spec_ptr),
'"')) ;
! make file string asciz
$str_desc_init ( descriptor = file_desc_block,
string = (.spec_len,.spec_ptr));
cvtas0(file_desc_block, file_z_ptr);
! Get the file's JFN
temp = 0 ;
temp = gj_sht or gj_old ;
skips = gtjfn (.temp,.file_z_ptr;handle ) ;
! free dynamic memory allocated by CVTAS0 call
freas0(.file_z_ptr);
! Check return
if .skips eql 0
then
return 0 ;
! Call DELNF to delete the specified number of files
skips = delnf ( .handle,.number_to_keep ; error, number_deleted ) ;
if .skips eql 0
then
begin
selectone .error of
set
[delfx1] :
sysmsg(s_nodelete,cat((.spec_len,.spec_ptr),
' is protected from deletion'),0);
[otherwise] :
bug(cat('DELVRS could not delete ', (.spec_len,.spec_ptr)));
tes;
end;
! release allocated JFN's
rljfn(.handle);
.number_deleted
end ; ! DELVRS
global routine isfile(spec_len, spec_ptr, a_is_valid) =
!++
! Functional Description:
!
! This routine determines if a specified file exists. If the
! specification contains one or more wild cards, the routine
! determines if there is at least one file satisfying the specification.
!
! Only the existence of the file is tested, not whether the process
! is permited to access it in any particular way.
!
! If the address of a fullword is supplied for storing validity status,
! any problem such as a missing directory is reported as a user mistake,
! and the validity status is set to FALSE. If no such fullword is
! supplied, any problem is reported as a bug.
!
! Formal Parameters:
!
! spec_len: Number of characters in the specification.
! spec_ptr: Character pointer to the first character of the
! specification.
! a_is_valid: Address of a fullword to receive validity status.
!
! TRUE means no user-reported problem occurred. If
! the value of isfile is returned as true, TRUE (for
! a_is_valid) means that the specification is well
! formed and the directory is accessible. If the
! value of isfile is returned as false, TRUE (for
! a_is_valid) means that there was no user-reported
! problem, so the file itself was missing or invalid.
!
! FALSE means a problem has been reported as a user
! mistake. FALSE will only occur in conjunction
! with the false return of isfile.
!
! In table form:
!
! isfile a_is_valid
! value: (status code):
!
! T T
! F T (no errmsg)
! F F (errmsg-user mistake)
!
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE is returned if at least one file satisfying the specification
! exists. The validity status, if asked for, is necessarily set to
! TRUE in this case. FALSE is returned if no such file exists, or if
! validity status is set to FALSE.
!
! Side Effects:
!
! None
!
!--
begin ! ISFILE
bind
is_valid = .a_is_valid ;
local
file_desc : desc_block,
file_z_ptr,
handle,
skips,
temp ;
routine stop_search(JFN, num_so_far) =
false ; ! Found one, so look no further.
!+
! Try to find at least one file ( because wilds will fail
! if file doesn't exist
!-
$str_desc_init( descriptor = file_desc,
string = (.spec_len, .spec_ptr)) ;
cvtas0 ( file_desc, file_z_ptr ) ;
skips = gtjfn ( gj_sht or gj_old or gj_ifg, .file_z_ptr; handle ) ;
! return dynamic memory allocated by CVTAS0
freas0(.file_z_ptr);
! check for errors in GTJFN jsys
if .skips eql 0 or .handle eql gjfx24
then
return false;
rljfn(.handle ; temp) ;
wilds(.spec_len, .spec_ptr, stop_search, is_valid) geq 1
end ; ! ISFILE
GLOBAL ROUTINE jfnstr (a_handle, a_file_desc):novalue =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine returns a full file specification from
! a given JFN. It puts the resultant in desc_block
! format.
!
!-
! FORMAL PARAMETERS:
!
! a_handle - address of word containing the JFN of the file
! a_file_desc - address of desc_block for resultant file spec.
! If the descriptor is class=static, the length is adjusted
! to match the length of the file_desc. In all cases
! the string is copied to descriptor.
!
! IMPLICIT INPUTS:
!
! The format of the string returned is the standard format -
! with punctuation.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! The desc_block is updated with the length and pointer
! to the file specification.
!
!--
BEGIN ! Routine JFNSTR
bind
file_desc = .a_file_desc : $str_descriptor(),
handle = .a_handle : block[1];
literal
format = %o'111110000001' ; ! format mask to jfns
local
upd_ptr, !updated string pointer
len, !length of file spec
ptr, !temporary pointer to file spec
resultant : vector[ch$allocation(extended_file_spec)], ! file spec
skips ;
ptr = ch$ptr(resultant) ;
! Use JFNS to get file spec
skips = jfns(.ptr, .handle[rh], format, 0 ; upd_ptr) ;
! set length of string
len = ch$diff(.upd_ptr, .ptr);
if (.file_desc[str$b_class] eql str$k_class_f and
.file_desc[str$h_length] gtr .len)
then
file_desc[str$h_length] = .len;
! Update desc_block
$str_copy (target = file_desc,
string = (.len,.ptr));
END; ! end of routine JFNSTR
global routine mrkrev(a_iob, a_zone, a_time) : novalue =
!++
! Functional Description:
!
! This routine establishes the revision date and time that will be
! given to a file that has been opened by XPORT. It also marks the
! file so that it can be recognized that the file has been closed by
! CMS rather than by the host, as in the event of a system shutdown.
!
! In the VAX/VMS implementation, the mark is a revision number of 2.
! None of this is effective in the file itself until the file is closed.
!
! On the TOPS-20 version the mark is an "S" in the user-settable word
! of the FDB. This is effective as soon as the monitor calls are finished.
!
! Formal Parameters:
!
! a_iob: Address of an open IOB for the file to be marked.
! a_zone: For VAX/VMS :
! Address of the definition block for a zone in which
! data structures extending the IOB can be allocated.
! This zone must not be flushed until the IOB is closed
! without the REMEMBER option.
! For TOPS-20 : DUMMY ARGUMENT
! a_time: Address of a time block containing the time to be
! established as the revision date and time.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! None
!
!--
begin ! MRKREV
bind
iob = .a_iob : $xpo_iob(),
time = .a_time : time_block ;
local
ac2, ! index, flags and jfn
buf, ! word containg "S"
error_num, ! error returned by jsys call
handle, ! JFN of file
mask, ! mask for bits to be changed
new_mark, ! First argument to CHFDB for STEP mark
new_time, ! First argument to CHFDB for revision time
ptr , ! pointer to buffer
skips ; ! return from jsys calls
! Check the IOB argument.
if not
(.iob[iob$v_open] and .iob[iob$v_output] and not .iob[iob$v_terminal])
then
bug(lit('MRKREV was given an invalid IOB')) ;
! We want to set up as much as we can before the calls to CHFDB
! This way, if the system crashes, we minimize the chance of
! inconsistent data.
! Get JFN from IOB
handle = .iob[iob$h_channel] ;
! Put handle in b17-35 ( fld macro doesn't work for this )
new_time = .handle ;
new_mark = .handle ;
! Set up AC1 for new time call
new_time = .new_time or ! put handle in b17-b35
fld( $fbwrt, cf_dsp ) or ! specify index into FDB
fld ( true,cf_nud) ; ! don't update file yet
! Specify all bits to be changed
mask = -1 ;
! Set up arguments for the mark of STEP
new_mark = .new_mark or ! put handle in b17-b35
fld( $fbusw, cf_dsp ) or ! specify index into fdb
fld ( false, cf_nud ) ; ! this time update file
! An 'S' is the mark
buf = %c'S' ;
! Change the fdb, and hope for the best
if not chfdb ( .new_time, .mask, .time)
then
begin
geter($fhslf ; error_num ) ;
bugsts(.error_num,lit('MRKREV could not change FDB')) ;
end ;
if not chfdb ( .new_mark, .mask, .buf )
then
begin
geter($fhslf ; error_num ) ;
bugsts(.error_num,lit('MRKREV could not change FDB')) ;
end ;
end ; ! MRKREV
global routine protec(a_iob, a_zone,
owner_access, group_access, world_access) : novalue =
!++
! Functional Description:
!
! This routine establishes the protection that will be given to a file
! which has been opened by XPORT. Any combination of read, write,
! execute, and delete access may be given for the owner, group, or
! world. Protection may be set absolutely, or as a change to the
! protection the file would otherwise receive.
!
! Formal Parameters:
!
! a_iob: Address of an IOB for a file open for output.
! a_zone: Address of the block for a zone in which
! RMS control blocks will be allocated.
! Dummy argument for TOPS-20.
! owner_access: A fullword of bits defining the access to be given
! to the owner of the file. Instructions for
! constructing this fullword are given in FILUSR.REQ.
! group_access: Same for the group to which the owner belongs.
! world_access: Same for the world.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! The FDB for the file is updated.
!
!--
begin ! PROTEC
bind
iob = .a_iob : $xpo_iob() ;
map
owner_access : access_fullword,
group_access : access_fullword,
world_access : access_fullword ;
local
ac1, ! Argument to chfdb
handle, ! JFN of file
index, ! Index into FDB for protection word
mask, ! specifies bits to be changed
def_pro: block[1] , ! Default protection in FDB
new_pro : block[1], ! New protection codes for file
new_owner, ! New code for owner
new_group, ! New code for group
new_world, ! New code for world
step_owner : access_fullword ,
step_group : access_fullword,
step_world : access_fullword ,
def_owner, ! Default code for owner
def_group, ! Default code for group
def_world, ! Default code for world
error_num ; ! Error number returned by JSYS
! Check the IOB argument.
if not
(.iob[iob$v_open] and .iob[iob$v_output] and not .iob[iob$v_terminal])
then
bug(lit('PROTEC was called with an invalid IOB')) ;
! Check the access arguments.
begin ! Access arguments.
routine check_access(access) : novalue =
begin ! CHECK_ACCESS internal routine.
map
access : access_fullword ;
local
zero_test : access_fullword ;
zero_test = .access ;
zero_test[acc_set_bits] = 0 ;
zero_test[acc_reset_bits] = 0 ;
zero_test[acc_same] = 0 ;
if .zero_test neq 0
then
bug(lit('PROTEC was given an invalid access fullword')) ;
if ((.access[acc_set_bits] and .access[acc_reset_bits]) neq 0)
or (not .access[acc_same] and .access[acc_reset_bits] neq 0)
then
bug(lit('PROTEC was given an inconsistent access code')) ;
end ; ! CHECK_ACCESS internal routine.
check_access(.owner_access) ;
check_access(.group_access) ;
check_access(.world_access) ;
end ; ! Access arguments.
! Modify the protection codes in the FDB
begin ! Modify protection.
routine modify_pro(cur_pro_bits, access) =
begin ! MODIFY_PRO internal routine.
map
access : access_fullword ;
! Write implies delete on TOPS-20
access[acc_w_bit] = .access[acc_w_bit] or .access[acc_d_bit] ;
access[acc_no_w_bit] = .access[acc_no_w_bit]
and .access[acc_no_d_bit] ;
! Compute the new protection bits. Note that in TOPS-20
! protection bits are normal, i.e. a one bit means grant access
if not .access[acc_same]
then
.access[acc_set_bits]
else
(((.cur_pro_bits) or .access[acc_set_bits])
and not .access[acc_reset_bits])
end ; ! MODIFY_PRO internal routine.
! Get the current protection from the FDB
handle = .iob[iob$h_channel] ; ! Get JFN from IOB
index = 0 ; ! clear index into FDB
index = ( 1 ^ 18 ) or $fbprt ; ! set up index
if not gtfdb ( .handle, .index, def_pro )
then
begin
geter($fhslf ; error_num ) ;
bugsts(.error_num,lit('PROTEC could not get FDB'));
end ;
begin
routine t20tostep ( t20_word ) =
begin ! Convert TOPS-20 bits to STEP bits
map
t20_word : block[1] ;
local
temp ;
macro
r_bit = 0,5,1,0%,
w_bit = 0,4,1,0%,
e_bit = 0,3,1,0%,
a_bit = 0,2,1,0%,
l_bit = 0,1,1,0% ;
temp = 0 ;
temp = .t20_word[r_bit] ^ 0 or
.t20_word[w_bit] ^ 1 or
.t20_word[e_bit] ^ 2 or
.t20_word[a_bit] ^ 4 or
.t20_word[l_bit] ^ 5 ;
.temp
end ; ! Convert TOPS-20 bits to STEP bits
! Split out the three protection codes and convert them to STEP format
def_owner = 0;
def_group = 0 ;
def_world = 0 ;
def_owner = t20tostep (.def_pro[owner] ) ;
def_group = t20tostep (.def_pro[group] ) ;
def_world = t20tostep ( .def_pro[world] ) ;
end ; ! Convert TOPS-20 bits to STEP bits
begin
routine stepto20 ( step_word ) =
begin ! Convert STEP protection bits to TOPS-20
map
step_word : access_fullword ;
local
temp ;
temp = 0 ;
temp = .step_word[acc_r_bit] ^ 5 or
.step_word[acc_w_bit] ^ 4 or
.step_word[acc_e_bit] ^ 3 or
.step_word[acc_a_bit] ^ 2 or
.step_word[acc_l_bit] ^ 1 ;
.temp
end; ! Convert STEP protection bits to TOPS-20
! Set the new protection
new_pro = 0 ;
step_owner = 0 ;
step_group = 0 ;
step_world = 0 ;
step_owner = modify_pro(.def_owner, .owner_access) ;
step_group = modify_pro(.def_group, .group_access ) ;
step_world = modify_pro(.def_world, .world_access ) ;
new_pro[owner] = stepto20 ( .step_owner ) ;
new_pro[group] = stepto20 (.step_group ) ;
new_pro[world] = stepto20 ( .step_world) ;
end ; ! Convert STEP bits to TOPS-20 bits
end ; ! MODIFY_PRO internal routine
! Set up arguments for CHFDB
ac1 = 0 ;
ac1 = .handle or ! put JFN in b17-b35
fld($fbprt, cf_dsp) or ! indicate displacement into FDB
fld(false, cf_nud ) ; ! Update file
mask = %o'000000777777' ; ! Only want to update RH
if not chfdb ( .ac1, .mask, .new_pro )
then
begin
geter($fhslf ; error_num ) ;
bugsts(.error_num,lit('PROTEC could not change FDB')) ;
end ;
end ; ! PROTEC
global routine nateql(a_left_spec, a_right_spec) =
!++
! Functional Description:
!
! This routine compares two file specifications to see if they have
! the same file name component and file type.
!
! Because of a problem in $XPO_PARSE_SPEC, this routine ignores
! a single leading underscore in each specification. This restriction
! will be removed when XPORT is fixed.
!
! Similarly, leading "STEP$" (but not "_STEP$") is also ignored.
!
! Formal Parameters:
!
! a_left_spec: Address of a descriptor of one file specification.
! a_right_spec: Address of a descriptor of the other specification.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE means the specifications have the same file name components and
! file types. FALSE means they do not.
!
! Side Effects:
!
! None
!
!--
begin ! NATEQL
bind
left_spec = .a_left_spec : desc_block,
right_spec = .a_right_spec : desc_block ;
local
edited_spec : desc_block, ! Specification with no
! leading underscore. This is
! needed to work around an
! XPORT deficiency.
left_block : $xpo_spec_block, ! For left specification.
right_block : $xpo_spec_block, ! For right specification.
status ; ! Status code from XPORT.
! Parse the specifications. The parse must succeed.
if not (status = $xpo_parse_spec(file_spec = left_spec,
spec_block = left_block))
then
bugxpo(.status, lit('Bad left specification for NATEQL')) ;
if not (status = $xpo_parse_spec(file_spec = right_spec,
spec_block = right_block))
then
bugxpo(.status, lit('Bad right specification for NATEQL')) ;
! Compare the names and types.
ch$eql(len_comma_ptr(left_block[xpo$t_file_name]),
len_comma_ptr(right_block[xpo$t_file_name]))
and ch$eql(len_comma_ptr(left_block[xpo$t_file_type]),
len_comma_ptr(right_block[xpo$t_file_type]))
end ; ! NATEQL
global routine revmrk(file_spec_len, file_spec_ptr, a_time, a_by_step) =
!++
! Functional Description:
!
! This routine obtains a specified file's revision time, in system
! format. A parameter is set to TRUE if the file was closed by
! STEP. FALSE is returned if the file does not exist.
!
! Formal Parameters:
!
! file_spec_len: The number of characters in the file specification.
! file_spec_ptr: Character pointer to the first character of the
! file specification.
! a_time: Address of a time block into which to store the
! file's revision time.
! a_by_step: Address of a fullword that will be set to TRUE if
! the file exists and was closed by STEP, and to FALSE
! otherwise.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE is returned if the file exists, and FALSE otherwise.
!
! Side Effects:
!
! Any trouble with the file other than non-existence is reported
! by calling BADLIB or equivalent.
!
!--
begin ! REVMRK
bind
time = .a_time : time_block,
by_step = .a_by_step ;
local
char , ! Character in user-settable word
error_num, ! Extra error info
fdb : block[25] , ! Storage for FDB
file_desc: desc_block, ! temp descriptor for asciz string
file_z_ptr, ! pointer to asciz string
handle, ! JFN of file to be checked
ptr, ! Character pointer to user-settable word
skips, ! Return of monitor call
temp, ! flags for GTJFN call
words ; ! number of words of FDB desired
! Initialize
by_step = false ;
! Initialize descriptor to convert to ASCIZ
$str_desc_init ( descriptor = file_desc,
string = (.file_spec_len, .file_spec_ptr)) ;
cvtas0( file_desc, file_z_ptr) ;
! Get the JFN for the file
temp = gj_sht or gj_old ; ! Request short form and require that the file exists
skips = gtjfn ( .temp, .file_z_ptr ; handle ) ;
! return dynamic memory
freas0(.file_z_ptr);
! Check return
if .skips eql 0
then
return false ;
! Now get the FDB
words = 0 ; ! Clear
words = 25 ^ 18 ; ! Set number of words to be 25. This must be in the left half.
! The offset is zero
if not gtfdb ( .handle, .words, fdb ) ! This always returns +1
then
begin
geter($fhslf ; error_num ) ;
bugsts(.error_num,cat('Unable to get FDB for "',
(.file_spec_len,.file_spec_ptr),'"')) ;
end ;
! Copy the time where the caller wants it.
timcop (fdb[fbwrt], time) ;
! release the JFN
rljfn(.handle;handle) ;
! Determine if the file was closed by STEP.
by_step = .fdb[fbusw] eql %c'S' ;
true
end ; ! REVMRK
global routine vernum(a_file_spec) =
!++
! Functional Description:
!
! This routine returns the binary version number of the file
! specification whose descriptor is supplied. Zero means the
! specification did not have a version number.
!
! Formal Parameters:
!
! A_FILE_SPEC Address of a descriptor of the file specification
! whose version number is to be returned.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! If the file specification has an explicit version number it is
! returned. Otherwise zero is returned.
!
! Side Effects:
!
! None
!
!--
begin ! VERNUM
bind
file_spec = .a_file_spec : desc_block ;
local
file_z_ptr, ! pointer to ASCIZ string
index :block[1], ! index into FDB
jfn, ! JFN of file
result:block[1], ! Routine value.
status ; ! XPORT status code.
! Convert string to ASCIZ
cvtas0( file_spec, file_z_ptr) ;
! Get JFN of file
! Try first with a new file - if that doesn't work, try again
! with an old file
status = gtjfn(gj_sht or gj_new, .file_z_ptr ; jfn ) ;
if .status neq 1
then
begin ! Try again with old file
status = gtjfn(gj_sht or gj_old, .file_z_ptr ; jfn);
if .status neq 1
then
return 0 ;
end ; ! Try again with old file
! Get FDB of file
index[lh] = 1; ! Specify one word to be retrieved
index[rh] = $fbgen ; ! Indicate displacement into FDB
if not gtfdb( .jfn, .index, result)
then
return 0 ;
! release JFN
rljfn( .jfn ; jfn) ;
.result[lh]
end ; ! VERNUM
global routine wilds(wild_spec_len, wild_spec_ptr, a_found_routine,a_is_valid)=
!++
! Functional Description:
!
! This routine accepts a file specification that may have wild cards
! and calls the supplied routine for each file that satisfies the
! specification. It returns a count of the number of times the
! routine was called.
!
! The supplied routine is called with a host dependent handle for the
! file that was found, and a count of the number of files found so far.
! It must return TRUE or FALSE depending on whether the search should
! continue or be aborted.
!
! If the address of a fullword is supplied for storing validity status,
! any problem that could be a user mistake, such as an invalid
! specification, is reported as a user mistake, and the validity status
! is set to FALSE. If no such fullword is supplied, any problem is
! reported as a bug.
!
! Formal Parameters:
!
! wild_spec_len: Number of characters in the file specification, which
! may contain wild cards.
! wild_spec_ptr: Character pointer to the first character of the
! specification.
! a_found_routine:Address of a routine to call for each file found. The
! caller should declare this routine as follows:
!
! ROUTINE FOUND(HANDLE, COUNT) =
!
! HANDLE is a host dependent designation of the file that
! was found. On VAX/VMS it is the address of a FAB that
! has a NAM block attached. On TOPS-20 it is a JFN.
!
! COUNT is the number of times that FOUND has been
! called, e.g., the first time FOUND is called COUNT
! will be 1.
!
! If FOUND returns TRUE, the search will continue.
! If FOUND returns FALSE, the search terminates
! immediately without looking for any more files.
!
! a_is_valid: Address of a fullword to receive validity status.
! TRUE means there were no problems, e.g., the
! specification was well formed and the directory was
! accessible. FALSE means a problem has been reported
! as a user mistake. If the address supplied is K_NULL,
! any problem is reported as a bug.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! The number of times the argument routine was called. This may be
! less than the number of matching files if the argument routine
! returned FALSE. Zero is returned if the validity status is
! set to FALSE.
!
! Side Effects:
!
! Note: The search order is in decending file version number, since
! RECOVR and VCNTRL expect ot see the most recently created file
! first.
!
!--
begin ! WILDS
bind
is_valid = .a_is_valid ;
bind routine
found_routine = .a_found_routine ;
literal
ch_per_wd = 5, ! number of ascii character per fullword
k_exp_fil_size = file_spec_size + 5,
! expect filename size in characters
k_init_stk = 5, ! initial file stack size (number of entries)
req_mask = %o'111110000001'; ! request mask for jfns call to get
! filename,ext,gen no
local ! ****** was: own
a_filstk: ref blockvector[,k_fil_stk_full] field(fil_stk_ent),
! address of current stack
a_cur_chn: ref block[k_chn_blk_full] field(chn_blk),
! chain block for remembering
! pointers to allocated text blocks
a_newstk: ref blockvector[,k_fil_stk_full] field(fil_stk_ent),
! address of new stack
cur_stk_size, ! cur number of entries for stack
f_pur_ext, ! purge stack and exit flag
f_len, ! len of this filename
file_desc :desc_block, ! MAke string ASCIZ
file_z_ptr, ! Pointer to ASCIZ string
ini_txt_blk, ! initial text block
lst_chn_addr, ! address of previous chain block
number_found, ! Number of times FOUND_ROUTINE
! was called.
next_blk, ! save area for backward link
nxt_txt_blk, ! address of next txt block
p_cur_txt, ! pointer to current position in text
! block
flag_bits, ! bits to turn on for GTJFN call
s_indx, ! current stack index(for the blockvector)
skips, ! Number of skips taken after JSYS call
status, ! status word
t_indx, ! temp index used for copy operation
t_handle, ! temp handle
temp : block[1], !
handle : block[1] , ! Return of GTJFN call
next_handle: block[1], ! Used for next file in group
unuse_ch, ! number of unused character left
u_ptr ; ! updated string pointer
! initialize selected values
lst_chn_addr = k_null ;
a_cur_chn = k_null ;
f_pur_ext = false ;
if is_valid neq k_null
then
is_valid = false ;
! Check the length of the specification.
if .wild_spec_len gtr extended_file_spec
then
begin ! Bad length.
if is_valid eql k_null
then
bug(cat('The specification beginning with "', (20, .wild_spec_ptr),
'" is too long for WILDS')) ;
err(cat('The specification beginning with "', (20, .wild_spec_ptr),
'" is too long')) ;
return 0 ;
end ; ! Bad length.
! set up initial memory for stack
$xpo_get_mem(fullwords=k_init_stk*k_fil_stk_full,
result= a_filstk) ;
cur_stk_size = k_init_stk ;
! get memory for the text of the filenames
$xpo_get_mem(characters=k_init_stk * k_exp_fil_size,
result=ini_txt_blk) ;
! Make string ASCIZ
$str_desc_init(descriptor = file_desc,
string = (.wild_spec_len, .wild_spec_ptr)) ;
cvtas0( file_desc, file_z_ptr) ;
%if 0 %then !***** debug ***********************************************
$xpo_put_msg (string = $str_concat ('WILDS called for ', file_desc));
%fi !***** debug ***********************************************
! Initialize the accumulators for JSYS call
temp = gj_sht OR gj_old OR gj_ifg OR gj_flg ;
! Get the file's JFN
skips = gtjfn(.temp, .file_z_ptr; handle) ;
freas0(.file_z_ptr) ;
! check results of call
if .skips eql 0
then
begin ! problem with file spec
! Report a user mistake if the user asked for a validity check and
! the problem is one that could be a user mistake.
if is_valid neq k_null
then
begin ! Report a mistake.
err(cat('There is a problem with "',
(.wild_spec_len, .wild_spec_ptr), '"')) ;
return 0 ;
end ! Report a mistake.
else
! Otherwise report a bug.
bug(cat('WILDS cannot parse "',
(.wild_spec_len, .wild_spec_ptr), '"')) ;
end ; ! Parse problem.
! Find the files. One already exists for the first call to FOUND
next_handle = .handle ;
number_found = 0 ;
p_cur_txt = .ini_txt_blk;
unuse_ch = k_init_stk * k_exp_fil_size ;
s_indx = 0 ;
!+
! put first jfn filename on the stack
!-
! get text of filename for this jfn
jfns(.p_cur_txt,.handle[rh],req_mask,0;u_ptr) ;
f_len = ch$diff(.u_ptr,.p_cur_txt) ;
if
.f_len gtr K_exp_fil_size
then
bug(cat('Length of file name string greater than expected. (WILDS)'));
! set up descriptor
$str_desc_init(descriptor=a_filstk[.s_indx,filtxt],
string=(.f_len,.p_cur_txt)) ;
! update pointers and count
s_indx = .s_indx + 1 ;
unuse_ch = .unuse_ch - .f_len ;
p_cur_txt = ch$plus(.p_cur_txt,.f_len) ;
!+
! Now loop thru the rest of the wild card files
!-
while .skips neq 0 do
begin ! get next file in the group loop
! Get next file in group
skips = gnjfn (.handle ; next_handle) ;
! Only allow wild cards in version number or file extension or file name
! Pointr is a macro that uses the mask as on offset
if pointr(.next_handle,gn_str) or
pointr(.next_handle,gn_dir) or
.skips eql 0
then
f_pur_ext = true ; ! force stack purge and loop exit
if
pointr(.next_handle,gn_nam) or
pointr(.next_handle,gn_ext) or
.f_pur_ext
then
begin ! new file or ext
!+
! decrement stack pointer as it normally points to the next
! available empty slot on the stack. For the subsequent
! purge of the stack it is necessary to start with the
! last filled slot on the stack.
!-
s_indx = .s_indx - 1 ;
! stack purge loop
until
.s_indx lss 0
do
begin ! generate call to found routine
! reset temp for subsequent translates
temp = 0 ;
temp = gj_sht OR gj_old OR gj_flg ;
! translate filename text to JFN
cvtas0(a_filstk[.s_indx,filtxt],file_z_ptr) ;
status = gtjfn(.temp,.file_z_ptr;t_handle) ;
! obtain JFN ok?
if
.status eql 0
then
bug(cat('WILDS cannot translate ',a_filstk[.s_indx,filtxt],
'into a JFN')) ;
freas0(.file_z_ptr) ;
number_found = .number_found + 1 ;
if not found_routine (t_handle, .number_found)
then
begin ! Search terminated.
if is_valid neq k_null
then
is_valid = true ;
rljfn (.t_handle ; status); ! release this JFN
rljfn (.handle;next_handle) ; ! Release all JFN's
! free all of memory
$xpo_free_mem(binary_data=(.cur_stk_size * k_fil_stk_full,
.a_filstk,fullwords)) ;
! free chain blocks and text blocks
until
.a_cur_chn eql k_null
do
begin ! free blocks
$xpo_free_mem(string=(k_init_stk * k_exp_fil_size,
.a_cur_chn[txt_ptr])) ;
! save address of next block
next_blk = .a_cur_chn[bw_lnk] ;
$xpo_free_mem(binary_data=(k_chn_blk_full,.a_cur_chn,fullwords)) ;
a_cur_chn = .next_blk ;
end ; ! free blocks
return .number_found ;
end ; ! Search terminated.
! processing of this filename complete - release JFN
rljfn(.t_handle;status) ;
! any more entries left on the stack to process?
if
.s_indx gtr 0
then
s_indx = .s_indx - 1
else
begin ! stack purged - reset for next filename
! free up old stack
!*******************************************************
! $xpo_free_mem(binary_data=(.cur_stk_size * k_fil_stk_full,
! .a_filstk,fullwords)) ;
! set up initial memory for stack
$xpo_get_mem(fullwords=k_init_stk*k_fil_stk_full,
result= a_filstk) ;
cur_stk_size = k_init_stk ;
! free chain blocks and text blocks
until
.a_cur_chn eql k_null
do
begin ! free blocks
$xpo_free_mem(string=(k_init_stk * k_exp_fil_size,
.a_cur_chn[txt_ptr])) ;
! save address of next block
next_blk = .a_cur_chn[bw_lnk] ;
$xpo_free_mem(binary_data=(k_chn_blk_full,.a_cur_chn,fullwords)) ;
a_cur_chn = .next_blk ;
end ; ! free blocks
p_cur_txt = .ini_txt_blk ;
unuse_ch = k_init_stk * k_exp_fil_size;
! clear chain block pointer
a_cur_chn = k_null ;
! make sure index starts at 0
s_indx = 0 ;
exitloop ;
end ; ! stack purged - reset for next filename
end ; ! generate calls to found routine
end ; ! new file or ext
!+
! Additional memory allocation processing.
!-
! check if stack big enough
if
.s_indx eql .cur_stk_size
then
begin ! need additional stack space
$xpo_get_mem(fullwords=(.cur_stk_size + k_init_stk) * k_fil_stk_full,
result=a_newstk) ;
! copy the stack
t_indx = 0 ;
until
.t_indx eql .s_indx
do
begin ! copy
$str_desc_init(descriptor=a_newstk[.t_indx,filtxt],
string=a_filstk[.t_indx,filtxt]) ;
t_indx = .t_indx + 1 ;
end ; ! copy
$xpo_free_mem(binary_data=(.cur_stk_size * k_fil_stk_full,
.a_filstk,fullwords)) ;
a_filstk = .a_newstk ;
cur_stk_size = .cur_stk_size + k_init_stk ;
end ; ! need additional stack space
! check if enough room in text block area
if
.unuse_ch lss k_exp_fil_size
then
begin ! need more memory in the text area
! get memory for chain blocks
$xpo_get_mem(fullwords=k_chn_blk_full,result=a_cur_chn) ;
! get memory block for filename text area
$xpo_get_mem(characters=k_init_stk * k_exp_fil_size,
result=a_cur_chn[txt_ptr]) ;
a_cur_chn[bw_lnk] = .lst_chn_addr ;
lst_chn_addr = .a_cur_chn ;
! set up pointers and counts
p_cur_txt = .a_cur_chn[txt_ptr] ;
unuse_ch = k_init_stk * k_exp_fil_size ;
end ; ! need more memory in the text area
if
.skips neq 0
then
begin ! load it on the stack
!+
! Put filename for this JFN on the FILENAME STACK
!-
! get text of this JFN
jfns(.p_cur_txt,.next_handle[rh],req_mask,0;u_ptr) ;
f_len = ch$diff(.u_ptr,.p_cur_txt) ;
if
.f_len gtr K_exp_fil_size
then
bug(cat('Length of file name string greater than expected. (WILDS)'));
! set up descriptor for this entry on the stack
$str_desc_init(descriptor=a_filstk[.s_indx,filtxt],
string=(.f_len,.p_cur_txt)) ;
! update stack pointer
s_indx = .s_indx + 1 ;
! update text area pointers
unuse_ch = .unuse_ch - .f_len ;
p_cur_txt = ch$plus(.p_cur_txt,.f_len) ;
end ; ! load it on the stack
! exit main loop require?
if
.f_pur_ext
then
exitloop;
end ; ! get next file in group loop
! release all JFN's
rljfn(.handle;next_handle) ;
! free up stack and initial text block
!*****************************************************
! $xpo_free_mem(binary_data=(.cur_stk_size * k_fil_stk_full,.a_filstk,fullwords)) ;
! $xpo_free_mem(string=(k_init_stk * k_exp_fil_size,.ini_txt_blk)) ;
!*****************************************************
! No more files
if is_valid neq k_null
then
is_valid = true ;
.number_found
end ; ! WILDS
end ! Module FILOPS
eludom