lib/Net/Cmd.pm

   1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $
   2 #
   3 # Copyright (c) 1995-2006 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.27_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
 270    my $select_ret = select($rout=$rin, undef, undef, $timeout);
 271    if ($select_ret > 0)
 272     {
 273      unless (sysread($cmd, $buf="", 1024))
 274       {
 275        carp(ref($cmd) . ": Unexpected EOF on command channel")
 276                 if $cmd->debug;
 277        $cmd->close;
 278        return undef;
 279       }
 280
 281      substr($buf,0,0) = $partial;       ## prepend from last sysread
 282
 283      my @buf = split(/\015?\012/, $buf, -1);    ## break into lines
 284
 285      $partial = pop @buf;
 286
 287      push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
 288
 289     }
 290    else
 291     {
 292      my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
 293      carp("$cmd: $msg") if($cmd->debug);
 294      return undef;
 295     }
 296   }
 297
 298  ${*$cmd}{'net_cmd_partial'} = $partial;
 299
 300  if ($tr)
 301   {
 302    foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
 303     {
 304      $ln = $cmd->toebcdic($ln);
 305     }
 306   }
 307
 308  shift @{${*$cmd}{'net_cmd_lines'}};
 309 }
 310
 311 sub ungetline
 312 {
 313  my($cmd,$str) = @_;
 314
 315  ${*$cmd}{'net_cmd_lines'} ||= [];
 316  unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
 317 }
 318
 319 sub parse_response
 320 {
 321  return ()
 322     unless $_[1] =~ s/^(\d\d\d)(.?)//o;
 323  ($1, $2 eq "-");
 324 }
 325
 326 sub response
 327 {
 328  my $cmd = shift;
 329  my($code,$more) = (undef) x 2;
 330
 331  ${*$cmd}{'net_cmd_resp'} ||= [];
 332
 333  while(1)
 334   {
 335    my $str = $cmd->getline();
 336
 337    return CMD_ERROR
 338         unless defined($str);
 339
 340    $cmd->debug_print(0,$str)
 341      if ($cmd->debug);
 342
 343    ($code,$more) = $cmd->parse_response($str);
 344    unless(defined $code)
 345     {
 346      $cmd->ungetline($str);
 347      last;
 348     }
 349
 350    ${*$cmd}{'net_cmd_code'} = $code;
 351
 352    push(@{${*$cmd}{'net_cmd_resp'}},$str);
 353
 354    last unless($more);
 355   }
 356
 357  substr($code,0,1);
 358 }
 359
 360 sub read_until_dot
 361 {
 362  my $cmd = shift;
 363  my $fh  = shift;
 364  my $arr = [];
 365
 366  while(1)
 367   {
 368    my $str = $cmd->getline() or return undef;
 369
 370    $cmd->debug_print(0,$str)
 371      if ($cmd->debug & 4);
 372
 373    last if($str =~ /^\.\r?\n/o);
 374
 375    $str =~ s/^\.\././o;
 376
 377    if (defined $fh)
 378     {
 379      print $fh $str;
 380     }
 381    else
 382     {
 383      push(@$arr,$str);
 384     }
 385   }
 386
 387  $arr;
 388 }
 389
 390 sub datasend
 391 {
 392  my $cmd = shift;
 393  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
 394  my $line = join("" ,@$arr);
 395
 396  return 0 unless defined(fileno($cmd));
 397
 398  my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
 399  $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
 400
 401  return 1 unless length $line;
 402
 403  if($cmd->debug) {
 404    foreach my $b (split(/\n/,$line)) {
 405      $cmd->debug_print(1, "$b\n");
 406    }
 407   }
 408
 409  $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
 410
 411   my $first_ch = '';
 412
 413   if ($last_ch eq "\015") {
 414     $first_ch = "\012" if $line =~ s/^\012//;
 415   }
 416   elsif ($last_ch eq "\012") {
 417     $first_ch = "." if $line =~ /^\./;
 418   }
 419
 420  $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
 421
 422  substr($line,0,0) = $first_ch;
 423
 424  ${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
 425
 426  my $len = length($line);
 427  my $offset = 0;
 428  my $win = "";
 429  vec($win,fileno($cmd),1) = 1;
 430  my $timeout = $cmd->timeout || undef;
 431
 432  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 433
 434  while($len)
 435   {
 436    my $wout;
 437    my $s = select(undef,$wout=$win, undef, $timeout);
 438    if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
 439     {
 440      my $w = syswrite($cmd, $line, $len, $offset);
 441      unless (defined($w))
 442       {
 443        carp("$cmd: $!") if $cmd->debug;
 444        return undef;
 445       }
 446      $len -= $w;
 447      $offset += $w;
 448     }
 449    else
 450     {
 451      carp("$cmd: Timeout") if($cmd->debug);
 452      return undef;
 453     }
 454   }
 455
 456  1;
 457 }
 458
 459 sub rawdatasend
 460 {
 461  my $cmd = shift;
 462  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
 463  my $line = join("" ,@$arr);
 464
 465  return 0 unless defined(fileno($cmd));
 466
 467  return 1
 468     unless length($line);
 469
 470  if($cmd->debug)
 471   {
 472    my $b = "$cmd>>> ";
 473    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
 474   }
 475
 476  my $len = length($line);
 477  my $offset = 0;
 478  my $win = "";
 479  vec($win,fileno($cmd),1) = 1;
 480  my $timeout = $cmd->timeout || undef;
 481
 482  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 483  while($len)
 484   {
 485    my $wout;
 486    if (select(undef,$wout=$win, undef, $timeout) > 0)
 487     {
 488      my $w = syswrite($cmd, $line, $len, $offset);
 489      unless (defined($w))
 490       {
 491        carp("$cmd: $!") if $cmd->debug;
 492        return undef;
 493       }
 494      $len -= $w;
 495      $offset += $w;
 496     }
 497    else
 498     {
 499      carp("$cmd: Timeout") if($cmd->debug);
 500      return undef;
 501     }
 502   }
 503
 504  1;
 505 }
 506
 507 sub dataend
 508 {
 509  my $cmd = shift;
 510
 511  return 0 unless defined(fileno($cmd));
 512
 513  my $ch = ${*$cmd}{'net_cmd_last_ch'};
 514  my $tosend;
 515
 516  if (!defined $ch) {
 517    return 1;
 518  }
 519  elsif ($ch ne "\012") {
 520    $tosend = "\015\012";
 521  }
 522
 523  $tosend .= ".\015\012";
 524
 525  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 526
 527  $cmd->debug_print(1, ".\n")
 528     if($cmd->debug);
 529
 530  syswrite($cmd,$tosend, length $tosend);
 531
 532  delete ${*$cmd}{'net_cmd_last_ch'};
 533
 534  $cmd->response() == CMD_OK;
 535 }
 536
 537 # read and write to tied filehandle
 538 sub tied_fh {
 539   my $cmd = shift;
 540   ${*$cmd}{'net_cmd_readbuf'} = '';
 541   my $fh = gensym();
 542   tie *$fh,ref($cmd),$cmd;
 543   return $fh;
 544 }
 545
 546 # tie to myself
 547 sub TIEHANDLE {
 548   my $class = shift;
 549   my $cmd = shift;
 550   return $cmd;
 551 }
 552
 553 # Tied filehandle read.  Reads requested data length, returning
 554 # end-of-file when the dot is encountered.
 555 sub READ {
 556   my $cmd = shift;
 557   my ($len,$offset) = @_[1,2];
 558   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 559   my $done = 0;
 560   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
 561      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
 562      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
 563   }
 564
 565   $_[0] = '';
 566   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
 567   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
 568   delete ${*$cmd}{'net_cmd_readbuf'} if $done;
 569
 570   return length $_[0];
 571 }
 572
 573 sub READLINE {
 574   my $cmd = shift;
 575   # in this context, we use the presence of readbuf to
 576   # indicate that we have not yet reached the eof
 577   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 578   my $line = $cmd->getline;
 579   return if $line =~ /^\.\r?\n/;
 580   $line;
 581 }
 582
 583 sub PRINT {
 584   my $cmd = shift;
 585   my ($buf,$len,$offset) = @_;
 586   $len    ||= length ($buf);
 587   $offset += 0;
 588   return unless $cmd->datasend(substr($buf,$offset,$len));
 589   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()
 590   return $len;
 591 }
 592
 593 sub CLOSE {
 594   my $cmd = shift;
 595   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
 596   delete ${*$cmd}{'net_cmd_readbuf'};
 597   delete ${*$cmd}{'net_cmd_sending'};
 598   $r;
 599 }
 600
 601 1;
 602
 603 __END__
 604
 605
 606 =head1 NAME
 607
 608 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
 609
 610 =head1 SYNOPSIS
 611
 612     use Net::Cmd;
 613
 614     @ISA = qw(Net::Cmd);
 615
 616 =head1 DESCRIPTION
 617
 618 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
 619 of C<IO::Handle>. These methods implement the functionality required for a
 620 command based protocol, for example FTP and SMTP.
 621
 622 =head1 USER METHODS
 623
 624 These methods provide a user interface to the C<Net::Cmd> object.
 625
 626 =over 4
 627
 628 =item debug ( VALUE )
 629
 630 Set the level of debug information for this object. If C<VALUE> is not given
 631 then the current state is returned. Otherwise the state is changed to
 632 C<VALUE> and the previous state returned.
 633
 634 Different packages
 635 may implement different levels of debug but a non-zero value results in
 636 copies of all commands and responses also being sent to STDERR.
 637
 638 If C<VALUE> is C<undef> then the debug level will be set to the default
 639 debug level for the class.
 640
 641 This method can also be called as a I<static> method to set/get the default
 642 debug level for a given class.
 643
 644 =item message ()
 645
 646 Returns the text message returned from the last command
 647
 648 =item code ()
 649
 650 Returns the 3-digit code from the last command. If a command is pending
 651 then the value 0 is returned
 652
 653 =item ok ()
 654
 655 Returns non-zero if the last code value was greater than zero and
 656 less than 400. This holds true for most command servers. Servers
 657 where this does not hold may override this method.
 658
 659 =item status ()
 660
 661 Returns the most significant digit of the current status code. If a command
 662 is pending then C<CMD_PENDING> is returned.
 663
 664 =item datasend ( DATA )
 665
 666 Send data to the remote server, converting LF to CRLF. Any line starting
 667 with a '.' will be prefixed with another '.'.
 668 C<DATA> may be an array or a reference to an array.
 669
 670 =item dataend ()
 671
 672 End the sending of data to the remote server. This is done by ensuring that
 673 the data already sent ends with CRLF then sending '.CRLF' to end the
 674 transmission. Once this data has been sent C<dataend> calls C<response> and
 675 returns true if C<response> returns CMD_OK.
 676
 677 =back
 678
 679 =head1 CLASS METHODS
 680
 681 These methods are not intended to be called by the user, but used or
 682 over-ridden by a sub-class of C<Net::Cmd>
 683
 684 =over 4
 685
 686 =item debug_print ( DIR, TEXT )
 687
 688 Print debugging information. C<DIR> denotes the direction I<true> being
 689 data being sent to the server. Calls C<debug_text> before printing to
 690 STDERR.
 691
 692 =item debug_text ( TEXT )
 693
 694 This method is called to print debugging information. TEXT is
 695 the text being sent. The method should return the text to be printed
 696
 697 This is primarily meant for the use of modules such as FTP where passwords
 698 are sent, but we do not want to display them in the debugging information.
 699
 700 =item command ( CMD [, ARGS, ... ])
 701
 702 Send a command to the command server. All arguments a first joined with
 703 a space character and CRLF is appended, this string is then sent to the
 704 command server.
 705
 706 Returns undef upon failure
 707
 708 =item unsupported ()
 709
 710 Sets the status code to 580 and the response text to 'Unsupported command'.
 711 Returns zero.
 712
 713 =item response ()
 714
 715 Obtain a response from the server. Upon success the most significant digit
 716 of the status code is returned. Upon failure, timeout etc., I<undef> is
 717 returned.
 718
 719 =item parse_response ( TEXT )
 720
 721 This method is called by C<response> as a method with one argument. It should
 722 return an array of 2 values, the 3-digit status code and a flag which is true
 723 when this is part of a multi-line response and this line is not the list.
 724
 725 =item getline ()
 726
 727 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
 728 upon failure.
 729
 730 B<NOTE>: If you do use this method for any reason, please remember to add
 731 some C<debug_print> calls into your method.
 732
 733 =item ungetline ( TEXT )
 734
 735 Unget a line of text from the server.
 736
 737 =item rawdatasend ( DATA )
 738
 739 Send data to the remote server without performing any conversions. C<DATA>
 740 is a scalar.
 741
 742 =item read_until_dot ()
 743
 744 Read data from the remote server until a line consisting of a single '.'.
 745 Any lines starting with '..' will have one of the '.'s removed.
 746
 747 Returns a reference to a list containing the lines, or I<undef> upon failure.
 748
 749 =item tied_fh ()
 750
 751 Returns a filehandle tied to the Net::Cmd object.  After issuing a
 752 command, you may read from this filehandle using read() or <>.  The
 753 filehandle will return EOF when the final dot is encountered.
 754 Similarly, you may write to the filehandle in order to send data to
 755 the server after issuing a command that expects data to be written.
 756
 757 See the Net::POP3 and Net::SMTP modules for examples of this.
 758
 759 =back
 760
 761 =head1 EXPORTS
 762
 763 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
 764 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
 765 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
 766
 767 =head1 AUTHOR
 768
 769 Graham Barr <gbarr@pobox.com>
 770
 771 =head1 COPYRIGHT
 772
 773 Copyright (c) 1995-2006 Graham Barr. All rights reserved.
 774 This program is free software; you can redistribute it and/or modify
 775 it under the same terms as Perl itself.
 776
 777 =cut