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   }

    21 }

    22 

    23 $VERSION = "2.24";

    24 @ISA     = qw(Exporter);

    25 @EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);

    26 

    27 sub CMD_INFO	{ 1 }

    28 sub CMD_OK	{ 2 }

    29 sub CMD_MORE	{ 3 }

    30 sub CMD_REJECT	{ 4 }

    31 sub CMD_ERROR	{ 5 }

    32 sub CMD_PENDING { 0 }

    33 

    34 my %debug = ();

    35 

    36 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;

    37 

    38 sub toebcdic

    39 {

    40  my $cmd = shift;

    41 

    42  unless (exists ${*$cmd}{'net_cmd_asciipeer'})

    43   {

    44    my $string = $_[0];

    45    my $ebcdicstr = $tr->toebcdic($string);

    46    ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;

    47   }

    48 

    49   ${*$cmd}{'net_cmd_asciipeer'}

    50     ? $tr->toebcdic($_[0])

    51     : $_[0];

    52 }

    53 

    54 sub toascii

    55 {

    56   my $cmd = shift;

    57   ${*$cmd}{'net_cmd_asciipeer'}

    58     ? $tr->toascii($_[0])

    59     : $_[0];

    60 }

    61 

    62 sub _print_isa

    63 {

    64  no strict qw(refs);

    65 

    66  my $pkg = shift;

    67  my $cmd = $pkg;

    68 

    69  $debug{$pkg} ||= 0;

    70 

    71  my %done = ();

    72  my @do   = ($pkg);

    73  my %spc = ( $pkg , "");

    74 

    75  while ($pkg = shift @do)

    76   {

    77    next if defined $done{$pkg};

    78 

    79    $done{$pkg} = 1;

    80 

    81    my $v = defined ${"${pkg}::VERSION"}

    82                 ? "(" . ${"${pkg}::VERSION"} . ")"

    83                 : "";

    84 

    85    my $spc = $spc{$pkg};

    86    $cmd->debug_print(1,"${spc}${pkg}${v}\n");

    87 

    88    if(@{"${pkg}::ISA"})

    89     {

    90      @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};

    91      unshift(@do, @{"${pkg}::ISA"});

    92     }

    93   }

    94 }

    95 

    96 sub debug

    97 {

    98  @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';

    99 

   100  my($cmd,$level) = @_;

   101  my $pkg = ref($cmd) || $cmd;

   102  my $oldval = 0;

   103 

   104  if(ref($cmd))

   105   {

   106    $oldval = ${*$cmd}{'net_cmd_debug'} || 0;

   107   }

   108  else

   109   {

   110    $oldval = $debug{$pkg} || 0;

   111   }

   112 

   113  return $oldval

   114     unless @_ == 2;

   115 

   116  $level = $debug{$pkg} || 0

   117     unless defined $level;

   118 

   119  _print_isa($pkg)

   120     if($level && !exists $debug{$pkg});

   121 

   122  if(ref($cmd))

   123   {

   124    ${*$cmd}{'net_cmd_debug'} = $level;

   125   }

   126  else

   127   {

   128    $debug{$pkg} = $level;

   129   }

   130 

   131  $oldval;

   132 }

   133 

   134 sub message

   135 {

   136  @_ == 1 or croak 'usage: $obj->message()';

   137 

   138  my $cmd = shift;

   139 

   140  wantarray ? @{${*$cmd}{'net_cmd_resp'}}

   141     	   : join("", @{${*$cmd}{'net_cmd_resp'}});

   142 }

   143 

   144 sub debug_text { $_[2] }

   145 

   146 sub debug_print

   147 {

   148  my($cmd,$out,$text) = @_;

   149  print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);

   150 }

   151 

   152 sub code

   153 {

   154  @_ == 1 or croak 'usage: $obj->code()';

   155 

   156  my $cmd = shift;

   157 

   158  ${*$cmd}{'net_cmd_code'} = "000"

   159 	unless exists ${*$cmd}{'net_cmd_code'};

   160 

   161  ${*$cmd}{'net_cmd_code'};

   162 }

   163 

   164 sub status

   165 {

   166  @_ == 1 or croak 'usage: $obj->status()';

   167 

   168  my $cmd = shift;

   169 

   170  substr(${*$cmd}{'net_cmd_code'},0,1);

   171 }

   172 

   173 sub set_status

   174 {

   175  @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';

   176 

   177  my $cmd = shift;

   178  my($code,$resp) = @_;

   179 

   180  $resp = [ $resp ]

   181 	unless ref($resp);

   182 

   183  (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);

   184 

   185  1;

   186 }

   187 

   188 sub command

   189 {

   190  my $cmd = shift;

   191 

   192  unless (defined fileno($cmd))

   193   {

   194     $cmd->set_status("599", "Connection closed");

   195     return $cmd;

   196   }

   197 

   198 

   199  $cmd->dataend()

   200     if(exists ${*$cmd}{'net_cmd_need_crlf'});

   201 

   202  if (scalar(@_))

   203   {

   204    local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';

   205 

   206    my $str =  join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);

   207    $str = $cmd->toascii($str) if $tr;

   208    $str .= "\015\012";

   209 

   210    my $len = length $str;

   211    my $swlen;

   212 

   213    $cmd->close

   214 	unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);

   215 

   216    $cmd->debug_print(1,$str)

   217 	if($cmd->debug);

   218 

   219    ${*$cmd}{'net_cmd_resp'} = [];      # the response

   220    ${*$cmd}{'net_cmd_code'} = "000";	# Made this one up :-)

   221   }

   222 

   223  $cmd;

   224 }

   225 

   226 sub ok

   227 {

   228  @_ == 1 or croak 'usage: $obj->ok()';

   229 

   230  my $code = $_[0]->code;

   231  0 < $code && $code < 400;

   232 }

   233 

   234 sub unsupported

   235 {

   236  my $cmd = shift;

   237 

   238  ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];

   239  ${*$cmd}{'net_cmd_code'} = 580;

   240  0;

   241 }

   242 

   243 sub getline

   244 {

   245  my $cmd = shift;

   246 

   247  ${*$cmd}{'net_cmd_lines'} ||= [];

   248 

   249  return shift @{${*$cmd}{'net_cmd_lines'}}

   250     if scalar(@{${*$cmd}{'net_cmd_lines'}});

   251 

   252  my $partial = defined(${*$cmd}{'net_cmd_partial'})

   253 		? ${*$cmd}{'net_cmd_partial'} : "";

   254  my $fd = fileno($cmd);

   255 

   256  return undef

   257 	unless defined $fd;

   258 

   259  my $rin = "";

   260  vec($rin,$fd,1) = 1;

   261 

   262  my $buf;

   263 

   264  until(scalar(@{${*$cmd}{'net_cmd_lines'}}))

   265   {

   266    my $timeout = $cmd->timeout || undef;

   267    my $rout;

   268    if (select($rout=$rin, undef, undef, $timeout))

   269     {

   270      unless (sysread($cmd, $buf="", 1024))

   271       {

   272        carp(ref($cmd) . ": Unexpected EOF on command channel")

   273 		if $cmd->debug;

   274        $cmd->close;

   275        return undef;

   276       } 

   277 

   278      substr($buf,0,0) = $partial;	## prepend from last sysread

   279 

   280      my @buf = split(/\015?\012/, $buf, -1);	## break into lines

   281 

   282      $partial = pop @buf;

   283 

   284      push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);

   285 

   286     }

   287    else

   288     {

   289      carp("$cmd: Timeout") if($cmd->debug);

   290      return undef;

   291     }

   292   }

   293 

   294  ${*$cmd}{'net_cmd_partial'} = $partial;

   295 

   296  if ($tr) 

   297   {

   298    foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) 

   299     {

   300      $ln = $cmd->toebcdic($ln);

   301     }

   302   }

   303 

   304  shift @{${*$cmd}{'net_cmd_lines'}};

   305 }

   306 

   307 sub ungetline

   308 {

   309  my($cmd,$str) = @_;

   310 

   311  ${*$cmd}{'net_cmd_lines'} ||= [];

   312  unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);

   313 }

   314 

   315 sub parse_response

   316 {

   317  return ()

   318     unless $_[1] =~ s/^(\d\d\d)(.?)//o;

   319  ($1, $2 eq "-");

   320 }

   321 

   322 sub response

   323 {

   324  my $cmd = shift;

   325  my($code,$more) = (undef) x 2;

   326 

   327  ${*$cmd}{'net_cmd_resp'} ||= [];

   328 

   329  while(1)

   330   {

   331    my $str = $cmd->getline();

   332 

   333    return CMD_ERROR

   334 	unless defined($str);

   335 

   336    $cmd->debug_print(0,$str)

   337      if ($cmd->debug);

   338 

   339    ($code,$more) = $cmd->parse_response($str);

   340    unless(defined $code)

   341     {

   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 sub read_until_dot

   357 {

   358  my $cmd = shift;

   359  my $fh  = shift;

   360  my $arr = [];

   361 

   362  while(1)

   363   {

   364    my $str = $cmd->getline() or return undef;

   365 

   366    $cmd->debug_print(0,$str)

   367      if ($cmd->debug & 4);

   368 

   369    last if($str =~ /^\.\r?\n/o);

   370 

   371    $str =~ s/^\.\././o;

   372 

   373    if (defined $fh)

   374     {

   375      print $fh $str;

   376     }

   377    else

   378     {

   379      push(@$arr,$str);

   380     }

   381   }

   382 

   383  $arr;

   384 }

   385 

   386 sub datasend

   387 {

   388  my $cmd = shift;

   389  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;

   390  my $line = join("" ,@$arr);

   391 

   392  return 0 unless defined(fileno($cmd));

   393 

   394  unless (length $line) {

   395    # Even though we are not sending anything, the fact we were

   396    # called means that dataend needs to be called before the next

   397    # command, which happens of net_cmd_need_crlf exists

   398    ${*$cmd}{'net_cmd_need_crlf'} ||= 0;

   399    return 1;

   400  }

   401 

   402  if($cmd->debug) {

   403    foreach my $b (split(/\n/,$line)) {

   404      $cmd->debug_print(1, "$b\n");

   405    }

   406   }

   407 

   408  $line =~ s/\r?\n/\r\n/sg;

   409  $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";

   410 

   411  $line =~ s/(\012\.)/$1./sog;

   412  $line =~ s/^\./../ unless ${*$cmd}{'net_cmd_need_crlf'};

   413 

   414  ${*$cmd}{'net_cmd_need_crlf'} = substr($line,-1,1) ne "\012";

   415 

   416  my $len = length($line);

   417  my $offset = 0;

   418  my $win = "";

   419  vec($win,fileno($cmd),1) = 1;

   420  my $timeout = $cmd->timeout || undef;

   421 

   422  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';

   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 rawdatasend

   449 {

   450  my $cmd = shift;

   451  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;

   452  my $line = join("" ,@$arr);

   453 

   454  return 0 unless defined(fileno($cmd));

   455 

   456  return 1

   457     unless length($line);

   458 

   459  if($cmd->debug)

   460   {

   461    my $b = "$cmd>>> ";

   462    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";

   463   }

   464 

   465  my $len = length($line);

   466  my $offset = 0;

   467  my $win = "";

   468  vec($win,fileno($cmd),1) = 1;

   469  my $timeout = $cmd->timeout || undef;

   470 

   471  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';

   472  while($len)

   473   {

   474    my $wout;

   475    if (select(undef,$wout=$win, undef, $timeout) > 0)

   476     {

   477      my $w = syswrite($cmd, $line, $len, $offset);

   478      unless (defined($w))

   479       {

   480        carp("$cmd: $!") if $cmd->debug;

   481        return undef;

   482       }

   483      $len -= $w;

   484      $offset += $w;

   485     }

   486    else

   487     {

   488      carp("$cmd: Timeout") if($cmd->debug);

   489      return undef;

   490     }

   491   }

   492 

   493  1;

   494 }

   495 

   496 sub dataend

   497 {

   498  my $cmd = shift;

   499 

   500  return 0 unless defined(fileno($cmd));

   501 

   502  return 1

   503     unless(exists ${*$cmd}{'net_cmd_need_crlf'});

   504 

   505  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';

   506  syswrite($cmd,"\015\012",2)

   507     if ${*$cmd}{'net_cmd_need_crlf'};

   508 

   509  $cmd->debug_print(1, ".\n")

   510     if($cmd->debug);

   511 

   512  syswrite($cmd,".\015\012",3);

   513 

   514  delete ${*$cmd}{'net_cmd_need_crlf'};

   515 

   516  $cmd->response() == CMD_OK;

   517 }

   518 

   519 # read and write to tied filehandle

   520 sub tied_fh {

   521   my $cmd = shift;

   522   ${*$cmd}{'net_cmd_readbuf'} = '';

   523   my $fh = gensym();

   524   tie *$fh,ref($cmd),$cmd;

   525   return $fh;

   526 }

   527 

   528 # tie to myself

   529 sub TIEHANDLE {

   530   my $class = shift;

   531   my $cmd = shift;

   532   return $cmd;

   533 }

   534 

   535 # Tied filehandle read.  Reads requested data length, returning

   536 # end-of-file when the dot is encountered.

   537 sub READ {

   538   my $cmd = shift;

   539   my ($len,$offset) = @_[1,2];

   540   return unless exists ${*$cmd}{'net_cmd_readbuf'};

   541   my $done = 0;

   542   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {

   543      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;

   544      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;

   545   }

   546 

   547   $_[0] = '';

   548   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);

   549   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';

   550   delete ${*$cmd}{'net_cmd_readbuf'} if $done;

   551 

   552   return length $_[0];

   553 }

   554 

   555 sub READLINE {

   556   my $cmd = shift;

   557   # in this context, we use the presence of readbuf to

   558   # indicate that we have not yet reached the eof

   559   return unless exists ${*$cmd}{'net_cmd_readbuf'};

   560   my $line = $cmd->getline;

   561   return if $line =~ /^\.\r?\n/;

   562   $line;

   563 }

   564 

   565 sub PRINT {

   566   my $cmd = shift;

   567   my ($buf,$len,$offset) = @_;

   568   $len    ||= length ($buf);

   569   $offset += 0;

   570   return unless $cmd->datasend(substr($buf,$offset,$len));

   571   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()

   572   return $len;

   573 }

   574 

   575 sub CLOSE {

   576   my $cmd = shift;

   577   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; 

   578   delete ${*$cmd}{'net_cmd_readbuf'};

   579   delete ${*$cmd}{'net_cmd_sending'};

   580   $r;

   581 }

   582 

   583 1;

   584 

   585 __END__

   586 

   587 

   588 =head1 NAME

   589 

   590 Net::Cmd - Network Command class (as used by FTP, SMTP etc)

   591 

   592 =head1 SYNOPSIS

   593 

   594     use Net::Cmd;

   595 

   596     @ISA = qw(Net::Cmd);

   597 

   598 =head1 DESCRIPTION

   599 

   600 C<Net::Cmd> is a collection of methods that can be inherited by a sub class

   601 of C<IO::Handle>. These methods implement the functionality required for a

   602 command based protocol, for example FTP and SMTP.

   603 

   604 =head1 USER METHODS

   605 

   606 These methods provide a user interface to the C<Net::Cmd> object.

   607 

   608 =over 4

   609 

   610 =item debug ( VALUE )

   611 

   612 Set the level of debug information for this object. If C<VALUE> is not given

   613 then the current state is returned. Otherwise the state is changed to 

   614 C<VALUE> and the previous state returned. 

   615 

   616 Different packages

   617 may implement different levels of debug but a non-zero value results in 

   618 copies of all commands and responses also being sent to STDERR.

   619 

   620 If C<VALUE> is C<undef> then the debug level will be set to the default

   621 debug level for the class.

   622 

   623 This method can also be called as a I<static> method to set/get the default

   624 debug level for a given class.

   625 

   626 =item message ()

   627 

   628 Returns the text message returned from the last command

   629 

   630 =item code ()

   631 

   632 Returns the 3-digit code from the last command. If a command is pending

   633 then the value 0 is returned

   634 

   635 =item ok ()

   636 

   637 Returns non-zero if the last code value was greater than zero and

   638 less than 400. This holds true for most command servers. Servers

   639 where this does not hold may override this method.

   640 

   641 =item status ()

   642 

   643 Returns the most significant digit of the current status code. If a command

   644 is pending then C<CMD_PENDING> is returned.

   645 

   646 =item datasend ( DATA )

   647 

   648 Send data to the remote server, converting LF to CRLF. Any line starting

   649 with a '.' will be prefixed with another '.'.

   650 C<DATA> may be an array or a reference to an array.

   651 

   652 =item dataend ()

   653 

   654 End the sending of data to the remote server. This is done by ensuring that

   655 the data already sent ends with CRLF then sending '.CRLF' to end the

   656 transmission. Once this data has been sent C<dataend> calls C<response> and

   657 returns true if C<response> returns CMD_OK.

   658 

   659 =back

   660 

   661 =head1 CLASS METHODS

   662 

   663 These methods are not intended to be called by the user, but used or 

   664 over-ridden by a sub-class of C<Net::Cmd>

   665 

   666 =over 4

   667 

   668 =item debug_print ( DIR, TEXT )

   669 

   670 Print debugging information. C<DIR> denotes the direction I<true> being

   671 data being sent to the server. Calls C<debug_text> before printing to

   672 STDERR.

   673 

   674 =item debug_text ( TEXT )

   675 

   676 This method is called to print debugging information. TEXT is

   677 the text being sent. The method should return the text to be printed

   678 

   679 This is primarily meant for the use of modules such as FTP where passwords

   680 are sent, but we do not want to display them in the debugging information.

   681 

   682 =item command ( CMD [, ARGS, ... ])

   683 

   684 Send a command to the command server. All arguments a first joined with

   685 a space character and CRLF is appended, this string is then sent to the

   686 command server.

   687 

   688 Returns undef upon failure

   689 

   690 =item unsupported ()

   691 

   692 Sets the status code to 580 and the response text to 'Unsupported command'.

   693 Returns zero.

   694 

   695 =item response ()

   696 

   697 Obtain a response from the server. Upon success the most significant digit

   698 of the status code is returned. Upon failure, timeout etc., I<undef> is

   699 returned.

   700 

   701 =item parse_response ( TEXT )

   702 

   703 This method is called by C<response> as a method with one argument. It should

   704 return an array of 2 values, the 3-digit status code and a flag which is true

   705 when this is part of a multi-line response and this line is not the list.

   706 

   707 =item getline ()

   708 

   709 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>

   710 upon failure.

   711 

   712 B<NOTE>: If you do use this method for any reason, please remember to add

   713 some C<debug_print> calls into your method.

   714 

   715 =item ungetline ( TEXT )

   716 

   717 Unget a line of text from the server.

   718 

   719 =item rawdatasend ( DATA )

   720 

   721 Send data to the remote server without performing any conversions. C<DATA>

   722 is a scalar.

   723 

   724 =item read_until_dot ()

   725 

   726 Read data from the remote server until a line consisting of a single '.'.

   727 Any lines starting with '..' will have one of the '.'s removed.

   728 

   729 Returns a reference to a list containing the lines, or I<undef> upon failure.

   730 

   731 =item tied_fh ()

   732 

   733 Returns a filehandle tied to the Net::Cmd object.  After issuing a

   734 command, you may read from this filehandle using read() or <>.  The

   735 filehandle will return EOF when the final dot is encountered.

   736 Similarly, you may write to the filehandle in order to send data to

   737 the server after issuing a commmand that expects data to be written.

   738 

   739 See the Net::POP3 and Net::SMTP modules for examples of this.

   740 

   741 =back

   742 

   743 =head1 EXPORTS

   744 

   745 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,

   746 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results

   747 of C<response> and C<status>. The sixth is C<CMD_PENDING>.

   748 

   749 =head1 AUTHOR

   750 

   751 Graham Barr <gbarr@pobox.com>

   752 

   753 =head1 COPYRIGHT

   754 

   755 Copyright (c) 1995-1997 Graham Barr. All rights reserved.

   756 This program is free software; you can redistribute it and/or modify

   757 it under the same terms as Perl itself.

   758 

   759 =for html <hr>

   760 

   761 I<$Id: //depot/libnet/Net/Cmd.pm#33 $>

   762 

   763 =cut