PDP-10 Archive: sources/rms/faltop.b36 from BB-JF18A-BM

Trailing-Edge - PDP-10 Archives - BB-JF18A-BM - sources/rms/faltop.b36

There are 3 other files named faltop.b36 in the archive. Click here to see a list.

%TITLE 'FALTOP - Top Level for RMSFAL'
MODULE FALTOP (MAIN=FALTOP,
               VERSION='3(652)',
               IDENT='3(652) 25-Jul-86') =
!++
!
!			    RMSFAL Top Level
!
!--
!
!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1984, 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.
!
!
!++
!
! FUNCTIONAL DESCRIPTION
!
!       This is the File Access Listener program.   It can be run by any  user,
!       for debugging, or it can be started as a detached not logged in job  by
!       NETSERVER, in which  case it also  takes NETWORK.CMD in  PS:<logged-in>
!       and communicates with NETJOB via a named IPCF PID (NETSERVER).  Logging
!       of actions taken  and errors is  done.  Attempts to  connect (good  and
!       bad) are sent to NETSERVER if this job is being controlled.
!
!       AUTHORS: Peter Mierswa, Andrew Nourse
!
!       HISTORY: This module, the top-level routine of FAL-20, was adapted from
!       RDS.BLI, which is  the top-level routine  of the DATATRIEVE-20  server,
!       written by  Peter  Mierswa.   The  architecture  of  both  servers  was
!       originally suggested to him  by Andrew Nourse, so  I guess we're  about
!       even. (I take no credit or blame for this "design"--Greg Scott)
!
!--

%SBTTL 'Revision History'
!++
! REVISION HISTORY:
!
!  634  Make RMSFAL's version number track with RMS.  Minor cleanups.
!       Gregory A. Scott  18-Jul-86
!
!    2  Set version number properly.  Don't try to type anything on the
!       terminal on an error.  Use DEFAULT-EXEC: for the exec.  Delete the
!       temp file with the take of network.cmd after it is used.
!       Gregory A. Scott 13-Jul-86
!
!    1  Creation.
!       Andrew Nourse  --no date--
!--

%SBTTL 'Environment'
BEGIN
!
! LINKAGE DECLARATIONS
!

LINKAGE Fatal_Linkage = PUSHJ : LINKAGE_REGS(15,15,0)
	NOPRESERVE(1,2,3,4,5,6,7,8,9,10,11,12,13,14);

!
! TABLE OF CONTENTS
!

FORWARD ROUTINE
    Fatal		: NOVALUE FATAL_LINKAGE,
    Faltop		: NOVALUE,
    Establish_Connection : NOVALUE,
    Shut_Down		: NOVALUE,
    Find_File		,
    Call_Exec		: NOVALUE,
    TopHandle           ;

!
! LIBRARY DECLARATIONS
!

REQUIRE 'rmsreq';
REQUIRE 'rmsosd';
LIBRARY 'BLISSNET';
LIBRARY 'CONDIT';

!
! MACROS
!
UNDECLARE %QUOTE Type;                  ! XPN cannot coexist with this

MACRO Banner_string= 'RMSFAL version 3.0, DAP Protocol version 7.0' %;


! Since this is a main program, signalling doesn't go over well for
! handling errors, so...

! Macro to cause a jump to the fatal error processing routine
!	for any errors. The machine instruction is
!	PUSHJ P,FATAL. Its a PUSHJ so that the PC of the caller
!	can be found on the stack.

MACRO DIE =
      BEGIN
      BUILTIN MACHOP;
      MACHOP(%O'260',15,FATAL,0,0);
      END %;

! This macro sends literal text to the user log
MACRO $USER_LOG(TEXT) =
      IF .LOG_JFN NEQ 0
      THEN BEGIN
           ODTIM(.LOG_JFN,-1,0);
           BOUT(.LOG_JFN,%C' ');
           SOUT(.LOG_JFN,CH$PTR(UPLIT(%ASCIZ %STRING(TEXT,%CHAR(13,10)))),0);
           END %,

! This macro sends a string to the user log

      $USER_LOG_STRING(POINTER,LENGTH) =
      IF .LOG_JFN NEQ 0
      THEN BEGIN
           ODTIM(.LOG_JFN,-1,0);
           BOUT(.LOG_JFN,%C' ');
           SOUT(.LOG_JFN,POINTER,-LENGTH);
           SOUT(.LOG_JFN,CH$PTR(UPLIT(%STRING(%CHAR(13),%CHAR(10)))));
           END %,

! This macro sends a string to the user log and dies

      $DIE(TEXT) =
      BEGIN
      $USER_LOG(TEXT);
      DIE;
      END %;

