[Unix, OpenVMS, Windows, Perl] Remotely executing a shell script


PRODUCT:    Perl V5.8.6 or above 


OP/SYS:     Unix/Linux running Perl
            OpenVMS Alpha and IA64 servers
            Windows computers with Perl installed


PREREQUISITE:  FTP server (Perl script server side)


SOURCE:     Philippe Vouters
            Fontainebleau/France


LOW-COST HIGH-TECH:  http://techno-star.fr


OVERVIEW:

This client/server Perl code can be used to copy a script file and execute it
on a target computer. This remote copy is performed in the client code using
Perl's FTP library. Then through a task to task TCP/IP communication the
copied script is then executed and afterwards removed from the remote node
disk.


*** CAUTION ***

These sample programs have been tested using Perl V5.8.6 or above on
on OpenVMS IA64 V8.3-1H1, Linux Fedora 11 and Windows XP SP3. However, we
cannot guarantee their effectiveness because of the possibility of error in
transmitting or implementing them. They are meant to be used as a templates
for writing your own programs, and may require modification for use on your 
system. 


DOWNLOADS:

Windows computers:

Download either Strawberry or Active State Perl from the following URL:
http://www.perl.com/download.csp#win32

Download Perl for OpenVMS Alpha and Itanium servers and its ECO from:
http://h71000.www7.hp.com/openvms/products/ips/apache/csws_modperl.html

Download Perl for Linux Fedora 11 with the following root command:
     $ yum install perl*


PROGRAMS NOTES:

OpenVMS systems:

With the provided Makefile.PL, spawn.h, spawn.c, tn.h, tn.c and MYSYSTEM.xs
below, you need to perform the following tasks, prior to executing the
script_server.pl Perl code:

    $ @PERL_ROOT:[UTILS]H2XS.COM "-A" "-n" MYSYSTEM
    $ copy Makefile.PL [.MYSYSTEM]
    $ copy tn.h [.MYSYSTEM]
    $ copy tn.c [.MYSYSTEM]
    $ copy spawn.h [.MYSYSTEM]
    $ copy spawn.c [.MYSYSTEM]
    $ copy MYSYSTEM.xs [.MYSYSTEM]
    $ set default [.MYSYSTEM]

Then
    $ set proc/priv=(NETMBX,TMPMBX,BYPASS)
    $ perl Makefile.PL
    $ mms install
    $ set default [-]

Why the Telnet TNA device on OpenVMS ? This is because a TNA device is both a
network device and a terminal device. The very advantage of it is that it can
be associated with a TCP/IP network device (BG devices) meanwhile having all
the features of a terminal device. This enables DCL commands such as
READ/PROMPT and INQUIRE. With the standard Perl/VMS implemented system API, the 
result is not as good as with the MYSYSTEM system purpose specific
reimplementation.

Unix - OpenVMS - Windows systems:

From a terminal where the shell script will execute on, issue the command:

    $ perl script_server.pl

From a Windows, Unix or OpenVMS computer, enter the following command:

    $ perl ftp_script.pl <host> <username> <password> <script>

where host is the IP address or DNS name, username/password are the login FTP
information and script is the local file being a shell script to be remotely
executed..

Providing your DCL, Unix shell or Windows script accepts arguments, just
surround the script name and its arguments with quotes. Your command ought to
then look like:

    $ perl ftp_script.pl <host> <username> <password> "<script> <params>"

Linux systems:

If you are running the Very Secure FTP daemon (vsftpd), you should uncomment
the following lines in /etc/vsftpd/vsftpd.conf:

          local_enable=YES
          write_enable=YES
          ascii_upload_enable=YES
          ascii_download_enable=YES

and restart vsftpd.

You should as well open up TCP ports 20, 21 and 7070 in your 
/etc/sysconfig/iptables file and then restart the iptables service.


SOME HINTS:

You are not limited to Unix, Windows or VMS scripts. You may as well execute
Perl scripts. For OpenVMS refer to the way PERL_ROOT:[UTILS]H2XS.COM is
written. This VMS DCL command procedure almost immediatly invokes Perl
passing a variable number of arguments to it.


INTERACTIVE SCRIPT FILES TESTED:

********
* Windows test.bat:
********
@echo off
set /p name=What is your name, please ?
echo Ah !!! You are the famous %name%...
echo.

********
* Linux test.sh:
********
#!/bin/ksh
#
# set -x
echo -n "What is your name, please ?"
read name
echo "Ah !!! You are the famous ${name}"
exit 0

