lib/Net/Cmd.pm

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