File Coverage

blib/lib/Spectrum/CLI.pm

Criterion	Covered	Total	%
statement	24	214	11.2
branch	0	132	0.0
condition	0	18	0.0
subroutine	8	16	50.0
pod	6	6	100.0
total	38	386	9.8

#  Spectrum::CLI - a perl module for use with Spectrum's Command Line Interface
#  Copyright (C) 1999-2003  Dave Plonka
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

# $Id: CLI.pm,v 1.16 2003/12/16 15:50:04 dplonka Exp $
# Dave Plonka

package Spectrum::CLI;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use IO::File;
use IO::Socket;
use IPC::Open2;
use File::Basename;
use POSIX qw(setsid);
use Sys::Hostname;

require Exporter;
require AutoLoader;

@Spectrum::CLI::ISA = qw(Exporter AutoLoader);
# convert the RCS revision to a reasonable Exporter VERSION:
'$Revision: 1.16 $' =~ m/(\d+)\.(\d+)/ && (( $Spectrum::CLI::VERSION ) = sprintf("%d.%03d", $1, $2));

sub new {
   my $class = shift;
   my $self = {};
   $self->{verbose} = 0;
   $ENV{CLISESSID} = $$; # default
   $ENV{CLIMNAMEWIDTH} = 1024; # default
   my $daemon; # absolute path to VnmShd
   while (@_) {
      if ('HASH' eq ref($_[0])) { # a hashref
	 $self->{verbose} = $_[0]->{verbose} || $_[0]->{Verbose};
	 $self->{Verbose} = $_[0]->{Verbose};
	 if (defined $_[0]->{CLISESSID}) {
            $ENV{CLISESSID} = $_[0]->{CLISESSID}
	 }
	 if ($_[0]->{CLIMNAMEWIDTH}) {
            $ENV{CLIMNAMEWIDTH} = $_[0]->{CLIMNAMEWIDTH}
	 }
	 if ($_[0]->{VNMSHRCPATH}) {
            $ENV{VNMSHRCPATH} = $_[0]->{VNMSHRCPATH}
	 }
	 if ($_[0]->{localhostname}) {
	    $self->{localhostname} = $_[0]->{localhostname}
	 }
	 if ($_[0]->{timeout}) {
	    $self->{timeout} = $_[0]->{timeout}
	 }
	 shift
      } else { # scalar
	 if (m|^/|) { # it's an absolute path
            $self->{dir} = shift
	 } else { # it's the VNM name
            $self->{vnm} = shift
	 }
      }
   }
   if ('' eq $self->{dir}) {
      if ($ENV{SPEC_ROOT}) {
         $self->{dir} = "$ENV{SPEC_ROOT}/vnmsh"
      } elsif ($ENV{SPECROOT}) {
         $self->{dir} = "$ENV{SPECROOT}/vnmsh"
      }
   }

   if ('' eq $self->{dir}) {
      warn "must set SPEC_ROOT/SPECROOT environment variable or pass full path to vnmsh directory to \"new\" method!\n" if $self->{verbose};
      return undef
   }

   if ('' eq $ENV{VNMSHRCPATH} && -f "$self->{dir}/.vnmshrc") {
      $ENV{VNMSHRCPATH} = "$self->{dir}/.vnmshrc"
   }

   # discover which vnmsh commands are available:
   my $entry;
   my $dir = $self->{dir}; # kludge since perl doesn't like this in a glob
   foreach $entry (<$dir/*>) {
      my $cmd =  basename $entry;
      $cmd    =~ s/.exe$//;
      if ($cmd =~ m;VnmShd$;) {
	 $daemon = $entry;
      }
      next if $cmd =~ m;(Vnm|stop)Shd$;; # skip these executables
      push(@{$self->{command}}, $cmd) if (-f $entry && -x _)

   }
   warn "valid vnmsh commands: @{$self->{command}}\n" if $self->{Verbose};

   # We don't want the vnmsh/connect command to launch VnmShd for us...
   # This is because (as of this writing - Spectrum 5.0r1) the vnmsh/connect
   # command not setting the close-on-exec flag before fork(2)ing/exec(2)ing
   # a VnmShd process.  This causes our perl read from pipe to hang (since
   # the other end of the pipe is still open for writing until VnmShd
   # terminates - ugh.)
   #
   # Unfortunately we now have a race condition here: If VnmShd shuts down
   # (e.g. is stopped intentionally) between when we start it and when we
   # run vnmsh/connect (which will restart VnmShd), we could hang
   # indefinitely in the read on the pipe from vnmsh/connect.
   # Then, when this new VnmShd terminates (e.g. is stopped intentionally)
   # read(2) will return with EOF, and we'll think we have a successful
   # connection - even though VnmShd is no longer running.
   # Ugh.
   #
   # All is not lost though - that would be an unlikely chain of events.
   # It should be able to be avoided by starting VnmShd "manually" before
   # any Spectrum::CLI scripts are run, and then shutting VnmShd down until
   # you know that no Spectrum::CLI scripts are running.
   #
   # This could all be fixed by fcntl(fd, F_GETFD, 0) followed by
   # fcntl(fd, F_SETFD, FD_CLOEXEC | flags) in vnmsh/connect.
   #
   # In hindsight it probably wasn't such a good idea for Spectrum to have
   # vnmsh/connect launch VnmShd when its not already running.  This runs
   # counter to the Unix permissions mechanism since any old Spectrum user
   # could be running VnmShd and doing SSAPI I/O on behalf of other users.
   # (IMHO, VnmShd should be run by the Spectrum install user.)

   # { Check to see if VnmShd is running (and start it if it's not):

   # determine which port VnmShd is to use (by parsing the config file):
   {
      my $fh = new IO::File "<$ENV{VNMSHRCPATH}";
      if (!ref($fh)) {
         warn "open \"$ENV{VNMSHRCPATH}\", \"r\": $!\n" if $self->{verbose}
      } else {
         while (<$fh>) {
            next if (m/^\s*#/); # skip comments
            if (m/\s*vsh_tcp_port\s*=\s*(0x([0-9a-f]+)|(\d+))/i) {
	       $self->{port} = $2? hex($2) : $3
            }
         }
      }
      undef $fh;
   }

   my $s = new IO::Socket::INET (Proto => 'tcp',
				 PeerAddr =>
				    ($self->{localhostname}?
				       $self->{localhostname} : hostname),
				 PeerPort =>
				    ($self->{port}? $self->{port}: 7777));
   if (!ref($s)) {
      warn "no VnmShd (yet)...\n" if $self->{Verbose};
      # start VnmShd
      if ('' eq $daemon) {
         warn("$self->{dir}/VnmShd not found!\n") if $self->{verbose};
         return undef
      }
      my @command = ($daemon);
      # FIXME stat(2)/access(2) VnmShd
      warn "fork, exec @command...\n" if $self->{Verbose};
      my $pid = fork();
      die "fork: $!\n" if (-1 == $pid);
      if (0 == $pid) { # child
	 # dissociate child from parent
	 setsid() or die "setsid: $!\n";
	 # Hmm... perhaps I should daemonize properly by chdir(2)ing,
	 # and association STDIN, STDOUT, and STDERR with "/dev/null".
	 # For the time being I'd like to see error messages (if any), so
	 # we'll leave it alone.  Besides this is no sloppier than how
	 # vnmsh/connect leaves things (when it launches VnmShd).
	 exec @command;
	 die "exec \"@command\": $!\n"
      } else { # parent
         warn "waiting a bit...\n" if $self->{Verbose};
	 sleep($self->{timeout}? $self->{timeout} : 5)
      }
   }
   undef $s;

   # }

   my @command = ('connect');
   push(@command, $self->{vnm}) if $self->{vnm};

   warn("dir: $self->{dir}\n" .
	"CLISESSID=$ENV{CLISESSID}\n" .
	"CLIMNAMEWIDTH=$ENV{CLIMNAMEWIDTH}\n" .
	"VNMSHRCPATH=$ENV{VNMSHRCPATH}\n") if $self->{Verbose};

   warn "@command...\n" if $self->{Verbose};
   my $fh = new IO::File "$self->{dir}/@command 2>&1 |";
   if (!ref($fh)) {
      warn("failed to pipe from \"@command\": $!\n") if $self->{verbose};
      return undef
   }
   @{$self->{results}} = <$fh>;
   $fh->close;
   $self->{status} = int($?/256);
   if (0 != $self->{status}) {
      warn("\"@command\" failed - exit status: ", $self->{status}, "\n") if $self->{verbose};
      return undef
   }

   bless($self, $class)
}

sub dir {
   my $self = shift;
   die unless ref($self);
   if (@_) {
      $self->{dir} = shift
   }
   $self->{dir}
}

sub verbose {
   my $self = shift;
   die unless ref($self);
   if (@_) {
      $self->{verbose} = shift
   } else {
      $self->{verbose}
   }
}

sub Verbose {
   my $self = shift;
   die unless ref($self);
   if (@_) {
      $self->{Verbose} = shift
   } else {
      $self->{Verbose}
   }
}

sub results {
   my $self = shift;
   die unless ref($self);
   @{$self->{results}}
}

sub status {
   my $self = shift;
   die unless ref($self);
   $self->{status}
}

sub AUTOLOAD {
   my $self = shift;
   my $call = $Spectrum::CLI::AUTOLOAD;
   $call =~ s/^.*:://;

   # There seems to be some problems with buffered I/O, let's flush it here
   # before we fork(2) any processes, just to be safe.
   flush STDOUT;
   flush STDERR;

   # There seems to be an intermittent problem with SIGPIPE being delivered.
   # Let's try to avoid that issue:
   my $saved_pipe_handler = $SIG{PIPE};
   $SIG{PIPE} = 'IGNORE';

   # { save the hashref, if one was passed, and remove it from the argument list
   my $hashref;
   my $n;
   for ($n=0; $n <= @_; $n++) {
      if ('HASH' eq ref($_[$n])) {
	 $hashref = splice(@_, $n, 1)
      }
   }
   # }

   my @command = (split(m/_/, $call), @_);

   if (!grep { $command[0] eq $_ } @{$self->{command}}) {
      die "Can't locate object method \"$call\""
   }

   warn "@command...\n" if $self->{Verbose};

   my $display = 1; # default to "display" commands such as "show" and "seek"
   if ('fetchall_arrayref' eq $command[0]) {
      $command[0] = 'show'
   } elsif ('show' ne $command[0] && 'seek' ne $command[0]) {
      $display = 0
   }

   my $fhin = new IO::File;
   die "IO::File->new failed: $!\n" unless ref($fhin);
   my $fh = new IO::File;
   die "IO::File->new failed: $!\n" unless ref($fh);
   my $pid = open2($fh, $fhin, $self->dir . "/@command 2>&1");
   print $fhin "y\n"; # answer 'y'es to "destroy model: are you sure ?", etc.

   if (!$display) {
      @{$self->{results}} = <$fh>;
      waitpid($pid, 0);
      $self->{status} = int($?/256);
      if (0 != $self->{status} && $self->{verbose}) {
	 warn @{$self->{results}}
      }
      $fh->close;
      $fhin->close;
      $SIG{PIPE} = $saved_pipe_handler;
      return wantarray? ($self->{status}, @{$self->{results}}) : !$self->{status}
   }

   # { parse the output of display commands:
   my @results;
   my $headings = <$fh>;
   @{$self->{results}} = ($headings);
   chomp $headings;
   my(@headings, @lengths);
   while ($headings) {
      $headings =~ s/^\s*(\S+)\s*//;
      push(@headings, $1);
      push(@lengths, length($&))
   }
   while (<$fh>) {
      push(@{$self->{results}}, $_);
      chomp;
      my $index = 1+$#results;
      my $start = 0; # position where this column starts
      my $lcv;
      for ($lcv = 0; $headings[$lcv]; $lcv++) {
	 my $val;
	 if ($lcv < $#headings) {
            $val = substr($_, $start, $lengths[$lcv]);
	    $start += $lengths[$lcv]
	 } else {
            $val = substr($_, $start)
	 }
	 if ($hashref) {
	    # skip columns that the caller didn't request...
	    next unless $hashref->{$headings[$lcv]}
	 }
	 $val =~ s/\s+$//;
         $results[$index]{$headings[$lcv]} = $val
      }
   }
   # }
   waitpid($pid, 0);
   $self->{status} = int($?/256);
   $fh->close;
   $fhin->close;
   if (0 != $self->{status} && $self->{verbose}) {
      warn @{$self->{results}}
   }

   $SIG{PIPE} = $saved_pipe_handler;
   wantarray? @results : \@results
}

sub DESTROY {
   my $self = shift;
   die unless ref $self;
   if ( $^O =~ /^(ms)?(dos|win(32|nt)?)/i ) {
      system($self->dir . "/disconnect >null 2>&1");
   } else {
      system($self->dir . "/disconnect >/dev/null 2>&1");
   }
}

1;
__END__