Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/dirops.bli
There are no other files named dirops.bli in the archive.
module dirops ( ! Host-dependent directory operations
%if %bliss(bliss32) %then
ident = '1',
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 provides routines to perform certain operations on
! directories. For example, one routine tests the existence of
! a directory.
!
! Environment: VAX/VMS, TOPS-20
!
! Author: Earl Van Horn Creation Date: May 1980
!
!--
!
! Table of Contents:
!
forward routine
dirspc : novalue, ! Extract the directory portion of a file spec.
fuldir, ! Return the full specification of a directory.
hasnet, ! Test a specification for network use.
isdir, ! Return TRUE if a specified directory exists.
cmsdir, ! full spec of non_special dir.
localf ; ! Report error on network attempt.
!
! Include Files:
!
%if %bliss(bliss32) %then
library 'SYS$LIBRARY:STARLET' ;
undeclare %quote $descriptor ; ! Conflict with XPORT
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
require 'JSYS:' ;
undeclare %quote $chlfd ;
undeclare %quote $chcrt ;
require 'TENDEF:' ;
%fi
%fi
library 'XPORT:' ;
require 'BLISSX:' ;
require 'SCONFG:' ;
!
! Macros:
!
!
! Equated Symbols:
!
!
! Own Storage:
!
!
! External References:
!
external literal
s_dcantget, !cannot get directory for...
s_ddnotfnd, !cant find directory description
s_errdev, !device is restricted, in use, or doesnt exist
s_errmisc, !problem with...
s_mustbedir, !must be a directory, not a file spec
s_neterr, !requires network activity not supported
s_nolib, !library not found
s_nowldcard, !wild cards not allowed
s_spcinv, !invalid directory specification
s_toolong; !the specification is too long
external routine
bug : novalue, ! Report a bug.
bugsts : novalue, ! Report a bug involving a system status code.
%if %bliss(bliss36) %then
%if %switches(tops20) %then
cvtas0,
%fi
%fi
err, ! Report a user mistake and continue.
ers, ! Report a user mistake.
errsts, ! Report a user mistake w/status and continue.
erssts, ! Report a user mistake with a status code.
fresad : novalue, ! Free a string and descriptor.
isfile, ! does the file exist ?
maksad, ! Allocate a string and descriptor.
%if VaxVms %then
spcfil, ! special file ?
%fi
trnlog ; ! Translate a logical name.
global routine dirspc(a_file_spec, a_dir_spec) : novalue =
!++
! Functional Description:
!
! This routine initializes a descriptor to denote the directory
! portion of a given file specification string.
!
! Formal Parameters:
!
! a_file_spec: Address of a descriptor denoting the file specification
! whose directory portion is to be found.
! a_dir_spec: Address of a descriptor to be initialized to denote
! the directory portion of the string denoted by the
! first parameter.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! None
!
! Side Effects:
!
! None
!
!--
begin ! DIRSPC
bind
file_spec = .a_file_spec : desc_block,
dir_spec = .a_dir_spec : desc_block ;
! Assume there is no directory portion.
$str_desc_init(descriptor = dir_spec, string = (0, .file_spec[desc_ptr])) ;
! Find the last character of the directory portion.
decr i from .file_spec[desc_len] to 1 do
selectone ch$rchar(ch$plus(.file_spec[desc_ptr], .i - 1)) of
set ! Examine one character.
[%c'A' to %c'Z', %c'a' to %c'z', %c'0' to %c'9',
%c'*', %c'%', %c'.', %c';']:
; ! Continue looking.
! TOPS-20 allows dollar signs, hyphens and underscores as
! part of a legal file specification
%if %bliss(bliss36) %then
%if %switches(tops20) %then
[%c'$',%c'-',%c'_']:
; ! Continue looking
%fi
%fi
[otherwise]:
begin ! Found the end.
dir_spec[desc_len] = .i ;
exitloop ;
end ; ! Found the end.
tes ; ! Examine one character.
end ; ! DIRSPC
global routine fuldir(spec_len, spec_ptr, a_is_valid, a_is_library) =
!++
! Functional Description:
!
! This routine determines if a specified directory exists. It also
! develops the full specification of the directory, in which all logical
! names and defaults are evaluated. The specification must have no wild
! cards, and have no file name, type, version number, or delimiters that
! would separate them.
!
! Only the directory's existence is tested, not whether the process is
! permited to use it in any particular way.
!
! 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 or device not ready, 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.
!
! If the address of a fullword is supplied for storing library status,
! the fullword is set to TRUE if the directory exists and is the
! current library directory.
!
! 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 problem occurred, e.g., the
! specification is well formed. 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.
! a_library: Address of a fullword to receive library status.
! If no problem has been reported, and the directory
! exists and is the current library directory, TRUE is
! stored. Otherwise FALSE is stored. If the address
! supplied is K_NULL, this test is not made.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! If the specified directory exists, the routine returns the address
! of a descriptor of the full directory specification, in which all
! logical names and defaults have been evaluated. The validity status,
! if requested, is set to TRUE in this case, and the library status,
! if requested, may be set to TRUE or FALSE.
!
! The routine returns K_NULL if the device is ready but no such directory
! exists, or if a problem was reported as a user mistake. The validity
! status, if requested, is set to TRUE or FALSE according to whether a
! problem was reported, and the library status, if requested, is set
! to FALSE.
!
! Side Effects:
!
! Unless the routine returns K_NULL, it allocates a string and
! descriptor and returns the address of the descriptor. The string
! and descriptor may be freed by calling FRESAD.
!
!--
begin ! FULDIR
bind
is_library = .a_is_library,
is_valid = .a_is_valid ;
%if %bliss(bliss32) %then
local
expanded_buf : vector[nam$c_maxrss, byte],
! Specification expanded to include
! device and directory.
fab : $fab_decl,
nam : $nam_decl,
r_full_spec : ref desc_block, ! Full directory specification.
save_did : vector[nam$s_did, byte], ! Save directory identification
! for comparison with library.
save_dvi : vector[nam$s_dvi, byte], ! Save device identification
! for comparison with library.
status ; ! Status code returned by a system
! service.
%fi
%if Tops20 %then
local
dir_desc : desc_block, ! For making ASCIZ string
dir_num, ! Directory numebr returned
dir_z_ptr, ! Pointer to ASCIZ string
error_num:block[1], ! Error returned by RCDIR call
expanded_buf : vector[ch$allocation(extended_file_spec)], ! full file specification
flag_bits, ! Flags given to RCDIR
full_spec_ptr, ! Pointer returned by DIRST
len, ! Length of full specification
log_buf : vector[ch$allocation(256)], ! Result of logical name translation
log_res :desc_block, ! resultant spec
new_flag_bits, ! Flags returned by RCDIR
r_full_spec : ref desc_block, ! Full directory specification.
save_dir_num, ! Save directory number
! for comparison with library.
skips, ! Return of DIRST
temp, ! unused return of RCDIR
updated_ptr ; ! returned by DIRST
%fi
! Initialize the validity.
if is_valid neq k_null
then
is_valid = false ;
! Initialize the library status.
if is_library neq k_null
then
is_library = false ;
%if %bliss(bliss32) %then
! Check the length of the specification.
if .spec_len gtr nam$c_maxrss
then
begin ! Bad length.
if is_valid eql k_null
then
bug(cat('The specification beginning with ', (20, .spec_ptr),
' is too long for ',fac_name)) ;
err(s_toolong,cat('The specification beginning with ', (20, .spec_ptr),
' is too long')) ;
return k_null ;
end ; ! Bad length.
! Initialize the RMS blocks.
$nam_init(nam = nam, ess = nam$c_maxrss, esa = expanded_buf) ;
$fab_init(fab = fab, nam = nam, fns = .spec_len, fna = .spec_ptr) ;
! Parse the specification.
if not (status = $parse(fab = fab))
then
begin ! Unsuccessful parse.
! Check if the device was ready but the directory was not found.
if .status eql rms$_dnf ! _dnf: directory not found
then
begin ! Report a missing directory.
if is_valid neq k_null
then
is_valid = true ;
return k_null ;
end ; ! Report a missing directory.
! Make sure the specification has no wild cards.
if .nam[nam$v_wild_dir]
then
begin ! Wild card.
if is_valid eql k_null
then
bug(cat(fac_name,' saw wild card in ',
(.spec_len,.spec_ptr)))
else
is_valid = true;
err(s_nowldcard,cat('Wild cards not allowed in ',
(.spec_len, .spec_ptr))) ;
return k_null;
end ; ! Wild card.
! Use the secondary status in a case where it is more informative.
if .status eql rms$_chn and .fab[fab$l_stv] eql ss$_ivdevnam
then
status = ss$_ivdevnam ; ! invalid device name
! Report a user mistake if the user asked for a validity check and
! the problem is one that could be a user mistake.
!
! rms error return codes used:
! _dev: bad device _dir: error in directory name
! _dnr: device not ready _fnm: syntax error in file name
! _lne: logical name err _nod: node name error
! _prv: file protection _quo: error in quoted string
! _syn: file spec syntax _typ: file type error
! _ver: version # error
!
if is_valid neq k_null
and (.status eql rms$_dev or .status eql rms$_dir or
.status eql rms$_dnr or .status eql rms$_fnm or
.status eql rms$_lne or .status eql rms$_nod or
.status eql rms$_prv or .status eql rms$_quo or
.status eql rms$_syn or .status eql rms$_typ or
.status eql rms$_ver or .status eql ss$_ivdevnam or
.status eql rms$_chn)
then
begin ! Report a mistake.
!Do special check for normal non-existent library
if
.status eql ss$_ivdevnam and
ch$eql(%charcount(lib),ch$ptr(uplit(lib)),.spec_len,.spec_ptr)
then
begin
err(s_nolib,lit(%string(fac_name,' Library not found')));
return k_null
end;
if .status eql rms$_dev or .status eql rms$_dnr then
begin
errsts(s_spcinv,.status, cat((.spec_len, .spec_ptr),
' is an invalid directory specification')) ;
return k_null
end;
!give a more informative message for channal assignment error
if
.status eql rms$_chn
then
errsts(s_errmisc,.fab[fab$l_stv] ,cat('Error in ',
(.spec_len, .spec_ptr)))
else
errsts(s_errmisc,.status, cat('Error in ',
(.spec_len, .spec_ptr))) ;
return k_null ;
end ; ! Report a mistake.
! Otherwise report a bug.
bugsts(.status, cat(fac_name,' cannot parse ',
(.spec_len, .spec_ptr))) ;
end ; ! Unsuccessful parse.
! Make sure this is a directory specification, not a file specification.
if .nam[nam$v_exp_name] or .nam[nam$v_exp_type] or .nam[nam$v_exp_ver]
then
begin ! File specification.
if is_valid eql k_null
then
bug(cat(fac_name,' saw file spec. ', (.spec_len, .spec_ptr))) ;
err(s_mustbedir,cat((.spec_len, .spec_ptr),
' must be a directory')) ;
return k_null ;
end ; ! File specification.
! Make sure the specification has no wild cards.
if .nam[nam$v_wild_dir]
then
begin ! Wild card.
if is_valid eql k_null
then
bug(cat(fac_name,' saw wild card in ', (.spec_len, .spec_ptr)));
err(s_nowldcard,cat('Wild cards not allowed in ',
(.spec_len, .spec_ptr))) ;
return k_null ;
end ; ! Wild card.
! The specification is valid.
if is_valid neq k_null
then
is_valid = true ;
! Create the full specification to return to the caller.
r_full_spec = maksad(.nam[nam$b_esl] - 2) ; ! Omit trailing ".;"
ch$copy(.nam[nam$b_esl] - 2, .nam[nam$l_esa], 0,
len_comma_ptr(.r_full_spec)) ;
! Report success if the caller is not interested in the library status.
if is_library eql k_null
then
return .r_full_spec ;
! Save the device and directory identifications for comparison.
ch$move(nam$s_dvi, ch$ptr(nam[nam$t_dvi]), ch$ptr(save_dvi)) ;
ch$move(nam$s_did, ch$ptr(nam[nam$w_did]), ch$ptr(save_did)) ;
! Reinitialize the RMS blocks.
$nam_init(nam = nam, ess = nam$c_maxrss, esa = expanded_buf) ;
$fab_init(fab = fab, nam = nam,
fns = %charcount(lib), fna = uplit(lib)) ;
! LIB is a macro declared in SCONFG.REQ .
! Parse the library specification to get the device and directory id's.
if not (status = $parse(fab = fab))
then
is_library = false
else
begin
! Compare the device and directory identifications.
if ch$eql(nam$s_dvi, ch$ptr(nam[nam$t_dvi]),
nam$s_dvi, ch$ptr(save_dvi))
and ch$eql(nam$s_did, ch$ptr(nam[nam$w_did]),
nam$s_did, ch$ptr(save_did))
then
is_library = true ;
end;
.r_full_spec
%fi
%if Tops20 %then
! Check the length of the specification.
if .spec_len gtr extended_file_spec
then
begin ! Bad length.
if is_valid eql k_null
then
bug(cat('The specification beginning with ', (20, .spec_ptr),
' is too long for ',fac_name)) ;
err(s_toolong,cat('The specification beginning with ', (20, .spec_ptr),
' is too long')) ;
return k_null ;
end ; ! Bad length.
! Parse the specification.
! First make directory string ASCIZ
! Check for a null string
if .spec_len eql 0
then
begin
$str_desc_init ( descriptor = dir_desc,
string = ('DSK:')) ;
cvtas0( dir_desc, dir_z_ptr);
end
else
begin
$str_desc_init ( descriptor = dir_desc,
string = (.spec_len, .spec_ptr )) ;
$str_desc_init (descriptor = log_res,
string=(256,ch$ptr(log_buf)));
if trnlog (dir_desc, log_res )
then
cvtas0 ( log_res, dir_z_ptr)
else
cvtas0 ( dir_desc, dir_z_ptr ) ;
end;
! Initialize flags
flag_bits = 0;
flag_bits = rc_emo ;
! Get around BLISS bug
new_flag_bits = 0;
temp = 0;
dir_num = 0;
! Test directory
skips = rcdir ( .flag_bits, .dir_z_ptr, 0 ; new_flag_bits, temp, dir_num );
!
! NOTE: If the directory in question does not exist, RCDIR does not
! concider this to be an error and does not do an ERJMP!
! In this case the RC_NOM (nomatch) bit is turned on.
!
if .skips eql 0 OR .pointr(new_flag_bits,rc_nom)
then
begin ! Unsuccessful parse.
! Check if the device was ready but the directory was not found.
if pointr(.new_flag_bits,rc_nom)
then
begin ! Report a missing directory.
if is_valid neq k_null
then
is_valid = true ;
return k_null ;
end ; ! Report a missing directory.
! Get more error information
geter ($fhslf ; error_num ) ;
error_num[lh] = 0;
! 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
and (.error_num eql rcdix2 or !invalid directory spec
.error_num eql rcdix3 or !invalid structure name
.error_num eql desx10 or !structure is dismounted
.error_num eql strx01) !structure not mounted
then
begin ! Report a mistake.
!Do special check for normal non-existent library
if
ch$eql(%charcount(lib),ch$ptr(uplit(lib)),.spec_len,.spec_ptr)
then
begin
err(s_nolib,lit(%string(fac_name,' Library not found')));
return k_null
end;
if .error_num eql rcdix2 or .error_num eql rcdix3 ! invalid directory specification
then
errsts(s_spcinv,.error_num, cat('Error in ',
(.spec_len, .spec_ptr)))
else
errsts(s_errmisc,.error_num, cat('Error in ',
(.spec_len, .spec_ptr))) ;
return k_null ;
end ; ! Report a mistake.
! Otherwise report a bug.
bug(cat(fac_name,' cannot parse ',
(.spec_len, .spec_ptr))) ;
end ; ! Unsuccessful parse.
! The specification is valid.
if is_valid neq k_null
then
is_valid = true ;
! Create the full specification to return to the caller.
full_spec_ptr = ch$ptr (expanded_buf ) ;
skips = dirst ( .full_spec_ptr, .dir_num ; updated_ptr ) ;
if not .skips
then
begin
local
error_num ;
geter($fhslf ; error_num) ;
errsts(s_dcantget,.error_num,cat('Cannot find directory for ',
(.spec_len, .spec_ptr))) ;
return k_null ;
end ;
Len = ch$diff ( .updated_ptr, .full_spec_ptr ) ;
r_full_spec = maksad( .len ) ;
ch$copy(.len ,.full_spec_ptr, 0,
len_comma_ptr(.r_full_spec)) ;
! Report success if the caller is not interested in the library status.
if is_library eql k_null
then
return .r_full_spec ;
! Save the device and directory identifications for comparison.
save_dir_num = .dir_num ;
dir_num = 0 ;
! Re-initialize descriptor for library
$str_desc_init ( descriptor = dir_desc,
string = lit(lib)) ; ! lib is a macro in SCONFG
$str_desc_init( descriptor = log_res,
string = (256,ch$ptr(log_buf)));
if trnlog (dir_desc, log_res )
then
cvtas0 ( log_res, dir_z_ptr)
else
cvtas0 ( dir_desc, dir_z_ptr ) ;
! Get directory number of library
if not rcdir ( .flag_bits, .dir_z_ptr, 0 ; new_flag_bits, temp, dir_num )
then
bug(lit(%string(fac_name,' could not get directory number for ',lib))) ;
! Compare the directory identifications.
if .save_dir_num eql .dir_num
then
is_library = true ;
.r_full_spec
%fi
end ; ! FULDIR
global routine hasnet(a_spec) =
!++
! Functional Description:
!
! This routine returns TRUE if the file specification supplied as
! argument contains or implies a network reference. Logical names
! are evaluated, and the user's default may be applied.
!
! Formal Parameters:
!
! A_SPEC Address of a descriptor of a specification to check
! for network use.
!
! Implicit Inputs:
!
! The user's default file specification.
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE means the specification contains or implies a network reference.
! FALSE means not.
!
! Side Effects:
!
! None
!
!--
begin ! HASNET
bind
spec = .a_spec : desc_block ;
local
equiv : desc_block, ! The translation of a logical name.
%if %bliss(bliss32) %then
equiv_vec : vector[nam$c_maxrss, byte], ! Denoted by EQUIV.
%fi
%if Tops20 %then
equiv_vec : vector[ch$allocation(extended_file_spec)], ! Denoted by EQUIV.
%fi
name : desc_block, ! Logical name to be translated.
! Denotes a prefix of NAME_ALL.
name_all : desc_block, ! String that may start with log. name.
! Denotes a prefix of NAME_BUF.
name_buf : desc_block, ! Denotes NAME_VEC.
name_to_translate, ! Potential logical name was found.
%if %bliss(bliss32) %then
name_vec : vector[nam$c_maxrss, byte], ! Denoted by above descriptors.
%fi
%if Tops20 %then
name_vec : vector[ch$allocation(extended_file_spec)], ! Denoted by above descriptors
%fi
user_default_used ; ! User's default has been considered.
%if %bliss(bliss32) %then
macro
user_default = 'SYS$DISK' % ; ! Default if user has none.
%fi
%if Tops20 %then
macro
user_default = 'PS' % ;
%fi
! Initialize local descriptors.
%if %bliss(bliss32) %then
$str_desc_init(descriptor = equiv, string = (nam$c_maxrss, equiv_vec)) ;
$str_desc_init(descriptor = name, string = (0, name_vec)) ;
$str_desc_init(descriptor = name_all, string = (0, name_vec)) ;
$str_desc_init(descriptor = name_buf, string = (nam$c_maxrss, name_vec)) ;
%fi
%if Tops20 %then
$str_desc_init(descriptor = equiv, string = (extended_file_spec, equiv_vec)) ;
$str_desc_init(descriptor = name, string = (0, name_vec)) ;
$str_desc_init(descriptor = name_all, string = (0, name_vec)) ;
$str_desc_init(descriptor = name_buf, string = (extended_file_spec, name_vec)) ;
%fi
! Default has not been applied.
user_default_used = false ;
! Start with the specification provided by the caller.
$str_copy(string = spec, target = name_buf) ;
name_all[desc_len] = .spec[desc_len] ;
incr i from 1 to 11 do !if we don't get on 7 tries give up
begin ! Make one translation.
! Any occurrence of '::' indicates network usage.
if $str_scan(string = name_all, find = '::')
then
return true ;
! Isolate a leading symbol that is possibly a logical name.
if $str_scan(string = name_all, stop = ':', substring = name)
neq str$_end_string
then
! Colon found.
name_to_translate = true
else
! Colon not found.
name_to_translate =
($str_scan(string = name, stop = '[<.;"') eql str$_end_string);
! In any case, do not translate an empty string.
if .name[desc_len] eql 0
then
name_to_translate = false ;
! Try to translate the logical name.
if
(if .name_to_translate
then
begin ! Translate
%if %bliss(bliss32) %then
equiv[desc_len] = nam$c_maxrss ; ! TRNLOG shortens EQUIV.
%fi
%if Tops20 %then
equiv[desc_len] = extended_file_spec ; !TRNLOG shortens EQUIV
%fi
trnlog(name, equiv)
end ! Translate
else
false)
then
begin ! Translation found.
! Translate again.
$str_copy(string = equiv, target = name_buf) ;
name_all[desc_len] = .equiv[desc_len] ;
end ! Translation found.
else
begin ! No translation.
! If we have a device, there is no need to consider the default.
if $str_scan(string = name_all, find = ':')
then
exitloop ;
! No device and no translation, so consider the user's default.
if not .user_default_used
then
begin ! Take the user's default.
$str_copy(string = user_default, target = name_buf) ;
name_all[desc_len] = %charcount(user_default) ;
user_default_used = true ;
end ! Take the user's default.
else
exitloop ;
end ; ! No translation.
end ; ! Make one translation.
! The search for a network reference has failed.
false
end ; ! HASNET
global routine isdir(spec_len, spec_ptr, a_is_valid, a_is_library) =
!++
! Functional Description:
!
! This routine determines if a specified directory exists. The
! specification must have no wild cards, and have no file name, type,
! version number, or delimiters that would separate them.
!
! Only the directory's existence is tested, not whether the process is
! permited to use it in any particular way.
!
! 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 or device not ready, 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.
!
! If the address of a fullword is supplied for storing library status,
! the fullword is set to TRUE if the directory exists and is the
! current library directory.
!
! 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 problem occurred, e.g., the
! specification is well formed. 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.
! a_library: Address of a fullword to receive library status.
! If no problem has been reported, and the directory
! exists and is the current library directory, TRUE is
! stored. Otherwise FALSE is stored. If the address
! supplied is K_NULL, this test is not made.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! The routine returns TRUE if the specified directory exists.
! The validity status, if requested, is set to TRUE in this case,
! and the library status, if requested, may be set to TRUE or FALSE.
!
! The routine returns FALSE if the device is ready but no such directory
! exists, or if a problem was reported as a user mistake. The validity
! status, if requested, is set to TRUE or FALSE according to whether a
! problem was reported, and the library status, if requested, is set
! to FALSE.
!
! Side Effects:
!
! None
!
!--
begin ! ISDIR
local
r_full_spec : ref desc_block ; ! Full directory specification.
r_full_spec = fuldir(.spec_len, .spec_ptr, .a_is_valid, .a_is_library) ;
if .r_full_spec eql k_null
then
return false
else
begin ! Found.
fresad(.r_full_spec) ; ! Deallocate the string and descriptor.
return true ;
end ; ! Found.
end ; ! ISDIR
global routine cmsdir(spec_len, spec_ptr, a_is_valid, a_is_library) =
!++
! Functional Description:
!
! This routine determines if a specified directory exists. It also
! develops the full specification of the directory, in which all logical
! names and defaults are evaluated. The specification must have no wild
! cards, and have no file name, type, version number, or delimiters that
! would separate them.
!
! Then the directory is tested to see whether it is allowable to be a CMS
! library. Specifically, it can not be a non-disc divice ie. NL:,sys$...
!
! 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 or device not ready, 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.
!
! If the address of a fullword is supplied for storing library status,
! the fullword is set to TRUE if the directory exists and is the
! current library directory.
!
! 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 problem occurred, e.g., the
! specification is well formed. 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.
! a_library: Address of a fullword to receive library status.
! If no problem has been reported, and the directory
! exists and is the current library directory, TRUE is
! stored. Otherwise FALSE is stored. If the address
! supplied is K_NULL, this test is not made.
!
! Implicit Inputs:
!
! None
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! If the specified directory exists, the routine returns the address
! of a descriptor of the full directory specification, in which all
! logical names and defaults have been evaluated. The validity status,
! if requested, is set to TRUE in this case, and the library status,
! if requested, may be set to TRUE or FALSE.
!
! The routine returns K_NULL if the device is ready but no such directory
! exists, or if a problem was reported as a user mistake. The validity
! status, if requested, is set to TRUE or FALSE according to whether a
! problem was reported, and the library status, if requested, is set
! to FALSE.
!
! Side Effects:
!
! Unless the routine returns K_NULL, it allocates a string and
! descriptor and returns the address of the descriptor. The string
! and descriptor may be freed by calling FRESAD.
!
!--
BEGIN
bind
is_library = .a_is_library,
is_valid = .a_is_valid ;
local
status,
ret_val, ! return value
expanded_buf : vector[ch$allocation(extended_file_spec)],
! Specification expanded to include
! device and directory.
%if
%bliss(bliss32)
%then
fab : $fab_decl,
nam : $nam_decl;
%else
dir_desc : desc_block, ! For making ASCIZ string
dir_num, ! Directory numebr returned
dir_z_ptr, ! Pointer to ASCIZ string
flag_bits, ! Flags given to RCDIR
log_buf : vector[ch$allocation(256)], ! Result of logical name translation
log_res :desc_block, ! resultant spec
new_flag_bits, ! Flags returned by RCDIR
temp; ! unused return of RCDIR
%fi
!call fuldir to check directory exists
ret_val = fuldir(.spec_len, .spec_ptr, .a_is_valid, .a_is_library);
%if VaxVms %then
if
.ret_val NEQ k_null
THEn
BEGIN
! Initialize the RMS blocks.
$nam_init(nam = nam, ess = nam$c_maxrss, esa = expanded_buf) ;
$fab_init(fab = fab, nam = nam, fns = .spec_len, fna = .spec_ptr) ;
! Parse the specification.
if (status = $parse(fab = fab))
then
!+
! Make sure the directory is not a "special" one like the null
!-
IF
spcfil(fab)
THEN
BEGIN
IF
is_valid EQL k_null
THEN
bug(cat((.nam[nam$b_esl],expanded_buf),
' is an invalid directory specification'));
err(s_spcinv, cat((.nam[nam$b_esl], expanded_buf),
' is an invalid directory specification'));
is_valid = false;
return k_null;
END;
END;
%fi
%if Tops20 %then
!
! No extra code needed for Tops-20.
!
%fi
RETURN .ret_val;
END;
global routine localf(spec_len, spec_ptr) =
!++
! Functional Description:
!
! This routine checks a file specification for possible network usage.
! Logical names are evaluated, and the user's default may be applied.
! If network usage is found, the user is informed that network
! operations are not supported, and FALSE is returned.
!
! Formal Parameters:
!
! SPEC_LEN Number of characters in the specification.
!
! SPEC_PTR Character pointer to the specification.
!
! Implicit Inputs:
!
! The user's default file specification.
!
! Implicit Outputs:
!
! None
!
! Routine Value:
! Completion Codes:
!
! TRUE means the specification did not contain a network reference.
! FALSE means it did and the user has been informed.
!
! Side Effects:
!
! None
!
!--
begin ! LOCALF
local
spec : desc_block ; ! For calling HASNET.
$str_desc_init(descriptor = spec, string = (.spec_len, .spec_ptr)) ;
if hasnet(spec)
then
begin ! Network.
err(s_neterr,cat(spec, %string(' requires network activity, ',
'which is not supported in this release'))) ;
return false ;
end ; ! Network.
true
end ; ! LOCALF
end ! Module DIROPS
eludom