lib/Net/Cmd.pm

   1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#28 $
   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.21";
  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  print STDERR "\n";
  77  while ($pkg = shift @do)
  78   {
  79    next if defined $done{$pkg};
  80
  81    $done{$pkg} = 1;
  82
  83    my $v = defined ${"${pkg}::VERSION"}
  84                 ? "(" . ${"${pkg}::VERSION"} . ")"
  85                 : "";
  86
  87    my $spc = $spc{$pkg};
  88    print STDERR "$cmd: ${spc}${pkg}${v}\n";
  89
  90    if(@{"${pkg}::ISA"})
  91     {
  92      @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
  93      unshift(@do, @{"${pkg}::ISA"});
  94     }
  95   }
  96
  97  print STDERR "\n";
  98 }
  99
 100 sub debug
 101 {
 102  @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
 103
 104  my($cmd,$level) = @_;
 105  my $pkg = ref($cmd) || $cmd;
 106  my $oldval = 0;
 107
 108  if(ref($cmd))
 109   {
 110    $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
 111   }
 112  else
 113   {
 114    $oldval = $debug{$pkg} || 0;
 115   }
 116
 117  return $oldval
 118     unless @_ == 2;
 119
 120  $level = $debug{$pkg} || 0
 121     unless defined $level;
 122
 123  _print_isa($pkg)
 124     if($level && !exists $debug{$pkg});
 125
 126  if(ref($cmd))
 127   {
 128    ${*$cmd}{'net_cmd_debug'} = $level;
 129   }
 130  else
 131   {
 132    $debug{$pkg} = $level;
 133   }
 134
 135  $oldval;
 136 }
 137
 138 sub message
 139 {
 140  @_ == 1 or croak 'usage: $obj->message()';
 141
 142  my $cmd = shift;
 143
 144  wantarray ? @{${*$cmd}{'net_cmd_resp'}}
 145            : join("", @{${*$cmd}{'net_cmd_resp'}});
 146 }
 147
 148 sub debug_text { $_[2] }
 149
 150 sub debug_print
 151 {
 152  my($cmd,$out,$text) = @_;
 153  print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
 154 }
 155
 156 sub code
 157 {
 158  @_ == 1 or croak 'usage: $obj->code()';
 159
 160  my $cmd = shift;
 161
 162  ${*$cmd}{'net_cmd_code'} = "000"
 163         unless exists ${*$cmd}{'net_cmd_code'};
 164
 165  ${*$cmd}{'net_cmd_code'};
 166 }
 167
 168 sub status
 169 {
 170  @_ == 1 or croak 'usage: $obj->status()';
 171
 172  my $cmd = shift;
 173
 174  substr(${*$cmd}{'net_cmd_code'},0,1);
 175 }
 176
 177 sub set_status
 178 {
 179  @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
 180
 181  my $cmd = shift;
 182  my($code,$resp) = @_;
 183
 184  $resp = [ $resp ]
 185         unless ref($resp);
 186
 187  (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
 188
 189  1;
 190 }
 191
 192 sub command
 193 {
 194  my $cmd = shift;
 195
 196  unless (defined fileno($cmd))
 197   {
 198     $cmd->set_status("599", "Connection closed");
 199     return $cmd;
 200   }
 201
 202
 203  $cmd->dataend()
 204     if(exists ${*$cmd}{'net_cmd_lastch'});
 205
 206  if (scalar(@_))
 207   {
 208    local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
 209
 210    my $str =  join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
 211    $str = $cmd->toascii($str) if $tr;
 212    $str .= "\015\012";
 213
 214    my $len = length $str;
 215    my $swlen;
 216
 217    $cmd->close
 218         unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
 219
 220    $cmd->debug_print(1,$str)
 221         if($cmd->debug);
 222
 223    ${*$cmd}{'net_cmd_resp'} = [];      # the response
 224    ${*$cmd}{'net_cmd_code'} = "000";    # Made this one up :-)
 225   }
 226
 227  $cmd;
 228 }
 229
 230 sub ok
 231 {
 232  @_ == 1 or croak 'usage: $obj->ok()';
 233
 234  my $code = $_[0]->code;
 235  0 < $code && $code < 400;
 236 }
 237
 238 sub unsupported
 239 {
 240  my $cmd = shift;
 241
 242  ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
 243  ${*$cmd}{'net_cmd_code'} = 580;
 244  0;
 245 }
 246
 247 sub getline
 248 {
 249  my $cmd = shift;
 250
 251  ${*$cmd}{'net_cmd_lines'} ||= [];
 252
 253  return shift @{${*$cmd}{'net_cmd_lines'}}
 254     if scalar(@{${*$cmd}{'net_cmd_lines'}});
 255
 256  my $partial = defined(${*$cmd}{'net_cmd_partial'})
 257                 ? ${*$cmd}{'net_cmd_partial'} : "";
 258  my $fd = fileno($cmd);
 259
 260  return undef
 261         unless defined $fd;
 262
 263  my $rin = "";
 264  vec($rin,$fd,1) = 1;
 265
 266  my $buf;
 267
 268  until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
 269   {
 270    my $timeout = $cmd->timeout || undef;
 271    my $rout;
 272    if (select($rout=$rin, undef, undef, $timeout))
 273     {
 274      unless (sysread($cmd, $buf="", 1024))
 275       {
 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     {
 293      carp("$cmd: Timeout") 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  return 1
 399     unless length($line);
 400
 401  if($cmd->debug)
 402   {
 403    my $b = "$cmd>>> ";
 404    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
 405   }
 406
 407  # Translate LF => CRLF, but not if the LF is
 408  # already preceeded by a CR
 409  $line =~ s/\G()\n|([^\r\n])\n/$+\015\012/sgo;
 410
 411  ${*$cmd}{'net_cmd_lastch'} ||= " ";
 412  $line = ${*$cmd}{'net_cmd_lastch'} . $line;
 413
 414  $line =~ s/(\012\.)/$1./sog;
 415
 416  ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
 417
 418  my $len = length($line) - 1;
 419  my $offset = 1;
 420  my $win = "";
 421  vec($win,fileno($cmd),1) = 1;
 422  my $timeout = $cmd->timeout || undef;
 423
 424  while($len)
 425   {
 426    my $wout;
 427    if (select(undef,$wout=$win, undef, $timeout) > 0)
 428     {
 429      my $w = syswrite($cmd, $line, $len, $offset);
 430      unless (defined($w))
 431       {
 432        carp("$cmd: $!") if $cmd->debug;
 433        return undef;
 434       }
 435      $len -= $w;
 436      $offset += $w;
 437     }
 438    else
 439     {
 440      carp("$cmd: Timeout") if($cmd->debug);
 441      return undef;
 442     }
 443   }
 444
 445  1;
 446 }
 447
 448 sub dataend
 449 {
 450  my $cmd = shift;
 451
 452  return 0 unless defined(fileno($cmd));
 453
 454  return 1
 455     unless(exists ${*$cmd}{'net_cmd_lastch'});
 456
 457  if(${*$cmd}{'net_cmd_lastch'} eq "\015")
 458   {
 459    syswrite($cmd,"\012",1);
 460    print STDERR "\n"
 461     if($cmd->debug);
 462   }
 463  elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
 464   {
 465    syswrite($cmd,"\015\012",2);
 466    print STDERR "\n"
 467     if($cmd->debug);
 468   }
 469
 470  print STDERR "$cmd>>> .\n"
 471     if($cmd->debug);
 472
 473  syswrite($cmd,".\015\012",3);
 474
 475  delete ${*$cmd}{'net_cmd_lastch'};
 476
 477  $cmd->response() == CMD_OK;
 478 }
 479
 480 # read and write to tied filehandle
 481 sub tied_fh {
 482   my $cmd = shift;
 483   ${*$cmd}{'net_cmd_readbuf'} = '';
 484   my $fh = gensym();
 485   tie *$fh,ref($cmd),$cmd;
 486   return $fh;
 487 }
 488
 489 # tie to myself
 490 sub TIEHANDLE {
 491   my $class = shift;
 492   my $cmd = shift;
 493   return $cmd;
 494 }
 495
 496 # Tied filehandle read.  Reads requested data length, returning
 497 # end-of-file when the dot is encountered.
 498 sub READ {
 499   my $cmd = shift;
 500   my (undef,$len,$offset) = @_;
 501   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 502   my $done = 0;
 503   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
 504      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
 505      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
 506   }
 507
 508   $_[0] = '';
 509   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
 510   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
 511   delete ${*$cmd}{'net_cmd_readbuf'} if $done;
 512
 513   return length $_[0];
 514 }
 515
 516 sub READLINE {
 517   my $cmd = shift;
 518   # in this context, we use the presence of readbuf to
 519   # indicate that we have not yet reached the eof
 520   return unless exists ${*$cmd}{'net_cmd_readbuf'};
 521   my $line = $cmd->getline;
 522   return if $line =~ /^\.\r?\n/;
 523   $line;
 524 }
 525
 526 sub PRINT {
 527   my $cmd = shift;
 528   my ($buf,$len,$offset) = @_;
 529   $len    ||= length ($buf);
 530   $offset += 0;
 531   return unless $cmd->datasend(substr($buf,$offset,$len));
 532   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()
 533   return $len;
 534 }
 535
 536 sub CLOSE {
 537   my $cmd = shift;
 538   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
 539   delete ${*$cmd}{'net_cmd_readbuf'};
 540   delete ${*$cmd}{'net_cmd_sending'};
 541   $r;
 542 }
 543
 544 1;
 545
 546 __END__
 547
 548
 549 =head1 NAME
 550
 551 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
 552
 553 =head1 SYNOPSIS
 554
 555     use Net::Cmd;
 556
 557     @ISA = qw(Net::Cmd);
 558
 559 =head1 DESCRIPTION
 560
 561 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
 562 of C<IO::Handle>. These methods implement the functionality required for a
 563 command based protocol, for example FTP and SMTP.
 564
 565 =head1 USER METHODS
 566
 567 These methods provide a user interface to the C<Net::Cmd> object.
 568
 569 =over 4
 570
 571 =item debug ( VALUE )
 572
 573 Set the level of debug information for this object. If C<VALUE> is not given
 574 then the current state is returned. Otherwise the state is changed to
 575 C<VALUE> and the previous state returned.
 576
 577 Different packages
 578 may implement different levels of debug but a non-zero value results in
 579 copies of all commands and responses also being sent to STDERR.
 580
 581 If C<VALUE> is C<undef> then the debug level will be set to the default
 582 debug level for the class.
 583
 584 This method can also be called as a I<static> method to set/get the default
 585 debug level for a given class.
 586
 587 =item message ()
 588
 589 Returns the text message returned from the last command
 590
 591 =item code ()
 592
 593 Returns the 3-digit code from the last command. If a command is pending
 594 then the value 0 is returned
 595
 596 =item ok ()
 597
 598 Returns non-zero if the last code value was greater than zero and
 599 less than 400. This holds true for most command servers. Servers
 600 where this does not hold may override this method.
 601
 602 =item status ()
 603
 604 Returns the most significant digit of the current status code. If a command
 605 is pending then C<CMD_PENDING> is returned.
 606
 607 =item datasend ( DATA )
 608
 609 Send data to the remote server, converting LF to CRLF. Any line starting
 610 with a '.' will be prefixed with another '.'.
 611 C<DATA> may be an array or a reference to an array.
 612
 613 =item dataend ()
 614
 615 End the sending of data to the remote server. This is done by ensuring that
 616 the data already sent ends with CRLF then sending '.CRLF' to end the
 617 transmission. Once this data has been sent C<dataend> calls C<response> and
 618 returns true if C<response> returns CMD_OK.
 619
 620 =back
 621
 622 =head1 CLASS METHODS
 623
 624 These methods are not intended to be called by the user, but used or
 625 over-ridden by a sub-class of C<Net::Cmd>
 626
 627 =over 4
 628
 629 =item debug_print ( DIR, TEXT )
 630
 631 Print debugging information. C<DIR> denotes the direction I<true> being
 632 data being sent to the server. Calls C<debug_text> before printing to
 633 STDERR.
 634
 635 =item debug_text ( TEXT )
 636
 637 This method is called to print debugging information. TEXT is
 638 the text being sent. The method should return the text to be printed
 639
 640 This is primarily meant for the use of modules such as FTP where passwords
 641 are sent, but we do not want to display them in the debugging information.
 642
 643 =item command ( CMD [, ARGS, ... ])
 644
 645 Send a command to the command server. All arguments a first joined with
 646 a space character and CRLF is appended, this string is then sent to the
 647 command server.
 648
 649 Returns undef upon failure
 650
 651 =item unsupported ()
 652
 653 Sets the status code to 580 and the response text to 'Unsupported command'.
 654 Returns zero.
 655
 656 =item response ()
 657
 658 Obtain a response from the server. Upon success the most significant digit
 659 of the status code is returned. Upon failure, timeout etc., I<undef> is
 660 returned.
 661
 662 =item parse_response ( TEXT )
 663
 664 This method is called by C<response> as a method with one argument. It should
 665 return an array of 2 values, the 3-digit status code and a flag which is true
 666 when this is part of a multi-line response and this line is not the list.
 667
 668 =item getline ()
 669
 670 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
 671 upon failure.
 672
 673 B<NOTE>: If you do use this method for any reason, please remember to add
 674 some C<debug_print> calls into your method.
 675
 676 =item ungetline ( TEXT )
 677
 678 Unget a line of text from the server.
 679
 680 =item read_until_dot ()
 681
 682 Read data from the remote server until a line consisting of a single '.'.
 683 Any lines starting with '..' will have one of the '.'s removed.
 684
 685 Returns a reference to a list containing the lines, or I<undef> upon failure.
 686
 687 =item tied_fh ()
 688
 689 Returns a filehandle tied to the Net::Cmd object.  After issuing a
 690 command, you may read from this filehandle using read() or <>.  The
 691 filehandle will return EOF when the final dot is encountered.
 692 Similarly, you may write to the filehandle in order to send data to
 693 the server after issuing a commmand that expects data to be written.
 694
 695 See the Net::POP3 and Net::SMTP modules for examples of this.
 696
 697 =back
 698
 699 =head1 EXPORTS
 700
 701 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
 702 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
 703 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
 704
 705 =head1 AUTHOR
 706
 707 Graham Barr <gbarr@pobox.com>
 708
 709 =head1 COPYRIGHT
 710
 711 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
 712 This program is free software; you can redistribute it and/or modify
 713 it under the same terms as Perl itself.
 714
 715 =for html <hr>
 716
 717 I<$Id: //depot/libnet/Net/Cmd.pm#28 $>
 718
 719 =cut