lib/Net/Cmd.pm

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