%SBTTL 'Module Storage'
!
! Job and IPCF info
!
OWN
    FalNlb: $xpn_Nlb(),                 ! NLB for the link
    JOB_NUMBER,				! My job number
    NS_PID, MY_PID,			! PIDs for IPCF
    PDESC : VECTOR [9],			! IPCF descriptor block
    PDATA : REF VECTOR[],		! Address of IPCF data block
    PDBLOCK : BLOCK [2000],		! IPCF data page
    LOG_JFN : INITIAL (0),		! JFN of user log file
    USER : BLOCK[CH$ALLOCATION(40)],	! User id of connection
    ACCOUNT : BLOCK[CH$ALLOCATION(40)],	! Account string of connection
    PASSWORD : BLOCK[CH$ALLOCATION(40)], ! Password of connection
    LOGGED_IN,				! True if we are logged in
    SAVED_PC,				! PC for interrupt system
    LAST_PACKET,
    PRINT_FIND_MSG;

!
! EXTERNALS
!

EXTERNAL
    UsrSts,
    UsrStv,
    FalObj;

EXTERNAL ROUTINE
    Fal$Do;

!
! GLOBAL DATA 
!

GLOBAL BlkSec: INITIAL(0);              ! What section Fabs, etc in
GLOBAL UstOsF;                          ! Error to give if JSYS fails

%SBTTL 'Routine FATAL'
GLOBAL ROUTINE FATAL : FATAL_LINKAGE NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
!	F A T A L
!
!    FUNCTIONAL DESCRIPTION
!	This routine handles all fatal errors.
!
!    FORMAL PARAMETERS
!	None
!
!    IMPLICIT PARAMETERS
!	The address of the instruction which called us
!	is on the stack as the return address.
!
!    RETURNED VALUE
!	It doesn't return
!
!------------------------------------------------------
BEGIN

BUILTIN MACHOP;

OWN
    POINTER,
    TEXT : BLOCK[CH$ALLOCATION(132)];

! Begin the error message
$USER_LOG(' ');
POINTER = CH$MOVE(32,CH$PTR(UPLIT(%ASCIZ '?RMSFAL Fatal error near PC = ')),
          CH$PTR(TEXT));

! Output the PC of the error
NOUT(.POINTER,(%O'777777' AND MACHOP(%O'200',0,0,15,0)) - 1, 8;POINTER);
CH$WCHAR_A(0,POINTER);
$USER_LOG_STRING(CH$PTR(TEXT),CH$DIFF(.POINTER,CH$PTR(TEXT)));

! Title for last JSYS error
POINTER = CH$MOVE(35,
	CH$PTR(UPLIT(%ASCIZ '	Last JSYS error in this process = ')),
	CH$PTR(TEXT));

! Output the last JSYS error
ERSTR(.POINTER,($FHSLF ^ 18) + %O'777777',0;POINTER);
CH$WCHAR_A(0,POINTER);
$USER_LOG_STRING(CH$PTR(TEXT),CH$DIFF(.POINTER,CH$PTR(TEXT)));

! Close the log file
IF .LOG_JFN NEQ 0 AND .LOG_JFN NEQ $PRIOU THEN
    BEGIN
	CLOSF(.LOG_JFN);
	LOG_JFN = 0;
    END;

! Halt.  If not logged in or we have been CRJOBed then we will logout

WHILE TRUE DO HALTF();

END;	!fatal!

%SBTTL 'Routine FALTOP'
ROUTINE FALTOP : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++
!
!	FALTOP
!
!   FUNCTIONAL DESCRIPTION
!	FALTOP is the root module of the FAL remote server.
!       The remote server is a standalone program,
!	to service remote requests.
!
!   FORMAL PARAMETERS
!	None.
!
!   RETURNED VALUE (R0)
!	None.
!
!-------------------------------------------------
BEGIN
ENABLE TopHandle;

! Enable all of our capabilities
IF NOT EPCAP($FHSLF,-1,-1) THEN DIE;

! Is this user logged in already?
IF NOT GETJI(-1,-1^18+LOGGED_IN,$JILNO) THEN DIE;
IF .LOGGED_IN<0,18,0> NEQ 0 THEN
    LOGGED_IN = TRUE
ELSE
    LOGGED_IN = FALSE;

! If we are not logged in, set our name
IF NOT .LOGGED_IN THEN
    IF NOT SETSN(%SIXBIT 'RMSFAL', %SIXBIT 'RMSFAL') THEN DIE;

! Get my job number
IF NOT GETJI(-1,-1^18+JOB_NUMBER,$JIJNO) THEN DIE;

