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