Google
 

Trailing-Edge - PDP-10 Archives - cuspmar86binsrc_2of2_bb-fp63a-sb - 10,7/dil/dilsrc/dirlst.bli
There are 21 other files named dirlst.bli in the archive. Click here to see a list.
MODULE DIRLST (	! Directory listing routines to type contents of a FAB & XABs
		IDENT = '2'
                %BLISS36(,ENTRY(
                                R$LIST,        ! List FAB to buffer
                                R$$LIST        ! List FAB to descriptor
                                ))
		) =
BEGIN

!  COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1985.
!  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
!
! ABSTRACT:  Routines to transfer records or blocks of file data.
!
!
! ENVIRONMENT:  RMS, BLISSNET, XPORT, Transportable code.
!
! AUTHOR:	Andrew Nourse, CREATION DATE:  3-Jan-82
!
! MODIFIED BY:
!
! Edit (%O'1', '12-Apr-84', 'Sandy Clemens')
! %( Add the TOPS-10 DAP sources for DIL V2.  Use the standard DIL
!    edit history format.
! )%
!
! Edit (%O'2', '23-May-84', 'Sandy Clemens')
!  %( Add a CRLF to the end of a bunch of files because without it, if
!     you copy the file to another system with FTS, you will lose the
!     last line of the file!  FILES:  DAPBLK.10-REQ, DAPERR.BLI,
!     DIRLST.10-BLI, DIR10.10-B36, DAPT10.10-B36.
!  )%
!
! Edit (%O'5', '5-Oct-84', 'Sandy Clemens')
!  %( Add new format of COPYRIGHT notice.  FILES:  ALL )%
!
! 	, : VERSION
! 02    - Start TOPS-10 support [Doug Rayner]
! 01	- Pry this code loose from DIRECT
!--
!
! INCLUDE FILES:
!

!LIBRARY 'BLI:XPORT';
 LIBRARY 'RMS';
 LIBRARY 'BLISSNET';
 LIBRARY 'CONDIT';
 LIBRARY 'DAP';
!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
        R$LIST,                         ! List contents of FAB to buffer
        R$$LIST;                        ! List contents of FAB to descriptor

!
! MACROS
!

MACRO CRLF=%CHAR(13,10) %;

!
! EQUATED SYMBOLS:
!
LITERAL
       FILESPEC_FIELD_SIZE=40;     ! Length of filespec field in directory list
!
! OWN STORAGE:
!

OWN SPECSIZE: INITIAL(FILESPEC_FIELD_SIZE); ! Patchable

!
! EXTERNAL REFERENCES:
!

EXTERNAL ROUTINE
        S$DTSTR;

GLOBAL ROUTINE R$LIST (FAB,PTR,LEN,LIST_LEVEL,ERR) =	! List contents of FAB

!++
! FUNCTIONAL DESCRIPTION:
!
!       Render a file's name and attributes into a readable form
!
! FORMAL PARAMETERS:
!
!       FAB: A FAB as defined by RMS
!       PTR: byte pointer for output
!       LEN: Length of output buffer
!       LIST_LEVEL: Verbosity of listing (/BRIEF, /LIST, /FULL)
!       ERR: Address of error routine
!
! IMPLICIT INPUTS:
!
!	NONE
!
! IMPLICIT OUTPUTS:
!
!	NONE
!
! ROUTINE VALUE:
!
!	Number of bytes written to buffer
!
! SIDE EFFECTS:
!
!	NONE

!--

    BEGIN
    MAP FAB: REF $FAB_DECL;
    BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;
    LOCAL DESC: $STR_DESCRIPTOR();

    $STR_DESC_INIT(DESC=DESC,STRING=(.LEN,.PTR));

    R$$LIST(FAB[$],DESC,.LIST_LEVEL)
    END;			!End of R$LIST

GLOBAL ROUTINE R$$LIST (FAB,DESC,LIST_LEVEL) = 

