lib/Net/Cmd.pm

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