$TITLE( 'REXEC - iRMX REMOTE COMMAND EXECUTION DISPATCHER' )
$COMPACT OPTIMIZE(3) DEBUG PAGELENGTH(60) PAGEWIDTH(132)

rexec_dispatcher: DO;

/****************************************************************************/
/*                                                                          */
/*  MODULE NAME:    rexec_dispatcher (REXEC.PLM)                            */
/*                                                                          */
/*  LAST UPDATE:    February 5, 1992 [18:46:40]                             */
/*                                                                          */
/*  AUTHOR:         N. Scott Pearson, Cableshare Inc.                       */
/*                                                                          */
/*  DESCRIPTION:    This module provides the  dispatcher  portion  of  the  */
/*                  remote command execution facility.                      */
/*                                                                          */
/****************************************************************************/

$INCLUDE( :SD:INC/PLM286/LTKSEL.LIT )
$INCLUDE( :SD:INC/PLM286/PLM286.LIT )
$INCLUDE( :SD:INC/PLM286/RMXII.LIT )
$INCLUDE( :SD:INC/PLM286/RMXII.EXT )

$INCLUDE( REXEC.LIT )

DECLARE port_tkn                TOKEN;
DECLARE pool_tkn                TOKEN;

DECLARE socket                  DWORD;
DECLARE socket_s                SOCKET$DESCR AT( @socket );

DECLARE request                 REXEC_REQUEST_DESCR;

DECLARE buffer_tkn              TOKEN;
DECLARE buffer_ptr              POINTER;
DECLARE response_msg            BASED buffer_ptr REXEC_RESPONSE_DESCR;
DECLARE output_msg              BASED buffer_ptr OUTPUT_REQUEST_DESCR;

DECLARE port_attribs            DATA$PORT$CREATE$DESCR;
DECLARE msg_attribs             MSG$RECEIVED$DESCR;
DECLARE excep_attribs           EXCEP$HANDLER$DESCR;

DECLARE user_tkn                TOKEN;
DECLARE directory_tkn           TOKEN;

DECLARE trans_id                WORD;
DECLARE dummy              (20) BYTE;

DECLARE our_slot                WORD;

DECLARE status                  WORD;
DECLARE instance                WORD;

DECLARE namebuff           (20) BYTE;
DECLARE workbuff          (128) BYTE;
DECLARE pathbuff          (128) BYTE;

DECLARE index                   WORD;
DECLARE char                    BYTE;

/****************************************************************************/
/* ABORT - Aborts the utility with an appropriate message                   */
/****************************************************************************/

abort: PROCEDURE( string_ptr );

    DECLARE type BYTE, string_ptr POINTER, aux_status WORD, buff (5) BYTE;
    DECLARE xlate (16) BYTE DATA( '0123456789ABCDEF' );
    
    CALL RQ$C$SEND$EO$RESPONSE( NIL, 0, @( 10, CR, LF, LF, 'REXEC: ' ), @aux_status );
    CALL RQ$C$SEND$EO$RESPONSE( NIL, 0, string_ptr, @aux_status );
    
    IF ( instance <> 0 ) THEN DO;
        CALL RQ$C$SEND$EO$RESPONSE( NIL, 0, @( 24, CR, LF, 'REXEC:     instance = ' ), @aux_status );
    
        buff(0) = 4;
        buff(1) = xlate(SHR( HIGH(instance), 4 ));
        buff(2) = xlate(HIGH(instance) AND 0FH);
        buff(3) = xlate(SHR( LOW(instance), 4 ));
        buff(4) = xlate(LOW(instance) AND 0FH);
        CALL RQ$C$SEND$EO$RESPONSE( NIL, 0, @buff, @aux_status );
    END;

    CALL RQ$C$SEND$EO$RESPONSE( NIL, 0, @( 22, CR, LF, 'REXEC:     status = ' ), @aux_status );

    buff(0) = 4;
    buff(1) = xlate(SHR( HIGH(status), 4 ));
    buff(2) = xlate(HIGH(status) AND 0FH);
    buff(3) = xlate(SHR( LOW(status), 4 ));
    buff(4) = xlate(LOW(status) AND 0FH);
    CALL RQ$C$SEND$EO$RESPONSE( NIL, 0, @buff, @aux_status );

    CALL RQ$C$SEND$EO$RESPONSE( NIL, 0, @( 3, CR, LF, LF ), @aux_status );
    CALL RQ$EXIT$IO$JOB( status, NIL, @status );

END abort;

/****************************************************************************/
/* Make sure we're not deleted because a system call failed                 */
/****************************************************************************/

