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";
  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    if (select(undef,$wout=$win, undef, $timeout) > 0 or -f $cmd) # -f for testing on win32
 435     {
 436      my $w = syswrite($cmd, $line, $len, $offset);
 437      unless (defined($w))
 438       {
 439        carp("$cmd: $!") if $cmd->debug;
 440        return undef;
 441       }
 442      $len -= $w;
 443      $offset += $w;
 444     }
 445    else
 446     {
 447      carp("$cmd: Timeout") if($cmd->debug);
 448      return undef;
 449     }
 450   }
 451
 452  1;
 453 }
 454
 455 sub rawdatasend
 456 {
 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   {
 468    my $b = "$cmd>>> ";
 469    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
 470   }
 471
 472  my $len = length($line);
 473  my $offset = 0;
 474  my $win = "";
 475  vec($win,fileno($cmd),1) = 1;
 476  my $timeout = $cmd->timeout || undef;
 477
 478  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 479  while($len)
 480   {
 481    my $wout;
 482    if (select(undef,$wout=$win, undef, $timeout) > 0)
 483     {
 484      my $w = syswrite($cmd, $line, $len, $offset);
 485      unless (defined($w))
 486       {
 487        carp("$cmd: $!") if $cmd->debug;
 488        return undef;
 489       }
 490      $len -= $w;
 491      $offset += $w;
 492     }
 493    else
 494     {
 495      carp("$cmd: Timeout") if($cmd->debug);
 496      return undef;
 497     }
 498   }
 499
 500  1;
 501 }
 502
 503 sub dataend
 504 {
 505  my $cmd = shift;
 506
 507  return 0 unless defined(fileno($cmd));
 508
 509  my $ch = ${*$cmd}{'net_cmd_last_ch'};
 510  my $tosend;
 511
 512  if (!defined $ch) {
 513    return 1;
 514  }
 515  elsif ($ch ne "\012") {
 516    $tosend = "\015\012";
 517  }
 518
 519  $tosend .= ".\015\012";
 520
 521  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 522
 523  $cmd->debug_print(1, ".\n")
 524     if($cmd->debug);
 525
 526  syswrite($cmd,$tosend, length $tosend);
 527
 528  delete ${*$cmd}{'net_cmd_last_ch'};
 529
 530  $cmd->response() == CMD_OK;
 531 }
 532
 533 # read and write to tied filehandle
 534 sub tied_fh {
 535   my $cmd = shift;
 536   ${*$cmd}{'net_cmd_readbuf'} = '';
 537   my $fh = gensym();
 538   tie *$fh,ref($cmd),$cmd;
 539   return $fh;
 540 }
 541
 542 # tie to myself
 543 sub TIEHANDLE {
 544   my $class = shift;
 545   my $cmd = shift;
 546   return $cmd;
 547 }
 548
 549 # Tied filehandle read.  Reads requested data length, returning
 550 # end-of-file when the dot is encountered.
 551 sub READ {
 552   my $cmd = shift;
 553   my ($len,$offset) = @_[1,2];
 554   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 555   my $done = 0;
 556   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
 557      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
 558      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
 559   }
 560
 561   $_[0] = '';
 562   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
 563   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
 564   delete ${*$cmd}{'net_cmd_readbuf'} if $done;
 565
 566   return length $_[0];
 567 }
 568
 569 sub READLINE {
 570   my $cmd = shift;
 571   # in this context, we use the presence of readbuf to
 572   # indicate that we have not yet reached the eof
 573   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 574   my $line = $cmd->getline;
 575   return if $line =~ /^\.\r?\n/;
 576   $line;
 577 }
 578
 579 sub PRINT {
 580   my $cmd = shift;
 581   my ($buf,$len,$offset) = @_;
 582   $len    ||= length ($buf);
 583   $offset += 0;
 584   return unless $cmd->datasend(substr($buf,$offset,$len));
 585   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()
 586   return $len;
 587 }
 588
 589 sub CLOSE {
 590   my $cmd = shift;
 591   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
 592   delete ${*$cmd}{'net_cmd_readbuf'};
 593   delete ${*$cmd}{'net_cmd_sending'};
 594   $r;
 595 }
 596
 597 1;
 598
 599 __END__
 600
 601
 602 =head1 NAME
 603
 604 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
 605
 606 =head1 SYNOPSIS
 607
 608     use Net::Cmd;
 609
 610     @ISA = qw(Net::Cmd);
 611
 612 =head1 DESCRIPTION
 613
 614 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
 615 of C<IO::Handle>. These methods implement the functionality required for a
 616 command based protocol, for example FTP and SMTP.
 617
 618 =head1 USER METHODS
 619
 620 These methods provide a user interface to the C<Net::Cmd> object.
 621
 622 =over 4
 623
 624 =item debug ( VALUE )
 625
 626 Set the level of debug information for this object. If C<VALUE> is not given
 627 then the current state is returned. Otherwise the state is changed to
 628 C<VALUE> and the previous state returned.
 629
 630 Different packages
 631 may implement different levels of debug but a non-zero value results in
 632 copies of all commands and responses also being sent to STDERR.
 633
 634 If C<VALUE> is C<undef> then the debug level will be set to the default
 635 debug level for the class.
 636
 637 This method can also be called as a I<static> method to set/get the default
 638 debug level for a given class.
 639
 640 =item message ()
 641
 642 Returns the text message returned from the last command
 643
 644 =item code ()
 645
 646 Returns the 3-digit code from the last command. If a command is pending
 647 then the value 0 is returned
 648
 649 =item ok ()
 650
 651 Returns non-zero if the last code value was greater than zero and
 652 less than 400. This holds true for most command servers. Servers
 653 where this does not hold may override this method.
 654
 655 =item status ()
 656
 657 Returns the most significant digit of the current status code. If a command
 658 is pending then C<CMD_PENDING> is returned.
 659
 660 =item datasend ( DATA )
 661
 662 Send data to the remote server, converting LF to CRLF. Any line starting
 663 with a '.' will be prefixed with another '.'.
 664 C<DATA> may be an array or a reference to an array.
 665
 666 =item dataend ()
 667
 668 End the sending of data to the remote server. This is done by ensuring that
 669 the data already sent ends with CRLF then sending '.CRLF' to end the
 670 transmission. Once this data has been sent C<dataend> calls C<response> and
 671 returns true if C<response> returns CMD_OK.
 672
 673 =back
 674
 675 =head1 CLASS METHODS
 676
 677 These methods are not intended to be called by the user, but used or
 678 over-ridden by a sub-class of C<Net::Cmd>
 679
 680 =over 4
 681
 682 =item debug_print ( DIR, TEXT )
 683
 684 Print debugging information. C<DIR> denotes the direction I<true> being
 685 data being sent to the server. Calls C<debug_text> before printing to
 686 STDERR.
 687
 688 =item debug_text ( TEXT )
 689
 690 This method is called to print debugging information. TEXT is
 691 the text being sent. The method should return the text to be printed
 692
 693 This is primarily meant for the use of modules such as FTP where passwords
 694 are sent, but we do not want to display them in the debugging information.
 695
 696 =item command ( CMD [, ARGS, ... ])
 697
 698 Send a command to the command server. All arguments a first joined with
 699 a space character and CRLF is appended, this string is then sent to the
 700 command server.
 701
 702 Returns undef upon failure
 703
 704 =item unsupported ()
 705
 706 Sets the status code to 580 and the response text to 'Unsupported command'.
 707 Returns zero.
 708
 709 =item response ()
 710
 711 Obtain a response from the server. Upon success the most significant digit
 712 of the status code is returned. Upon failure, timeout etc., I<undef> is
 713 returned.
 714
 715 =item parse_response ( TEXT )
 716
 717 This method is called by C<response> as a method with one argument. It should
 718 return an array of 2 values, the 3-digit status code and a flag which is true
 719 when this is part of a multi-line response and this line is not the list.
 720
 721 =item getline ()
 722
 723 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
 724 upon failure.
 725
 726 B<NOTE>: If you do use this method for any reason, please remember to add
 727 some C<debug_print> calls into your method.
 728
 729 =item ungetline ( TEXT )
 730
 731 Unget a line of text from the server.
 732
 733 =item rawdatasend ( DATA )
 734
 735 Send data to the remote server without performing any conversions. C<DATA>
 736 is a scalar.
 737
 738 =item read_until_dot ()
 739
 740 Read data from the remote server until a line consisting of a single '.'.
 741 Any lines starting with '..' will have one of the '.'s removed.
 742
 743 Returns a reference to a list containing the lines, or I<undef> upon failure.
 744
 745 =item tied_fh ()
 746
 747 Returns a filehandle tied to the Net::Cmd object.  After issuing a
 748 command, you may read from this filehandle using read() or <>.  The
 749 filehandle will return EOF when the final dot is encountered.
 750 Similarly, you may write to the filehandle in order to send data to
 751 the server after issuing a commmand that expects data to be written.
 752
 753 See the Net::POP3 and Net::SMTP modules for examples of this.
 754
 755 =back
 756
 757 =head1 EXPORTS
 758
 759 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
 760 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
 761 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
 762
 763 =head1 AUTHOR
 764
 765 Graham Barr <gbarr@pobox.com>
 766
 767 =head1 COPYRIGHT
 768
 769 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
 770 This program is free software; you can redistribute it and/or modify
 771 it under the same terms as Perl itself.
 772
 773 =for html <hr>
 774
 775 I<$Id: //depot/libnet/Net/Cmd.pm#34 $>
 776
 777 =cut