Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/rmsdir.b36
There are 3 other files named rmsdir.b36 in the archive. Click here to see a list.
%TITLE 'RMSDIR - $PARSE, $SEARCH, $RENAME'
MODULE RMSDIR (
IDENT = '3(661)'
%BLISS36(,ENTRY(
$PARSE, ! Parse filespec into components
$SEARCH, ! Search (wildcard)
DAP$SEARCH, ! Search (wildcard) remote
DAP$MERGE, ! Merge remote filespecs
$RENAME, ! Rename local or remote file(s)
_SSCAN ! ^V-handling string scanner
))
) =
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, RMS
!
! ABSTRACT: Routines to do wildcarding, renaming, and filespec handling
!
!
! ENVIRONMENT: RMS, BLISSNET, XPORT, Transportable code.
!
! AUTHOR: Andrew Nourse, CREATION DATE: 3-Jan-82
! 661 - Handle ^V properly in most if not all cases.
! 651 - DAP$SEARCH and DAP$MERGE didn't stop on a null causing it not to work
! sometimes and in particular on TOPS-10 filenames.
! 650 - DAP$SEARCH didn't update the NAM block lengths and pointers properly
! for remote files breaking DIU's directory command and wildcards
! to/from remotes.
! 575 - Do remote node/user/password correctly
! 566 - Make some improvements in handling wildcarding
!
! 07 - Change to use new-style NAM block
! 06 - RMS'ify
! 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:
!
REQUIRE 'RMSREQ';
LIBRARY 'BLISSNET';
LIBRARY 'CONDIT';
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
$PARSE, ! Parse filespec into component parts
$SEARCH, ! Search (wildcard)
DAP$SEARCH, ! Search (wildcard) remote
DAP$MERGE, ! Merge remote filespecs
$RENAME, ! Rename local or remote file(s)
_SSCAN; ! Special string scanner (handle ^V)
!
! Feature Tests:
!
COMPILETIME MULTIPLE_FILESPECS=1; ! On to allow multiple filespecs in FAB
!
! MACROS:
!
UNDECLARE %QUOTE SUCCESS; ! This macro screws us !a545
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
!
! PURE DATA:
!
PSECT OWN=$HIGH$;
!
! EXTERNAL REFERENCES:
!
EXTERNAL ROUTINE
R$NULL,
DAP$OPENFILE,
Dap$EndAccess,
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
S$DTSTR,
RL$PARSE,
RL$MERGE, ! Merge local filespecs
RL$SEARCH, ! Search (wildcard) local
RL$RENAME, ! Rename local file(s)
GetJfn,
RlsJfn, !615
XST$SCAN,
D$JfnAi,
D$FspAi,
D$NamAi;
%IF MULTIPLE_FILESPECS
%THEN EXTERNAL ROUTINE DAP$NEXTFILE; %FI
GLOBAL ROUTINE $Parse ( P_Fab, P_Err ) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Decompose a filespec & merge in related filespec
!
! FORMAL PARAMETERS:
!
! P_FAB: Addr of FAB
! P_ERR: Address of error routine
!
! COMPLETION CODES:
!
! RMS Codes
!
!--
BEGIN
LOCAL GtJfnBits: BITVECTOR[%BPUNIT];
BIND UFab=.P_Fab: $Fab_decl;
BIND ROUTINE $$Errrtn=.P_Err: Rms_Ercal;
BIND UNam=UAddr(.UFab[Fab$a_Nam]): $Nam_decl;
MAP
!
! RMSLIB cannot define these externals as MONWORD (because
! a library file cannot reference a structure from a library
! file) so MAP them instead.
!
dvflgs : monword; ! Device flags (from DVCHAR)
rmsentry ('$PARSE');
!+
! Fetch the user's FAB and error address.
!-
fab = Ufab; ! Get address of FAB
erradr = .P_err; ! and user error address
errorblock (fab); ! All errors go to the FAB
!
! Make sure this is a FAB.
!
IF .UFab [Fab$h_Bid] NEQ Fab$k_Bid THEN usererror (Rms$_Fab);
IF .UFab [Fab$h_Bln] LSS Fab$k_BLn THEN usererror (Rms$_Bln);
!
! Make sure there is a NAM block.
!
IF UNam EQL 0 THEN usererror (Rms$_Nam);
IF .UNam[Nam$h_Bid] NEQ Nam$k_Bid THEN usererror (Rms$_Nam);
IF .UNam[Nam$h_Bln] LSS Nam$k_BLn THEN usererror (Rms$_Bln);
oaflags = 0; ! Clear the open-abort flags
!
! End of setup
!
!
! Make ESA/RSA into byte pointers, if not already
!
BEGIN
BIND Esaptr=UNam[Nam$a_Esa]: $Byte_Pointer;
BIND Rsaptr=UNam[Nam$a_Rsa]: $Byte_Pointer;
UNam[Nam$g_Wcc] = 0; ! Start at the beginning
IF .Esaptr[Ptr$v_owg_section_number] EQL 0
THEN ! Local Address
BEGIN
Esaptr[Ptr$v_Byte_Size] = CH$SIZE();
Esaptr[Ptr$v_Byte_Position] = %BPVAL;
END
ELSE
IF .Esaptr[Ptr$v_Owg_ps] EQL 0 ! If not already byte pointer
THEN Esaptr[Ptr$v_Owg_Ps] = %O'61'; ! One-word global equivalent
IF .Rsaptr[Ptr$v_owg_section_number] EQL 0
THEN ! Local Address
BEGIN
Rsaptr[Ptr$v_Byte_Size] = CH$SIZE();
Rsaptr[Ptr$v_Byte_Position] = %BPVAL;
END
ELSE
IF .Rsaptr[Ptr$v_Owg_Ps] EQL 0 ! If not already byte pointer
THEN Rsaptr[Ptr$v_Owg_Ps] = %O'61'; ! One-word global equivalent
END;
IF .UFab[Fab$a_Ifi] EQL 0 !m572v
THEN
BEGIN
IF (UFab[Fab$a_Ifi] = fst = gmem (fst$k_bln)) EQL false ! Room for FST?
THEN
returnstatus (er$dme); ! No - error
fst [fst$h_bln] = fst$k_bln; ! Set up blocklength !m502
fst [fst$h_bid] = fst$k_bid; ! Set up block id !a504
fst [fst$a_flink] = .fst; ! No streams active yet !a572
setflag (oaflags, abrfst); ! Flush FST on aborting
END; !m572^
IF .UFab[Fab$v_Ofp]
THEN GtJfnBits = (GJ_FOU+GJ_OFG+GJ_IFG+GJ_FLG+ ! output wildcard
((GJ_NEW+$GJLEG)*(.UFab[Fab$v_Sup] EQL 0))) !m577
ELSE GtJfnBits = GJ_OLD+GJ_IFG+GJ_FLG; !
IF .UFab[Fab$v_Cif] !a566
THEN GtJfnBits = GJ_IFG+GJ_OFG+GJ_FLG;
IF .UNam[Nam$v_SynChk] ! Parse-only !a566
THEN
BEGIN
IF .UFab[Fab$v_Ofp]
THEN GtJfnBits = GJ_OFG+GJ_FLG+GJ_FOU
ELSE GtJfnBits = GJ_OFG+GJ_FLG;
END;
GtJfnBits = GetJfn( .GtJfnBits ); ! Get the jfn and flags
IF .UFab[Fab$h_Jfn] EQL 0 ! If we just got this JFN !a566
THEN UNam[Nam$g_Fnb]=.GtjfnBits<lh>; ! then save the flags
IF .userjfn LSS $ErBas ! If we have a JFN, not an error code
AND .userjfn GTR 0 ! or nothing
THEN
BEGIN
UFab[Fab$h_Jfn] = .UserJfn; ! Give JFN back to user !a566
dvflgs = devchar (.userjfn); ! Get device flags (20 format)
END;
IF .UFab[Fab$v_Remote] ! IF File is remote !m566v
THEN
BEGIN
Dap$Merge( UFab,
Merge$m_Expanded+Merge$m_Rlf+Merge$m_Point,
$$ErrRtn ); !a600
IF NOT .UNam[Nam$v_SynChk] ! Not parse-only, really do things
THEN
BEGIN !
LOCAL Functioncode;
IF .UFab[Fab$v_Ofp] ! If output file
THEN Functioncode = 0 ! Just open link & get config
ELSE Functioncode = Dap$k_Open+Fab$m_Nam; ! Open but leave attrs
IF .UFab[Fab$v_Cif] ! If Create-if, set $Create !m570
THEN Functioncode = Dap$k_Create;
fst[fst$h_bid]=fst$k_bid; ! Set up FST, SETFST is not used here
fst[fst$a_flink]=.fst; ! No streams active yet
fab[fab$a_ifi] = .fst; ! Return file-ID
Dap$Openfile( UFab,
.Functioncode,
0, ! for $Search
$$ErrRtn ); ! File is remote
fst[fst$h_rfm] = .fab[fab$v_rfm];
fst[fst$b_fac] = .fab[fab$h_fac];
fst[fst$h_mrs] = .fab[fab$h_mrs];
fst[fst$g_mrn] = .fab[fab$g_mrn];
fst[fst$h_fop] = .fab[fab$h_fop]; ! Use new place in FST !m557
fst[fst$v_drj] = 1; ! Required for wildcarding
fst[fst$h_rat] = .fab[fab$h_rat];
fst[fst$h_bsz] = .fab[fab$v_bsz];
fst[fst$h_org] = .fab[fab$v_org];
fst[fst$a_blink]=fst[fst$a_flink]=.fst; ! Link to self
fst[fst$h_device_type]=dvdsk; !? Assume disk for now
END;
END !d600
ELSE ! Local Parse
Rl$Parse( UFab, $$ErrRtn );
%IF %SWITCHES(TOPS20) !615
%THEN
IF .UNam[Nam$v_SynChk]
THEN
BEGIN
LOCAL v;
v=Rlsjfn (.Userjfn ) ;
UFab[Fab$h_Jfn] = 0;
END;
%FI
OaFlags = 0;
UsrRet()
END; !End of $PARSE
GLOBAL ROUTINE $Search (P_Fab,P_Err) = ! Get next file
!++
! FUNCTIONAL DESCRIPTION:
!
! Get directory info for a file
!
! FORMAL PARAMETERS:
!
! P_FAB: A FAB as defined by RMS -- Filled in by this routine
! P_ERR: Address of error routine
!
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
BIND UFab=.P_Fab: $Fab_decl;
BIND UNam=UAddr(.UFab[Fab$a_Nam]): $Nam_decl;
BIND ROUTINE $$Errrtn=.P_Err: Rms_ercal;
rmsentry ('$SEARCH'); !a566
!+
! Fetch the user's FAB and error address.
!-
fab = UFab; ! Get address of FAB !a566
erradr = $$Errrtn; ! and user error address !a566
errorblock (fab); ! All errors go to the FAB !a566
!
! Make sure this is a FAB.
!
IF .UFab [Fab$h_Bid] NEQ Fab$k_Bid THEN usererror (Rms$_Fab);
IF .UFab [Fab$h_Bln] LSS Fab$k_BLn THEN usererror (Rms$_Bln);
!
! Make sure there is a NAM block.
!
IF UNam EQL 0 THEN usererror (Rms$_Nam);
IF .UNam[Nam$h_Bid] NEQ Nam$k_Bid THEN usererror (Rms$_Nam);
IF .UNam[Nam$h_Bln] LSS Nam$k_BLn THEN usererror (Rms$_Bln);
!
! Set up Fst pointer & check it
!
Fst = .UFab [Fab$a_Ifi]; !a566
IF .UFab[Fab$v_Remote]
THEN
Dap$Search( UFab, $$ErrRtn )
ELSE
Rl$Search( UFab, $$ErrRtn );
IF .UsrSts NEQ Rms$_Suc ! If we got an error, give error !m566
THEN UserError( .UFab[Fab$h_Sts] );
OaFlags = 0;
UsrRet()
END; !End of $SEARCH
GLOBAL ROUTINE Dap$Search (P_Fab,P_Err) = ! Get next file
!++
! FUNCTIONAL DESCRIPTION:
!
! Get directory info for a remote file
!
! FORMAL PARAMETERS:
!
! P_FAB: A FAB as defined by RMS -- FNA contains wildcard spec
! P_ERR: Address of error routine
!
! COMPLETION CODES:
!
! Standard RMS codes
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
BIND Fab=.P_Fab: $Fab_decl;
BIND ROUTINE $$Errrtn=.P_Err: Rms_ercal;
BIND Nam=UAddr(.Fab[Fab$a_Nam]): $Nam_decl; ! Name block
BIND Fst=.FAB[FAB$a_Ifi]: $Rms_Fst;
BIND Idd=.Fst[Fst$a_I_DD]: $DAP_DESCRIPTOR;
BIND Odd=.Fst[Fst$a_O_DD]: $DAP_DESCRIPTOR;
LOCAL Fabsav: VOLATILE;
LOCAL Errsav: VOLATILE;
LOCAL d, uptr, desc : $STR_DESCRIPTOR (CLASS=BOUNDED);
ENABLE DAP$HANDLE (fabsav, errsav); ! Setup Condition handler
errsav = $$ERRRTN;
fabsav = fab; ! Handler will need this
IF .Fst[Fst$v_Access_Active] EQL 0
THEN
BEGIN
Fab[Fab$h_Sts] = UsrSts = Rms$_Nmf;
%IF MULTIPLE_FILESPECS
%THEN IF DAP$NEXTFILE(Fab,$$ErrRtn) NEQ 0
THEN BEGIN ! [4] If not a DIRECTORY operation
IF .Fst[Fst$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
Nam[Nam$h_Wcc_Count]=.Nam[Nam$h_Wcc_Count]+1; ! Incr wildcard count
BEGIN
! If the file was not closed yet (and not first time)
IF (.Nam[Nam$h_Wcc_Count] NEQ 1)
AND NOT .Fst[Fst$v_Close_Done] !m566
THEN
BEGIN ! Send Access Complete to close it
BIND cmpfunc=( IF .Fst[Fst$v_Error]
THEN Dap$k_Accomp_Skip
ELSE Dap$k_Accomp_Command );
Fst[Fst$h_Fop]=Fab$m_Drj; ! Don't close the link !m547
Dap$EndAccess( Fab, cmpfunc, R$Null ); !m566
IF .Fst[Fst$v_Access_Active] EQL 0
THEN
BEGIN
Fst[Fst$v_Drj]=.Fab[Fab$v_Drj];
RETURN ( Fab[Fab$h_Sts] = UsrSts = Rms$_Nmf ); !m566
END;
END;
Fst[Fst$v_Close_Done] = 0; ! Clear Close_Done, not same file !m566
Fab[Fab$h_Sts] = UsrSts = RMS$_SUC; ! Assume we will win
Fab[Fab$h_Stv]=0; ! for now
! Now get the resultant filespec and file attributes back.
! (Unless we get an error)
DAP$GET_ATTRIBUTES (idd, fab);
! Zero unused part of buffer left over from previous filenames. This
! confuses us later if we don't clean it up now. Then recompute the
! pointers for the name block.
CH$FILL (0, ! Zero unused part of buffer
.nam[NAM$H_RSS] - .nam[NAM$H_RSL],
CH$PLUS(UAPOINTER(.nam[NAM$A_RSA]), .nam[NAM$H_RSL]));
! Correct name block pointers and sizes as needed.
$STR_DESC_INIT (DESC = desc, CLASS = BOUNDED,
STRING = (.nam[NAM$H_RSS] - .nam[NAM$B_NODE],
UAPOINTER(.nam[NAM$A_DEV])));
uptr = .nam[NAM$A_DEV]; ! Start at the device name
nam[NAM$B_DEV] = ! Clear length of non node filespec
nam[NAM$B_DIR] = ! components,
nam[NAM$B_NAME] = ! They will be
nam[NAM$B_TYPE] = ! set up in the code
nam[NAM$B_VER] = 0; ! that follows
IF SSCAN (REMAINDER = desc, SUBSTRING = desc,
STOP=%STRING(%CHAR(0),':;./ '),
DELIMITER = d) EQL STR$_NORMAL
AND (.d EQL %C':')
THEN BEGIN ! device name found
desc[STR$H_LENGTH] = .desc[STR$H_LENGTH]+1; ! Include the colon
nam[NAM$B_DEV] = .desc[STR$H_LENGTH]; ! Set the length of dev
END;
uptr = CH$PLUS(.uptr, .nam[NAM$B_DEV]); ! Update user pointer
DO BEGIN ! loop thru filespec
IF SSCAN (REMAINDER = desc, SUBSTRING = desc, ! Isolate File Name
DELIMITER = d, STOP=%STRING(%CHAR(0),',+!.([<; '))
NEQ STR$_NORMAL
THEN EXITLOOP; ! Finished if at end of string
IF .desc[STR$H_LENGTH] NEQ 0 ! If any name here
THEN BEGIN
nam[NAM$B_NAME] = .desc[STR$H_LENGTH]; ! Set its length
nam[NAM$A_NAME] = .uptr; ! Say where name is
uptr = CH$PLUS (.uptr, .nam[NAM$B_NAME]); ! Update user pointer
END;
SELECT .d OF
SET
[%C'.']: BEGIN
! Descriptor still points to the filename, Bump the length by one
! so it points to the filename plus dot. Then we can scan through
! the string for another dot for version, or other delimiter
desc[STR$H_LENGTH] = .desc[STR$H_LENGTH] + 1; ! Skip the initial
SSCAN (REMAINDER = desc, SUBSTRING = desc,
STOP=%STRING(%CHAR(0),'.;,+!<(['), DELIMITER = d);
! Having found the end of the file type, we must back up
! the beginning to include the dot again
desc[STR$A_POINTER] = CH$PLUS(.desc[STR$A_POINTER], -1);
desc[STR$H_PFXLEN] = .desc[STR$H_PFXLEN] - 1;
desc[STR$H_LENGTH] = .desc[STR$H_LENGTH] + 1;
nam[NAM$B_TYPE] = .desc[STR$H_LENGTH];
nam[NAM$A_TYPE] = .uptr;
uptr = CH$PLUS (.uptr, .nam[NAM$B_TYPE]);
SELECT .d OF
SET
[%C'.',%C';']: ! Version/Generation number
BEGIN
SSCAN (REMAINDER = desc, SUBSTRING = desc, DELIMITER = d,
SPAN = ';.0123456789-*%?'); ! Generation number
! Don't be fooled by 20-ish file attributes IF we get one of
! those, find a delimiter & get out
IF (.desc[STR$H_LENGTH] EQL 1) AND (.d GEQ %C'A')
THEN SSCAN (REMAINDER = desc, SUBSTRING = desc,
DELIMITER = .d, STOP=',+! ')
ELSE nam[NAM$B_VER] = .desc[STR$H_LENGTH];
nam[NAM$A_VER] = .uptr;
uptr = CH$PLUS (.uptr, .nam[NAM$B_VER]);
END;
TES;
END;
[%C';']: ! Version/Generation number
BEGIN
SSCAN (REMAINDER = desc, SUBSTRING = desc, DELIMITER = d,
SPAN=';0123456789-%?*'); ! Generation number
! Don't be fooled by 20-ish file attributes
! IF we get one of those, find a delimiter & get out
IF (.desc[STR$H_LENGTH] EQL 1) AND (.d GEQ %C'A')
THEN SSCAN (REMAINDER = desc, SUBSTRING = desc,
DELIMITER = D, STOP=',+! ' );
nam[NAM$B_VER] = .desc[STR$H_LENGTH];
nam[NAM$A_VER] = .uptr;
uptr = CH$PLUS (.uptr, .nam[NAM$B_VER]);
END;
[%C'[', %C'<', %C'(']: ! Directory
BEGIN
SSCAN (REMAINDER = desc, SUBSTRING = desc, STOP=']>)',
DELIMITER = d);
SELECT .d OF
SET
[%C']',%C'>',%C')']: desc[STR$H_LENGTH] = .desc[STR$H_LENGTH]+1;
TES;
nam[NAM$B_DIR] = .desc[STR$H_LENGTH];
nam[NAM$A_DIR] = .uptr;
uptr = CH$PLUS (.uptr, .nam[NAM$B_DIR]);
END;
[0, %C' ', %C' ']: EXITLOOP;
TES;
END WHILE 1; ! Loop until filespec is eaten
! End of name block readjustment code
SELECT .Fab[Fab$h_Sts] OF
SET
[Rms$_Fnf]: ! If file-not-found
Fst[Fst$v_Access_Active]=0; ! then access not active
[Rms$k_Suc_Min TO Rms$k_Suc_Max]:
BEGIN
Fst[Fst$v_Access_Active]
=Fst[Fst$v_File_Open]=1; ! else file is open
Fst[Fst$v_Error]=0; ! No error
END;
[OTHERWISE]:
BEGIN
Fst[Fst$v_File_Open]=0; ! else file is not open
Fst[Fst$v_Error]=1; ! and we got an error
END;
TES;
RETURN .Fab[Fab$h_Sts] ! return with it
END
END; !End of DAP$SEARCH
GLOBAL ROUTINE Dap$Merge (
P_Fab: REF $Fab_Decl,
Flags: BITVECTOR,
P_Err
) =
!++
! FUNCTIONAL DESCRIPTION:
!
! Merge the related file spec with the filespec
! to get the resultant file spec
!
! FORMAL PARAMETERS:
!
! P_FAB: Address of FAB, which may have NAM block attached
! FLAGS: Merge flags (defined in RMSSYS)
! P_ERR: Address of error routine or 0
!
! COMPLETION CODES:
!
! Standard RMS codes
!
!--
BEGIN
BIND Fab=.P_Fab: $Fab_Decl;
BIND Nam=UAddr(.Fab[Fab$a_Nam]): $nam_decl;
BIND RNam=UAddr(.Nam[Nam$a_Rlf]): $Nam_decl;
LOCAL desc: $Str_Descriptor(Class=Bounded); ! Filespec descriptor
LOCAL Fdesc: $Str_Descriptor(Class=Bounded); ! Filespec descriptor !a600
LOCAL Odesc: $str_Descriptor( Class=Bounded );
LOCAL uptr; ! Ptr to current user field
LOCAL tptr;
LOCAL d; ! Delimiter for $STR_SCAN
LOCAL next; ! Offset to next filespec
IF Rnam EQL 0 ! If nothing to merge
THEN Flags[Merge$v_Rlf]=0; ! do not merge anything
IF .Flags[Merge$v_Expanded] ! Which spec are we writing?
THEN ! Expanded
BEGIN
uptr = .nam[NAM$A_ESA];
$STR_DESC_INIT (DESC = odesc, CLASS = BOUNDED,
STRING = (.nam[NAM$H_ESS], UAPOINTER(.nam[NAM$A_ESA])))
END
ELSE ! Resultant
BEGIN
uptr = .nam[NAM$A_RSA];
$STR_DESC_INIT (DESC = odesc, CLASS = BOUNDED,
STRING = (.nam[NAM$H_RSS], UAPOINTER(.nam[NAM$A_RSA])));
END;
fab[FAB$H_STS] = usrsts = RMS$_SUC; ! Successful so far
Nam[Nam$b_Node] = ! Clear lengths of
Nam[Nam$b_Dev] = ! filespec
Nam[Nam$b_Dir] = ! components,
Nam[Nam$b_Name] = ! They will be
Nam[Nam$b_Type] = ! set up in the code
Nam[Nam$b_Ver] = 0; ! that follows
IF .fab[Fab$v_Ofp]
THEN next=0 ! No multiple output filespecs
ELSE next=.Nam[Nam$h_Wcc_Next]; ! Input multpile filespecs OK
tptr=CH$PLUS(UAPointer(.Fab[Fab$a_Fna]), .next);
Nam[Nam$a_Node] = .Uptr;
$Str_Desc_Init(Desc=Desc, Class=Bounded, ! Point to original filespec
String=Asciz_Str(.tptr) );
$Str_Desc_Init(Desc=FDesc, Class=Bounded, ! Point to original filespec
String=(.Desc[Str$h_MaxLen], .tptr)); !a600
IF $STR_SCAN (Remainder=Desc, Substring=Desc, Find='::') ! Isolate node name
THEN
BEGIN ! Got node name, check for access info in it
LOCAL d;
LOCAL
Nodeid: $Str_Descriptor(CLASS=DYNAMIC, STRING=(0,0)),
UserId: $Str_Descriptor(CLASS=DYNAMIC, STRING=(0,0)),
Password: $Str_Descriptor(CLASS=DYNAMIC, STRING=(0,0)),
Account: $Str_Descriptor(CLASS=DYNAMIC, STRING=(0,0));
Nam[Nam$v_Node]=1; ! Filespec has a nodeid
%IF %SWITCHES(TOPS20)
%THEN
IF (.UserJfn NEQ 0) AND (.UserJfn LSS %O'600000')
THEN
D$JfnAI( .UserJfn, Nodeid, UserId, Password, Account )
ELSE
%FI
D$FspAI( FDesc, Nodeid, UserId, Password, Account, 0 );
D$NamAi( Nam, Nodeid, UserId, Password, Account );
! Update descr for expanded string to reflect the nodeid we wrote there
ODesc[Str$h_Length] = .Nam[Nam$b_Node];
Uptr = CH$PLUS( .Uptr, .Nam[Nam$b_Node] ); ! Update pointer
!
! Free the descriptors if they are dynamic
! D$FspAi sets them up as fixed, D$JfnAi makes them dynamic
!
IF .Nodeid[Str$b_Class] EQL Str$k_Class_D
THEN $Xpo_Free_Mem( STRING=Nodeid );
IF .Userid[Str$b_Class] EQL Str$k_Class_D
THEN $Xpo_Free_Mem( STRING=Userid );
IF .Password[Str$b_Class] EQL Str$k_Class_D
THEN $Xpo_Free_Mem( STRING=Password );
IF .Account[Str$b_Class] EQL Str$k_Class_D
THEN $Xpo_Free_Mem( STRING=Account);
END; !m600^
Nam[Nam$a_Dev] = .Uptr;
IF SSCAN (REMAINDER = desc, SUBSTRING = desc,
STOP=%STRING(%CHAR(0),':;./ '), DELIMITER = d) EQL STR$_NORMAL
AND (.d EQL %C':')
THEN ! device name found
BEGIN
Desc[Str$h_Length]=.desc[Str$h_Length]+1; ! include :
IF SSCAN (String=Desc,Stop='?%*') EQL Str$_Normal ! check for wildcards
THEN
Nam[Nam$v_Wild_Dev]=1; ! device is wildcarded
IF .flags[Merge$v_Rlf] AND .nam[Nam$v_Wild_Dev]
THEN
BEGIN
Nam[Nam$b_Dev]=.rnam[Nam$b_Dev]; ! length
$str_Append( String=(.rnam[Nam$b_Dev], UAPointer(.rnam[Nam$a_Dev])),
Target=Odesc )
END
ELSE
BEGIN
Nam[Nam$b_Dev]=.desc[Str$h_Length];
$str_Append( String=Desc,
Target=Odesc )
END
END
ELSE
Nam[Nam$b_Dev] = Desc[Str$h_Length] = 0; ! else let the rest be scanned
Uptr = CH$PLUS( .Uptr, .Nam[Nam$b_Dev] ); ! Update user pointer
DO BEGIN ! loop thru filespec
SSCAN (REMAINDER = desc, SUBSTRING = desc, ! Isolate File Name
DELIMITER = d, STOP = %STRING(%CHAR(0),',+!.([<; '));
If .desc[Str$h_Length] NEQ 0 ! if any name here
THEN ! File Name found
BEGIN
IF SSCAN (String=Desc,Stop='?%*') EQL Str$_Normal ! check for wildcards
THEN
Nam[Nam$v_Wild_Name]=1; ! device is wildcarded
IF .flags[Merge$v_Rlf] AND .nam[Nam$v_Wild_Name]
THEN
BEGIN
Nam[Nam$b_Name]=.rnam[Nam$b_Name]; ! Length
$Str_Append( String=(.RNam[Nam$b_Name],
UAPointer(.RNam[Nam$a_Name])),
Target=ODesc )
END
ELSE
BEGIN
Nam[Nam$b_Name]=.Desc[Str$h_Length];
$Str_Append( String=Desc,
Target=Odesc );
END;
Nam[Nam$a_Name] = .Uptr; ! Say where name is going to start !m546
Uptr = CH$PLUS( .Uptr, .Nam[Nam$b_Name] ); ! Update user pointer !m546
END;
SELECT .d OF ! What's next
SET
[%C'.']:
BEGIN
!+
! Descriptor still points to the filename,
! Bump the length by one so it points to the filename plus .
! Then we can scan through the string for another .
! for version, or other delimiter
!-
Desc[Str$h_Length]=.Desc[Str$h_Length]+1; ! Skip the initial .
SSCAN (REMAINDER = desc, SUBSTRING = desc,
STOP=%STRING(%CHAR(0),'.;,+!<(['), DELIMITER = d);
!+
! Having found the end of the file type, we must back up
! the beginning to include the . again
!-
Desc[Str$a_Pointer]=CH$PLUS(.Desc[Str$a_Pointer], -1); !m546
Desc[Str$h_PfxLen]=.Desc[Str$h_Pfxlen] - 1 ;
Desc[Str$h_Length]=.Desc[Str$h_Length] + 1 ; !add 1 for . !m546
IF SSCAN (String=Desc,Stop='?%*') EQL Str$_Normal
THEN Nam[Nam$v_Wild_Type]=1; ! Check for wildcards
IF .Flags[Merge$v_Rlf] AND .Nam[Nam$v_Wild_Type]
THEN
BEGIN
Nam[Nam$b_Type]=.Rnam[Nam$b_Type]; ! Length
$Str_Append( String=(.RNam[Nam$b_Type],
UAPointer(.RNam[Nam$a_Type])),
Target=ODesc );
END
ELSE
BEGIN
Nam[Nam$b_Type]=.Desc[Str$h_Length];
$Str_Append( String=Desc, Target=Odesc );
END;
Nam[Nam$a_Type] = .Uptr;
UPtr = CH$PLUS( .UPtr, .Nam[Nam$b_Type] );
SELECT .d OF
SET
[%C'.',%C';']: ! Version/Generation number
BEGIN
SSCAN (REMAINDER = desc, SUBSTRING = desc, DELIMITER = d,
SPAN = ';.0123456789-*%?'); ! Generation
!m575
! Don't be fooled by 20-ish file attributes
! IF we get one of those, find a delimiter & get out
IF (.Desc[Str$h_Length] EQL 1) AND (.D GEQ %C'A')
THEN SSCAN (REMAINDER = desc, SUBSTRING = desc,
DELIMITER = .d, STOP = ',+! ')
ELSE
BEGIN
IF SSCAN (STRING = desc, STOP = '?%*')
NEQ STR$_END_STRING
THEN Nam[Nam$v_Wild_Ver]=1; ! Check for wildcards
IF .Flags[Merge$v_Rlf] AND .Nam[Nam$v_Wild_Ver]
THEN
BEGIN
Nam[Nam$b_Ver]=.Rnam[Nam$b_Ver];
$Str_Append(String=(.RNam[Nam$b_Ver],
UAPointer(.RNam[Nam$a_Ver])),
Target=ODesc);
END
ELSE
BEGIN
Nam[Nam$b_Ver]=.Desc[Str$h_Length];
$Str_Append( String=Desc, Target=Odesc );
END;
Nam[Nam$a_Ver] = .UPtr;
UPtr = CH$PLUS( .UPtr, .Nam[Nam$b_Ver] );
END;
END;
TES;
END;
[%C';']: ! Version/Generation number
BEGIN
SSCAN (REMAINDER = desc, SUBSTRING = desc, DELIMITER = d,
SPAN = ';0123456789-%?*'); ! Generation number !m575
! Don't be fooled by 20-ish file attributes
! IF we get one of those, find a delimiter & get out
IF (.Desc[Str$h_Length] EQL 1) AND (.D GEQ %C'A')
THEN SSCAN (REMAINDER = desc, SUBSTRING = desc,
DELIMITER = d, STOP = ',+! ' )
ELSE
BEGIN
IF SSCAN (STRING = desc, STOP = '?%*') NEQ STR$_END_STRING
THEN Nam[Nam$v_Wild_Ver]=1; ! Check for wildcards
IF .Flags[Merge$v_Rlf] AND .Nam[Nam$v_Wild_Ver]
THEN
BEGIN
Nam[Nam$b_Ver]=.Rnam[Nam$b_Ver];
$Str_Append( String=(.RNam[Nam$b_Ver],
UAPointer(.RNam[Nam$a_Ver])),
Target=ODesc );
END
ELSE
BEGIN
Nam[Nam$b_Ver]=.Desc[Str$h_Length];
$Str_Append( String=Desc,
Target=Odesc );
END;
Nam[Nam$a_Ver] = .UPtr;
UPtr = CH$PLUS( .UPtr, .Nam[Nam$b_Ver] );
END;
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;
IF SSCAN (STRING = desc, STOP='?%*') EQL STR$_NORMAL
THEN Nam[Nam$v_Wild_Dir]=1; ! Check for wildcards
IF .Flags[Merge$v_Rlf] AND .Nam[Nam$v_Wild_Dir]
THEN
BEGIN
Nam[Nam$b_Dir]=.Rnam[Nam$b_Dir];
$Str_Append( String=(.RNam[Nam$b_Dir],
UAPointer(.RNam[Nam$a_Dir])),
Target=ODesc );
END
ELSE
BEGIN
Nam[Nam$b_Dir]=.Desc[Str$h_Length];
$Str_Append( String=Desc,
Target=Odesc );
END;
Nam[Nam$a_Dir] = .UPtr;
UPtr = CH$PLUS( .UPtr, .Nam[Nam$b_Dir] );
END;
TES;
SELECT .D OF ! Check delimiter now
SET
[%C',', %C'+']: Nam[Nam$v_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$g_Fnb] AND Nam$m_Wildcard_Bits) NEQ 0
THEN Nam[Nam$v_Wildcard]=1; ! Wildcard somewhere
BEGIN
LOCAL fsplen;
fsplen = .Nam[Nam$b_Node]
+ .Nam[Nam$b_Dev]
+ .Nam[Nam$b_Dir]
+ .Nam[Nam$b_Name]
+ .Nam[Nam$b_Type]
+ .Nam[Nam$b_Ver];
IF .Flags[Merge$v_Expanded]
THEN Nam[Nam$h_Esl] = .fsplen
ELSE Nam[Nam$h_Rsl] = .fsplen
END;
.Fab[Fab$h_Sts] ! Return status
END; ! End of DAP$MERGE
GLOBAL ROUTINE $Rename ( P_Sfab, P_Dfab ) = ! Rename a file
!++
! FUNCTIONAL DESCRIPTION:
!
! Rename a file
! Use RMS if file is local, DAP (via DAP$CONNECT) if remote.
!
! FORMAL PARAMETERS:
!
! P_SFAB: A FAB as defined by RMS
! P_DFAB: A FAB as defined by RMS
!
! IMPLICIT INPUTS:
!
! NONE
!
! IMPLICIT OUTPUTS:
!
! NONE
!
! ROUTINE VALUE:
! COMPLETION CODES:
!
! NONE
!
! SIDE EFFECTS:
!
! NONE
!--
BEGIN
BIND Sfab=.P_Sfab: $fab_decl;
BIND Dfab=.P_Dfab: $fab_decl;
LOCAL GtJfnBits: BITVECTOR[%BPUNIT];
RmsEntry ('$RENAME');
!+
! Fetch the user's FAB and error address.
!-
fab = .P_Sfab; ! Get address of FAB
erradr = 0; ! and user error address
errorblock (fab); ! All errors go to the FAB
!
! Make sure this is a FAB.
!
IF .fab [blocktype] NEQ fabcode THEN usererror (er$fab);
IF .fab [blocklength] LSS v1fabsize THEN usererror (er$bln);
oaflags = 0; ! Clear the open-abort flags
!
! End of setup
!
IF .Fab[Fab$v_Ofp]
THEN GtJfnBits = GJ_New
ELSE GtJfnBits = GJ_Old;
!+
! Allocate some core for File Status Table to set up three fields.
! If the fst is not already there, and this a open by nam block
!-
IF .Fab[Fab$v_Nam] AND (.Fab[Fab$a_Ifi] NEQ 0) ! If Open by NAM !a547v
THEN fst=.Fab[Fab$a_Ifi] ! then use this
ELSE
BEGIN
IF (fst = gmem (fst$k_bln)) EQL false ! Room for FST?
THEN
returnstatus (er$dme); ! No - error
fst [fst$h_bln] = fst$k_bln; ! Set up blocklength
fst [fst$h_bid] = fst$k_bid; ! Set up block id
setflag (oaflags, abrfst); ! Flush FST on aborting
END; !a547^^
GetJfn( .GtJfnBits );
IF .userjfn LSS $ErBas ! If we have a JFN, not an error code
AND .userjfn GTR 0 ! or nothing
THEN dvflgs = devchar (.userjfn); ! Get device flags (20 format)
!+
! Test remoteness & set for user
!-
IF (Sfab[Fab$v_Remote]=.Fst[Fst$v_Remote]) !m571
THEN
BEGIN
!
! Make sure both nodes are the same
!
LOCAL
jfn,
Id: $Str_Descriptor(String=Asciz_Str(UAPointer(.SFab[Fab$a_Fna])),
Class=Bounded),
Od: $Str_Descriptor(String=Asciz_Str(UAPointer(.DFab[Fab$a_Fna])),
Class=Bounded),
In: $Str_Descriptor(),
On: $Str_Descriptor();
IF (jfn = .SFab[Fab$h_Jfn]) NEQ 0 !m600
THEN D$jfnAi( .jfn, in, 0, 0, 0 )
ELSE D$FspAi( id, in, 0, 0, 0, 0 );
IF (jfn = .DFab[Fab$h_Jfn]) NEQ 0 !m600
THEN D$jfnAi( .jfn, on, 0, 0, 0 )
ELSE D$FspAi( od, on, 0, 0, 0, 0 );
IF $Str_Eql( String1=$Str_Format( in, Up_Case ),
String2=$Str_Format( on, Up_Case ) ) EQL 0
THEN UserError( Rms$_Rtn );
!
! Try to do it now
!
IF .SFab[Fab$v_Nam] AND .Fst[Fst$v_File_Open] ! By NAM block?
THEN
BEGIN
Dap$EndAccess( .SFab, Dap$k_Accomp_Change_Begin, r$null );
Dap$EndAccess( .Dfab, Dap$k_Accomp_Change_End, r$null );
END
ELSE
Dap$openfile( Sfab, Dap$k_Rename, Dfab, r$null ) ! file is remote
END
ELSE
Rl$Rename( Sfab, Dfab, r$null );
oaflags = 0; ! No unwind needed
usrret()
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
[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] = UsrSts =.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] = UsrSts =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] = UsrSts =Rms$_Dcf;
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] = UsrSts =Rms$_Dcb;
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] = UsrSts =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(PARSE,BLK);
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