********
* OpenVMS test.com:
********
$ inquire name "What is your name, please?"
$ write sys$output "Ah !!! You are the famous ''name'"
$ exit


PROGRAMS:

                             COPYRIGHT (C) 2009 BY
                              HEWLETT-PACKARD COMPANY
                                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 HEWLETT-PACKARD COMPANY.

     HP ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
     SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY HP.

     NO RESPONSIBILITY IS ASSUMED FOR THE USE OR RELIABILITY OF SOFTWARE
     ON EQUIPMENT THAT IS NOT SUPPLIED BY HEWLETT-PACKARD COMPANY.

     SUPPORT FOR THIS SOFTWARE IS NOT COVERED UNDER ANY HP SOFTWARE
     PRODUCT SUPPORT CONTRACT, BUT MAY BE PROVIDED UNDER THE TERMS OF THE
     CONSULTING AGREEMENT UNDER WHICH THIS SOFTWARE WAS DEVELOPED.

******
* script_server.pl
******
#! /usr/bin/perl

use strict;
use IO::Socket;
use IO::Select;
use FileHandle;
# OpenVMS conditional use
eval "use POSIX ':sys_wait_h'";
eval "use vmsish status'";
eval "use ExtUtils::testlib";
eval "use Autoloader";
eval "use MYSYSTEM";

sub fork_exec(@_){
  my $script = shift;
  my $sock = shift;
  my $status;
  my $data;
  if (($^O !~ /VMS/) && ($^O !~ /MSWin32/)) {
      #
      # Unix systems
      #
      my $pid = fork();
      die "fork() failed: $!" unless defined $pid;
      if ($pid) {
          $status = waitpid($pid,0);
          if ($status == -1){
              $data = "Submit a bug report\n";
              return syswrite($sock,$data,length $data);
          }
          else{
              $data = "Script completion status : $?\n";
              return syswrite($sock,$data,length $data);
          }
      }
      else {
          close STDIN;
          open(STDIN,"<&",$sock) or die "Can't dup STDIN: $!";
          close STDOUT;
          open(STDOUT, ">&",$sock) or die "Can't dup STDOUT: $!";
          close STDERR;
          open(STDERR, ">&",$sock) or die ;
          exec $script;
      }
   }
   if ($^O =~ /MSWin32/){
      #
      # Windows systems
      #
      close STDIN;
      open STDIN, "<&",$sock or die "Can't dup STDIN: $!";
      close STDOUT;
      open STDOUT, ">&",$sock or die "Can't dup STDOUT: $!";
      close STDERR;
      open STDERR, ">&",$sock or die;
      $status = system($script);
      close STDIN;
      close STDOUT;
      close STDERR;
      open STDIN, "<-";
      open STDOUT, ">-";
      open STDERR, ">-";
      $data = "Script completion status : $?\n";
      return syswrite($sock,$data,length $data);
   }
   if ($^O =~ /VMS/){
      $status = MYSYSTEM::my_system($script,fileno($sock))
                or die "Can't spawn $script: $!";
      $data = "\nScript completion status : $?\n";
      return syswrite($sock,$data,length $data);
   }
}

my $script;
my $new_sock;
my @args;
my $separator;
my $sock = new IO::Socket::INET (
               LocalHost => '0.0.0.0',
               LocalPort => '7070',
               Proto => 'tcp',
               Listen => 1,
               Reuse => 1,
               )
   or die "Can't create server's listening socket: $!";
