lib/Net/Cmd.pm

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