!++
! FUNCTIONAL DESCRIPTION:
!
!       Render a file's name and attributes into a readable form
!
! FORMAL PARAMETERS:
!
!       FAB: A FAB as defined by RMS
!       DESC: String descriptor for output
!       LIST_LEVEL: How much info to list (RMS$K_LIST_????)
!
! ROUTINE VALUE:
!
!	Number of bytes written to buffer
!--

    BEGIN
    MAP FAB: REF $FAB_DECL;
    MAP DESC: REF $STR_DESCRIPTOR();
    BIND NAM=.FAB[FAB$A_NAM]: $NAM_DECL;        ! Find the name block
    LOCAL NAMDESC: $STR_DESCRIPTOR(CLASS=DYNAMIC);      ! Filename descriptor
    LOCAL NBDESC: $STR_DESCRIPTOR(CLASS=BOUNDED);    !... for scanning
    LOCAL CDTDESC: $STR_DESCRIPTOR();          ! Create Date/Time descriptor
    LOCAL RDTDESC: $STR_DESCRIPTOR();          ! Read Date/Time descriptor
    LOCAL EDTDESC: $STR_DESCRIPTOR();          ! Scratch Date/Time descriptor
    LOCAL CDT_STRING: VECTOR[CH$ALLOCATION(22)] INITIAL(0); ! Create date
    LOCAL RDT_STRING: VECTOR[CH$ALLOCATION(22)] INITIAL(0); ! Read date
    LOCAL EDT_STRING: VECTOR[CH$ALLOCATION(22)] INITIAL(0); ! Scratch date
    LOCAL BDESC: $STR_DESCRIPTOR(CLASS=DYNAMIC_BOUNDED);
    LOCAL PRODESC: $STR_DESCRIPTOR();           ! Protection descriptor
    LOCAL DAT: REF $XABDAT_DECL;                ! Date/Time XAB descriptor
    LOCAL LENGTH;                               ! Length of result
    LOCAL DELIM;

    DAT=.FAB[FAB$A_XAB];                        ! Find the Date/Time XAB if any
    WHILE .DAT NEQ 0
    DO (IF .DAT[XABDAT$Z_COD] EQL XABDAT$K_COD
        THEN EXITLOOP
        ELSE DAT=.DAT[XABDAT$A_NXT]);

    $STR_DESC_INIT(DESC=NAMDESC, CLASS=DYNAMIC);

    $STR_DESC_INIT(DESC=NBDESC, CLASS=BOUNDED,
                   STRING=ASCIZ_STR(.FAB[FAB$A_FNA]));

    IF (NAM NEQ 0)                        ! Find a name
    THEN (IF .NAM[NAM$H_RSL] NEQ 0
          THEN $STR_DESC_INIT(DESC=NBDESC, CLASS=BOUNDED,
                              STRING=(.NAM[NAM$H_RSL],.NAM[NAM$A_RSA])));


    $STR_SCAN(REMAINDER=NBDESC, SUBSTRING=NBDESC, STOP='":', DELIMITER=DELIM);
    IF .DELIM EQL %C'"'                     ! Access info to skip over
    THEN
        BEGIN
        $STR_COPY(STRING=NBDESC, TARGET=NAMDESC);
        $STR_SCAN(REMAINDER=NBDESC, FIND='::', SUBSTRING=NBDESC);
        $STR_APPEND(STRING=STR_STRING_PLUS_REMAINDER(NBDESC), TARGET=NAMDESC);
        END
    ELSE $STR_COPY(STRING=STR_STRING_PLUS_REMAINDER(NBDESC), TARGET=NAMDESC);

    $STR_DESC_INIT(DESC=CDTDESC,
                   STRING=(22,CH$PTR(CDT_STRING)));
    $STR_DESC_INIT(DESC=RDTDESC,
                   STRING=(22,CH$PTR(RDT_STRING)));
    $STR_DESC_INIT(DESC=EDTDESC,
                   STRING=(22,CH$PTR(EDT_STRING)));

    $STR_DESC_INIT(DESC=BDESC, CLASS=DYNAMIC_BOUNDED);

                                               ! Convert dates to ASCII
    IF .DAT NEQ 0                              ! if we got them
    THEN
        BEGIN
        IF .DAT[XABDAT$G_CDT] NEQ 0 
        THEN S$DTSTR(.DAT[XABDAT$G_CDT],CDTDESC);       ! Create date
        IF .DAT[XABDAT$G_RDT] NEQ 0 
        THEN S$DTSTR(.DAT[XABDAT$G_RDT],RDTDESC);       ! Read date
        IF .DAT[XABDAT$G_EDT] NEQ 0 
        THEN S$DTSTR(.DAT[XABDAT$G_EDT],EDTDESC);       ! Scratch date
        END;