! Bring in RMS
$Init;

! Start by establishing connection
Establish_Connection( FalNlb );

! Bring the log file into being
IF .LOG_JFN EQL 0 THEN
    BEGIN
	LOG_JFN = FIND_FILE(CH$PTR(UPLIT(%ASCII 'FAL.LOG')),8,
	    GJ_SHT+GJ_OLD+GJ_FOU);
	IF .LOG_JFN NEQ 0 THEN
	    BEGIN
		IF NOT OPENF(.LOG_JFN,OF_WR+7^30) THEN
		    BEGIN
			LOG_JFN = 0;
			IF NOT RLJFN(.LOG_JFN) THEN DIE;
		    END
		ELSE
		    BEGIN
			IF NOT CLOSF(.LOG_JFN + CO_NRJ) THEN
			    BEGIN
				LOG_JFN = 0;
				DIE;
			    END;
			IF NOT OPENF(.LOG_JFN,OF_WR+7^30) THEN
			    BEGIN
				LOG_JFN = 0;
				DIE;
			    END;
		    END;
	    END;
    END;

! Output banner to the log file
$USER_LOG(Banner_string);

! Establish this users job context by making an EXEC take NETWORK.CMD
Call_Exec();

! Do .INI file if we decide we need one

! Go and read messages and do things until the link dies

Fal$do(FalNlb);

Shut_Down();

END; !FALTOP!

%SBTTL 'Routine Establish_Connection'
ROUTINE Establish_Connection ( P_NLB ) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++
!
!	E S T A B L I S H _ C O N N E C T I O N
!
!   FUNCTIONAL DESCRIPTION
!	Establish a connection to a HOST.
!
!   FORMAL PARAMETERS
!	P_NLB: Address of NLB
!
!   RETURNED VALUE (R0)
!	None.
!
!-------------------------------------------------
BEGIN
BIND Nlb=.P_Nlb: $Xpn_Nlb();

LITERAL Pc_Usr = 1^30; ! PC%USR FROM MACREL

LOCAL
    Connected,
    Levtab : VECTOR [3],
    Chntab : VECTOR [36];

! Set up the IPCF system

IF NOT .logged_In THEN
    BEGIN
	Pdata = (((Pdblock AND %O'777777') + 777) ^ -9) * 512;
	! Get NETSERVER's PID
	Pdesc[$ipcfl] = Ip_Cpd;
	Pdesc[$ipcfs] = 0;
	Pdesc[$ipcfr] = 0;
	Pdesc[$ipcfp] = 4^18 + .pdata;
	Pdata[0] = $ipciw;
	Pdata[1] = 0;
	Pdata[2] = %ASCII 'NETSE';
	Pdata[3] = %ASCIZ 'RVER';
	IF NOT MSend(4,Pdesc) THEN Die;
	My_Pid = .pdesc[$ipcfs];
	Pdesc[$ipcfl] = 0;
	Pdesc[$ipcfs] = 0;
	Pdesc[$ipcfr] = .My_Pid;
	Pdesc[$ipcfp] = 512^18 + .Pdata;
	IF NOT MRecv(7,Pdesc) THEN Fatal();
	Ns_Pid = .Pdata[1];
    END;

! Try over and over again until we are connected
Connected = False;
WHILE NOT .Connected DO
    BEGIN
    ! Set up the NLB
    $Xpn_Nlb_Init( Nlb=Nlb );

    ! Open a passive task, wait for somebody to connect to us
    $Xpn_Open( Nlb=Nlb, Type=Passive, Option=Wait , Object=.FalObj );

    ! If the user is already logged in, then succeed
    IF .Logged_In
    THEN Connected = True
    ELSE
        BEGIN
	LOCAL
	    Directory;
	! Get the user id
	IF NOT Mtopr(.Nlb[Nlb$h_Jfn],$Morus,CH$PTR(User),0) THEN Die;

	! Get the password
	IF NOT Mtopr(.Nlb[Nlb$h_Jfn],$Morpw,CH$PTR(Password),0) THEN Die;

	! Get the account
	IF NOT Mtopr(.Nlb[Nlb$h_Jfn],$Morac,CH$PTR(Account),0) THEN Die;

	! Turn the user name into a directory number
	!	log him in, and report to NETSERVER
	Pdesc[$Ipcfl] = 0;
	Pdesc[$Ipcfs] = .My_Pid;
	Pdesc[$Ipcfr] = .Ns_Pid;
	Pdesc[$Ipcfp] = 10^18 + .Pdata;
	! The IPCF packet has job number and user id
	Pdata[1] = .Job_Number;
	CH$MOVE(40,CH$PTR(User),CH$PTR(Pdata[2]));
	IF NOT Rcusr(0,CH$PTR(User),0;Directory) OR
	    NOT Login(.Directory,(%O'777777000000' OR Password),
	    (IF CH$RCHAR(CH$PTR(Account)) EQL 0 THEN 0 ELSE CH$PTR(Account)))
	    THEN BEGIN
		! Log this failure to NETSERVER
		Pdata[0] = -1;
		IF NOT MSend(4,PDesc) THEN Die;
		$Xpn_Disconnect ( Nlb=Nlb , Type=Reject,
                                  Code=Xpn$k_NoAccess );
                $Xpn_Close ( Nlb=Nlb );
	    END
	ELSE
	    BEGIN
		! Log this successful connection to NETSERVER
		Pdata[0] = -2;
                IF NOT Msend(4,Pdesc) THEN Die;
		Connected = True;
	    END;
    END;