LINE: while (1){
   $new_sock = $sock->accept();
   $new_sock->autoflush(1);
   print $new_sock $^O."\n";
   $script = <$new_sock>;
   chomp($script);
   if ($^O =~ /VMS/){
       $separator = "";
   }
   if ($^O =~ /MSWin32/) {
       $separator = "\\";
   }
   if (($^O !~ /VMS/) && ($^O !~ /MSWin32/)){
       $separator = "/";
   }
   $script=$ENV{"HOME"}.$separator.$script if ($ENV{"HOME"});
   @args = split(/ /,$script);
   if (!(-e $args[0])){
       close $new_sock;
       next LINE;
   }
   if ($^O =~ /VMS/){
       setsockopt($new_sock, SOL_SOCKET, SO_LINGER, pack("II",1,0))
          or die "Can't set SO_LINGER: $!";
   }
   if (($^O !~ /VMS/) && ($^O !~ /MSWin32/)) {
        # Unix systems
        my $fh = new FileHandle;
        if ($fh->open("<$args[0]")){
            # Read the very first script line to get the shell interpreter
            # and get rid from the first "#!" two character. */
            my $linein = $fh->gets;
            chomp $linein;
            $linein =~ s/^#\!([\/\w\d \-]+)\r?/$1/;
            my $cmd=$linein." ".$script;
            if ($cmd =~ m/^ $script/){
                $fh->close; # close file
                print $new_sock "no shell specification in first line\n";
                $new_sock->close;
                next LINE;
            }
            $script = $cmd;
            $fh->close; # close file
        } 
        else{
            print $new_sock  $script." not found\n";
            $new_sock->close;
            next LINE;
        } 
   }
   my $ret = fork_exec($script,$new_sock);
   #
   # delete the temporary script file
   #
   if ($^O =~ /VMS/){
       unlink("/sys\$login/TCPIP\$FTP_SERVER.LOG");
   }
   if (unlink($args[0]) != 1){
       if ($ret > 0){
           print $new_sock "Failed to delete $args[0]\n";
       }
   }
   else{
       if ($ret > 0){
           print $new_sock "$args[0] successfully deleted\n";
       }
   }
   if ($ret > 0){
       shutdown $new_sock,2;
   }
   close $new_sock;
}
close $sock;

******
* ftp_script.pl
******
#! /usr/bin/perl

use Net::FTP;
use Switch;
use IO::Socket;
use IO::Select;
use File::Basename;
use FileHandle;

sub usage($){
    my $str=shift;
    die "Usage: $str <server> <username> <password> <script>\n";
}
my $server;
my $username;
my $password;
my $localfile;
my @fin;
my $remotefile;

if (@ARGV == undef) { usage($0); }
my $i=0;
foreach $arg (@ARGV) {
   switch($i) {
     case 0 { $server = $arg }
     case 1 { $username = $arg }
     case 2 { $password = $arg }
     case 3 { $localfile = $arg }
   }
   ++$i;
}
if (!($server != undef) && ($username != undef) && ($password != undef) &&
      ($localfile != undef)) { usage($0); }
my @script_cmd = split(/ /,$localfile);
if (!(-e $script_cmd[0])){
    die "$script_cmd[0] file not found\n"
}
$remotefile=basename($script_cmd[0]);
#
# FTP transfer modes being set to non passive, this forces you to open up
# the TCP ports 20 and 21 in your firewall. Along with the TCP task-to-task
# communication which follows, you have to open up TCP port 7070 as well.
#
$ftp = Net::FTP->new($server,Passive=>0) or die "can't connect to $server\n";
$ftp->login($username,$password) or die "invalid username/password\n";
$ftp->ascii;
$ftp->put($script_cmd[0],$remotefile) or die $ftp->message;
print "$script_cmd[0] transfered to $server:/\~$username/$remotefile\n";
$ftp->quit;
my $sock = new IO::Socket::INET ( PeerAddr => $server,
                                  PeerPort => '7070', 
                                  Proto => 'tcp', ); 
die "Could not create socket: $!\n" unless $sock;
#binmode $sock;
setsockopt($sock, SOL_SOCKET, SO_LINGER, pack("II",1,0))
          or die "Can't set SO_LINGER: $!";

#
# send the remote peer the shell script file name along with its arguments
#
chomp($remote_system=<$sock>);
$i=0;
foreach (@script_cmd) {
    if ($i == 0) {
        print $sock $remotefile;
        ++$i;
    }
    else {
        print $sock " ".$_;
    }
}
print $sock "\n";
#
# Output on the screen of this TCP client any output information given by
# remote execution of this Unix shell or VMS DCL script.
#
my $timeout = 1.0;
my $readfds = new IO::Select($sock);
if (($^O !~ /VMS/) && ($^O !~ /MSWin32/)){
    $readfds->add(\*STDIN);
    $timeout = undef;
}
$| = fileno($sock);
$| = 1;
#binmode STDOUT;
while (1){
     my @rh_set;
     if (@rh_set=$readfds->can_read($timeout)){
         foreach $fh (@rh_set){
            if ($fh == $sock){
               my $data;
               if (sysread($sock,$data,1,0) > 0){
                   if (length $data != 0){
                       print $data;
                   }
               }
               else{
                   close $sock;
                   exit (0);
               }
            }
            else {
               $keyboard_input = <STDIN>;
               last if (not defined($keyboard_input));
               print $sock $keyboard_input;
            }
        }
    }
    else {
         if (@rh_set=$readfds->can_write()){
             chomp($keyboard_input = <STDIN>);
             last if not defined($keyboard_input);
             if ($remote_system =~ /VMS/){
                 print $sock $keyboard_input."\r";
             } else {
                  print $sock $keyboard_input."\n";
             }
         }
         else {
             close $sock;
             exit(0);
         }
    }
}
close $sock;
exit(0);

