lib/Net/Cmd.pm

   1 # Net::Cmd.pm
   2 #
   3 # Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
   4 # reserved. 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 =head1 NAME
  10
  11 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
  12
  13 =head1 SYNOPSIS
  14
  15     use Net::Cmd;
  16
  17     @ISA = qw(Net::Cmd);
  18
  19 =head1 DESCRIPTION
  20
  21 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
  22 of C<IO::Handle>. These methods implement the functionality required for a
  23 command based protocol, for example FTP and SMTP.
  24
  25 =head1 USER METHODS
  26
  27 These methods provide a user interface to the C<Net::Cmd> object.
  28
  29 =over 4
  30
  31 =item debug ( VALUE )
  32
  33 Set the level of debug information for this object. If C<VALUE> is not given
  34 then the current state is returned. Otherwise the state is changed to
  35 C<VALUE> and the previous state returned. If C<VALUE> is C<undef> then
  36 the debug level will be set to the default debug level for the class.
  37
  38 This method can also be called as a I<static> method to set/get the default
  39 debug level for a given class.
  40
  41 =item message ()
  42
  43 Returns the text message returned from the last command
  44
  45 =item code ()
  46
  47 Returns the 3-digit code from the last command. If a command is pending
  48 then the value 0 is returned
  49
  50 =item ok ()
  51
  52 Returns non-zero if the last code value was greater than zero and
  53 less than 400. This holds true for most command servers. Servers
  54 where this does not hold may override this method.
  55
  56 =item status ()
  57
  58 Returns the most significant digit of the current status code. If a command
  59 is pending then C<CMD_PENDING> is returned.
  60
  61 =item datasend ( DATA )
  62
  63 Send data to the remote server, delimiting lines with CRLF. Any lin starting
  64 with a '.' will be prefixed with another '.'.
  65
  66 =item dataend ()
  67
  68 End the sending of data to the remote server. This is done by ensureing that
  69 the data already sent ends with CRLF then sending '.CRLF' to end the
  70 transmission. Once this data has been sent C<dataend> calls C<response> and
  71 returns true if C<response> returns CMD_OK.
  72
  73 =back
  74
  75 =head1 CLASS METHODS
  76
  77 These methods are not intended to be called by the user, but used or
  78 over-ridden by a sub-class of C<Net::Cmd>
  79
  80 =over 4
  81
  82 =item debug_print ( DIR, TEXT )
  83
  84 Print debugging information. C<DIR> denotes the direction I<true> being
  85 data being sent to the server. Calls C<debug_text> before printing to
  86 STDERR.
  87
  88 =item debug_text ( TEXT )
  89
  90 This method is called to print debugging information. TEXT is
  91 the text being sent. The method should return the text to be printed
  92
  93 This is primarily meant for the use of modules such as FTP where passwords
  94 are sent, but we do not want to display them in the debugging information.
  95
  96 =item command ( CMD [, ARGS, ... ])
  97
  98 Send a command to the command server. All arguments a first joined with
  99 a space character and CRLF is appended, this string is then sent to the
 100 command server.
 101
 102 Returns undef upon failure
 103
 104 =item unsupported ()
 105
 106 Sets the status code to 580 and the response text to 'Unsupported command'.
 107 Returns zero.
 108
 109 =item responce ()
 110
 111 Obtain a responce from the server. Upon success the most significant digit
 112 of the status code is returned. Upon failure, timeout etc., I<undef> is
 113 returned.
 114
 115 =item parse_response ( TEXT )
 116
 117 This method is called by C<response> as a method with one argument. It should
 118 return an array of 2 values, the 3-digit status code and a flag which is true
 119 when this is part of a multi-line response and this line is not the list.
 120
 121 =item getline ()
 122
 123 Retreive one line, delimited by CRLF, from the remote server. Returns I<undef>
 124 upon failure.
 125
 126 B<NOTE>: If you do use this method for any reason, please remember to add
 127 some C<debug_print> calls into your method.
 128
 129 =item ungetline ( TEXT )
 130
 131 Unget a line of text from the server.
 132
 133 =item read_until_dot ()
 134
 135 Read data from the remote server until a line consisting of a single '.'.
 136 Any lines starting with '..' will have one of the '.'s removed.
 137
 138 Returns a reference to a list containing the lines, or I<undef> upon failure.
 139
 140 =back
 141
 142 =head1 EXPORTS
 143
 144 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
 145 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
 146 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
 147
 148 =head1 AUTHOR
 149
 150 Graham Barr <Graham.Barr@tiuk.ti.com>
 151
 152 =head1 REVISION
 153
 154 $Revision: 2.2 $
 155
 156 =head1 COPYRIGHT
 157
 158 Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
 159 software; you can redistribute it and/or modify it under the same terms
 160 as Perl itself.
 161
 162 =cut
 163
 164 require 5.001;
 165 require Exporter;
 166
 167 use strict;
 168 use vars qw(@ISA @EXPORT $VERSION);
 169 use Carp;
 170
 171 $VERSION = sprintf("%d.%02d", q$Revision: 2.2 $ =~ /(\d+)\.(\d+)/);
 172 @ISA     = qw(Exporter);
 173 @EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
 174
 175 sub CMD_INFO    { 1 }
 176 sub CMD_OK      { 2 }
 177 sub CMD_MORE    { 3 }
 178 sub CMD_REJECT  { 4 }
 179 sub CMD_ERROR   { 5 }
 180 sub CMD_PENDING { 0 }
 181
 182 my %debug = ();
 183
 184 sub _print_isa
 185 {
 186  no strict qw(refs);
 187
 188  my $pkg = shift;
 189  my $cmd = $pkg;
 190
 191  $debug{$pkg} ||= 0;
 192
 193  my %done = ();
 194  my @do   = ($pkg);
 195  my %spc = ( $pkg , "");
 196
 197  print STDERR "\n";
 198  while ($pkg = shift @do)
 199   {
 200    next if defined $done{$pkg};
 201
 202    $done{$pkg} = 1;
 203
 204    my $v = defined ${"${pkg}::VERSION"}
 205                 ? "(" . ${"${pkg}::VERSION"} . ")"
 206                 : "";
 207
 208    my $spc = $spc{$pkg};
 209    print STDERR "$cmd: ${spc}${pkg}${v}\n";
 210
 211    if(defined @{"${pkg}::ISA"})
 212     {
 213      @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
 214      unshift(@do, @{"${pkg}::ISA"});
 215     }
 216   }
 217
 218  print STDERR "\n";
 219 }
 220
 221 sub debug
 222 {
 223  @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
 224
 225  my($cmd,$level) = @_;
 226  my $pkg = ref($cmd) || $cmd;
 227  my $oldval = 0;
 228
 229  if(ref($cmd))
 230   {
 231    $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
 232   }
 233  else
 234   {
 235    $oldval = $debug{$pkg} || 0;
 236   }
 237
 238  return $oldval
 239     unless @_ == 2;
 240
 241  $level = $debug{$pkg} || 0
 242     unless defined $level;
 243
 244  _print_isa($pkg)
 245     if($level && !exists $debug{$pkg});
 246
 247  if(ref($cmd))
 248   {
 249    ${*$cmd}{'net_cmd_debug'} = $level;
 250   }
 251  else
 252   {
 253    $debug{$pkg} = $level;
 254   }
 255
 256  $oldval;
 257 }
 258
 259 sub message
 260 {
 261  @_ == 1 or croak 'usage: $obj->message()';
 262
 263  my $cmd = shift;
 264
 265  wantarray ? @{${*$cmd}{'net_cmd_resp'}}
 266            : join("", @{${*$cmd}{'net_cmd_resp'}});
 267 }
 268
 269 sub debug_text { $_[2] }
 270
 271 sub debug_print
 272 {
 273  my($cmd,$out,$text) = @_;
 274  print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
 275 }
 276
 277 sub code
 278 {
 279  @_ == 1 or croak 'usage: $obj->code()';
 280
 281  my $cmd = shift;
 282
 283  ${*$cmd}{'net_cmd_code'};
 284 }
 285
 286 sub status
 287 {
 288  @_ == 1 or croak 'usage: $obj->code()';
 289
 290  my $cmd = shift;
 291
 292  substr(${*$cmd}{'net_cmd_code'},0,1);
 293 }
 294
 295 sub set_status
 296 {
 297  @_ == 3 or croak 'usage: $obj->set_status( CODE, MESSAGE)';
 298
 299  my $cmd = shift;
 300
 301  (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = @_;
 302
 303  1;
 304 }
 305
 306 sub command
 307 {
 308  my $cmd = shift;
 309
 310  $cmd->dataend()
 311     if(exists ${*$cmd}{'net_cmd_lastch'});
 312
 313  if (scalar(@_))
 314   {
 315    my $str = join(" ", @_) . "\015\012";
 316
 317    syswrite($cmd,$str,length $str);
 318
 319    $cmd->debug_print(1,$str)
 320         if($cmd->debug);
 321
 322    ${*$cmd}{'net_cmd_resp'} = [];       # the responce
 323    ${*$cmd}{'net_cmd_code'} = "000";    # Made this one up :-)
 324   }
 325
 326  $cmd;
 327 }
 328
 329 sub ok
 330 {
 331  @_ == 1 or croak 'usage: $obj->ok()';
 332
 333  my $code = $_[0]->code;
 334  0 < $code && $code < 400;
 335 }
 336
 337 sub unsupported
 338 {
 339  my $cmd = shift;
 340
 341  ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
 342  ${*$cmd}{'net_cmd_code'} = 580;
 343  0;
 344 }
 345
 346 sub getline
 347 {
 348  my $cmd = shift;
 349
 350  ${*$cmd}{'net_cmd_lines'} ||= [];
 351
 352  return shift @{${*$cmd}{'net_cmd_lines'}}
 353     if scalar(@{${*$cmd}{'net_cmd_lines'}});
 354
 355  my $partial = ${*$cmd}{'net_cmd_partial'} || "";
 356
 357  my $rin = "";
 358  vec($rin,fileno($cmd),1) = 1;
 359
 360  my $buf;
 361
 362  until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
 363   {
 364    my $timeout = $cmd->timeout || undef;
 365    my $rout;
 366    if (select($rout=$rin, undef, undef, $timeout))
 367     {
 368      unless (sysread($cmd, $buf="", 1024))
 369       {
 370        carp ref($cmd) . ": Unexpected EOF on command channel";
 371        return undef;
 372       }
 373
 374      substr($buf,0,0) = $partial;       ## prepend from last sysread
 375
 376      my @buf = split(/\015?\012/, $buf);        ## break into lines
 377
 378      $partial = length($buf) == 0 || substr($buf, -1, 1) eq "\012"
 379                 ? ''
 380                 : pop(@buf);
 381
 382      map { $_ .= "\n" } @buf;
 383
 384      push(@{${*$cmd}{'net_cmd_lines'}},@buf);
 385
 386     }
 387    else
 388     {
 389      carp "$cmd: Timeout" if($cmd->debug);
 390      return undef;
 391     }
 392   }
 393
 394  ${*$cmd}{'net_cmd_partial'} = $partial;
 395
 396  shift @{${*$cmd}{'net_cmd_lines'}};
 397 }
 398
 399 sub ungetline
 400 {
 401  my($cmd,$str) = @_;
 402
 403  ${*$cmd}{'net_cmd_lines'} ||= [];
 404  unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
 405 }
 406
 407 sub parse_response
 408 {
 409  return ()
 410     unless $_[1] =~ s/^(\d\d\d)(.)//o;
 411  ($1, $2 eq "-");
 412 }
 413
 414 sub response
 415 {
 416  my $cmd = shift;
 417  my($code,$more) = (undef) x 2;
 418
 419  ${*$cmd}{'net_cmd_resp'} ||= [];
 420
 421  while(1)
 422   {
 423    my $str = $cmd->getline();
 424
 425    $cmd->debug_print(0,$str)
 426      if ($cmd->debug);
 427
 428    if($str =~ s/^(\d\d\d)(.?)//o)
 429     {
 430      ($code,$more) = ($1,$2 && $2 eq "-");
 431     }
 432    elsif(!$more)
 433     {
 434      $cmd->ungetline($str);
 435      last;
 436     }
 437
 438    push(@{${*$cmd}{'net_cmd_resp'}},$str);
 439
 440    last unless($more);
 441   }
 442
 443  ${*$cmd}{'net_cmd_code'} = $code;
 444
 445  substr($code,0,1);
 446 }
 447
 448 sub read_until_dot
 449 {
 450  my $cmd = shift;
 451  my $arr = [];
 452
 453  while(1)
 454   {
 455    my $str = $cmd->getline();
 456
 457    $cmd->debug_print(0,$str)
 458      if ($cmd->debug & 4);
 459
 460    last if($str =~ /^\.\n/o);
 461
 462    $str =~ s/^\.\././o;
 463
 464    push(@$arr,$str);
 465   }
 466
 467  $arr;
 468 }
 469
 470 sub datasend
 471 {
 472  my $cmd = shift;
 473  my $lch = exists ${*$cmd}{'net_cmd_lastch'} ? ${*$cmd}{'net_cmd_lastch'}
 474                                              : " ";
 475  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
 476  my $line = $lch . join("" ,@$arr);
 477
 478  ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
 479
 480  return 1
 481     unless length($line) > 1;
 482
 483  if($cmd->debug)
 484   {
 485    my $ln = substr($line,1);
 486    my $b = "$cmd>>> ";
 487    print STDERR $b,join("\n$b",split(/\n/,$ln)),"\n";
 488   }
 489
 490  $line =~ s/\n/\015\012/sgo;
 491  $line =~ s/(?=\012\.)/./sgo;
 492
 493  my $len = length($line) - 1;
 494
 495  return $len < 1 ||
 496         syswrite($cmd, $line, $len, 1) == $len;
 497 }
 498
 499 sub dataend
 500 {
 501  my $cmd = shift;
 502
 503  return 1
 504     unless(exists ${*$cmd}{'net_cmd_lastch'});
 505
 506  if(${*$cmd}{'net_cmd_lastch'} eq "\015")
 507   {
 508    syswrite($cmd,"\012",1);
 509    print STDERR "\n"
 510     if($cmd->debug);
 511   }
 512  elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
 513   {
 514    syswrite($cmd,"\015\012",2);
 515    print STDERR "\n"
 516     if($cmd->debug);
 517   }
 518
 519  print STDERR "$cmd>>> .\n"
 520     if($cmd->debug);
 521
 522  syswrite($cmd,".\015\012",3);
 523
 524  delete ${*$cmd}{'net_cmd_lastch'};
 525
 526  $cmd->response() == CMD_OK;
 527 }
 528
 529 1;