END;

! Accept the connection
$xpn_Put ( Nlb=Nlb, Type=Accept );

! Turn off the interrupt system
IF NOT Dir($Fhslf) THEN Die;

RETURN;

END;

%SBTTL 'Routine Shut_Down'
ROUTINE Shut_Down (P_Nlb) : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++
!
!	S H U T _ D O W N
!
!   FUNCTIONAL DESCRIPTION
!	SHUT_DOWN closes down the Server.  Shutdown
!	just causes the server to go away, cleanly if possible,
!	but mostly just away.
!
!   FORMAL PARAMETERS
!	P_Nlb: Address of NLB
!
!   RETURNED VALUE
!	none
!-------------------------------------------------
BEGIN
BIND Nlb=.P_Nlb: $Xpn_Nlb();

$xpn_Close( Nlb=Nlb );

$USER_LOG('FAL terminates normally');

! Close the log file
IF .LOG_JFN NEQ 0 AND .LOG_JFN NEQ $PRIOU
THEN CLOSF(.LOG_JFN);

! Time to push up daisies

WHILE TRUE DO HALTF()

END; !shut_down!

%SBTTL 'Routine Find_File'
ROUTINE Find_File (POINTER, LENGTH, FLAGS) =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
!	F I N D _ F I L E
!
!    FUNCTIONAL DESCRIPTION
!	This routine looks to see if a file exists in
!	PS:<logged-in-directory>
!
!    FORMAL PARAMETERS
!	POINTER - to file name.
!	LENGTH - of file name.
!	FLAGS - for GTJFN.
!
!    RETURNED VALUE
!	JFN of file if it exists.
!	0 if it doesn't.
!
!------------------------------------------------------
BEGIN
LOCAL
    JFN,
    DIRECTORY,
    TEMP_PTR,
    LOCAL_TEXT : BLOCK[CH$ALLOCATION(80)];

! Initialize the temporary descriptor
TEMP_PTR = CH$PTR(LOCAL_TEXT);

! Get the user's logged in directory number
IF NOT GETJI(-1,(-1 ^ 18) OR DIRECTORY,$JILNO) THEN DIE;

! Convert the directory number to a string
IF NOT DIRST(.TEMP_PTR,.DIRECTORY;TEMP_PTR) THEN DIE;

! Add the file name and compute total string length
TEMP_PTR = CH$MOVE(.LENGTH,.POINTER,.TEMP_PTR);
CH$WCHAR_A(0,TEMP_PTR);

! Now check to see if the file exists
IF GTJFN(.FLAGS,CH$PTR(LOCAL_TEXT);JFN)
THEN RETURN .JFN
ELSE RETURN 0;

END;

%SBTTL 'Routine Call_Exec'
ROUTINE Call_Exec : NOVALUE =
!+++++++++++++++++++++++++++++++++++++++++++++++++++
!
!	C A L L _ E X E C
!
!    FUNCTIONAL DESCRIPTION
!	This routine forces an exec in a lower fork to
!	take NETWORK.CMD, if it exists.
!
!    FORMAL PARAMETERS
!	None.
!
!    RETURNED VALUE
!	None.
!
!------------------------------------------------------
BEGIN

LOCAL
    TEMP_JFN,
    FORK_HANDLE,
    EXEC_JFN,
    FILE_JFN,
    POINTER,
    RSCAN_BUFFER : BLOCK[CH$ALLOCATION(200)];

! Does network.cmd exist?
FILE_JFN = FIND_FILE(CH$PTR(UPLIT(%ASCII 'NETWORK.CMD')),11,GJ_SHT+GJ_OLD);
IF .FILE_JFN EQL 0 THEN RETURN;

