# Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#26 $
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::Cmd;

require 5.001;
require Exporter;

use strict;
use vars qw(@ISA @EXPORT $VERSION);
use Carp;

BEGIN {
  if ($^O eq 'os390') {
    require Convert::EBCDIC;
#    Convert::EBCDIC->import;
  }
}

$VERSION = "2.20";
@ISA     = qw(Exporter);
@EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);

sub CMD_INFO	{ 1 }
sub CMD_OK	{ 2 }
sub CMD_MORE	{ 3 }
sub CMD_REJECT	{ 4 }
sub CMD_ERROR	{ 5 }
sub CMD_PENDING { 0 }

my %debug = ();

my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;

sub toebcdic
{
 my $cmd = shift;

 unless (exists ${*$cmd}{'net_cmd_asciipeer'})
  {
   my $string = $_[0];
   my $ebcdicstr = $tr->toebcdic($string);
   ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
  }

  ${*$cmd}{'net_cmd_asciipeer'}
    ? $tr->toebcdic($_[0])
    : $_[0];
}

sub toascii
{
  my $cmd = shift;
  ${*$cmd}{'net_cmd_asciipeer'}
    ? $tr->toascii($_[0])
    : $_[0];
}

sub _print_isa
{
 no strict qw(refs);

 my $pkg = shift;
 my $cmd = $pkg;

 $debug{$pkg} ||= 0;

 my %done = ();
 my @do   = ($pkg);
 my %spc = ( $pkg , "");

 print STDERR "\n";
 while ($pkg = shift @do)
  {
   next if defined $done{$pkg};

   $done{$pkg} = 1;

   my $v = defined ${"${pkg}::VERSION"}
                ? "(" . ${"${pkg}::VERSION"} . ")"
                : "";

   my $spc = $spc{$pkg};
   print STDERR "$cmd: ${spc}${pkg}${v}\n";

   if(@{"${pkg}::ISA"})
    {
     @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
     unshift(@do, @{"${pkg}::ISA"});
    }
  }

 print STDERR "\n";
}

sub debug
{
 @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';

 my($cmd,$level) = @_;
 my $pkg = ref($cmd) || $cmd;
 my $oldval = 0;

 if(ref($cmd))
  {
   $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
  }
 else
  {
   $oldval = $debug{$pkg} || 0;
  }

 return $oldval
    unless @_ == 2;

 $level = $debug{$pkg} || 0
    unless defined $level;

 _print_isa($pkg)
    if($level && !exists $debug{$pkg});

 if(ref($cmd))
  {
   ${*$cmd}{'net_cmd_debug'} = $level;
  }
 else
  {
   $debug{$pkg} = $level;
  }

 $oldval;
}

sub message
{
 @_ == 1 or croak 'usage: $obj->message()';

 my $cmd = shift;

 wantarray ? @{${*$cmd}{'net_cmd_resp'}}
    	   : join("", @{${*$cmd}{'net_cmd_resp'}});
}

sub debug_text { $_[2] }

sub debug_print
{
 my($cmd,$out,$text) = @_;
 print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
}

sub code
{
 @_ == 1 or croak 'usage: $obj->code()';

 my $cmd = shift;

 ${*$cmd}{'net_cmd_code'} = "000"
	unless exists ${*$cmd}{'net_cmd_code'};

 ${*$cmd}{'net_cmd_code'};
}

sub status
{
 @_ == 1 or croak 'usage: $obj->status()';

 my $cmd = shift;

 substr(${*$cmd}{'net_cmd_code'},0,1);
}

sub set_status
{
 @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';

 my $cmd = shift;
 my($code,$resp) = @_;

 $resp = [ $resp ]
	unless ref($resp);

 (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);

 1;
}

sub command
{
 my $cmd = shift;

 unless (defined fileno($cmd))
  {
    $cmd->set_status("599", "Connection closed");
    return $cmd;
  }


 $cmd->dataend()
    if(exists ${*$cmd}{'net_cmd_lastch'});

 if (scalar(@_))
  {
   local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';

   my $str =  join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
   $str = $cmd->toascii($str) if $tr;
   $str .= "\015\012";

   my $len = length $str;
   my $swlen;

   $cmd->close
	unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);

   $cmd->debug_print(1,$str)
	if($cmd->debug);

   ${*$cmd}{'net_cmd_resp'} = [];      # the response
   ${*$cmd}{'net_cmd_code'} = "000";	# Made this one up :-)
  }

 $cmd;
}

sub ok
{
 @_ == 1 or croak 'usage: $obj->ok()';

 my $code = $_[0]->code;
 0 < $code && $code < 400;
}

sub unsupported
{
 my $cmd = shift;

 ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
 ${*$cmd}{'net_cmd_code'} = 580;
 0;
}

