lib/Net/Cmd.pm

   1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $
   2 #
   3 # Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
   4 # This program is free software; you can redistribute it and/or
   5 # modify it under the same terms as Perl itself.
   6
   7 package Net::Cmd;
   8
   9 require 5.001;
  10 require Exporter;
  11
  12 use strict;
  13 use vars qw(@ISA @EXPORT $VERSION);
  14 use Carp;
  15 use Symbol 'gensym';
  16
  17 BEGIN {
  18   if ($^O eq 'os390') {
  19     require Convert::EBCDIC;
  20 #    Convert::EBCDIC->import;
  21   }
  22 }
  23
  24 $VERSION = "2.26_01";
  25 @ISA     = qw(Exporter);
  26 @EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
  27
  28 sub CMD_INFO    { 1 }
  29 sub CMD_OK      { 2 }
  30 sub CMD_MORE    { 3 }
  31 sub CMD_REJECT  { 4 }
  32 sub CMD_ERROR   { 5 }
  33 sub CMD_PENDING { 0 }
  34
  35 my %debug = ();
  36
  37 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
  38
  39 sub toebcdic
  40 {
  41  my $cmd = shift;
  42
  43  unless (exists ${*$cmd}{'net_cmd_asciipeer'})
  44   {
  45    my $string = $_[0];
  46    my $ebcdicstr = $tr->toebcdic($string);
  47    ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
  48   }
  49
  50   ${*$cmd}{'net_cmd_asciipeer'}
  51     ? $tr->toebcdic($_[0])
  52     : $_[0];
  53 }
  54
  55 sub toascii
  56 {
  57   my $cmd = shift;
  58   ${*$cmd}{'net_cmd_asciipeer'}
  59     ? $tr->toascii($_[0])
  60     : $_[0];
  61 }
  62
  63 sub _print_isa
  64 {
  65  no strict qw(refs);
  66
  67  my $pkg = shift;
  68  my $cmd = $pkg;
  69
  70  $debug{$pkg} ||= 0;
  71
  72  my %done = ();
  73  my @do   = ($pkg);
  74  my %spc = ( $pkg , "");
  75
  76  while ($pkg = shift @do)
  77   {
  78    next if defined $done{$pkg};
  79
  80    $done{$pkg} = 1;
  81
  82    my $v = defined ${"${pkg}::VERSION"}
  83                 ? "(" . ${"${pkg}::VERSION"} . ")"
  84                 : "";
  85
  86    my $spc = $spc{$pkg};
  87    $cmd->debug_print(1,"${spc}${pkg}${v}\n");
  88
  89    if(@{"${pkg}::ISA"})
  90     {
  91      @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
  92      unshift(@do, @{"${pkg}::ISA"});
  93     }
  94   }
  95 }
  96
  97 sub debug
  98 {
  99  @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
 100
 101  my($cmd,$level) = @_;
 102  my $pkg = ref($cmd) || $cmd;
 103  my $oldval = 0;
 104
 105  if(ref($cmd))
 106   {
 107    $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
 108   }
 109  else
 110   {
 111    $oldval = $debug{$pkg} || 0;
 112   }
 113
 114  return $oldval
 115     unless @_ == 2;
 116
 117  $level = $debug{$pkg} || 0
 118     unless defined $level;
 119
 120  _print_isa($pkg)
 121     if($level && !exists $debug{$pkg});
 122
 123  if(ref($cmd))
 124   {
 125    ${*$cmd}{'net_cmd_debug'} = $level;
 126   }
 127  else
 128   {
 129    $debug{$pkg} = $level;
 130   }
 131
 132  $oldval;
 133 }
 134
 135 sub message
 136 {
 137  @_ == 1 or croak 'usage: $obj->message()';
 138
 139  my $cmd = shift;
 140
 141  wantarray ? @{${*$cmd}{'net_cmd_resp'}}
 142            : join("", @{${*$cmd}{'net_cmd_resp'}});
 143 }
 144
 145 sub debug_text { $_[2] }
 146
 147 sub debug_print
 148 {
 149  my($cmd,$out,$text) = @_;
 150  print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
 151 }
 152
 153 sub code
 154 {
 155  @_ == 1 or croak 'usage: $obj->code()';
 156
 157  my $cmd = shift;
 158
 159  ${*$cmd}{'net_cmd_code'} = "000"
 160         unless exists ${*$cmd}{'net_cmd_code'};
 161
 162  ${*$cmd}{'net_cmd_code'};
 163 }
 164
 165 sub status
 166 {
 167  @_ == 1 or croak 'usage: $obj->status()';
 168
 169  my $cmd = shift;
 170
 171  substr(${*$cmd}{'net_cmd_code'},0,1);
 172 }
 173
 174 sub set_status
 175 {
 176  @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
 177
 178  my $cmd = shift;
 179  my($code,$resp) = @_;
 180
 181  $resp = [ $resp ]
 182         unless ref($resp);
 183
 184  (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
 185
 186  1;
 187 }
 188
 189 sub command
 190 {
 191  my $cmd = shift;
 192
 193  unless (defined fileno($cmd))
 194   {
 195     $cmd->set_status("599", "Connection closed");
 196     return $cmd;
 197   }
 198
 199
 200  $cmd->dataend()
 201     if(exists ${*$cmd}{'net_cmd_last_ch'});
 202
 203  if (scalar(@_))
 204   {
 205    local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 206
 207    my $str =  join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
 208    $str = $cmd->toascii($str) if $tr;
 209    $str .= "\015\012";
 210
 211    my $len = length $str;
 212    my $swlen;
 213
 214    $cmd->close
 215         unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
 216
 217    $cmd->debug_print(1,$str)
 218         if($cmd->debug);
 219
 220    ${*$cmd}{'net_cmd_resp'} = [];      # the response
 221    ${*$cmd}{'net_cmd_code'} = "000";    # Made this one up :-)
 222   }
 223
 224  $cmd;
 225 }
 226
 227 sub ok
 228 {
 229  @_ == 1 or croak 'usage: $obj->ok()';
 230
 231  my $code = $_[0]->code;
 232  0 < $code && $code < 400;
 233 }
 234
 235 sub unsupported
 236 {
 237  my $cmd = shift;
 238
 239  ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
 240  ${*$cmd}{'net_cmd_code'} = 580;
 241  0;
 242 }
 243
 244 sub getline
 245 {
 246  my $cmd = shift;
 247
 248  ${*$cmd}{'net_cmd_lines'} ||= [];
 249
 250  return shift @{${*$cmd}{'net_cmd_lines'}}
 251     if scalar(@{${*$cmd}{'net_cmd_lines'}});
 252
 253  my $partial = defined(${*$cmd}{'net_cmd_partial'})
 254                 ? ${*$cmd}{'net_cmd_partial'} : "";
 255  my $fd = fileno($cmd);
 256
 257  return undef
 258         unless defined $fd;
 259
 260  my $rin = "";
 261  vec($rin,$fd,1) = 1;
 262
 263  my $buf;
 264
 265  until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
 266   {
 267    my $timeout = $cmd->timeout || undef;
 268    my $rout;
 269    if (select($rout=$rin, undef, undef, $timeout))
 270     {
 271      unless (sysread($cmd, $buf="", 1024))
 272       {
 273        carp(ref($cmd) . ": Unexpected EOF on command channel")
 274                 if $cmd->debug;
 275        $cmd->close;
 276        return undef;
 277       }
 278
 279      substr($buf,0,0) = $partial;       ## prepend from last sysread
 280
 281      my @buf = split(/\015?\012/, $buf, -1);    ## break into lines
 282
 283      $partial = pop @buf;
 284
 285      push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
 286
 287     }
 288    else
 289     {
 290      carp("$cmd: Timeout") if($cmd->debug);
 291      return undef;
 292     }
 293   }
 294
 295  ${*$cmd}{'net_cmd_partial'} = $partial;
 296
 297  if ($tr)
 298   {
 299    foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
 300     {
 301      $ln = $cmd->toebcdic($ln);
 302     }
 303   }
 304
 305  shift @{${*$cmd}{'net_cmd_lines'}};
 306 }
 307
 308 sub ungetline
 309 {
 310  my($cmd,$str) = @_;
 311
 312  ${*$cmd}{'net_cmd_lines'} ||= [];
 313  unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
 314 }
 315
 316 sub parse_response
 317 {
 318  return ()
 319     unless $_[1] =~ s/^(\d\d\d)(.?)//o;
 320  ($1, $2 eq "-");
 321 }
 322
 323 sub response
 324 {
 325  my $cmd = shift;
 326  my($code,$more) = (undef) x 2;
 327
 328  ${*$cmd}{'net_cmd_resp'} ||= [];
 329
 330  while(1)
 331   {
 332    my $str = $cmd->getline();
 333
 334    return CMD_ERROR
 335         unless defined($str);
 336
 337    $cmd->debug_print(0,$str)
 338      if ($cmd->debug);
 339
 340    ($code,$more) = $cmd->parse_response($str);
 341    unless(defined $code)
 342     {
 343      $cmd->ungetline($str);
 344      last;
 345     }
 346
 347    ${*$cmd}{'net_cmd_code'} = $code;
 348
 349    push(@{${*$cmd}{'net_cmd_resp'}},$str);
 350
 351    last unless($more);
 352   }
 353
 354  substr($code,0,1);
 355 }
 356
 357 sub read_until_dot
 358 {
 359  my $cmd = shift;
 360  my $fh  = shift;
 361  my $arr = [];
 362
 363  while(1)
 364   {
 365    my $str = $cmd->getline() or return undef;
 366
 367    $cmd->debug_print(0,$str)
 368      if ($cmd->debug & 4);
 369
 370    last if($str =~ /^\.\r?\n/o);
 371
 372    $str =~ s/^\.\././o;
 373
 374    if (defined $fh)
 375     {
 376      print $fh $str;
 377     }
 378    else
 379     {
 380      push(@$arr,$str);
 381     }
 382   }
 383
 384  $arr;
 385 }
 386
 387 sub datasend
 388 {
 389  my $cmd = shift;
 390  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
 391  my $line = join("" ,@$arr);
 392
 393  return 0 unless defined(fileno($cmd));
 394
 395  my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
 396  $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
 397
 398  return 1 unless length $line;
 399
 400  if($cmd->debug) {
 401    foreach my $b (split(/\n/,$line)) {
 402      $cmd->debug_print(1, "$b\n");
 403    }
 404   }
 405
 406  $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
 407
 408   my $first_ch = '';
 409
 410   if ($last_ch eq "\015") {
 411     $first_ch = "\012" if $line =~ s/^\012//;
 412   }
 413   elsif ($last_ch eq "\012") {
 414     $first_ch = "." if $line =~ /^\./;
 415   }
 416
 417  $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
 418
 419  substr($line,0,0) = $first_ch;
 420
 421  ${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
 422
 423  my $len = length($line);
 424  my $offset = 0;
 425  my $win = "";
 426  vec($win,fileno($cmd),1) = 1;
 427  my $timeout = $cmd->timeout || undef;
 428
 429  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 430
 431  while($len)
 432   {
 433    my $wout;
 434    my $s = select(undef,$wout=$win, undef, $timeout);
 435    if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
 436     {
 437      my $w = syswrite($cmd, $line, $len, $offset);
 438      unless (defined($w))
 439       {
 440        carp("$cmd: $!") if $cmd->debug;
 441        return undef;
 442       }
 443      $len -= $w;
 444      $offset += $w;
 445     }
 446    else
 447     {
 448      carp("$cmd: Timeout") if($cmd->debug);
 449      return undef;
 450     }
 451   }
 452
 453  1;
 454 }
 455
 456 sub rawdatasend
 457 {
 458  my $cmd = shift;
 459  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
 460  my $line = join("" ,@$arr);
 461
 462  return 0 unless defined(fileno($cmd));
 463
 464  return 1
 465     unless length($line);
 466
 467  if($cmd->debug)
 468   {
 469    my $b = "$cmd>>> ";
 470    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
 471   }
 472
 473  my $len = length($line);
 474  my $offset = 0;
 475  my $win = "";
 476  vec($win,fileno($cmd),1) = 1;
 477  my $timeout = $cmd->timeout || undef;
 478
 479  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 480  while($len)
 481   {
 482    my $wout;
 483    if (select(undef,$wout=$win, undef, $timeout) > 0)
 484     {
 485      my $w = syswrite($cmd, $line, $len, $offset);
 486      unless (defined($w))
 487       {
 488        carp("$cmd: $!") if $cmd->debug;
 489        return undef;
 490       }
 491      $len -= $w;
 492      $offset += $w;
 493     }
 494    else
 495     {
 496      carp("$cmd: Timeout") if($cmd->debug);
 497      return undef;
 498     }
 499   }
 500
 501  1;
 502 }
 503
 504 sub dataend
 505 {
 506  my $cmd = shift;
 507
 508  return 0 unless defined(fileno($cmd));
 509
 510  my $ch = ${*$cmd}{'net_cmd_last_ch'};
 511  my $tosend;
 512
 513  if (!defined $ch) {
 514    return 1;
 515  }
 516  elsif ($ch ne "\012") {
 517    $tosend = "\015\012";
 518  }
 519
 520  $tosend .= ".\015\012";
 521
 522  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 523
 524  $cmd->debug_print(1, ".\n")
 525     if($cmd->debug);
 526
 527  syswrite($cmd,$tosend, length $tosend);
 528
 529  delete ${*$cmd}{'net_cmd_last_ch'};
 530
 531  $cmd->response() == CMD_OK;
 532 }
 533
 534 # read and write to tied filehandle
 535 sub tied_fh {
 536   my $cmd = shift;
 537   ${*$cmd}{'net_cmd_readbuf'} = '';
 538   my $fh = gensym();
 539   tie *$fh,ref($cmd),$cmd;
 540   return $fh;
 541 }
 542
 543 # tie to myself
 544 sub TIEHANDLE {
 545   my $class = shift;
 546   my $cmd = shift;
 547   return $cmd;
 548 }
 549
 550 # Tied filehandle read.  Reads requested data length, returning
 551 # end-of-file when the dot is encountered.
 552 sub READ {
 553   my $cmd = shift;
 554   my ($len,$offset) = @_[1,2];
 555   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 556   my $done = 0;
 557   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
 558      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
 559      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
 560   }
 561
 562   $_[0] = '';
 563   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
 564   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
 565   delete ${*$cmd}{'net_cmd_readbuf'} if $done;
 566
 567   return length $_[0];
 568 }
 569
 570 sub READLINE {
 571   my $cmd = shift;
 572   # in this context, we use the presence of readbuf to
 573   # indicate that we have not yet reached the eof
 574   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 575   my $line = $cmd->getline;
 576   return if $line =~ /^\.\r?\n/;
 577   $line;
 578 }
 579
 580 sub PRINT {
 581   my $cmd = shift;
 582   my ($buf,$len,$offset) = @_;
 583   $len    ||= length ($buf);
 584   $offset += 0;
 585   return unless $cmd->datasend(substr($buf,$offset,$len));
 586   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()
 587   return $len;
 588 }
 589
 590 sub CLOSE {
 591   my $cmd = shift;
 592   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
 593   delete ${*$cmd}{'net_cmd_readbuf'};
 594   delete ${*$cmd}{'net_cmd_sending'};
 595   $r;
 596 }
 597
 598 1;
 599
 600 __END__
 601
 602
 603 =head1 NAME
 604
 605 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
 606
 607 =head1 SYNOPSIS
 608
 609     use Net::Cmd;
 610
 611     @ISA = qw(Net::Cmd);
 612
 613 =head1 DESCRIPTION
 614
 615 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
 616 of C<IO::Handle>. These methods implement the functionality required for a
 617 command based protocol, for example FTP and SMTP.
 618
 619 =head1 USER METHODS
 620
 621 These methods provide a user interface to the C<Net::Cmd> object.
 622
 623 =over 4
 624
 625 =item debug ( VALUE )
 626
 627 Set the level of debug information for this object. If C<VALUE> is not given
 628 then the current state is returned. Otherwise the state is changed to
 629 C<VALUE> and the previous state returned.
 630
 631 Different packages
 632 may implement different levels of debug but a non-zero value results in
 633 copies of all commands and responses also being sent to STDERR.
 634
 635 If C<VALUE> is C<undef> then the debug level will be set to the default
 636 debug level for the class.
 637
 638 This method can also be called as a I<static> method to set/get the default
 639 debug level for a given class.
 640
 641 =item message ()
 642
 643 Returns the text message returned from the last command
 644
 645 =item code ()
 646
 647 Returns the 3-digit code from the last command. If a command is pending
 648 then the value 0 is returned
 649
 650 =item ok ()
 651
 652 Returns non-zero if the last code value was greater than zero and
 653 less than 400. This holds true for most command servers. Servers
 654 where this does not hold may override this method.
 655
 656 =item status ()
 657
 658 Returns the most significant digit of the current status code. If a command
 659 is pending then C<CMD_PENDING> is returned.
 660
 661 =item datasend ( DATA )
 662
 663 Send data to the remote server, converting LF to CRLF. Any line starting
 664 with a '.' will be prefixed with another '.'.
 665 C<DATA> may be an array or a reference to an array.
 666
 667 =item dataend ()
 668
 669 End the sending of data to the remote server. This is done by ensuring that
 670 the data already sent ends with CRLF then sending '.CRLF' to end the
 671 transmission. Once this data has been sent C<dataend> calls C<response> and
 672 returns true if C<response> returns CMD_OK.
 673
 674 =back
 675
 676 =head1 CLASS METHODS
 677
 678 These methods are not intended to be called by the user, but used or
 679 over-ridden by a sub-class of C<Net::Cmd>
 680
 681 =over 4
 682
 683 =item debug_print ( DIR, TEXT )
 684
 685 Print debugging information. C<DIR> denotes the direction I<true> being
 686 data being sent to the server. Calls C<debug_text> before printing to
 687 STDERR.
 688
 689 =item debug_text ( TEXT )
 690
 691 This method is called to print debugging information. TEXT is
 692 the text being sent. The method should return the text to be printed
 693
 694 This is primarily meant for the use of modules such as FTP where passwords
 695 are sent, but we do not want to display them in the debugging information.
 696
 697 =item command ( CMD [, ARGS, ... ])
 698
 699 Send a command to the command server. All arguments a first joined with
 700 a space character and CRLF is appended, this string is then sent to the
 701 command server.
 702
 703 Returns undef upon failure
 704
 705 =item unsupported ()
 706
 707 Sets the status code to 580 and the response text to 'Unsupported command'.
 708 Returns zero.
 709
 710 =item response ()
 711
 712 Obtain a response from the server. Upon success the most significant digit
 713 of the status code is returned. Upon failure, timeout etc., I<undef> is
 714 returned.
 715
 716 =item parse_response ( TEXT )
 717
 718 This method is called by C<response> as a method with one argument. It should
 719 return an array of 2 values, the 3-digit status code and a flag which is true
 720 when this is part of a multi-line response and this line is not the list.
 721
 722 =item getline ()
 723
 724 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
 725 upon failure.
 726
 727 B<NOTE>: If you do use this method for any reason, please remember to add
 728 some C<debug_print> calls into your method.
 729
 730 =item ungetline ( TEXT )
 731
 732 Unget a line of text from the server.
 733
 734 =item rawdatasend ( DATA )
 735
 736 Send data to the remote server without performing any conversions. C<DATA>
 737 is a scalar.
 738
 739 =item read_until_dot ()
 740
 741 Read data from the remote server until a line consisting of a single '.'.
 742 Any lines starting with '..' will have one of the '.'s removed.
 743
 744 Returns a reference to a list containing the lines, or I<undef> upon failure.
 745
 746 =item tied_fh ()
 747
 748 Returns a filehandle tied to the Net::Cmd object.  After issuing a
 749 command, you may read from this filehandle using read() or <>.  The
 750 filehandle will return EOF when the final dot is encountered.
 751 Similarly, you may write to the filehandle in order to send data to
 752 the server after issuing a command that expects data to be written.
 753
 754 See the Net::POP3 and Net::SMTP modules for examples of this.
 755
 756 =back
 757
 758 =head1 EXPORTS
 759
 760 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
 761 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
 762 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
 763
 764 =head1 AUTHOR
 765
 766 Graham Barr <gbarr@pobox.com>
 767
 768 =head1 COPYRIGHT
 769
 770 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
 771 This program is free software; you can redistribute it and/or modify
 772 it under the same terms as Perl itself.
 773
 774 =for html <hr>
 775
 776 I<$Id: //depot/libnet/Net/Cmd.pm#34 $>
 777
 778 =cut