lib/Net/Cmd.pm

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