Trailing-Edge
-
PDP-10 Archives
-
cuspmar86binsrc_2of2_bb-fp63a-sb
-
10,7/dil/dilsrc/direct.bli
There are 21 other files named direct.bli in the archive. Click here to see a list.
MODULE DIRECTORY ( !
IDENT = '6'
%BLISS36(,ENTRY(
R$PARSE, ! Parse filespec into components
R$DIRECTORY, ! Initiate directory search
R$SEARCH, ! Search (wildcard)
DAP$SEARCH, ! Search (wildcard) remote
DAP$MERGE, ! Merge remote filespecs
R$NULL, ! The Null routine--does nothing
R$$MERGE, ! Merge filespecs into Resultant
R$RENAME, ! Rename local or remote file(s)
_SSCAN ! ^V-handling string scanner
))
) =
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
!
! 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'5', '5-Oct-84', 'Sandy Clemens')
! %( Add new format of COPYRIGHT notice. FILES: ALL )%
!
! 06 - Start TOPS-10 support [Doug Rayner]
! 05 - Make R$RENAME call DAP$NEXTFILE for additional files
! 04 - Return after DAP$NEXTFILE if not DIRECTORY
! 03 - Use original punctuation for generation number
! 02 - Move system-dependant code to DIR20.
! 01 - The beginning
!--
!
! INCLUDE FILES:
!
!LIBRARY 'BLI:XPORT';
LIBRARY 'RMS';
LIBRARY 'BLISSNET';
LIBRARY 'CONDIT';
LIBRARY 'DAP';
%BLISS36(
%IF %SWITCHES(TOPS20)
%THEN
LIBRARY 'TWENTY';
! LIBRARY 'BLI:TENDEF';
! LIBRARY 'BLI:MONSYM';
%FI
%IF %SWITCHES(TOPS10)
%THEN
LIBRARY 'BLI:TENDEF';
%FI)
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
R$PARSE, ! Parse filespec into component parts
R$DIRECTORY, ! Initiate directory search
R$SEARCH, ! Search (wildcard)
DAP$SEARCH, ! Search (wildcard) remote
DAP$MERGE, ! Merge remote filespecs
R$NULL, ! The Null routine... does nothing
R$$MERGE: NOVALUE, ! Merge filespecs into Resultant
R$RENAME, ! Rename local or remote file(s)
_SSCAN, ! Special string scanner (handle ^V)
DIR$HANDLE; ! Condition handler
!
! Feature Tests:
!
COMPILETIME MULTIPLE_FILESPECS=1; ! On to allow multiple filespecs in FAB
!
! MACROS:
!
MACRO SSCAN[]=$STR_SCAN(%REMAINING) %; ! String Scan macro
%IF %BLISS(BLISS36)
%THEN
%IF %SWITCHES(TOPS20)
%THEN
UNDECLARE %QUOTE SSCAN;
KEYWORDMACRO
SSCAN( string, remainder, stop, find, span, option, options,
substring, target, delimiter, success, failure = STR$FAILURE ) =
%EXPAND $xpo$required( string remainder, 'STRING= or REMAINDER=' )
%EXPAND $xpo$required( find span stop, 'FIND=, SPAN= or STOP=' )
%IF %EXPAND $xpo$conflict( string, remainder )
%THEN
%WARN( 'STRING= and REMAINDER= are mutually exclusive' )
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict( find, span, stop )
%THEN
%WARN( 'FIND=, SPAN= and STOP= are mutually exclusive' )
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict( option, options )
%THEN
%WARN( 'OPTION= and OPTIONS= are mutually exclusive' )
%EXITMACRO
%FI
%IF %EXPAND $xpo$conflict( substring, target )
%THEN
%WARN( 'SUBSTRING= and TARGET= are mutually exclusive' )
%EXITMACRO
%FI
%ASSIGN( $str$options, %EXPAND $str$opt_init )
%IF NOT %NULL( remainder )
%THEN
%ASSIGN( $str$options, $str$options OR STR$M_REMAINDER )
%FI
%IF NOT %NULL( find )
%THEN
%ASSIGN( $str$function, STR$K_FIND )
%ELSE %IF NOT %NULL( span )
%THEN
%ASSIGN( $str$function, STR$K_SPAN )
%ELSE
%ASSIGN( $str$function, STR$K_STOP )
%FI %FI
%IF NOT %NULL( target )
%THEN
%ASSIGN( $str$options, $str$options OR STR$M_TARGET )
%FI
BEGIN
! %EXPAND $xpo$force( $xpo$ex_routine( _SSCAN ) )
%EXPAND $xpo$ex_failure( failure )
%IF NOT %NULL( delimiter )
%THEN
LOCAL $str$status,
$str$delimiter;
%ELSE
LITERAL $str$delimiter = 0;
%FI
$str$declare( LOCAL, $str$string, string remainder )
$str$declare( LOCAL, $str$pattern, find span stop )
$str$local_init( $str$string, string remainder )
$str$local_init( $str$pattern, find span stop )
%IF NOT %NULL( delimiter )
%THEN
$str$status =
%FI
_SSCAN( %NUMBER( $str$options ) + %NUMBER( $str$function ),
$str$string,
$str$pattern,
$xpo$default( substring target, 0 ),
$str$delimiter,
$xpo$default( success, 0 ),
$xpo$default( failure, 0 ) )
%IF NOT %NULL( delimiter )
%THEN
;
IF .$str$status
THEN
delimiter = .$str$delimiter;
.$str$status
%FI
END %;
%FI
%FI
!
! EQUATED SYMBOLS:
!
LITERAL
FILESPEC_FIELD_SIZE=40; ! Length of filespec field in directory list
!
! OWN STORAGE:
!
OWN SPECSIZE: INITIAL(FILESPEC_FIELD_SIZE); ! Patchable
OWN D_NULL: $STR_DESCRIPTOR(STRING=%CHAR(0));
OWN D_SPACE: $STR_DESCRIPTOR(STRING=' ');
!
! EXTERNAL REFERENCES:
!
EXTERNAL ROUTINE
R$LIST,
R$$LIST,
DAP$OPENFILE,
DAP$GET_MESSAGE,
DAP$PUT_MESSAGE,
DAP$GET_ATTRIBUTES,
DAP$GET_STRING,
DAP$GET_STATUS,
DAP$PUT_STRING,
DAP$PUT_CONTROL,
DAP$GET_ACK,
DAP$ERROR_DAP_RMS,
DAP$HANDLE, ! Condition handler
RL$PARSE,
RL$MERGE, ! Merge local filespecs
RL$DIRECTORY, ! Initiate directory search local
RL$SEARCH, ! Search (wildcard) local
RL$RENAME, ! Rename local file(s)
RL$ERASE, ! Delete local file(s)
XST$SCAN;
EXTERNAL D_SKIP: $XPN_DESCRIPTOR();
%IF MULTIPLE_FILESPECS
%THEN EXTERNAL ROUTINE DAP$NEXTFILESPEC; %FI
GLOBAL ROUTINE R$PARSE (FAB,ERR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Decompose a filespec & merge in related filespec
!
! FORMAL PARAMETERS:
!
! FAB: A FAB as defined by RMS
! ERR: Address of error routine
!
! COMPLETION CODES:
!
! RMS Codes
!
!--
BEGIN
MAP FAB: REF $FAB_DECL;
BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;
BIND NAM=.FAB[FAB$A_NAM]: $NAM_DECL;
IF FIND_SUBSTRING(.FAB[FAB$A_FNA],PP('::')) NEQ 0
THEN FAB[FAB$V_REMOTE]=1; ! Remember
IF .FAB[FAB$V_REMOTE]
THEN
BEGIN
RL$MERGE(FAB[$],MERGE$M_DEFAULTS,.ERR); ! Get defaults first
DAP$MERGE(FAB[$],MERGE$M_EXPANDED+MERGE$M_POINT,.ERR) ! File is remote
END
ELSE RL$PARSE(FAB[$],.ERR) ! Do local parse
END; !End of R$PARSE
GLOBAL ROUTINE R$DIRECTORY (FAB,ERR) = ! Open a directory for listing
!++
! FUNCTIONAL DESCRIPTION:
!
! Open a directory for listing
! Use RMS if file is local, DAP (via DAP$GET) if remote.
!
! FORMAL PARAMETERS:
!
! FAB: A FAB as defined by RMS
! ERR: Address of error routine
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
MAP FAB: REF $FAB_DECL;
BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;
IF FIND_SUBSTRING(.FAB[FAB$A_FNA],PP('::')) NEQ 0
THEN
BEGIN
FAB[FAB$V_REMOTE]=1; ! Remember
DAP$OPENFILE(FAB[$],DAP$K_DIRECTORY,0,.ERR) ! File is remote.
END
ELSE
BEGIN
FAB[FAB$V_REMOTE]=0;
RL$DIRECTORY(FAB[$],.ERR)
END
END; !End of R$DIRECTORY
GLOBAL ROUTINE R$SEARCH (FAB,ERR) = ! Get next file
!++
! FUNCTIONAL DESCRIPTION:
!
! Get directory info for a file
! Use RMS if file is local, DAP (via DAP$DIR_GET) if remote.
!
! FORMAL PARAMETERS:
!
! FAB: A FAB as defined by RMS -- Filled in by this routine
! ERR: Address of error routine
!
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
MAP FAB: REF $FAB_DECL;
BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;
IF .FAB[FAB$V_REMOTE]
THEN DAP$SEARCH(FAB[$],.ERR)
ELSE RL$SEARCH(FAB[$],.ERR)
END; !End of R$SEARCH
GLOBAL ROUTINE DAP$SEARCH (FAB,ERR) = ! Get next file
!++
! FUNCTIONAL DESCRIPTION:
!
! Get directory info for a remote file
!
! FORMAL PARAMETERS:
!
! FAB: A FAB as defined by RMS -- FNA contains wildcard spec
! ERR: Address of error routine
!
! COMPLETION CODES:
!
! Standard RMS codes
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
MAP FAB: REF $FAB_DECL;
BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;
BIND NAM=.FAB[FAB$A_NAM]: $NAM_DECL; ! Name block
LOCAL FABSAV: VOLATILE;
LOCAL ERRSAV: VOLATILE;
ENABLE DIR$HANDLE(FABSAV,ERRSAV); ! Setup Condition handler
ERRSAV=.ERR;
FABSAV=.FAB; ! Handler will need this
IF NAM EQL 0
THEN
BEGIN
FAB[FAB$H_STS]=RMS$_NAM;
$$ERROR(OPEN,FAB[$]);
.FAB[FAB$H_STS]
END
ELSE
BEGIN
BIND DIB=.FAB[FAB$A_DIB]: $DIB;
BIND IDD=.DIB[DIB$A_I_DD]: $DAP_DESCRIPTOR;
BIND ODD=.DIB[DIB$A_O_DD]: $DAP_DESCRIPTOR;
IF .DIB[DIB$V_ACCESS_ACTIVE] EQL 0
THEN
BEGIN
FAB[FAB$H_STS]=RMS$_NMF;
%IF MULTIPLE_FILESPECS
%THEN IF DAP$NEXTFILESPEC(FAB[$],.ERR) NEQ 0
THEN
BEGIN ! [4] If not a DIRECTORY operation
IF .DIB[DIB$B_OPERATION] NEQ DAP$K_DIRECTORY
THEN RETURN .FAB[FAB$H_STS] ![4] Done now
END
ELSE
BEGIN
$$ERROR(GET,FAB[$]);
RETURN .FAB[FAB$H_STS];
END
%ELSE
$$ERROR(GET,FAB[$]);
RETURN .FAB[FAB$H_STS];
%FI
END;
!
! Receive info from other system
!
BEGIN ! If we had an error before
IF (.FAB[FAB$H_STS] NEQ RMS$_SUC)
THEN
BEGIN ! Send CONTINUE(SKIP)
DAP$PUT_STRING(ODD[$],D_SKIP);
DAP$PUT_MESSAGE(ODD[$]);
END;
FAB[FAB$H_STS]=RMS$_SUC; ! Assume we will win
FAB[FAB$H_STV]=0; ! for now
DAP$GET_ATTRIBUTES(IDD[$],FAB[$]);
IF .FAB[FAB$H_STS] EQL RMS$_FNF ! If file-not-found
THEN DIB[DIB$V_ACCESS_ACTIVE]=0; ! then access not active
RETURN .FAB[FAB$H_STS] ! return with it
END
END
END; !End of DAP$SEARCH
GLOBAL ROUTINE DAP$MERGE (FAB: REF $FAB_DECL, FLAGS: BITVECTOR, ERR) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Merge the related file spec with the filespec
! to get the resultant file spec
!
! FORMAL PARAMETERS:
!
! FAB: Address of FAB, which may have NAM block attached
! FLAGS: Merge flags to pass to R$$MERGE (defined in RMSUSR)
!
! COMPLETION CODES:
!
! Standard RMS codes
!
!--
BEGIN
BIND NAM=.FAB[FAB$A_NAM]: $NAM_DECL;
LOCAL DESC: $STR_DESCRIPTOR(CLASS=BOUNDED); ! Filespec descriptor
LOCAL D; ! Delimiter for $STR_SCAN
LOCAL NEXT; ! Offset to next filespec
FAB[FAB$H_STS]=RMS$_SUC; ! Successful so far
IF .FAB[FAB$V_FOP_OFP]
THEN NEXT=0 ! No multiple output filespecs
ELSE NEXT=.NAM[NAM$H_WCC_NEXT]; ! Input multpile filespecs OK
$STR_DESC_INIT(DESC=DESC, CLASS=BOUNDED, ! Point to original filespec
STRING=ASCIZ_STR(CH$PLUS(.FAB[FAB$A_FNA], .NEXT)));
IF $STR_SCAN(REMAINDER=DESC, SUBSTRING=DESC, FIND='::') ! Isolate node name
THEN
BEGIN ! Got node name, check for access info in it
LOCAL NDESC: $STR_DESCRIPTOR(CLASS=BOUNDED); ! Node descriptor
LOCAL D;
$STR_DESC_INIT(DESC=NDESC, STRING=STR_PREFIX(DESC), CLASS=BOUNDED);
$STR_SCAN(REMAINDER=NDESC, SUBSTRING=NDESC,
DELIMITER=D, STOP='"');
$STR_COPY(STRING=$STR_CONCAT(STR_STRING_PLUS_PREFIX(NDESC),
%STRING('::',%CHAR(0))),
TARGET=(RMS$K_NODE_NAME_SIZE,CH$PTR(NAM[NAM$T_NODE])));
NAM[NAM$V_FNB_NODE]=1; ! Filespec has a nodeid
IF .D EQL %C'"'
THEN ! Found access info, save it
BEGIN ! User name
NDESC[STR$H_LENGTH]=.NDESC[STR$H_LENGTH]+1; ! Skip initial quote
$STR_SCAN(REMAINDER=NDESC, SUBSTRING=NDESC, STOP=' "', DELIMITER=D);
$STR_COPY(STRING=$STR_CONCAT(NDESC,D_NULL),
TARGET=(RMS$K_USERID_SIZE,CH$PTR(NAM[NAM$T_USERID])));
IF .D EQL %C' '
THEN
BEGIN ! Password
NDESC[STR$H_LENGTH]=.NDESC[STR$H_LENGTH]+1; ! Skip delimiter
$STR_SCAN(REMAINDER=NDESC, SUBSTRING=NDESC,
STOP=' "', DELIMITER=D);
$STR_COPY(STRING=$STR_CONCAT(NDESC,D_NULL),
TARGET=(RMS$K_PASSWORD_SIZE,
CH$PTR(NAM[NAM$T_PASSWORD])));
IF .D EQL %C' '
THEN
BEGIN ! Account
NDESC[STR$H_LENGTH]=.NDESC[STR$H_LENGTH]+1; ! Skip delimiter
$STR_SCAN(REMAINDER=NDESC, SUBSTRING=NDESC,
STOP=' "', DELIMITER=D);
$STR_COPY(STRING=$STR_CONCAT(NDESC,D_NULL),
TARGET=(RMS$K_ACCOUNT_SIZE,
CH$PTR(NAM[NAM$T_ACCOUNT])));
IF .D EQL %C' '
THEN
BEGIN ! Optional data
NDESC[STR$H_LENGTH]=.NDESC[STR$H_LENGTH]+1; !Skip delimiter
$STR_SCAN(REMAINDER=NDESC, SUBSTRING=NDESC,
STOP='"');
$STR_COPY(STRING=$STR_CONCAT(NDESC,D_NULL),
TARGET=(RMS$K_OPTIONAL_DATA_SIZE,
CH$PTR(NAM[NAM$T_OPTIONAL_DATA])));
END;
END;
END;
END;
END;
IF SSCAN(REMAINDER=DESC, SUBSTRING=DESC, STOP=':') EQL STR$_NORMAL
THEN ! Device name found
BEGIN
DESC[STR$H_LENGTH]=.DESC[STR$H_LENGTH]+1; ! Include :
$STR_COPY(STRING=$STR_CONCAT(DESC,D_NULL),
TARGET=(RMS$K_DEVICE_NAME_SIZE,CH$PTR(NAM[NAM$T_DVI])));
IF SSCAN(STRING=DESC,STOP='?%*') EQL STR$_NORMAL ! Check for wildcards
THEN NAM[NAM$V_FNB_DEV]=1;
END
ELSE DESC[STR$H_LENGTH]=0; ! Else let the rest be scanned
DO BEGIN ! Loop thru filespec
SSCAN(REMAINDER=DESC, SUBSTRING=DESC, ! Isolate file name
DELIMITER=D, STOP=',+!.([<; ');
IF .DESC[STR$H_LENGTH] NEQ 0 ! If any name here
THEN
BEGIN
$STR_COPY(STRING=$STR_CONCAT(DESC,D_NULL), ! copy it
TARGET=(RMS$K_FILE_NAME_SIZE, CH$PTR(NAM[NAM$T_NAM])));
IF SSCAN(STRING=DESC,STOP='?%*') EQL STR$_NORMAL
THEN NAM[NAM$V_FNB_NAM]=1; ! Check for wildcards
END;
SELECT .D OF ! What's next
SET
[%C'.']:
BEGIN
DESC[STR$H_LENGTH]=.DESC[STR$H_LENGTH]+1; ! Skip the initial .
SSCAN(REMAINDER=DESC, SUBSTRING=DESC,
STOP='.;,+!<([',DELIMITER=D);
$STR_COPY(STRING=$STR_CONCAT('.',DESC,D_NULL), ! Extension
TARGET=(RMS$K_EXTENSION_SIZE, CH$PTR(NAM[NAM$T_EXT])));
IF SSCAN(STRING=DESC,STOP='?%*') EQL STR$_NORMAL
THEN NAM[NAM$V_FNB_EXT]=1; ! Check for wildcards
SELECT .D OF
SET
[%C'.',%C';']: ! Version/Generation number
BEGIN
$STR_SCAN(REMAINDER=DESC, SUBSTRING=DESC, DELIMITER=.D,
SPAN=';.0123456789-*'); ! Generation number
$STR_COPY(STRING=$STR_CONCAT(DESC,D_NULL),
TARGET=(RMS$K_VERSION_SIZE,
CH$PTR(NAM[NAM$T_VER])));
IF $STR_SCAN(STRING=DESC,STOP='?%*') NEQ STR$_END_STRING
THEN NAM[NAM$V_FNB_VER]=1; ! Check for wildcards
END;
TES;
END;
[%C';']: ! Version/Generation number
BEGIN
$STR_SCAN(REMAINDER=DESC, SUBSTRING=DESC, DELIMITER=.D,
SPAN=';.0123456789-*'); ! Generation number
$STR_COPY(STRING=$STR_CONCAT(DESC,D_NULL),
TARGET=(RMS$K_VERSION_SIZE,
CH$PTR(NAM[NAM$T_VER])));
IF $STR_SCAN(STRING=DESC,STOP='?%*') NEQ STR$_END_STRING
THEN NAM[NAM$V_FNB_VER]=1; ! Check for wildcards
END;
[%C'[', %C'<', %C'(']: !Directory
BEGIN
SSCAN(REMAINDER=DESC, SUBSTRING=DESC, STOP=']>)',DELIMITER=D);
SELECT .D OF
SET
[%C']',%C'>',%C')']: ! Count directory terminator if any
DESC[STR$H_LENGTH]=.DESC[STR$H_LENGTH]+1;
[OTHERWISE]:;
TES;
$STR_COPY(STRING=$STR_CONCAT(DESC,D_NULL),
TARGET=(RMS$K_DIRECTORY_NAME_SIZE,
CH$PTR(NAM[NAM$T_DIR])));
IF SSCAN(STRING=DESC,STOP='?%*') EQL STR$_NORMAL
THEN NAM[NAM$V_FNB_DIR]=1; ! Check for wildcards
END;
TES;
SELECT .D OF ! Check delimiter now
SET
[%C',', %C'+']: NAM[NAM$V_FNB_MULTIPLE]=1; ! Flag multiple filespecs
[%C',', %C'+', %C'!', %C' ', 0]:
BEGIN
IF .FLAGS[MERGE$V_POINT] ! Point to end of spec if requested
THEN NAM[NAM$H_WCC_NEXT]=
.NAM[NAM$H_WCC_NEXT]+.DESC[STR$H_PFXLEN]+.DESC[STR$H_LENGTH];
EXITLOOP;
END;
TES;
END WHILE 1; ! Loop until filespec is eaten
IF .NAM[NAM$V_FNB_DEV] OR .NAM[NAM$V_FNB_DIR] OR .NAM[NAM$V_FNB_NAM]
OR .NAM[NAM$V_FNB_EXT] OR .NAM[NAM$V_FNB_VER]
THEN NAM[NAM$V_FNB_WILDCARD]=1; ! Wildcard somewhere
R$$MERGE(NAM,.FLAGS); ! Build expanded filespec
.FAB[FAB$H_STS] ! Return status
END; ! End of DAP$MERGE
GLOBAL ROUTINE R$NULL=
!++
! FUNCTIONAL DESCRIPTION:
! This routine does absolutely nothing
BEGIN
0
END;
GLOBAL ROUTINE R$$MERGE(P_NAM, FLAGS: BITVECTOR): NOVALUE=
!++
! FUNCTIONAL DESCRIPTION:
!
! Merge the parts of the name in a name block into a complete filespec.
! This can be either an expanded or resultant filespec:
! If a resultant filespec is built,
! wildcarded parts are taken from the related name block, if any.
!
! FORMAL PARAMETERS:
!
! P_NAM: Address of name block
! FLAGS: Bitvector of merge flags (defined in RMSUSR)
!
!
! ROUTINE VALUE:
!
! NONE
!
!--
BEGIN
LOCAL DESC: $STR_DESCRIPTOR(CLASS=BOUNDED);
BIND NAM=.P_NAM: $NAM_DECL;
LOCAL RNAM: REF $NAM_DECL; ! Address of related name block
IF .FLAGS[MERGE$V_RLF]
THEN
BEGIN
RNAM=.NAM[NAM$A_RLF]; ! Merge with related filespec
IF .RNAM EQL 0 THEN RNAM=NAM; ! If nothing to merge merge itself
END
ELSE
BEGIN
RNAM=NAM; ! Do not merge anything
END;
$STR_DESC_INIT(DESC=DESC, CLASS=DYNAMIC);
IF .NAM[NAM$V_FNB_NODE] NEQ 0
THEN $STR_COPY(STRING=ASCIZ_STR(CH$PTR(NAM[NAM$T_NODE])), TARGET=DESC);
IF CH$RCHAR(CH$PTR(NAM[NAM$T_USERID])) NEQ 0
THEN
BEGIN
DESC[STR$H_LENGTH]=.DESC[STR$H_LENGTH]-2; ! Trim off ::
$STR_APPEND(STRING=$STR_CONCAT('"',
ASCIZ_STR(CH$PTR(NAM[NAM$T_USERID])),
D_SPACE,
ASCIZ_STR(CH$PTR(NAM[NAM$T_PASSWORD])),
D_SPACE,
ASCIZ_STR(CH$PTR(NAM[NAM$T_ACCOUNT])),
'"::'),
TARGET=DESC); ! Put in "user pass acct"::
END;
IF .NAM[NAM$V_FNB_DEV] NEQ 0 ! Wildcard device
THEN $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(RNAM[NAM$T_DEV])), TARGET=DESC)
ELSE $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(NAM[NAM$T_DEV])), TARGET=DESC);
IF .NAM[NAM$V_FNB_DIR] NEQ 0 ! Wildcard directory
THEN $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(RNAM[NAM$T_DIR])), TARGET=DESC)
ELSE $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(NAM[NAM$T_DIR])), TARGET=DESC);
IF .NAM[NAM$V_FNB_NAM] NEQ 0 ! Wildcard name
THEN $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(RNAM[NAM$T_NAM])), TARGET=DESC)
ELSE $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(NAM[NAM$T_NAM])), TARGET=DESC);
IF .NAM[NAM$V_FNB_EXT] NEQ 0 ! Wildcard extension
THEN $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(RNAM[NAM$T_EXT])), TARGET=DESC)
ELSE $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(NAM[NAM$T_EXT])), TARGET=DESC);
IF .NAM[NAM$V_FNB_VER] NEQ 0 ! Wildcard generation
THEN
BEGIN
![3] Use original punctuation for generation/version number
LOCAL PTR, RPTR, R1PTR;
PTR=CH$PTR(NAM[NAM$T_VER]);
RPTR=R1PTR=CH$PTR(RNAM[NAM$T_VER]);
IF CH$RCHAR_A(R1PTR) NEQ 0 ! If related has a generation
THEN
BEGIN
IF CH$RCHAR(.PTR) NEQ 0 ! and our name block has too
THEN ! Use our form of generation number
BEGIN
$STR_APPEND(STRING=(1,.PTR), TARGET=DESC);
RPTR=.R1PTR; ! Start resultant from 2nd char
END;
$STR_APPEND(STRING=ASCIZ_STR(.RPTR),TARGET=DESC);
END;
END
ELSE $STR_APPEND(STRING=ASCIZ_STR(CH$PTR(NAM[NAM$T_VER])), TARGET=DESC);
$STR_APPEND(STRING=D_NULL, TARGET=DESC); ! Make ASCIZ
! For now, expanded string gets copied to resultant also
IF .NAM[NAM$H_RSS] GEQ .DESC[STR$H_LENGTH]-1 ! If there is room
THEN
BEGIN
$STR_COPY(STRING=DESC, ! Copy to resultant string always
TARGET=(.NAM[NAM$H_RSS],.NAM[NAM$A_RSA]));
NAM[NAM$H_RSL]=.DESC[STR$H_LENGTH]-1; ! Length of resultant less null
END;
IF .FLAGS[MERGE$V_EXPANDED] ! Expanded string needed?
AND (.NAM[NAM$H_ESS] GEQ .DESC[STR$H_LENGTH]-1) ! And room for it
THEN
BEGIN
$STR_COPY(STRING=DESC, ! Copy to expanded string
TARGET=(.NAM[NAM$H_ESS],.NAM[NAM$A_ESA]));
NAM[NAM$H_ESL]=.DESC[STR$H_LENGTH]-1; ! Length of expanded less null
END;
$XPO_FREE_MEM(STRING=DESC); ! Free temp storage
END;
GLOBAL ROUTINE R$RENAME (SFAB,DFAB,ERR) = ! Rename a file
!++
! FUNCTIONAL DESCRIPTION:
!
! Rename a file
! Use RMS if file is local, DAP (via DAP$CONNECT) if remote.
!
! FORMAL PARAMETERS:
!
! SFAB: A FAB as defined by RMS
! DFAB: A FAB as defined by RMS
! ERR: Address of error routine
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
MAP SFAB: REF $FAB_DECL;
MAP DFAB: REF $FAB_DECL;
BIND ROUTINE $$ERRRTN=.ERR: RMS_ERCAL;
IF FIND_SUBSTRING(.SFAB[FAB$A_FNA],PP('::')) NEQ 0
THEN
BEGIN
%IF MULTIPLE_FILESPECS
%THEN
DO BEGIN
SFAB[FAB$V_REMOTE]=1; ! Remember
DAP$OPENFILE(SFAB[$],DAP$K_RENAME,DFAB[$],.ERR) ! file is remote
END WHILE DAP$NEXTFILESPEC(SFAB[$],.ERR) ![5] Go for more files
%ELSE
SFAB[FAB$V_REMOTE]=1; ! Remember
DAP$OPENFILE(SFAB[$],DAP$K_RENAME,DFAB[$],.ERR) ! file is remote
%FI
END
ELSE
BEGIN
RL$RENAME(SFAB[$],DFAB[$],.ERR)
END
END; !End of R$RENAME
GLOBAL ROUTINE _SSCAN(FUNCT,STRING,PATTERN,TARGET,DELIM,SUCC,FAIL)=
!++
! Functional Description:
!
! Do $STR_SCAN actions, except that a STOP= string will
! ignore target characters preceded by ^V
!
! Formal Parameters: (Same as XST$SCAN)
!
! FUNCT: Function code and option bits (as defined in XPORT.REQ)
! STRING: Descriptor from STRING= or REMAINDER=
! PATTERN: Descriptor from STOP=, FIND=, or SPAN=
! DELIM: Address of where to store delimiter (DELIMITER=)
! SUCC: Address of success action routine (SUCCESS=)
! FAIL: Address of failure action routine (FAILURE=)
!
! Completion Codes: (Same as XST$SCAN)
!--
BEGIN
MAP FUNCT: BLOCK FIELD($STR$OPT_FIELDS);
MAP STRING: REF $STR_DESCRIPTOR(CLASS=BOUNDED);
MAP PATTERN: REF $STR_DESCRIPTOR(CLASS=BOUNDED);
MAP TARGET: REF $STR_DESCRIPTOR(CLASS=BOUNDED);
LOCAL TFUNCT: BLOCK[1] FIELD($STR$OPT_FIELDS);
LOCAL V;
LOCAL TSTRING: $STR_DESCRIPTOR(CLASS=BOUNDED);
IF .FUNCT[STR$V_REMAINDER]
THEN $STR_DESC_INIT(DESC=TSTRING,CLASS=BOUNDED, ! REMAINDER given
STRING=STR_REMAINDER(STRING))
ELSE $STR_DESC_INIT(DESC=TSTRING,CLASS=BOUNDED, ! STRING given
STRING=(.STRING[STR$H_LENGTH],.STRING[STR$A_POINTER]));
IF (.TARGET NEQ 0) ! Make target pointer point to start
AND .FUNCT[STR$V_REMAINDER] ! if REMAINDER
THEN
BEGIN
TARGET[STR$A_POINTER]=.TSTRING[STR$A_POINTER];
TARGET[STR$H_PFXLEN]=.TARGET[STR$H_PFXLEN]+.TARGET[STR$H_LENGTH];
END;
TFUNCT=.FUNCT;
TFUNCT[STR$V_REMAINDER]=1; ! Always use remainder with our desc
WHILE 1 ! Loop until we find what we want
DO BEGIN ! without ^V before it, or end string
V=XST$SCAN(.TFUNCT,TSTRING,.PATTERN,TSTRING,.DELIM,.SUCC,.FAIL);
IF .V EQL STR$_END_STRING THEN EXITLOOP;
! Now check for ^V
IF CH$RCHAR(CH$PLUS(.TSTRING[STR$A_POINTER],.TSTRING[STR$H_LENGTH]))
EQL $CHCNV
THEN TSTRING[STR$H_LENGTH]=.TSTRING[STR$H_LENGTH]+1 ! Skip quoted char
ELSE EXITLOOP;
END;
IF .TARGET NEQ 0 ! If we have a target, compute length
THEN TARGET[STR$H_LENGTH]=.TSTRING[STR$H_LENGTH]+
CH$DIFF(.TSTRING[STR$A_POINTER],.TARGET[STR$A_POINTER]);
! Substring includes what was
! skipped due to ^V
! plus what we just found
.V ! Returned value (value of $STR_SCAN)
END;
GLOBAL ROUTINE DIR$HANDLE (SIGNAL_ARGS,MECH_ARGS,ENABLE_ARGS) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Condition handler for directory operations
!
! FORMAL PARAMETERS:
!
! SIGNAL_ARGS: addr of vector of SIGNAL arguments,
! MECH_ARGS: not used,
! ENABLE_ARGS: args passed when this handler was established
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! COMPLETION CODES:
!
! 0: Resignal, 1: Continue
!
! SIDE EFFECTS:
!
! NONE
!
!--
BEGIN
MAP SIGNAL_ARGS: REF VECTOR,
MECH_ARGS: REF VECTOR,
ENABLE_ARGS: REF VECTOR;
BIND BLK=..ENABLE_ARGS[1]: $FAB_DECL; ! RMS block
BIND ROUTINE $$ERRRTN=..ENABLE_ARGS[2]: RMS_ERCAL; ! Error routine
LOCAL SEVERITY;
SEVERITY= .(SIGNAL_ARGS[1])<0,3>;
SELECT .SIGNAL_ARGS[1] OF
SET
[DAP$_FNF]:
BEGIN
END;
[SS$_UNWIND]:
BEGIN
RETURN STS$K_NORMAL;
END;
[RMS$K_SUC_MIN TO RMS$K_SUC_MAX]: SEVERITY=SS$_NORMAL;
[RMS$K_ERR_MIN TO RMS$K_ERR_MAX]:
SEVERITY=SS$_ERROR;
[RMS$K_ERR_MIN TO RMS$K_ERR_MAX, RMS$K_SUC_MIN TO RMS$K_SUC_MAX]:
BEGIN
BLK[FAB$H_STS]=.SIGNAL_ARGS[1];
BLK[FAB$H_STV]=.SIGNAL_ARGS[2];
END;
[DAP$K_FACILITY_CODE TO DAP$K_FACILITY_CODE+%O'7777777']:
BEGIN
BLK[FAB$H_STS]=DAP$ERROR_DAP_RMS(.SIGNAL_ARGS[1]);
BLK[FAB$H_STV]=.(SIGNAL_ARGS[1])<DAPCODE>;
END;
[XPN$$SELECT_XPN_ERRORS]:
IF NOT .SEVERITY ! If this is a connect error
THEN ! then change to RMS code
BEGIN
BLK[FAB$H_STS]=RMS$_CON;
BLK[FAB$H_STV]=.SIGNAL_ARGS[1]; ! XPN code
END;
[XPN$_ABORTED, XPN$_DISCONN]:
BEGIN
SEVERITY=STS$K_ERROR; ! Treat as error
BLK[FAB$H_STS]=RMS$_NLB;
END; ! Network link broken (Abort or Disconnect)
[XPN$_NO_OPEN, XPN$_REJECTED]:
BLK[FAB$H_STV]=.SIGNAL_ARGS[2];
! DECnet reason code will be STV for
! unspecified open error
[OTHERWISE]:
BEGIN
BLK[FAB$H_STS]=RMS$_BUG; ! Should not occur
BLK[FAB$H_STV]=.SIGNAL_ARGS[1]; !
SEVERITY=SS$_FATAL; !
END;
TES;
CASE .SEVERITY FROM 0 TO 7 OF
SET
[STS$K_WARNING, STS$K_ERROR]:
BEGIN
$$ERROR(OPEN,BLK); !? Should get operation too
RETURN STS$K_NORMAL;
END;
[STS$K_NORMAL, STS$K_INFO]: RETURN STS$K_NORMAL;
[STS$K_FATAL,INRANGE]: ;
TES;
SS$_RESIGNAL
END; !End of DIR$HANDLE
END !End of module
ELUDOM