Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/dapt20.b36
There are 20 other files named dapt20.b36 in the archive. Click here to see a list.
MODULE DAPT20(
IDENT='7.0(664) 6-Feb-87',
ENTRY(
s$fbsiz,
s$fbbyv,
S$Dtstr,
S$Strdt,
S$Jfn_Str,
S$Mount,
S$Jobusr,
S$Username,
s$GetError
)
)=
BEGIN
!
! COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1981, 1986.
! ALL RIGHTS RESERVED.
!
! 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 THAT IS NOT SUPPLIED BY DIGITAL.
!
!++
! FACILITY:
! DAP-20.
!
! ABSTRACT:
! This module contains various interface routines to TOPS-20.
!
! ENVIRONMENT:
! TOPS-20 user mode, XPORT.
!
! AUTHOR: Larry Campbell, CREATION DATE: 21 Oct 1982
! MODIFIED BY: Andrew Nourse
! Revision History
!
! RMS edits:
! 664 - s$fbsiz, s$fbbyv
! 534 - S$mount
!
! Module edits:
! 02 - Pure Data belongs in the hiseg
! 01 - Move these routines from FTST20 to DAPT20 (this module)
!--
FORWARD ROUTINE
s$fbbyv, ! Read file's fbbyv word
s$fbsiz, ! Read file's byte count word
s$dtstr : NOVALUE, ! Convert date/time to string
s$strdt, ! convert string to date/time
s$jfn_str, ! Convert JFN to string
s$mount: NOVALUE, ! Mount a structure & access it
s$jobusr,
s$username,
S$GetError;
!
! INCLUDE FILES:
!
REQUIRE 'RMSREQ';
REQUIRE 'RMSOSD'; ! O/S DEPENDENT CODE
!
! MACROS:
!
%( IN REQUIRE FILES
MACRO
lh = 18, 18 %,
rh = 0, 18 %;
MACRO
asciz_len (string) =
BEGIN
LOCAL
tptr;
tptr = string;
INCR i FROM 0
DO
IF CH$RCHAR_A (tptr) EQL 0
THEN
EXITLOOP .i
END %;
)%
!
! EQUATED SYMBOLS:
!
LITERAL
minute = %O'1000000' / (24 * 60); ! One minute
!
! THERE IS NO OWN STORAGE:
! THERE IS, HOWEVER PURE DATA CREATED BY XPORT
!
PSECT OWN=$HIGH$;
GLOBAL ROUTINE s$fbbyv (fab_jfn) : =
!++
! FUNCTIONAL DESCRIPTION:
! Return file's .FBBYV word
!
! FORMAL PARAMETERS:
! fab_jfn: JFN of file
!
! ROUTINE VALUE:
! word from FDB
!--
BEGIN
LOCAL byv;
IF gtfdb (.fab_jfn, $XWD(1,$FBBYV), byv)
THEN RETURN (.byv) ! Return byte size and other stuff
ELSE RETURN (0); ! or zero if error
END; ! End of s$fbbyv
GLOBAL ROUTINE s$fbsiz (fab_jfn) : =
!++
! FUNCTIONAL DESCRIPTION:
! Return file byte count
!
! FORMAL PARAMETERS:
! fab_jfn: JFN of file
!
! ROUTINE VALUE:
! file byte count from FDB
!--
BEGIN
LOCAL byte_count;
IF gtfdb (.fab_jfn, $XWD(1,$FBSIZ), byte_count)
THEN RETURN (.byte_count) ! Return byte count
ELSE RETURN (0); ! or zero if error
END; ! End of s$fbsiz
GLOBAL ROUTINE s$dtstr (date_time, p_descr) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
! Convert internal date/time to string.
!
! FORMAL PARAMETERS:
! date_time - date and time in universal internal format
! (-1 means now)
! p_descr - pointer to descriptor to receive string
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
BIND
descr = .p_descr : $STR_DESCRIPTOR ();
LOCAL
ptr,
length,
string_buffer : VECTOR [CH$ALLOCATION (32)];
ODTIM (CH$PTR (string_buffer), .date_time, 0);
ptr = CH$PTR (string_buffer);
length = 0;
UNTIL (CH$RCHAR_A (ptr) EQL 0)
DO
length = .length + 1;
$STR_COPY (STRING = (.length, CH$PTR (string_buffer)), TARGET = descr,
OPTION = TRUNCATE);
END; ! End of s$dtstr
GLOBAL ROUTINE s$strdt (p_descr) =
!++
! FUNCTIONAL DESCRIPTION:
! Convert string to internal date/time
!
! FORMAL PARAMETERS:
! p_descr - pointer to descriptor to string
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE
! Internal Date/Time
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
BIND
descr = .p_descr : $STR_DESCRIPTOR ();
LOCAL
internal_date_time,
result,
string_buffer : VECTOR [CH$ALLOCATION (32)];
$STR_COPY (STRING = $STR_CONCAT (descr, %CHAR(0)),
TARGET = (31, CH$PTR (string_buffer)),
OPTION = TRUNCATE);
IF IDTIM (CH$PTR (string_buffer), 0; result, internal_date_time)
THEN
RETURN (.internal_date_time) ! Returned value
ELSE
SIGNAL (.result) ! String was trash or something
END; ! End of s$strdt
GLOBAL ROUTINE s$jfn_str (jfn, p_desc, bits) =
!++
! FUNCTIONAL DESCRIPTION:
! Convert a JFN to a filespec string.
!
! FORMAL PARAMETERS:
! jfn - the JFN
! p_desc - address of descriptor to receive the string
! bits - format control bits (AC3 of JFNS call). If 0, this
! defaults to the usual case (supply and punctuate everything)
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! The length of the filespec string is returned, or 0 if any errors (which
! are also signalled).
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
BIND
desc = .p_desc : $STR_DESCRIPTOR ();
LOCAL
temp_desc : $STR_DESCRIPTOR (CLASS = FIXED),
temp_desc_buffer : VECTOR [CH$ALLOCATION (255)],
adjusted_length,
jfns_bits,
new_ptr;
$STR_DESC_INIT (DESCRIPTOR = temp_desc,
STRING = (255, CH$PTR (temp_desc_buffer)));
IF .bits EQL 0
THEN
jfns_bits = %O'111110000001' ! Return all the usual fields
ELSE
jfns_bits = .bits;
IF NOT JFNS (.temp_desc[STR$A_POINTER], .jfn, .jfns_bits, 0; new_ptr)
THEN
RETURN (SIGNAL (XPO$_CHANNEL); 0);
temp_desc[STR$H_LENGTH] = ABS (CH$DIFF (.new_ptr,
.temp_desc[STR$A_POINTER])) + 1;
$STR_COPY (STRING = temp_desc, TARGET = desc, OPTION = TRUNCATE);
!
! Unless the target descriptor was too short, we also copied the trailing
! null. Here we account for that. If the last character of the target
! is null, we copied the null, so must return a length one less.
!
adjusted_length = MIN (.desc[STR$H_LENGTH],
.temp_desc[STR$H_LENGTH]);
IF CH$RCHAR (CH$PLUS (.desc[STR$A_POINTER], .adjusted_length - 1)) EQL 0
THEN
adjusted_length = .adjusted_length - 1;
RETURN (.adjusted_length)
END; ! End of s$jfn_str
GLOBAL ROUTINE s$$mount (count, pointer) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! MOUNT and ACCESS one structure, or SIGNAL error if can't.
!
! FORMAL PARAMETERS:
!
! count - length of structure name
! pointer - character pointer to structure name
!
!--
BEGIN
LOCAL
mstatus, ! Status returned by MSTR
mstr_args : VECTOR [$MSGST + 1], ! argument block for MSTR
str_name : VECTOR [CH$ALLOCATION(7)], ! structure or dir name
str_descr : $STR_DESCRIPTOR (CLASS = FIXED), ! descriptor for above
retcode, ! return value
ac1; ! temp for value of AC1
!
! If no structure specified, return now.
!
IF .count EQL 0
THEN
RETURN;
!
! Create descriptor to structure name for error messages
!
$STR_DESC_INIT (DESCRIPTOR = str_descr, CLASS = FIXED,
STRING = (.count, .pointer));
!
! Make ASCIZ copy of structure name
!
CH$COPY (.count, .pointer,
0,
.count + 1, CH$PTR (str_name));
!
! Get the current status of the structure
!
mstr_args[$MSGSN] = CH$PTR (str_name);
ac1<lh> = $MSGST + 1;
ac1<rh> = $MSGSS;
IF NOT MSTR (.ac1, mstr_args)
THEN
UserError ( Rms$_Dev );
MSTATUS=.MSTR_ARGS[$MSGST]; ! Save structure status
!
! If structure is PS, no need to mount it
!
IF (.mstatus AND MS_PPS) NEQ 0
THEN
RETURN;
!
! OK, try to mount the structure
!
mstr_args[$MSDEV] = CH$PTR (str_name);
ac1<lh> = $MSDEV + 1;
ac1<rh> = $MSIMC;
IF MSTR (.ac1, mstr_args) EQL 0 ! If it fails
THEN ! find out why
!
! Analyze the error. "Structure already mounted" is OK.
!
BEGIN
IF (retcode = s$geterror ($FHSLF)) NEQ MSTX31 ! Structure mounted?
THEN
BEGIN
UserError( Rms$_Dev ); ! Invalid device
RETURN; ! not accessable
END
END;
!
![3] If structure is Domestic, try to ACCESS our own directory on it
!
IF (.MSTATUS AND MS_DOM) NEQ 0 ! If Domestic
THEN ! then try ACCESS
BEGIN
LOCAL ACCBLK: VECTOR[3]; ! ACCES argument block
LOCAL dir_desc: $STR_DESCRIPTOR(CLASS=DYNAMIC); ! Desc for username
$STR_DESC_INIT(DESC=dir_desc, CLASS=DYNAMIC); !
s$username(s$jobusr(-1),dir_desc); ! Get our username
$STR_COPY(STRING=$STR_CONCAT(str_descr, ! Structure name
':<', ! delimiters
dir_desc, ! username
%STRING('>',%CHAR(0))), ! delimiters
TARGET=dir_desc); ! Make str:<username>
ACCBLK[$ACDIR]=.dir_desc[STR$A_POINTER];
ACCBLK[$ACPSW]=0; ! No password needed
ACCBLK[$ACJOB]=-1; ! Our job
ACCES(AC_OWN+3,ACCBLK); ! Try it, and ignore failure
$XPO_FREE_MEM(STRING=dir_desc); ! Free the temporary
END;
END; ! End of s$mount
GLOBAL ROUTINE s$jobusr (job) =
!++
! FUNCTIONAL DESCRIPTION:
! Return the user number under which a job is logged in.
!
! FORMAL PARAMETERS:
! job - job number
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! 0 - some sort of failure
! or user number
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
LOCAL
getji_block,
getji_arg2;
getji_arg2<lh> = -1;
getji_arg2<rh> = getji_block;
IF GETJI (.job, .getji_arg2, $JIUNO)
THEN
RETURN (.getji_block)
ELSE
RETURN (0);
END; ! End of s$jobusr
GLOBAL ROUTINE s$username (user_number, p_desc) =
!++
! FUNCTIONAL DESCRIPTION:
! Get the username string associated with a user number.
!
! FORMAL PARAMETERS:
! user_number - TOPS-20 user number
! p_desc - pointer to descriptor to receive string
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! The length of the filespec string is returned.
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
BIND
dst_desc = .p_desc : $STR_DESCRIPTOR ();
LOCAL
string_buff : VECTOR [CH$ALLOCATION (40)],
length;
DIRST (CH$PTR (string_buff), .user_number);
$STR_COPY (TARGET = dst_desc,
STRING = (length = asciz_len (CH$PTR (string_buff)),
CH$PTR (string_buff)));
RETURN (.length)
END; ! End of s$username
GLOBAL ROUTINE s$geterror (fork_handle) =
!++
! FUNCTIONAL DESCRIPTION:
! Return the most recent TOPS20 error code for the process.
!
! FORMAL PARAMETERS:
! NONE
!
! IMPLICIT INPUTS:
! NONE
!
! IMPLICIT OUTPUTS:
! NONE
!
! ROUTINE VALUE and
! COMPLETION CODES:
! NONE
!
! SIDE EFFECTS:
! NONE
!
!--
BEGIN
LOCAL
error_code;
GETER ($FHSLF; error_code);
RETURN (.error_code<rh>)
END; ! End of s$geterror
GLOBAL ROUTINE S$Mount( Fsp ) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
! MOUNT and ACCESS one structure, or SIGNAL error if can't.
!
! FORMAL PARAMETERS:
!
! FSP - character pointer to filespec
!
!--
BEGIN
LOCAL jfn;
LOCAL tdesc: $Str_Descriptor();
LOCAL strname: VECTOR[CH$ALLOCATION(7)];
LOCAL strlen;
$Str_Desc_Init( Desc=Tdesc, Class=Bounded, String=(6,CH$PTR(strname)) );
IF NOT GTJFN( GJ_OFG+GJ_SHT, .Fsp; Jfn ) THEN SIGNAL( Rms$_CGJ );
strlen = S$Jfn_Str( .Jfn, tdesc, JS_DEV );
s$$mount( .strlen, CH$PTR( strname ) );
END;
END ELUDOM ! End of Module