excep_attribs.excep$handler$ptr = NIL;
excep_attribs.excep$mode = NO$EXCEPTIONS;

CALL RQ$SET$EXCEPTION$HANDLER( @excep_attribs, @status );

/****************************************************************************/
/* Obtain the id of the user we were invoked by.                            */
/****************************************************************************/

user_tkn = RQ$GET$DEFAULT$USER( THIS$JOB, @status );

IF ( status <> E$OK ) THEN DO;
    instance = 1;
    CALL abort( @( 27, 'Unable to ascertain user id' ) );
END;

request.id_array_size = 10;
CALL RQ$INSPECT$USER( user_tkn, @request.id_array_size, @status );

IF ( status <> E$OK ) THEN DO;
    instance = 2;
    CALL abort( @( 27, 'Unable to ascertain user id' ) );
END;

/****************************************************************************/
/* Obtain the pathname of the current directory                             */
/****************************************************************************/

directory_tkn = RQ$S$ATTACH$FILE( @( 3, ':$:' ), @status );

IF ( status <> E$OK ) THEN DO;
    instance = 1;
    CALL abort( @( 46, 'Unable to ascertain path for current directory' ) );
END;

namebuff(0) = 0;
pathbuff(0) = 0;

CALL RQSGETPATHCOMPONENT( directory_tkn, @workbuff, @status );

IF ( status <> E$OK ) THEN DO;
    instance = 2;
    CALL abort( @( 46, 'Unable to ascertain path for current directory' ) );
END;

CALL RQ$S$DELETE$CONNECTION( directory_tkn, @status );

IF ( status <> E$OK ) THEN DO;
    instance = 3;
    CALL abort( @( 46, 'Unable to ascertain path for current directory' ) );
END;

DO WHILE ( workbuff(0) <> 0 );

    IF ( pathbuff(0) = 0 ) THEN
        pathbuff(0) = workbuff(0);
    ELSE
        DO;
            index = workbuff(0) + 1;
            workbuff(index) = '/';
            CALL MOVB( @pathbuff(1), @workbuff(index+1), pathbuff(0) );
            pathbuff(0) = index + pathbuff(0);
        END;

    CALL MOVB( @workbuff(1), @pathbuff(1), pathbuff(0) );

    namebuff(0) = namebuff(0) + 1;
    namebuff(namebuff(0)) = '^';
    
    directory_tkn = RQ$S$ATTACH$FILE( @namebuff, @status );

    IF ( status <> E$OK ) THEN DO;
        instance = 4;
        CALL abort( @( 46, 'Unable to ascertain path for current directory' ) );
    END;

    CALL RQSGETPATHCOMPONENT( directory_tkn, @workbuff, @status );

    IF ( status <> E$OK ) THEN DO;
        instance = 5;
        CALL abort( @( 46, 'Unable to ascertain path for current directory' ) );
    END;

    CALL RQ$S$DELETE$CONNECTION( directory_tkn, @status );

    IF ( status <> E$OK ) THEN DO;
        instance = 6;
        CALL abort( @( 46, 'Unable to ascertain path for current directory' ) );
    END;
END;

request.directory(0) = pathbuff(0) + 1;
request.directory(1) = '/';
CALL MOVB( @pathbuff(1), @request.directory(2), pathbuff(0) );

/****************************************************************************/
/* Obtain the command to be remotely executed                               */
/****************************************************************************/

char = RQ$C$GET$CHAR( @status );

IF ( status <> E$OK ) THEN DO;
    instance = 1;
    CALL abort( @( 26, 'Unable to get command line' ) );
END;

DO WHILE ( char <= ' ' );
    char = RQ$C$GET$CHAR( @status );

    IF ( status <> E$OK ) THEN DO;
        instance = 2;
        CALL abort( @( 26, 'Unable to get command line' ) );
    END;
END;

index = 0;

DO WHILE ( char <> 0 );
    index = index + 1;
    request.command(index) = char;
    char = RQ$C$GET$CHAR( @status );

    IF ( status <> E$OK ) THEN DO;
        instance = 3;
        CALL abort( @( 26, 'Unable to get command line' ) );
    END;
END;

DO WHILE ( request.command(index) <= ' ' );
    index = index - 1;
END;

request.command(0) = index;

/****************************************************************************/
/* Create the port we use to receive responses and associate a buffer pool  */
/* and a few buffers with it.                                               */
/****************************************************************************/

port_attribs.port$id = 901H;
port_attribs.type = DATA$PORT;
port_attribs.reserved = 0;
port_attribs.flags = FIFO$QUEUING$PORT + NO$BUFFER$CHAINING;