******
* MYSYSTEM.xs
******
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "ppport.h"

MODULE = MYSYSTEM               PACKAGE = MYSYSTEM              

#include <stdlib.h>
#include <string.h>
#include <socket.h>
#include <starlet.h>
#include <lib$routines.h>
#include <libwaitdef.h>
#include <efndef.h>
#include <dvidef.h>
#include <ssdef.h>
#include <descrip.h>
#include <devdef.h>
#include "tn.h"
#include "spawn.h"

#define MAX_BUF_VMS 256
#ifndef TNA_DEVICE
#define TNA_DEVICE "TNA"
#endif

#define DEVICE_NAME_LENGTH 64
#define MAXMSG 1024

int
my_system(str,s)
char *str
int s
 CODE:
     char tna_name[DEVICE_NAME_LENGTH];
     char tmpbuf[MAXMSG];
     char filbuf[PATH_MAX];
     int tna_unit_number=0;
     short chan;
     int efn;
     int fd;
     int status;
     int retlen;
     int child_status;
     struct sockaddr_in to;
     unsigned int tolen;
     short tnachan=-1;
     int devchar;
     int devchar2;
     unsigned short len;
     int devsts;            
     /* Item list sys$getdvi */
     typedef struct {  /* Standard OpenVMS item definition */
         unsigned short length; 
         unsigned short code;   
         void *buffer;          
         void *retlen;          
     } item_t;
     struct  iosb_struct{
         short status;
         short dummy;
         int pid;
     } iosb;
     struct dsc$descriptor_s input = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
     item_t *getdvi_itmlst;

     status =SS$_NORMAL;
     if (!str){
        STMT_START {
           set_errno(EVMSERR); set_vaxc_errno(SS$_ABORT);
           Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d",
                      status,__FILE__,__LINE__); 
        } STMT_END;
     }
     tolen=sizeof(to);
     if (getpeername(s,(struct sockaddr *)&to,&tolen)<0){
        STMT_START {
           set_errno(EVMSERR); set_vaxc_errno(SS$_ABORT);
           Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d",
                      status,__FILE__,__LINE__);
        } STMT_END;
     }
     getdvi_itmlst = calloc(4,sizeof(item_t));
     getdvi_itmlst[0].length = sizeof(devchar);
     getdvi_itmlst[0].code = DVI$_DEVCHAR;
     getdvi_itmlst[0].buffer = &devchar;
     getdvi_itmlst[0].retlen = &len;
     getdvi_itmlst[1].length = sizeof(devchar2);
     getdvi_itmlst[1].code = DVI$_DEVCHAR2;
     getdvi_itmlst[1].buffer = &devchar2;
     getdvi_itmlst[1].retlen = &len;
     getdvi_itmlst[2].length = sizeof(devsts);
     getdvi_itmlst[2].code = DVI$_STS;
     getdvi_itmlst[2].buffer = &devsts;
     getdvi_itmlst[2].retlen = &len;
     do {
       sprintf(tna_name,"%s%1d:",TNA_DEVICE,++tna_unit_number);
       input.dsc$w_length=strlen(tna_name);
       input.dsc$a_pointer = tna_name;
       status = sys$getdviw (EFN$C_ENF,
                             0,
                             &input,
                             getdvi_itmlst,
                             &iosb,
                             0,
                             0,
                             0 );
       if (status & 1) status = iosb.status;
       if (status == SS$_NORMAL || status == SS$_DEVOFFLINE) 
           continue;
       if (status != SS$_NOSUCHDEV)
           status = SS$_ABORT;
       if ((status == SS$_NOSUCHDEV) || (status == SS$_ABORT))
           break;
     } while (1);
     free (getdvi_itmlst);
     if (status == SS$_NOSUCHDEV){
        chan = vaxc$get_sdc(s);
        status = create_terminal(tna_name,chan,&tnachan);
        STMT_START {
           if (!(status & 1)) {
               set_errno(EVMSERR); set_vaxc_errno(status);
               Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d",
                          status,__FILE__,__LINE__); }
        } STMT_END;
     }
     strcpy(filbuf,"tempXXXXXX");
     if ((fd = mkstemp(filbuf)) == -1){
        STMT_START {
           Perl_croak(aTHX_ "Fatal mkstemp error (errno=%d) at %s, line %d",
                      errno,__FILE__,__LINE__);
        } STMT_END;
     }
     strcpy(tmpbuf,"$ on error then logout\n");
     if (write(fd,tmpbuf,strlen(tmpbuf)) != strlen(tmpbuf)){
        STMT_START {
           Perl_croak(aTHX_ "Fatal write error (errno=%d) at %s, line %d",
                      errno,__FILE__,__LINE__);
        } STMT_END;
     }
     strcpy(tmpbuf,"$ set terminal/noecho\n");
     if (write(fd,tmpbuf,strlen(tmpbuf)) != strlen(tmpbuf)){
        STMT_START {
           Perl_croak(aTHX_ "Fatal write error (errno=%d) at %s, line %d",
                      errno,__FILE__,__LINE__);
        } STMT_END;
     }
     sprintf(tmpbuf,"$ define/user sys$input %s\n",tna_name);
     if (write(fd,tmpbuf,strlen(tmpbuf)) != strlen(tmpbuf)){
        STMT_START {
           Perl_croak(aTHX_ "Fatal write error (errno=%d) at %s, line %d",
                       errno,__FILE__,__LINE__);
        } STMT_END;
     }
     sprintf(tmpbuf,"$ @%s\n",str);
     if (write(fd,tmpbuf,strlen(tmpbuf)) != strlen(tmpbuf)){
        STMT_START {
           Perl_croak(aTHX_ "Fatal write error (errno=%d) at %s, line %d",
                   errno,__FILE__,__LINE__);
        } STMT_END;
     }
     strcpy(tmpbuf,"$ logout\n");
     if (write(fd,tmpbuf,strlen(tmpbuf)) != strlen(tmpbuf)){
        STMT_START {
           Perl_croak(aTHX_ "Fatal write error (errno=%d) at %s, line %d",
                      errno,__FILE__,__LINE__);
        } STMT_END;
     }
     close(fd);
     sprintf (tmpbuf,"@%s.;",filbuf);
     status = spawn(tmpbuf, &child_status, tna_name,&efn);
     STMT_START {
       if (!(status & 1)) {
           set_errno(EVMSERR); set_vaxc_errno(status);
           Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d",
                      status,__FILE__,__LINE__); }
     } STMT_END;
     status = sys$waitfr(efn);
     STMT_START {
       if (!(status & 1)) {
           set_errno(EVMSERR); set_vaxc_errno(status);
           Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d",
                      status,__FILE__,__LINE__); }
     } STMT_END;
     lib$free_ef(&efn);
     remove(filbuf);
     if (tnachan != -1) status = sys$dassgn(tnachan);
     STMT_START {
       if (!(status & 1)) {
           set_errno(EVMSERR); set_vaxc_errno(status);
           Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d",
                      status,__FILE__,__LINE__); }
     } STMT_END;

     status = delete_tna_device(tna_name);
     STMT_START {
       if (!(status & 1)) {
          set_errno(EVMSERR); set_vaxc_errno(status);
          Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d",
                     status,__FILE__,__LINE__); }
     } STMT_END;
     STATUS_NATIVE = child_status;
     STATUS_NATIVE_EXPORT;
     RETVAL = status & 1;
 OUTPUT:
    RETVAL

