$!Subject: rexec 3 of 4 (rexec.source)
$!
$ show default
$ check_sum = 2065967902
$ write sys$output "Creating DESCRIP.MMS"
$ create DESCRIP.MMS
$ DECK/DOLLARS="$*$*EOD*$*$"
! DEBUG = /DEBUG
LIST = /NOLIST
LINKFLAGS = /NOMAP/EXE=$@ $(DEBUG)
BFLAGS = /OPTIMIZE=LEVEL:0 $(DEBUG) $(LIST)
NAME = EXEC

build :         exec.exe
        $ write sys$output "$(NAME):  Build finished."

install : build, [exe]exec.exe, [cld]exec.cld
        $ write sys$output "Installation finished"

exec.exe :      exec.obj, exec_err.obj
        $ LINK $(LINKFLAGS) exec.obj, exec_err.obj, [library]neterror.obj

exec.obj : exec.bli

[exe]exec.exe : exec.exe
        $ copy $< $@

[cld]exec.cld : exec.cld
        $ copy $< $@
$*$*EOD*$*$
$ checksum DESCRIP.MMS
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ check_sum = 57660336
$ write sys$output "Creating EXEC.BLI"
$ create EXEC.BLI
$ DECK/DOLLARS="$*$*EOD*$*$"
! Execute remote commands.
! Foreign-port #512 (or optional user-specified)
!
! We will open a TCP connection to the UNIX remote execution server.
! This should let us execute commands on the other system with input
! and output on the local system.
!
! DCL command format is:
!
! $ exec [/username = {current-username} ] host-name remote-command
!        [/password= ]
!        [/input = {NL:} ]
!        [/output = {SYS$OUTPUT} ]
!        [/error = {SYS$ERROR} ]
!        [/service_port = {512} ]
!
!       host-name = some known host
!       remote-command = any command to be executed on the remote host
!
!       The password will be prompted for (with noecho) if not supplied.
!
!
! Written by Kevin Carosso, Hughes Aircraft Co., SCG/CTC
!
! 1.1   15-FEB-1987 Kevin Carosso    Hughes Aircraft Co., SCG/CTC
!               Modified to work with the CMU version of Tek TCP/IP.
!
module Exec (MAIN = start, ident = '1.1',
                list (norequire, noobject, nobinary)) =
begin

library 'SYS$LIBRARY:xport';
library 'SYS$LIBRARY:starlet';
library '[library]netVMS';
library '[library]netmacros';
library '[library]network';
library '[library]neterror';

builtin
        LOCC, MOVC3;

external routine
        CLI$PRESENT : addressing_mode (general),
        CLI$GET_VALUE : addressing_mode (general),
        LIB$GET_EF : addressing_mode (general),
        LIB$SIGNAL : addressing_mode (general),
        STR$TRIM : addressing_mode (general),
        STR$TRANSLATE : addressing_mode (general),
        OTS$CVT_TU_L : addressing_mode (general);

external literal
        EXEC_BADEFN,
        EXEC_NETERR,
        EXEC_INFILERR,
        EXEC_OUTFILERR,
        EXEC_ERRFILERR,
        EXEC_PWDREADERR,
        EXEC_RTLERR,
        EXEC_SYSERR;

literal
        max_UNIX_username_len   = 8,            ! To trim default username.
        max_buffer_size         = 1024;

macro
!
! Check the status return of a QIO.  If the status is bad, this
! will signal.
!
  Check_net_QIO (status) =
    if not .status then
      LIB$SIGNAL (EXEC_NETERR, 0, .status)
  %;

macro
!
! Check the status return in an IOSB.  If the status is bad, this
! will then look for SS$_ABORT.  If that's the case, then check
! for specific TCP errors.  This will ALSO signal if anything is bad.
!
  Check_net_IOSB (iosb) =
    if not .iosb[VMS_code] then
      dump_IOSB(iosb)
  %;

%SBTTL 'Dump the iosb'

routine dump_IOSB (iosb : ref network_IO_status_block) : novalue =
begin

  if .iosb[VMS_code] neq SS$_ABORT then
    LIB$SIGNAL (EXEC_NETERR, 0, .iosb[VMS_code])
  else
    LIB$SIGNAL (EXEC_NETERR, 0, .iosb[net_xerror]);
end;

%SBTTL 'Write a buffer to output'
!
! This writes a buffer out.  It is careful to convert UNIX newlines
! into record terminators...
!
routine write_buffer (buffer, buffer_size, rab : ref $RAB_DECL) : novalue =

begin
  own
    save_buffer : vector [max_buffer_size, byte],
    save_buffer_offset : initial (0);

  local
    buff_pointer,
    found,
    length,
    rc;

  buff_pointer = .buffer;

  while .buff_pointer LSS .buffer + .buffer_size do
  begin

    LOCC (%REF (10),
          %REF (.buffer_size - (.buff_pointer - .buffer)),
          .buff_pointer; found, length);

    length = .length - .buff_pointer;

    if (.found EQL 0) OR (.save_buffer_offset GTR 0) then
    begin
      MOVC3 (%REF (MIN (.length, max_buffer_size - .save_buffer_offset)),
             .buff_pointer, save_buffer[.save_buffer_offset];
             ,,, save_buffer_offset);
      save_buffer_offset = .save_buffer_offset - save_buffer;
    end;

    if (.found NEQ 0) OR (.save_buffer_offset EQL max_buffer_size) then