port_tkn = RQ$CREATE$PORT( 10, @port_attribs, @status );

DO WHILE ( ( status <> E$OK ) AND ( port_attribs.port$id < 905H ) );
    port_attribs.port$id = port_attribs.port$id + 1;
    port_tkn = RQ$CREATE$PORT( 10, @port_attribs, @status );
END;

IF ( status <> E$OK ) THEN DO;
    instance = 1;
    CALL abort( @( 38, 'Unable to initialise transport service' ) );
END;

pool_tkn = RQ$CREATE$BUFFER$POOL( 10, NO$BUFFER$CHAINING, @status );

IF ( status <> E$OK ) THEN DO;
    instance = 2;
    CALL abort( @( 38, 'Unable to initialise transport service' ) );
END;

DO index = 1 TO 5;
    buffer_tkn = RQ$CREATE$SEGMENT( SIZE(output_msg), @status );

    IF ( status <> E$OK ) THEN DO;
        instance = 3;
        CALL abort( @( 38, 'Unable to initialise transport service' ) );
    END;

    CALL RQ$RELEASE$BUFFER( pool_tkn, buffer_tkn, SINGLE$BUFFER, @status );

    IF ( status <> E$OK ) THEN DO;
        instance = 4;
        CALL abort( @( 38, 'Unable to initialise transport service' ) );
    END;
END;

CALL RQ$ATTACH$BUFFER$POOL( pool_tkn, port_tkn, @status );

IF ( status <> E$OK ) THEN DO;
    instance = 5;
    CALL abort( @( 38, 'Unable to initialise transport service' ) );
END;

our_slot = RQ$GET$HOST$ID( @status );

IF ( status <> E$OK ) THEN DO;
    instance = 6;
    CALL abort( @( 38, 'Unable to initialise transport service' ) );
END;

/****************************************************************************/
/* Send the request to the server.                                          */
/****************************************************************************/

request.opcode = REXEC_REQUEST;

socket_s.port$id = 900H;
socket_s.host$id = 0;

trans_id = RQ$SEND( port_tkn, socket, @dummy, @request, SIZE(request),
    SINGLE$BUFFER + SYNC$TRANSMISSION, @status );

DO WHILE ( ( status <> E$OK ) AND ( socket_s.host$id <= our_slot ) );
    socket_s.host$id = socket_s.host$id + 1;
    
    trans_id = RQ$SEND( port_tkn, socket, @dummy, @request, SIZE(request),
        SINGLE$BUFFER + SYNC$TRANSMISSION, @status );
END;

IF ( status <> E$OK ) THEN DO;
    instance = 0;
    CALL abort( @( 35, 'Unable to communicate with a server' ) );
END;

/****************************************************************************/
/* Process messages coming back until completion message arrives            */
/****************************************************************************/

instance = 0;

DO FOREVER;
    buffer_ptr = RQ$RECEIVE( port_tkn, WAIT$INDEFINITELY, @msg_attribs, @status );

    IF ( status <> E$OK ) THEN
        CALL abort( @( 41, 'Unable to receive response(s) from server' ) );

    IF ( msg_attribs.status <> E$OK ) THEN DO;
        status = msg_attribs.status;
        CALL abort( @( 41, 'Unable to receive response(s) from server' ) );
    END;

    IF ( msg_attribs.flags <> (MSG$IN$SINGLE$BUFFER + TRANSACTIONLESS$MSG) ) THEN DO;
        status = 0FFFFH;
        CALL abort( @( 41, 'Unable to receive response(s) from server' ) );
    END;

    IF ( output_msg.opcode = OUTPUT_REQUEST ) THEN
        DO;
            CALL RQ$C$SEND$CO$RESPONSE( NIL, 0, @output_msg.length, @status );
            CALL RQ$RELEASE$BUFFER( pool_tkn, SELECTOR$OF(buffer_ptr), SINGLE$BUFFER, @status );
        END;
    ELSE
        IF ( response_msg.opcode = REXEC_RESPONSE ) THEN
            IF ( ( response_msg.status <> E$OK ) AND ( response_msg.instance <> 0 ) ) THEN
                DO;
                    instance = response_msg.instance;
                    status = response_msg.status;
                    CALL abort( @( 41, 'Command dispatch error reported by server' ) );
                END;
            ELSE
                CALL RQ$EXIT$IO$JOB( response_msg.status, NIL, @status );
        ELSE
            DO;
                status = 0FFFFH;
                CALL abort( @( 27, 'Unexpected message received' ) );
            END;
END;

END rexec_dispatcher;