sub getline
{
 my $cmd = shift;

 ${*$cmd}{'net_cmd_lines'} ||= [];

 return shift @{${*$cmd}{'net_cmd_lines'}}
    if scalar(@{${*$cmd}{'net_cmd_lines'}});

 my $partial = defined(${*$cmd}{'net_cmd_partial'})
		? ${*$cmd}{'net_cmd_partial'} : "";
 my $fd = fileno($cmd);

 return undef
	unless defined $fd;

 my $rin = "";
 vec($rin,$fd,1) = 1;

 my $buf;

 until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
  {
   my $timeout = $cmd->timeout || undef;
   my $rout;
   if (select($rout=$rin, undef, undef, $timeout))
    {
     unless (sysread($cmd, $buf="", 1024))
      {
       carp(ref($cmd) . ": Unexpected EOF on command channel")
		if $cmd->debug;
       $cmd->close;
       return undef;
      } 

     substr($buf,0,0) = $partial;	## prepend from last sysread

     my @buf = split(/\015?\012/, $buf, -1);	## break into lines

     $partial = pop @buf;

     push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);

    }
   else
    {
     carp("$cmd: Timeout") if($cmd->debug);
     return undef;
    }
  }

 ${*$cmd}{'net_cmd_partial'} = $partial;

 if ($tr) 
  {
   foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) 
    {
     $ln = $cmd->toebcdic($ln);
    }
  }

 shift @{${*$cmd}{'net_cmd_lines'}};
}

sub ungetline
{
 my($cmd,$str) = @_;

 ${*$cmd}{'net_cmd_lines'} ||= [];
 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
}

sub parse_response
{
 return ()
    unless $_[1] =~ s/^(\d\d\d)(.?)//o;
 ($1, $2 eq "-");
}

sub response
{
 my $cmd = shift;
 my($code,$more) = (undef) x 2;

 ${*$cmd}{'net_cmd_resp'} ||= [];

 while(1)
  {
   my $str = $cmd->getline();

   return CMD_ERROR
	unless defined($str);

   $cmd->debug_print(0,$str)
     if ($cmd->debug);

   ($code,$more) = $cmd->parse_response($str);
   unless(defined $code)
    {
     $cmd->ungetline($str);
     last;
    }

   ${*$cmd}{'net_cmd_code'} = $code;

   push(@{${*$cmd}{'net_cmd_resp'}},$str);

   last unless($more);
  } 

 substr($code,0,1);
}

sub read_until_dot
{
 my $cmd = shift;
 my $fh  = shift;
 my $arr = [];

 while(1)
  {
   my $str = $cmd->getline() or return undef;

   $cmd->debug_print(0,$str)
     if ($cmd->debug & 4);

   last if($str =~ /^\.\r?\n/o);

   $str =~ s/^\.\././o;

   if (defined $fh)
    {
     print $fh $str;
    }
   else
    {
     push(@$arr,$str);
    }
  }

 $arr;
}

sub datasend
{
 my $cmd = shift;
 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
 my $line = join("" ,@$arr);

 return 0 unless defined(fileno($cmd));

 return 1
    unless length($line);

 if($cmd->debug)
  {
   my $b = "$cmd>>> ";
   print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
  }

 # Translate LF => CRLF, but not if the LF is
 # already preceeded by a CR
 $line =~ s/\G()\n|([^\r\n])\n/$+\015\012/sgo;

 ${*$cmd}{'net_cmd_lastch'} ||= " ";
 $line = ${*$cmd}{'net_cmd_lastch'} . $line;

 $line =~ s/(\012\.)/$1./sog;

 ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);

 my $len = length($line) - 1;
 my $offset = 1;
 my $win = "";
 vec($win,fileno($cmd),1) = 1;
 my $timeout = $cmd->timeout || undef;

 while($len)
  {
   my $wout;
   if (select(undef,$wout=$win, undef, $timeout) > 0)
    {
     my $w = syswrite($cmd, $line, $len, $offset);
     unless (defined($w))
      {
       carp("$cmd: $!") if $cmd->debug;
       return undef;
      }
     $len -= $w;
     $offset += $w;
    }
   else
    {
     carp("$cmd: Timeout") if($cmd->debug);
     return undef;
    }
  }

 1;
}

sub dataend
{
 my $cmd = shift;

 return 0 unless defined(fileno($cmd));

 return 1
    unless(exists ${*$cmd}{'net_cmd_lastch'});

 if(${*$cmd}{'net_cmd_lastch'} eq "\015")
  {
   syswrite($cmd,"\012",1);
   print STDERR "\n"
    if($cmd->debug);
  }
 elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
  {
   syswrite($cmd,"\015\012",2);
   print STDERR "\n"
    if($cmd->debug);
  }

 print STDERR "$cmd>>> .\n"
    if($cmd->debug);

 syswrite($cmd,".\015\012",3);

 delete ${*$cmd}{'net_cmd_lastch'};

 $cmd->response() == CMD_OK;
}

1;