******
* tn.h
******
#ifndef __TN_H
#define __TN_H
extern int create_terminal(char *,short, short *);
extern int create_tna_device(char *,short);
extern int delete_tna_device(char *);
#endif

******
* tn.c
******
#ifndef _SOCKADDR_LEN
#define _SOCKADDR_LEN   /* this is required for the BSD 4.4  struct sockaddr */
#endif
#include <types.h>
#include <socket.h>
#include <in.h>
#include <inet.h>
#include <netdb.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <tniodef.h>
#include <ttdef.h>
#include <tt2def.h>
#include <tcpip$inetdef.h>
#include <descrip.h>
#include <starlet.h>
#include <iodef.h>
#include <ssdef.h>
#include <dcdef.h>
#include <ttdef.h>
#include <dvidef.h>
#include <devdef.h>
#include <ucbdef.h>

typedef struct {  /* I/O Status Block */
    unsigned short status;
    unsigned short count;
    unsigned long funcdep;
} iosb_t;

typedef struct {  /* Structure descriptor */
    unsigned long length;
    void *address;
} struct_desc_t;

typedef struct {  /* Item definition for TELNET QIO services */
    unsigned short length;
    unsigned short code;
    void *buffer;
} item_l2_t;

typedef struct {  /* Standard OpenVMS item definition */
    unsigned short length;
    unsigned short code;
    void *buffer;
    void *retlen;
} item_t;