! Tell user what we are doing
$USER_LOG('TAKEing PS:NETWORK.CMD =>');
! Now put the necessary command in a temp file
IF NOT GTJFN(GJ_SHT,CH$PTR(UPLIT(%ASCIZ '--rmsfal--.TMP;T'));TEMP_JFN)
THEN DIE;
IF NOT OPENF(.TEMP_JFN,OF_WR+7^30) THEN DIE;

! "TAKE "
POINTER = CH$MOVE(5,CH$PTR(UPLIT(%ASCII 'TAKE ')),CH$PTR(RSCAN_BUFFER));

! "filename"
IF NOT JFNS(.POINTER,.FILE_JFN,0;POINTER) THEN DIE;

! Release the JFN
IF NOT RLJFN(.FILE_JFN) THEN DIE;

! "<CRLF>POP<CRLF>"
POINTER = CH$MOVE(17,CH$PTR(UPLIT(%STRING(
	%ASCII ',',
	%CHAR(13),%CHAR(10),
	%ASCII 'ECHO',
	%CHAR(13),%CHAR(10),
	%CHAR(13),%CHAR(10),
	%ASCII 'POP',
	%CHAR(13),%CHAR(10),%CHAR(0)))),.POINTER);

! Now copy the text to the temp file
IF NOT SOUT(.TEMP_JFN,CH$PTR(RSCAN_BUFFER),0) THEN DIE;
IF NOT CLOSF(.TEMP_JFN+CO_NRJ) THEN DIE;
IF NOT OPENF(.TEMP_JFN,OF_RD+7^30) THEN DIE;
 
! Start up a lower level exec
IF NOT CFORK(0;FORK_HANDLE) THEN DIE;
 
! Give the fork our privs minus logout
IF NOT EPCAP(.FORK_HANDLE,NOT SC_LOG,NOT SC_LOG) THEN DIE;
 
! Get a JFN for the EXEC
IF NOT GTJFN(GJ_SHT+GJ_OLD,CH$PTR(UPLIT(%ASCIZ 'SYSTEM:EXEC.EXE'));EXEC_JFN)
THEN DIE;
 
! Get the exec file into the fork
IF NOT GET(.FORK_HANDLE^18 + .EXEC_JFN) THEN DIE;
 
! Make sure the exec doesnt write anything to the tty
IF NOT SPJFN(.FORK_HANDLE,.TEMP_JFN^18 +
    (IF .LOG_JFN NEQ 0 THEN .LOG_JFN ELSE $NULIO)) THEN DIE;

! Start the EXEC
IF NOT SFRKV(.FORK_HANDLE,0) THEN DIE;
 
! Wait for the EXEC to finish
IF NOT WFORK(.FORK_HANDLE) THEN DIE;
 
! Kill the fork and release the execs JFN
IF NOT KFORK(.FORK_HANDLE) THEN DIE;

! Close then and delete and expunge the temp file

IF NOT CLOSF(.temp_jfn+CO_NRJ) THEN DIE;
IF NOT DELF(.temp_jfn+DF_EXP) THEN DIE;

END;

%SBTTL 'Routine MonErr'
GLOBAL ROUTINE MonErr : ExitSub =

! Monitor Call Failed, Get error code into USRSTV

BEGIN

GetEr( $FhSlf ; UsrStv );

IF .UstOsF NEQ 0
THEN UsrSts=.UstOsF
ELSE UsrSts=Rms$_Bug;

UsrErr()
END;

%SBTTL 'Routine TopHandle'

ROUTINE TopHandle ( Signal_Args: REF VECTOR,
                    Mech_Args:   REF VECTOR,
                    Enable_Args: REF VECTOR ) =
BEGIN

IF .signal_args[1] NEQ SS$_UNWIND       ! Nothing if unwinding
THEN BEGIN                              ! Any other signal
     LOCAL pointer;                     ! Pointer to error text
     pdata[0] = -3;                     ! Indicate error message
     pointer = CH$MOVE(29,              ! Start the text string
                       CH$PTR(UPLIT(%ASCII'Unexpected fatal error, code ')),
                       CH$PTR(pdata[2]));
     NOUT(.pointer, .signal_args[1], 10; pointer);
     IF .logged_in                      ! Are we running detached?
     THEN PSOUT(CH$PTR(pdata[2]))       ! Yes, type on terminal
     ELSE IF NOT MSEND(4,pdesc)         ! No, send message to NETJOB
          THEN die;                     ! Die if can't MSEND
     END;

SS$_CONTINUE                            ! Continue

END;
END
ELUDOM