!
! Need to write something out...
!
      if (.save_buffer_offset NEQ 0) then
!
! Write from "save_buffer"
!
      begin
        rab[RAB$L_RBF] = save_buffer;
        rab[RAB$W_RSZ] = .save_buffer_offset;
        if not (rc = $PUT (RAB = .rab)) then
          LIB$SIGNAL (EXEC_OUTFILERR, 0, .rc, .rab[RAB$L_STV]);
        save_buffer_offset = 0;
      end
      else
!
! Write from buffer
!
      begin
        rab[RAB$L_RBF] = .buff_pointer;
        rab[RAB$W_RSZ] = .length;
        if not (rc = $PUT (RAB = .rab)) then
          LIB$SIGNAL (EXEC_OUTFILERR, 0, .rc, .rab[RAB$L_STV]);
      end;

    buff_pointer = .buff_pointer + .length + 1;
  end;
end;

%SBTTL 'Mainline'

routine start : novalue=
begin

register
        rc;

literal
        input_buffer_size = 1024,
        pass_prompt_len = 17,                   ! length of pass_prompt
        LF = 10;                                ! Line feed
bind
        CLI_host_label = %ASCID 'HOST',
        CLI_remote_command = %ASCID 'RCMD',
        CLI_input = %ASCID 'INPUT',
        CLI_output = %ASCID 'OUTPUT',
        CLI_error = %ASCID 'ERROR',
        CLI_username = %ASCID 'USERNAME',
        CLI_password = %ASCID 'PASSWORD',
        CLI_port = %ASCID 'SERVICE_PORT',
        uppercase = %ASCID 'ABCDEFGHIJKLMNOPQRSTUVWXYZ',
        lowercase = %ASCID 'abcdefghijklmnopqrstuvwxyz',
        pass_prompt = Plit (%ASCII 'Remote password: '),
        net_device = %ASCID 'IP:';

own
        tmp_str : vector [256, byte],
        tmp_desc : $STR_DESCRIPTOR (CLASS = fixed, STRING = (256, tmp_str)),

        fhost_str : vector[20, byte],
        fhost_desc : $STR_DESCRIPTOR (CLASS = fixed, STRING = (20, fhost_str)),

        fcmd_str : vector[256, byte],
        fcmd_desc : $STR_DESCRIPTOR (CLASS = fixed, STRING = (256, fcmd_str)),

        username_str : vector[32, byte],
        username_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                         STRING = (32, username_str)),
        username_list : $ITMLST_DECL (ITEMS = 1),

        password_str : vector[32, byte],
        password_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                         STRING = (32, password_str)),

        passFAB : $FAB (FAC = GET, FNM = 'SYS$INPUT'),
        passRAB : $RAB (FAB = passFAB, ROP = (RNE, PMT),
                        UBF = password_str, USZ = 32,
                        PBF = pass_prompt, PSZ = pass_prompt_len),

        infile_str : vector[256, byte],
        infile_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                        STRING = (256, infile_str)),

        input_buffer : vector [input_buffer_size + 1, byte],

        inFAB : $FAB (FAC = GET),
        inRAB : $RAB (FAB = inFAB,
                      UBF = input_buffer, USZ = input_buffer_size),

        outfile_str : vector[256, byte],
        outfile_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                        STRING = (256, outfile_str)),
        outFAB : $FAB (RFM = VAR, RAT = CR, FAC = PUT),
        outRAB : $RAB (FAB = outFAB),

        errfile_str : vector[256, byte],
        errfile_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                        STRING = (256, errfile_str)),
        errFAB : $FAB (RFM = VAR, RAT = CR, FAC = PUT),
        errRAB : $RAB (FAB = errFAB),

        length,

        input_done : initial (0),               ! Flags for I/O
        output_done : initial (0),
        error_done : initial (1),

        input_pending : initial (0),
        output_pending : initial (0),
        error_pending : initial (0),

        input_efn,                              ! Event flags
        output_efn,
        error_efn,

        carriage_return,                        ! Indicate file will need <LF>

        send_buffer : vector[max_buffer_size, byte],
        send_buffer_size,

        netchan,                ! Network I/O channel
        exec_port,              ! TCP service port for exec (usually 512)

        input_IOSB : network_IO_status_block,
        output_IOSB : network_IO_status_block,
        error_IOSB : network_IO_status_block;

!------------------------  Code begin here  --------------------------------
!
! Do some initialization.  Allocate event flags.
!
    LIB$GET_EF (input_efn);
    LIB$GET_EF (output_efn);
    LIB$GET_EF (error_efn);

    if ((.input_efn/32) NEQ (.output_efn/32))
        OR ((.input_efn/32) NEQ (.error_efn/32)) then
      LIB$SIGNAL (EXEC_BADEFN);