typedef struct {
    unsigned char class;
    unsigned char type;
    unsigned short width;
    unsigned int termchar:24;
    unsigned char length;
} termchar_t;

/*
 * The delete_tna_device acts very much like the TELNET> DELETE_SESSION in
 * all its visible aspects on the target TNA and associated BG device.
 */
int delete_tna_device(char *tnname){
    struct dsc$descriptor_s tn_dev = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
    struct dsc$descriptor_s bg_dev = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
    int status;
    item_l2_t *itmlst;
    item_t *getdvi_itmlst;
    iosb_t iosb;
    int devchar;
    int devchar2;
    int devsts;
    unsigned short tnchan,BGchan;
    unsigned short len;
    char BGname[64];

    tn_dev.dsc$w_length = strlen(tnname);
    tn_dev.dsc$a_pointer=tnname;
    getdvi_itmlst = calloc(4,sizeof(item_t));
    getdvi_itmlst[0].length = sizeof(devchar);
    getdvi_itmlst[0].code = DVI$_DEVCHAR;
    getdvi_itmlst[0].buffer = &devchar;
    getdvi_itmlst[0].retlen = &len;
    getdvi_itmlst[1].length = sizeof(devchar2);
    getdvi_itmlst[1].code = DVI$_DEVCHAR2;
    getdvi_itmlst[1].buffer = &devchar2;
    getdvi_itmlst[1].retlen = &len;
    getdvi_itmlst[2].length = sizeof(devsts);
    getdvi_itmlst[2].code = DVI$_STS;
    getdvi_itmlst[2].buffer = &devsts;
    getdvi_itmlst[2].retlen = &len;
    status = sys$getdviw( 0, 0, &tn_dev, getdvi_itmlst, &iosb, NULL, 0, NULL);
    free (getdvi_itmlst);
    if (status & 1) status = iosb.status;
    if (!(status & 1)) {
        if ((status != SS$_NOSUCHDEV) && (status != SS$_DEVOFFLINE))
             printf("Failed to get %s device dependent characteristics.\n",
                     tnname);
        return(status);
    }
    /*
     * Check inbound Telnet devices and templates or temporary UCBs.
     * Do not delete them.
     */
    if ((!(devchar & DEV$M_AVL))  || (devchar2 & DEV$M_RED) ||
        ((devsts & UCB$M_TEMPLATE) & (!(devsts & UCB$M_DELETEUCB))))
          return (SS$_NORMAL);

    status = sys$assign(&tn_dev, &tnchan, 0, 0);
    if (!(status & 1)) {
        printf("Failed to assign channel to %s channel.\n",tnname);
        return(status);
    }

    /*
     * Allocate and Build the item list.
     */
    itmlst = calloc(2,sizeof(item_l2_t));
    itmlst[0].length = sizeof(BGname);
    itmlst[0].code = TN$_NETWORK_DEVICE_NAME;
    itmlst[0].buffer = BGname;

    status = sys$qiow(0, tnchan, IO$_TTY_PORT_BUFIO | IO$M_TN_SENSEMODE,
                      &iosb, 0, 0, 0, 0, 0, 0, itmlst , 0); 
    free(itmlst);
    /*
     * At this point under the OpenVMS debugger, we retreive the
     * BG device name that has been visible after the WRITEVBLK.
     * DBG> exa/ascic BGname
     * TN\delete_tna_device\BGname:    'BG18206:'
     */
    if (status & 1) status = iosb.status;
    if (!(status & 1)) {
        printf("Failed to SENSEMODE %s device.Status=%1x\n",tnname,status);
        return(status);
    }
    bg_dev.dsc$w_length = BGname[0];
    bg_dev.dsc$a_pointer=&BGname[1];
    status = sys$assign(&bg_dev, &BGchan, 0, 0);
    if (!(status & 1)) {
        printf("Failed to assign channel to %.*s.\n",BGname[0],&BGname[1]);
        return(status);
    }
    status = sys$qiow(0, tnchan, IO$_TTY_PORT |  IO$M_TN_SHUTDOWN,
                      &iosb, 0, 0, BGchan, 0, 0, 0, 0 , 0); 
    if (status & 1) status = iosb.status;
    if (!(status & 1)) {
        printf("Failed to SHUTDOWN %s device.Status=%1x\n",tnname,status);
        return(status);
    }
    status = sys$dassgn(BGchan);
    if (!(status & 1)){
        printf("Failed to deassign the %.*s channel.\n",BGname[0],&BGname[1]);
        return(status);
    }
    /*
     * Deassign temporary channel.
     */

    status = sys$dassgn(tnchan);
    if (!(status & 1)){
        printf("Failed to deassign the %s channel.\n",tnname);
        return(status);
    }
    return (status);

}
/*
 * The create_tna_device acts very much like the TELNET> CREATE_SESSION in
 * all its visible aspects on the created TNA and associated BG device.
 */
