Trailing-Edge
-
PDP-10 Archives
-
tops20-v7-ft-dist2-clock
-
language-sources/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 = '1'
%BLISS36(,ENTRY(
R$LIST, ! List FAB to buffer
R$$LIST ! List FAB to descriptor
))
) =
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
!
! 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:
!
! , : VERSION
! 01 - Pry this code loose from DIRECT
!--
!
! INCLUDE FILES:
!
!LIBRARY 'BLI:XPORT';
LIBRARY 'RMS';
LIBRARY 'BLISSNET';
LIBRARY 'CONDIT';
LIBRARY 'DAP';
%BLISS36(
LIBRARY 'TWENTY';
! LIBRARY 'BLI:TENDEF';
! LIBRARY 'BLI:MONSYM';
)
!
! 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:
!
%BLISS36(
LITERAL
FILE_NAME_LENGTH=40;
)
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