CASE .LIST_LEVEL FROM 0 TO 5 OF
    SET
    [RMS$K_LIST_DEFAULT, RMS$K_LIST_NORMAL]:
        BEGIN
        ! Pad the name out with spaces if necessary (leave alone if too long)
        IF .NAMDESC[STR$H_LENGTH] LSS .SPECSIZE
        THEN $STR_COPY(STRING=$STR_FORMAT(NAMDESC, LENGTH=.SPECSIZE),
                       TARGET=NAMDESC);

        $STR_COPY(TARGET=BDESC,
                  STRING=$STR_CONCAT(NAMDESC,' ',
                                     $STR_ASCII(.FAB[FAB$G_ALQ]),'	',
                                     CDTDESC,
                                     CRLF));
        END;
    [RMS$K_LIST_BRIEF]:
        $STR_COPY(TARGET=BDESC,
                  STRING=$STR_CONCAT(NAMDESC,CRLF));
    [RMS$K_LIST_FULL]:
        BEGIN
        MACRO VALLIST(PFX)[VL]=
               %NAME(PFX,VL) %;

        MACRO VALNAMELIST(PFX)[]=			  ! Vector of names
            VECTOR[MAX(VALLIST(PFX,%REMAINING))+1]	  ! by value 
            PRESET(VALNAMES(PFX,%REMAINING)) %;

        MACRO VALNAMES(PFX)[VL]=
            [%NAME(PFX,VL)]=%ASCIZ %STRING(VL) %;

        MACRO SAY_WHICH_BITS_1 (DESC,BLK,PFX,COD)[BT]=    ! FLD=(BIT,BIT,BIT)
            IF .BLK[%NAME(PFX,BT)]        ! Is the bit on	
            THEN
		BEGIN
		IF .FIRSTTIME NEQ 0
		THEN $STR_APPEND(STRING=%STRING(' ',
						COD,
						'=('),
				 TARGET=DESC)
                ELSE $STR_APPEND(STRING=',', TARGET=DESC);
		FIRSTTIME=0;
		$STR_APPEND(STRING=%STRING(BT),
                            TARGET=DESC)  
		END %;

	MACRO SAY_WHICH_BITS (DESC,BLK,PFX,COD)[]=
	     BEGIN
	     LOCAL FIRSTTIME: INITIAL(-1);
	     SAY_WHICH_BITS_1(DESC,BLK,PFX,COD,%REMAINING);
	     IF .FIRSTTIME EQL 0
	     THEN $STR_APPEND(STRING=')', TARGET=DESC)
	     END %;

        OWN ORGNAM: VALNAMELIST(FAB$K_ORG_,SEQ,REL,IDX,HSH);
        OWN RFMNAM: VALNAMELIST(FAB$K_RFM_,VAR,STM,LSA,FIX,VFC,UDF);

        $STR_COPY(TARGET=BDESC,
                  STRING=$STR_CONCAT(NAMDESC,'   ',
                                     $STR_ASCII(.FAB[FAB$G_ALQ]),'  ',
                                     CDTDESC,' ',
                                     RDTDESC,' ',
                                     EDTDESC,' '));

        IF  (.FAB[FAB$Z_RFM] NEQ FAB$K_RFM_STM) ! If not stream
	AND (.FAB[FAB$Z_RFM] NEQ FAB$K_RFM_LSA) ! or sequenced,
        AND (.FAB[FAB$Z_RFM] NEQ FAB$K_RFM_UDF) ! or undefined record format
        THEN                                    ! list attributes
            BEGIN
            $STR_APPEND(STRING=$STR_CONCAT('   ORG=',      ! File organization
                                           (3,CH$PTR(ORGNAM[.FAB[FAB$Z_ORG]]))),
			TARGET=BDESC);

            $STR_APPEND(STRING=$STR_CONCAT('   RFM=',   ! Record format & sizz
                                           (3,CH$PTR(RFMNAM[.FAB[FAB$Z_RFM]])),
                                           ':',$STR_ASCII(.FAB[FAB$H_MRS]),
					   '   '),
                        TARGET=BDESC);

            IF .FAB[FAB$H_RAT] NEQ 0    ! Do record attributes if any
            THEN SAY_WHICH_BITS(BDESC,FAB,FAB$V_RAT_,
				RAT,BLK,FTN,CR,PRN,EMB,CBL);

            $STR_APPEND(STRING=$STR_CONCAT('   BSZ=',
					   $STR_ASCII(.FAB[FAB$Z_BSZ])),
			TARGET=BDESC); ! bytesize
            END; ! RMS attributes listing code
	$STR_APPEND(STRING=CRLF, TARGET=BDESC); ! End with a CRLF
        END;

    [RMS$K_LIST_NAME_ONLY]: $STR_COPY(STRING=NAMDESC,TARGET=BDESC);
    [INRANGE, OUTRANGE]:
               $STR_COPY(STRING=%STRING('? Invalid List Function code',CRLF),
                         TARGET=BDESC);
    TES;       

    LENGTH=.BDESC[STR$H_LENGTH];
    
    $STR_COPY(STRING=BDESC, TARGET=DESC[$]);    ! Copy to user's string

    $XPO_FREE_MEM(STRING=NAMDESC);
    $XPO_FREE_MEM(STRING=BDESC);

    .LENGTH
    END;			!End of R$$LIST
END ELUDOM