int create_tna_device(char *tn_device,short BGchan){
    $DESCRIPTOR(tna0_dev,"TNA0:");
    $DESCRIPTOR(inet_dev,"UCX$DEVICE");
    struct dsc$descriptor_s dev = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
    unsigned short tna0chan;
    struct {
        unsigned char len;
        char devname[63];
    } ASCIC_devname;
    int protocol = TN$K_PROTOCOL_RAW;
    int service_type = TN$K_SERVICE_NONE;
    int status;
    int devchar;
    item_l2_t *itmlst;
    item_t *getdvi_itmlst;
    iosb_t iosb;
    int characteristics = /*TN$M_PERMANENT_UCB | TN$M_RETAIN_ON_DASSGN | */
                          TN$M_AUTOCONNECT ;
    int device_unit;
    char junk[50];
    unsigned short len;

    /*
     * Check this is the TNA device.
     */
    if (strncasecmp(tn_device,"TNA",3) != 0) return (SS$_ABORT);
    /* Get device unit. */
    status = sscanf(tn_device,"%c %c %c %d %c",&junk[0],&junk[1],&junk[2],
                                &device_unit,&junk[3]);
    if (status != 5) return (SS$_ABORT);

    dev.dsc$w_length = strlen(tn_device);
    dev.dsc$a_pointer = tn_device;

    getdvi_itmlst = calloc(2,sizeof(item_t));
    getdvi_itmlst[0].length = sizeof(devchar);
    getdvi_itmlst[0].code = DVI$_DEVCHAR;
    getdvi_itmlst[0].buffer = &devchar;
    getdvi_itmlst[0].retlen = &len;
    status = sys$getdviw( 0, 0, &dev, getdvi_itmlst, &iosb, NULL, 0, NULL);
    free (getdvi_itmlst);
    if (status & 1) status = iosb.status;
    if ((status & 1)) {
         if (!(devchar & DEV$M_AVL))
              return (SS$_DEVOFFLINE);

        printf("Device %s device already exists.Not created\n",tn_device);
        return(SS$_DEVALRALLOC);
    }
    status = sys$assign(&tna0_dev, &tna0chan, 0, 0);
    if (!(status & 1)) {
        printf("Failed to assign channel to TNA0.\n");
        return(status);
    }
    /*
     * Allocate and Build the item list.
     * When the sys$qiow completes, we get
     * an unconnected TNA device.
     */
    itmlst = calloc(6,sizeof(item_l2_t));
    itmlst[0].length = sizeof (int);
    itmlst[0].code = TN$_SERVICE_TYPE;
    itmlst[0].buffer = &service_type;
    itmlst[1].length = sizeof (int);
    itmlst[1].code = TN$_PROTOCOL;
    itmlst[1].buffer = &protocol;
    itmlst[2].length = sizeof (int);
    itmlst[2].code = TN$_DEVICE_UNIT;
    itmlst[2].buffer = &device_unit;
    itmlst[3].length = sizeof (int);
    itmlst[3].code = TN$_CHARACTERISTICS;
    itmlst[3].buffer = &characteristics;
    status = sys$qiow(0, tna0chan, IO$_TTY_PORT_BUFIO | IO$M_TN_SETMODE, &iosb,
                        0, 0, 0, 0,
                        0, 0, itmlst , 0); 
    free(itmlst);
    if (status & 1) status = iosb.status;
    if (!(status & 1)) {
        printf("Failed to create %s terminal.\n",tn_device);
        return(status);
    }

    /*
     * Binds our socket to the TELNET terminal.
     */
    status = sys$qiow(0, tna0chan, IO$_TTY_PORT | IO$M_TN_STARTUP,
                        &iosb, 0, 0, BGchan, protocol, characteristics,
                        0, 0, 0);
    if (status & 1) status = iosb.status;
    if (!(status & 1)) {
        printf("Failed to bind to a TELNET terminal.\n");
        return(status);
    }
    /*
     * Deassign TNAxxxx temporary channel.
     */
    status = sys$dassgn(tna0chan);
    if (!(status & 1)){
        printf("Failed to deassign the TNA0 channel.\n");
        return(status);
    }
    return (status);
}

