Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/chklib.bli
There are no other files named chklib.bli in the archive.
MODULE chklib ( IDENT = '000001',
%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
!
! ABSTRACT:
!
! Examine the CMSLibrary directory file and get the file
! retention count value for the library.
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: D. Knight
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
chklib; !get file retention count
!
! INCLUDE FILES:
!
%if %bliss(bliss32) %then
library 'SYS$LIBRARY:LIB'; ! VMS macros and codes
undeclare %QUOTE $descriptor;
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
require 'JSYS:' ; ! Interface to monitor calls
%else
%error('DS-10 support not implemented')
%fi
%fi
library 'xport:';
require 'blissx:';
require 'sconfg:' ;
!
! MACROS:
!
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
!
! EXTERNAL REFERENCES:
!
external routine
%if %bliss(bliss36) %then
%if %switches(tops20) %then
cvtas0, ! convert string to ASCIZ
dirspc, ! Get directory portion of file spec
%else
%error('DS-10 support not implemented')
%fi
%fi
bugsts;
global routine chklib (iob) =
!++
! FUNCTIONAL DESCRIPTION:
!
! VMS : Look up the directory file that goes with the CMS library.
! Pick up the file retention count from the associated record
! attribute block.
!
! TOPS-20: Get the directory specification from the IOB. Get the
! corresponding directory number. Get the file retention
! count from the associated directory block.
!
! FORMAL PARAMETERS:
!
! IOB - address of open IOB for any file in the library
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE,
! COMPLETION CODES:
!
! File retention count is returned.
! (0 is returned if the system default is in force).
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
%if %bliss(bliss32) %then
map
iob : ref $xpo_iob();
LOCAL
attr_list : block[12,byte], ! used in QIO for attributes
channel, ! holds channel number
fab : ref $fab_decl, ! pointer to FAB
fib : block[FIB$K_LENGTH,byte], ! File information block
fib_desc : block[DSC$K_S_BLN,byte], ! string descriptor for FIB
iosb : vector[2], ! I/O status block
nam : ref $nam_decl, ! name block pointer
rec_attr : block[fat$k_length,byte], ! record attribute block
status; ! status for each operation
!Assign the proper disk
if
not (status=$assign(devnam=lit(%string(fac_name,'$LIB')),
chan=channel))
then
bugsts(.status,lit('Assign failed (CHKLIB)'));
!Point to the name block to get to the directory file pointer
fab=.iob[iob$a_rms_fab];
nam=.fab[fab$l_nam];
!The FIB contains the file ID of the file being identified
!(the directory file).
ch$fill(0,FIB$K_LENGTH,ch$ptr(FIB));
ch$move(6,ch$ptr(nam[nam$w_did]),ch$ptr(FIB[FIB$W_FID]));
$str_desc_init(descriptor=fib_desc,string=(fib$k_length,fib));
!The attribute list says that we want to read the record attribute area
attr_list[atr$w_size] = atr$s_recattr;
attr_list[atr$w_type] = atr$c_recattr;
attr_list[atr$l_addr] = rec_attr;
attr_list[8,0,%bpval,0] = 0;
status = $QIOW(efn=0,chan=.channel,func=IO$_ACCESS,iosb=IOSB,
p1=FIB_desc,p5=attr_list);
IF
.(iosb[0])<0,16> neq ss$_normal
THEN
bugsts(.status,lit('IO$_ACCESS failed (CHKLIB)'));
if
not (status = $DASSGN(chan=.channel))
then
bugsts(.status,lit('$DASSGN failed (CHKLIB)'));
!Return with the number of versions to keep
.rec_attr[fat$w_versions]
%fi
%if %bliss(bliss36) %then
%if %switches(tops20) %then
map
iob : ref $xpo_iob();
local
dir_num, ! directory number
dir_block : vector[10], ! directory block
dir_string :vector[ch$allocation(extended_file_spec)], ! put directory string
dir_spec : desc_block, ! directory specification
dir_z_ptr, ! pointer to ASCIZ string
error_num, ! error returned
file_spec : desc_block, ! file specification
flags,
jfn, ! jfn
pw, ! pointer to password string
pw_string : vector[ch$allocation(31)] ,
updated_ptr ;
! Get jfn from iob
jfn = .iob[iob$h_channel] ;
! Get the full file spec
dir_z_ptr = ch$ptr (dir_string) ;
if not jfns ( .dir_z_ptr, .jfn, %o'111110000001', k_null ; updated_ptr )
then
begin
geter( $fhslf ; error_num);
bugsts( .error_num, lit(' CHKLIB could not get string')) ;
end;
! INitialize descriptor
$str_desc_init( descriptor = file_spec,
string = (ch$diff(.updated_ptr,.dir_z_ptr),.dir_z_ptr)) ;
! get directory part only
dirspc ( file_spec, dir_spec) ;
! make directory string ASCIZ
cvtas0( dir_spec, dir_z_ptr) ;
! Get directory number
if not rcdir( rc_emo, .dir_z_ptr, 0 ; flags, updated_ptr, dir_num)
then
begin
geter( $fhslf ; error_num);
bugsts( .error_num, lit( 'CHKLIB could not get directory number')) ;
end ;
! Now get directory info
! Although we are not interested in the password information, we must
! supply a place to put it
pw= ch$ptr(pw_string) ;
dir_block[$cdpsw] = .pw;
! Set first word of dir_block to get only the number of words we need
dir_block[$cdlen] = 10;
if not gtdir( .dir_num, dir_block, .pw ; updated_ptr)
then
begin
geter( $fhslf ;error_num) ;
bugsts( .error_num, lit('CHKLIB was unable to get directory block')) ;
end ;
! Return the default generations to keep
.dir_block[$cdret]
%else
%error('Not implemented on TOPS10')
%fi
%fi
END; ! end of routine CHKLIB
END !End of module
ELUDOM