lib/Net/Cmd.pm

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