int create_terminal(char *tn_device, short BGchan,short *tnachan){
    $DESCRIPTOR (inet_dev,"UCX$DEVICE");
    unsigned short tnchan,socket_channel;
    int status;
    iosb_t iosb_r,iosb_w;
    short sck_parm[2];  /* Socket creation parameter */

    termchar_t termchar;
    char buffer[100],*buf;
    struct dsc$descriptor_s tn_dev = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};

    status = create_tna_device(tn_device,BGchan);
    if (!(status & 1)){
        printf ("Failed to create %s device.\n",tn_device);
        return(status);
    }
    else{
        /*
         * Set TNAxxx: string descriptor.
         */
        tn_dev.dsc$w_length = strlen(tn_device);
        tn_dev.dsc$a_pointer = tn_device;
        /*
         * Assign and return channel to dynamically created device.
         */
        if (!((status = sys$assign(&tn_dev, &tnchan, 0, 0)) & 1)) {
             printf ("Failed to assign channel from %s device.\n",tn_device);
             return(status);
        }
    }

    /*
     * Get the current terminal characteristics for this TNAxxx device.
     */
    status = sys$qiow (0, tnchan, IO$_SENSEMODE, &iosb_r, 0, 0,
                        &termchar, sizeof (termchar), 0, 0, 0, 0);
    if (status & 1) status = iosb_r.status;
    if (!(status & 1)) {
        printf("Failed to get %s terminal characteristics.\n",tn_device);
        return(status);
    }
    /*
     * Set the terminal type for this TNAxxx device.
     */
    if (termchar.class != DC$_TERM) return (SS$_ABORT);
    *tnachan = tnchan;
    return(SS$_NORMAL);
}

******
* spawn.h
******
#ifndef _SPAWN_H
#define _SPAWN_H
extern int spawn(char *, int *, char *, int *);
#endif

******
* spawn.c
******
#include <string.h>
#include <starlet.h>
#include <lib$routines.h>
#include <libwaitdef.h>
#include <efndef.h>
#include <dvidef.h>
#include <ssdef.h>
#include <descrip.h>
#include <clidef.h>

int spawn(char *str, int *child_status, char *tna_name,  unsigned int *efn){
    int status;
    int flags = CLI$M_NOWAIT|CLI$M_NOCONTROL;
    struct dsc$descriptor_s input = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
    struct dsc$descriptor_s output;
    struct dsc$descriptor_s command = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};

    if (!str)
        return SS$_ABORT;
    input.dsc$w_length  = strlen(tna_name);
    input.dsc$a_pointer = tna_name;
    command.dsc$w_length = strlen(str);
    command.dsc$a_pointer = str;
    memcpy(&output, &input, sizeof(output));
    lib$get_ef(efn);
    status = lib$spawn(&command,&input,&output,&flags,NULL,
                              NULL,child_status,efn);
    return status;
}

******
* Makefile.PL
******
use 5.008006;
use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
WriteMakefile(
    NAME              => 'MYSYSTEM',
    VERSION_FROM      => 'lib/MYSYSTEM.pm', # finds $VERSION
    PREREQ_PM         => {}, # e.g., Module::Name => 1.1
    ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
      (ABSTRACT_FROM  => 'lib/MYSYSTEM.pm', # retrieve abstract from module
       AUTHOR         => 'Philippe Vouters <phv@x9000.fr>') : ()),
    LIBS              => [''], # e.g., '-lm'
    DEFINE            => '-D_SOCKADDR_LEN', # e.g., '-DHAVE_SOMETHING'
    INC               => '-I.', # e.g., '-I. -I/usr/include/other'
    depend            => {'MYSYSTEM.c' => 'MYSYSTEM.xs','TN.OBJ' => 'TN.c',
                          'spawn.OBJ' => 'spawn.c' },
        # Un-comment this if you add C files to link with later:
    OBJECT            => '$(O_FILES)', # link all the C files too
);
package MY; # so that "SUPER" works right
sub c_o {
 my $regex = "(.*)TARGET_NAME\\)\.c";
 my $inherited = shift->SUPER::c_o(@_);
 $inherited =~ s/$regex/$1TARGET_NAME).c + sys\$library:sys\$lib_c\/lib/;
 $inherited;
 }


REFERENCE(S):

Google searches regarding available Perl and Perlvms technonology.

The tn.c code is derived from:
../tima/OpenVMS-TCPIP-Creating-and-Deleting-a-Telnet-device.html