Google
 

Trailing-Edge - PDP-10 Archives - CFS_TSU04_19910205_1of1 - update/t20src/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