!
! Now parse our command line
!
! get foreign host name from DCL, trim blanks, and make it ASCIZ.
!
  CLI$GET_VALUE (CLI_host_label, fhost_desc);
  if not (rc = STR$TRIM (fhost_desc, fhost_desc, length)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
  fhost_desc[STR$H_LENGTH] = .length + 1;
  fhost_str[.fhost_desc[STR$H_LENGTH] - 1] = 0;
!
! get command to send, trim blanks, and make it ASCIZ.
!
  CLI$GET_VALUE (CLI_remote_command, fcmd_desc);
  if not (rc = STR$TRIM (fcmd_desc, fcmd_desc, length)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
  fcmd_desc[STR$H_LENGTH] = .length + 1;
  fcmd_str[.fcmd_desc[STR$H_LENGTH] - 1] = 0;
!
! Get the username for the other side...
!
  CLI$GET_VALUE (CLI_username, username_desc);
  if not (rc = STR$TRIM (username_desc, username_desc, length)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
!
! If username qualifier value is not provided, default to the
! lowercase representation of the user's username on the local
! system.
!
  if .length EQL 0 then
  begin
    $ITMLST_INIT (ITMLST = username_list,
                   (ITMCOD = JPI$_USERNAME, BUFADR = username_str,
                    BUFSIZ = 32, RETLEN = username_desc[STR$H_LENGTH])
                 );
    if not (rc = $GETJPI (ITMLST = username_list)) then
      LIB$SIGNAL (EXEC_SYSERR, 0, .rc);
    if not (rc = STR$TRANSLATE (username_desc, username_desc,
                                lowercase, uppercase)) then
      LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
    if .username_desc[STR$H_LENGTH] GTR max_UNIX_username_len then
      username_desc[STR$H_LENGTH] = max_UNIX_username_len;
  end;

  if not (rc = STR$TRIM (username_desc, username_desc, length)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
  username_desc[STR$H_LENGTH] = .length + 1;
  username_str[.username_desc[STR$H_LENGTH] - 1] = 0;
!
! Get the password for the other side...
!
  if CLI$PRESENT (CLI_password) then
  begin
    CLI$GET_VALUE (CLI_password, password_desc);
    if not (rc = STR$TRIM (password_desc, password_desc, length)) then
      LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
  end
!
! If there was no /PASSWORD qualifier, then read it from SYS$INPUT.
! In case it's a terminal, read will be prompted and will not echo.
!
  else
  begin
    if not (rc = $OPEN (FAB = passFAB)) then
      LIB$SIGNAL (EXEC_PWDREADERR, 0, .rc, .passFAB[FAB$L_STV]);
    if not (rc = $CONNECT (RAB = passRAB)) then
      LIB$SIGNAL (EXEC_PWDREADERR, 0, .rc, .passRAB[RAB$L_STV]);
    if not (rc = $GET (RAB = passRAB)) then
      LIB$SIGNAL (EXEC_PWDREADERR, 0, .rc, .passRAB[RAB$L_STV]);
    length = .passRAB[RAB$W_RSZ];
    $CLOSE (FAB = passFAB);
  end;

  password_desc[STR$H_LENGTH] = .length + 1;
  password_str[.password_desc[STR$H_LENGTH] - 1] = 0;
!
! Get input filename, trim blanks.  It may have a default.
!
  CLI$GET_VALUE (CLI_input, infile_desc);
  if not (rc = STR$TRIM (infile_desc, infile_desc, length)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
  infile_desc[STR$H_LENGTH] = .length;
!
! Open the input.  If it had PRINT or CR record attributes, then we will
! append a LF when sending to UNIX.
!
  inFAB[FAB$L_FNA] = infile_str;
  inFAB[FAB$B_FNS] = .infile_desc[STR$H_LENGTH];
  if not (rc = $OPEN (FAB = inFAB)) then
    LIB$SIGNAL (EXEC_INFILERR, 0, .rc, .inFAB[FAB$L_STV]);
  if not (rc = $CONNECT (RAB = inRAB)) then
    LIB$SIGNAL (EXEC_INFILERR, 0, .rc, .inRAB[RAB$L_STV]);

  carriage_return = (.inFAB[FAB$B_RAT] AND (FAB$M_CR OR FAB$M_PRN)) NEQU 0;
!
! Get output filename, trim blanks.  This will have a default.
!
  CLI$GET_VALUE (CLI_output, outfile_desc);
  if not (rc = STR$TRIM (outfile_desc, outfile_desc, length)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
  outfile_desc[STR$H_LENGTH] = .length;
!
! Open the output
!
  outFAB[FAB$L_FNA] = outfile_str;
  outFAB[FAB$B_FNS] = .outfile_desc[STR$H_LENGTH];
  if not (rc = $CREATE (FAB = outFAB)) then
    LIB$SIGNAL (EXEC_OUTFILERR, 0, .rc, .outFAB[FAB$L_STV]);
  if not (rc = $CONNECT (RAB = outRAB)) then
    LIB$SIGNAL (EXEC_OUTFILERR, 0, .rc, .outRAB[RAB$L_STV]);
!
! Get error filename, trim blanks.  This also has a default.
!
  CLI$GET_VALUE (CLI_error, errfile_desc);
  if not (rc = STR$TRIM (errfile_desc, errfile_desc, length)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
  errfile_desc[STR$H_LENGTH] = .length;
!
! Open the error
!
  errFAB[FAB$L_FNA] = errfile_str;
  errFAB[FAB$B_FNS] = .errfile_desc[STR$H_LENGTH];
  if not (rc = $CREATE (FAB = errFAB)) then
    LIB$SIGNAL (EXEC_ERRFILERR, 0, .rc, .errFAB[FAB$L_STV]);
  if not (rc = $CONNECT (RAB = errRAB)) then
    LIB$SIGNAL (EXEC_ERRFILERR, 0, .rc, .errRAB[RAB$L_STV]);
!
! Ignore the error channel for now
!
    error_done = 1;
    error_IOSB = 0;
    $CLREF (EFN = .error_efn);
!
! Get the TCP service port to use off the command line
!
  CLI$GET_VALUE (CLI_port, tmp_desc);
  if not (rc = OTS$CVT_TU_L (tmp_desc, exec_port, 4, 1)) then
    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
!  if not (rc = STR$TRIM (tmp_desc, tmp_desc, length)) then
!    LIB$SIGNAL (EXEC_RTLERR, 0, .rc);
!  tmp_desc[STR$H_LENGTH] = .length;
!
! open network device
!
  if not (rc = $ASSIGN (DEVNAM = net_device, CHAN = netchan)) then
    LIB$SIGNAL (EXEC_NETERR, 0, .rc);
!
! do a network open
!
  if not (rc = NET$OPEN(
                FHNAM = fhost_str,
                FOREIGN_PRT = .exec_port,
                LOCAL_PRT = 0,
                TIMOUT = 60,
                OPENMODE = active,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
              ))
  then
    LIB$SIGNAL (EXEC_NETERR, 0, .rc);

  Check_net_IOSB (output_IOSB);
!
! Send port number for SYS$ERROR.  Send null string for now...
!
  send_buffer[0] = 0;
  send_buffer_size = 1;

  rc = NET$SEND(
                BUFADRS = send_buffer,
                BUFSIZE = .send_buffer_size,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_net_QIO (rc);
  Check_net_IOSB (output_IOSB);
!
! Send username
!
  rc = NET$SEND(
                BUFADRS = username_str,
                BUFSIZE = .username_desc[STR$H_LENGTH],
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_net_QIO (rc);
  Check_net_IOSB (output_IOSB);
!
! Send password.
!
  rc = NET$SEND(
                BUFADRS = password_str,
                BUFSIZE = .password_desc[STR$H_LENGTH],
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_net_QIO (rc);
  Check_net_IOSB (output_IOSB);
!
! Send command
!
  rc = NET$SEND(
                BUFADRS = fcmd_str,
                BUFSIZE = .fcmd_desc[STR$H_LENGTH],
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_net_QIO (rc);
  Check_net_IOSB (output_IOSB);
!
! Receive 1 byte status to see if we logged in ok.
!
  rc = NET$RECEIVE(
                BUFADRS = send_buffer,
                BUFSIZE = 1,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_net_QIO (rc);
  Check_net_IOSB (output_IOSB);
!
! Check the return status from the remote.  Should be 0.  If not, then
! read an error message...
!
  if .send_buffer[0] NEQ 0 then
  begin
    rc = NET$RECEIVE(
                BUFADRS = send_buffer,
                BUFSIZE = max_buffer_size,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );

    Check_net_QIO (rc);
    Check_net_IOSB (output_IOSB);

    write_buffer (send_buffer, .output_IOSB[bytes_xfered], errRAB);
  end
  else
  begin
    while not (.input_done AND .output_done AND .error_done) do
    begin
!
! If input done, then we should close the connection so the other
! side gets some indication of "end-of-file".
!
      if not (.input_done OR .input_pending) then
      begin
!       $CLREF (EFN = .input_efn);
!       input_IOSB = 0;
$SETEF (EFN = .input_efn);
input_IOSB = 1;
        rc = $GET (RAB = inRAB);
        if .rc EQL RMS$_EOF then
        begin
          NET$CLOSE (IOCHAN = .netchan, IO$SB = input_IOSB, CLOSENOWAIT = 1);
          input_done = 1;
          input_IOSB = 0;
          $CLREF (EFN = .input_efn);
        end
        else
          if not .rc then
            LIB$SIGNAL (EXEC_INFILERR, 0, .rc, .inrab[RAB$L_STV]);
        input_pending = 1;
      end;
!
! Receive something from net for local output.
!
      if not (.output_done OR .output_pending) then
      begin
        rc = NET$RECEIVE(
                EF = .output_efn,
                BUFADRS = send_buffer,
                BUFSIZE = max_buffer_size,
                IOCHAN = .netchan,
                IO$SB = output_IOSB,
                IOMODE = asynch
                );

        Check_net_QIO (rc);
        output_pending = 1;
      end;
!
! Here we wait around for one of the input IO's to finish.
!
      $WFLOR (EFN = .input_efn,
              MASK = ((1 ^ (.input_efn MOD 32)) +
                      (1 ^ (.output_efn MOD 32)) +
                      (1 ^ (.error_efn MOD 32))));
!
! Whatever outstanding IO's completed will have non-zero IOSB's.
! Check each IOSB and handle accordingly...
!
      if .input_IOSB NEQ 0 then
      begin
        if .carriage_return then
        begin
          input_buffer[.inRAB[RAB$W_RSZ]] = LF;
          inRAB[RAB$W_RSZ] = .inRAB[RAB$W_RSZ] + 1;
        end;
        rc = NET$SEND(
                BUFADRS = input_buffer,
                BUFSIZE = .inRAB[RAB$W_RSZ],
                IOCHAN = .netchan,
                IO$SB = input_IOSB
                );
        Check_net_QIO (rc);
!
! Error may occur if other side done before we read EOF and stopped
! sending.  (eg. "head" finishes w/o reading all)
! Maybe we should check output_done and if we get connection reset or
! and output_done then just shutdown...
!
        Check_net_IOSB (input_IOSB);
        input_pending = 0;
      end;
!
! Check the IOSB.  If the VMS error code is SS$_ABORT then check the
! TCP field, otherwise exit if it's an error.  If the TCP field is
! TCP_CONCLS then the other side has shut down that particular connection
! and we treat it like end-of-file, otherwise exit with the TCP error.
!
      if .output_IOSB NEQ 0 then
      begin
        if (not .output_IOSB[VMS_code]) then
          if .output_IOSB[VMS_code] EQL SS$_ABORT then
            if .output_IOSB[net_xerror] NEQ NET$_CC then
              LIB$SIGNAL (EXEC_NETERR, 0, .output_IOSB[net_xerror])
            else
            begin
              output_done = 1;
              output_IOSB = 0;
              $CLREF (EFN = .output_efn);
            end
          else
            LIB$SIGNAL (EXEC_NETERR, 0, .output_IOSB[VMS_code]);

        if not .output_done then
          write_buffer (send_buffer, .output_IOSB[bytes_xfered], outRAB);
        output_pending = 0;
      end;

    end; !while
  end;  ! else
!
! deassign the network device
!
  $DASSGN (CHAN = .netchan);
!
! Close any open files
!
  $CLOSE (FAB = inFAB);
  $CLOSE (FAB = outFAB);
  $CLOSE (FAB = errFAB);
end;

end
eludom
$*$*EOD*$*$
$ checksum EXEC.BLI
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ check_sum = 1059529279
$ write sys$output "Creating EXEC.CLD"
$ create EXEC.CLD
$ DECK/DOLLARS="$*$*EOD*$*$"
! Command description for EXEC (remote command execution via TCP)
!
define verb EXEC
  image IP_ROOT:[EXE]exec
  parameter P1,
    label = HOST,
    prompt = "Remote host",
    value (required)
  parameter P2,
    label = RCMD,
    prompt = "Remote command",
    value (required)
  qualifier INPUT,
     default,
     nonnegatable,
     value (default = "NLA0:", type = $INFILE)
  qualifier OUTPUT,
    default,
    nonnegatable,
    value (default = "SYS$OUTPUT", type = $OUTFILE)
  qualifier ERROR,
    default,
    nonnegatable,
    value (default = "SYS$ERROR", type = $OUTFILE)
  qualifier USERNAME,
    default,
    nonnegatable,
    value (required)
  qualifier PASSWORD,
    value (required)
  qualifier SERVICE_PORT
    default,
    nonnegatable,
    value (default = "512", type = $NUMBER)
$*$*EOD*$*$
$ checksum EXEC.CLD
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ check_sum = 2102364388
$ write sys$output "Creating EXEC_ERR.MSG"
$ create EXEC_ERR.MSG
$ DECK/DOLLARS="$*$*EOD*$*$"
!
! Written by Kevin Carosso, Hughes Aircraft Co., SCG/CTC
!
        .Title          EXEC_ERRORS - EXEC error messages.
        .Facility       EXEC, 14/prefix = EXEC_

        .Severity       Fatal

BADEFN          <Internal EFN allocation error -- EFNs not in same cluster>
NETERR          <Network IO error>
INFILERR        <Input file IO error>
OUTFILERR       <Output file IO error>
ERRFILERR       <Error file IO error>
PWDREADERR      <File IO error -- reading password>
RTLERR          <Run-Time Library signalled error>
SYSERR          <System Service signalled error>
$*$*EOD*$*$
$ checksum EXEC_ERR.MSG
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ check_sum = 1178949573
$ write sys$output "Creating EXEC_SUB.BLI"
$ create EXEC_SUB.BLI
$ DECK/DOLLARS="$*$*EOD*$*$"
! Execute remote commands (callable subroutine).
! Foreign-port #512.
!
! We will open a TCP connection to the UNIX remote execution server.
! This should let us execute commands on the other system with input
! and output on the local system.
!
! Calling format is:
!
! exec_remote_command (host-name, username, password, remote-command
!                       input-file, output-file, error-file)
!
! Written by Kevin Carosso, Hughes Aircraft Co., SCG/CTC
!
! 1.1   15-FEB-1987 Kevin Carosso    Hughes Aircraft Co., SCG/CTC
!               Modified to work with the CMU version of Tek TCP/IP.
!
module Exec_sub (ident = '1.0', list (norequire, noobject, nobinary)) =
begin

library 'SYS$LIBRARY:xport';
library 'SYS$LIBRARY:starlet';
library 'TCP$SOURCES:VMS';
library 'TCP$SOURCES:macros';
library 'TCP$SOURCES:network';

require 'errdefs';                      ! TCP message definitions

builtin
        LOCC, MOVC3;

external routine
        TCP_error_code : addressing_mode (general),
        LIB$GET_EF : addressing_mode (general);

external literal
        EXEC_BADEFN;

literal
        exec_port               = 512,
        max_buffer_size         = 1024;

macro
!
! Check the status return of a QIO.  If the status is bad, this
! will signal an error.
!
  Check_QIO (status) =
    if not .status then
    begin
      NET$ABORT (LC_ID = .lcn, IOCHAN = .netchan, IO$SB = 0);
      LIB$SIGNAL (.status);
    end
  %;

macro
!
! Check the status return in an IOSB.  If the status is bad, this
! will then look for SS$_ABORT.  If that's the case, then check
! for specific TCP errors.  This will ALSO signal if anything is bad.
!
  Check_IOSB (iosb) =
    if not .iosb[VMS_return_code] then
      dump_IOSB(iosb)
  %;

%SBTTL 'Dump the iosb'

routine dump_IOSB (iosb : ref netio_status_block) : novalue =
begin

  if .iosb[VMS_return_code] neq SS$_ABORT then
    LIB$SIGNAL (.iosb[VMS_return_code])
  else
    LIB$SIGNAL (TCP_error_code (.iosb[tcperr]));
end;

%SBTTL 'Write a buffer to output'
!
! This writes a buffer out.  It is careful to convert UNIX newlines
! into record terminators...
!
routine write_buffer (buffer, buffer_size, rab : ref $RAB_DECL) : novalue =

begin
  own
    save_buffer : vector [max_buffer_size, byte],
    save_buffer_offset : initial (0);

  local
    buff_pointer,
    found,
    length,
    rc;

  buff_pointer = .buffer;

  while .buff_pointer LSS .buffer + .buffer_size do
  begin

    LOCC (%REF (10),
          %REF (.buffer_size - (.buff_pointer - .buffer)),
          .buff_pointer; found, length);

    length = .length - .buff_pointer;

    if (.found EQL 0) OR (.save_buffer_offset GTR 0) then
    begin
      MOVC3 (%REF (MIN (.length, max_buffer_size - .save_buffer_offset)),
             .buff_pointer, save_buffer[.save_buffer_offset];
             ,,, save_buffer_offset);
      save_buffer_offset = .save_buffer_offset - save_buffer;
    end;

    if (.found NEQ 0) OR (.save_buffer_offset EQL max_buffer_size) then
!
! Need to write something out...
!
      if (.save_buffer_offset NEQ 0) then
!
! Write from "save_buffer"
!
      begin
        rab[RAB$L_RBF] = save_buffer;
        rab[RAB$W_RSZ] = .save_buffer_offset;
        if not (rc = $PUT (RAB = .rab)) then
          LIB$SIGNAL (.rc);
        save_buffer_offset = 0;
      end
      else
!
! Write from buffer
!
      begin
        rab[RAB$L_RBF] = .buff_pointer;
        rab[RAB$W_RSZ] = .length;
        if not (rc = $PUT (RAB = .rab)) then
          LIB$SIGNAL (.rc);
      end;

    buff_pointer = .buff_pointer + .length + 1;
  end;
end;

routine exec_remote_command (fhost_desc, username_desc, password_desc,
                             fcmd_desc, infile_desc, outfile_desc, errfile_desc
                            ) : novalue =
begin

register
        rc;

literal
        input_buffer_size = 1024,
        LF = 10;                                ! Line feed
bind
        net_device = %ASCID 'TCP:';

own
        fhost_str : vector[20, byte],
        fhost_desc : $STR_DESCRIPTOR (CLASS = fixed, STRING = (20, fhost_str)),

        fcmd_str : vector[256, byte],
        fcmd_desc : $STR_DESCRIPTOR (CLASS = fixed, STRING = (256, fcmd_str)),

        username_str : vector[32, byte],
        username_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                         STRING = (32, username_str)),
        password_str : vector[32, byte],
        password_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                         STRING = (32, password_str)),

        infile_str : vector[256, byte],
        infile_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                        STRING = (256, infile_str)),

        input_buffer : vector [input_buffer_size + 1, byte],

        inFAB : $FAB (FAC = GET),
        inRAB : $RAB (FAB = inFAB, !ROP = ASY,
                      UBF = input_buffer, USZ = input_buffer_size),

        outfile_str : vector[256, byte],
        outfile_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                        STRING = (256, outfile_str)),
        outFAB : $FAB (RFM = VAR, RAT = CR, FAC = PUT),
        outRAB : $RAB (FAB = outFAB),

        errfile_str : vector[256, byte],
        errfile_desc : $STR_DESCRIPTOR (CLASS = fixed,
                                        STRING = (256, errfile_str)),
        errFAB : $FAB (RFM = VAR, RAT = CR, FAC = PUT),
        errRAB : $RAB (FAB = errFAB),

        length,

        input_done : initial (0),               ! Flags for I/O
        output_done : initial (0),
        error_done : initial (1),

        input_pending : initial (0),
        output_pending : initial (0),
        error_pending : initial (0),

        input_efn,                              ! Event flags
        output_efn,
        error_efn,

        carriage_return : initial (1),          ! Indicate file will need <LF>

        send_buffer : vector[max_buffer_size, byte],
        send_buffer_size,

        netchan,                                        ! Network I/O channel
        lcn,                                            ! Local connection id.

        input_IOSB : netio_status_block,
        output_IOSB : netio_status_block,
        error_IOSB : netio_status_block;

!------------------------  Code begin here  --------------------------------
!
! Do some initialization.  Allocate event flags.
!
    LIB$GET_EF (input_efn);
    LIB$GET_EF (output_efn);
    LIB$GET_EF (error_efn);

    if ((.input_efn/32) NEQ (.output_efn/32))
        OR ((.input_efn/32) NEQ (.error_efn/32)) then
      LIB$SIGNAL (EXEC_BADEFN);
!
! Make the strings ASCIZ that need to be.
!
  fhost_desc[STR$H_LENGTH] = .length + 1;
  fhost_str[.fhost_desc[STR$H_LENGTH] - 1] = 0;

  fcmd_desc[STR$H_LENGTH] = .length + 1;
  fcmd_str[.fcmd_desc[STR$H_LENGTH] - 1] = 0;

  username_desc[STR$H_LENGTH] = .length + 1;
  username_str[.username_desc[STR$H_LENGTH] - 1] = 0;

  password_desc[STR$H_LENGTH] = .length + 1;
  password_str[.password_desc[STR$H_LENGTH] - 1] = 0;
!
! Open the input
!
  inFAB[FAB$L_FNA] = infile_str;
  inFAB[FAB$B_FNS] = .infile_desc[STR$H_LENGTH];
  if not (rc = $OPEN (FAB = inFAB)) then
    LIB$SIGNAL (.rc);
  if not (rc = $CONNECT (RAB = inRAB)) then
    LIB$SIGNAL (.rc);
!
! Open the output
!
  outFAB[FAB$L_FNA] = outfile_str;
  outFAB[FAB$B_FNS] = .outfile_desc[STR$H_LENGTH];
  if not (rc = $CREATE (FAB = outFAB)) then
    LIB$SIGNAL (.rc);
  if not (rc = $CONNECT (RAB = outRAB)) then
    LIB$SIGNAL (.rc);
!
! Open the error
!
  errFAB[FAB$L_FNA] = errfile_str;
  errFAB[FAB$B_FNS] = .errfile_desc[STR$H_LENGTH];
  if not (rc = $CREATE (FAB = errFAB)) then
    LIB$SIGNAL (.rc);
  if not (rc = $CONNECT (RAB = errRAB)) then
    LIB$SIGNAL (.rc);
!
! Ignore the error channel for now
!
    error_done = 1;
    error_IOSB = 0;
    $CLREF (EFN = .error_efn);
!
! open network device
!
  if not (rc = $ASSIGN (DEVNAM = net_device, CHAN = netchan)) then
    LIB$SIGNAL (.rc);
!
! do a network open
!
  if not (rc = NET$OPEN(
                FHNAM = fhost_str,
                FOREIGN_PRT = exec_port,
                LOCAL_PRT = 0,
                TIMOUT = 180,
                OPENMODE = active,
                DBSIZE = 0,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
              ))
  then
    LIB$SIGNAL (.rc);

  Check_IOSB (output_IOSB);
!
! Get local connection ID
!
  lcn = .output_IOSB[local_connection_id];
!
! Send port number for SYS$ERROR.  Send null string for now...
!
  send_buffer[0] = 0;
  send_buffer_size = 1;

  rc = NET$SEND(
                LC_ID = .lcn,
                BUFADRS = send_buffer,
                BUFSIZE = .send_buffer_size,
                TAG = 5,
                EOL = false,
                URGENT = false,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_QIO (rc);
  Check_IOSB (output_IOSB);
!
! Send username
!
  rc = NET$SEND(
                LC_ID = .lcn,
                BUFADRS = username_str,
                BUFSIZE = .username_desc[STR$H_LENGTH],
                TAG = 5,
                EOL = false,
                URGENT = false,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_QIO (rc);
  Check_IOSB (output_IOSB);
!
! Send password.
!
  rc = NET$SEND(
                LC_ID = .lcn,
                BUFADRS = password_str,
                BUFSIZE = .password_desc[STR$H_LENGTH],
                TAG = 5,
                EOL = false,
                URGENT = false,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_QIO (rc);
  Check_IOSB (output_IOSB);
!
! Send command
!
  rc = NET$SEND(
                LC_ID = .lcn,
                BUFADRS = fcmd_str,
                BUFSIZE = .fcmd_desc[STR$H_LENGTH],
                TAG = 5,
                EOL = false,
                URGENT = false,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_QIO (rc);
  Check_IOSB (output_IOSB);
!
! Receive 1 byte status to see if we logged in ok.
!
  rc = NET$RECEIVE(
                LC_ID = .lcn,
                BUFADRS = send_buffer,
                BUFSIZE = 1,
                TAG = 5,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );
  Check_QIO (rc);
  Check_IOSB (output_IOSB);
!
! Check the return status from the remote.  Should be 0.  If not, then
! read an error message...
!
  if .send_buffer[0] NEQ 0 then
  begin
    rc = NET$RECEIVE(
                LC_ID = .lcn,
                BUFADRS = send_buffer,
                BUFSIZE = max_buffer_size,
                TAG = 5,
                IOCHAN = .netchan,
                IO$SB = output_IOSB
                );

    Check_QIO (rc);
    Check_IOSB (output_IOSB);

    write_buffer (send_buffer, .output_IOSB[bytes_xfered], errRAB);
  end
  else
  begin
    while not (.input_done AND .output_done AND .error_done) do
    begin
!
! If input done, then we should close the connection so the other
! side gets some indication of "end-of-file".
!
      if not (.input_done OR .input_pending) then
      begin
!       $CLREF (EFN = .input_efn);
!       input_IOSB = 0;
$SETEF (EFN = .input_efn);
input_IOSB = 1;
        rc = $GET (RAB = inRAB);
        if .rc EQL RMS$_EOF then
        begin
          NET$CLOSE (LC_ID = .lcn, IOCHAN = .netchan, IO$SB = input_IOSB);
          input_done = 1;
          input_IOSB = 0;
          $CLREF (EFN = .input_efn);
        end
        else
          Check_QIO (rc);
        input_pending = 1;
      end;
!
! Receive something from net for local output.
!
      if not (.output_done OR .output_pending) then
      begin
        rc = NET$RECEIVE(
                EF = .output_efn,
                LC_ID = .lcn,
                BUFADRS = send_buffer,
                BUFSIZE = max_buffer_size,
                TAG = 5,
                IOCHAN = .netchan,
                IO$SB = output_IOSB,
                IOMODE = 1                      ! Asynch
                );

        Check_QIO (rc);
        output_pending = 1;
      end;
!
! Here we wait around for one of the input IO's to finish.
!
      $WFLOR (EFN = .input_efn,
              MASK = ((1 ^ (.input_efn MOD 32)) +
                      (1 ^ (.output_efn MOD 32)) +
                      (1 ^ (.error_efn MOD 32))));
!
! Whatever outstanding IO's completed will have non-zero IOSB's.
! Check each IOSB and handle accordingly...
!
      if .input_IOSB NEQ 0 then
      begin
        if .carriage_return then
        begin
          input_buffer[.inRAB[RAB$W_RSZ]] = LF;
          inRAB[RAB$W_RSZ] = .inRAB[RAB$W_RSZ] + 1;
        end;
        rc = NET$SEND(
                LC_ID = .lcn,
                BUFADRS = input_buffer,
                BUFSIZE = .inRAB[RAB$W_RSZ],
                TAG = 5,
                EOL = false,
                URGENT = false,
                IOCHAN = .netchan,
                IO$SB = input_IOSB
                );
        Check_QIO (rc);
!
! Error may occur if other side done before we read EOF and stopped
! sending.  (eg. "head" finishes w/o reading all)
! Maybe we should check output_done and if we get connection reset or
! and output_done then just shutdown...
!
        Check_IOSB (input_IOSB);
        input_pending = 0;
      end;
!
! Check the IOSB.  If the VMS error code is SS$_ABORT then check the
! TCP field, otherwise exit if it's an error.  If the TCP field is
! TCP_CONCLS then the other side has shut down that particular connection
! and we treat it like end-of-file, otherwise exit with the TCP error.
!
      if .output_IOSB NEQ 0 then
      begin
        if (not .output_IOSB[VMS_return_code]) then
          if .output_IOSB[VMS_return_code] EQL SS$_ABORT then
            if TCP_error_code (.output_IOSB[TCPerr]) NEQ TCP_CONCLS then
              LIB$SIGNAL (TCP_error_code (.output_IOSB[TCPerr]))
            else
            begin
              output_done = 1;
              output_IOSB = 0;
              $CLREF (EFN = .output_efn);
            end
          else
            LIB$SIGNAL (.output_IOSB[VMS_return_code]);

        if not .output_done then
          write_buffer (send_buffer, .output_IOSB[bytes_xfered], outRAB);
        output_pending = 0;
      end;

    end; !while
  end;  ! else
!
! deassign the network device
!
  $DASSGN (CHAN = .netchan);
!
! Close any open files
!
  $CLOSE (FAB = inFAB);
  $CLOSE (FAB = outFAB);
  $CLOSE (FAB = errFAB);
end;

end
eludom
$*$*EOD*$*$
$ checksum EXEC_SUB.BLI
$ if checksum$checksum .ne. check_sum then -
$   write sys$output "Checksum failed, file probably corrupted"
$ exit
