This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to libnet-1.20. Includes some additional version bumps where bleadperl
[perl5.git] / lib / Net / Cmd.pm
1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $
2 #
3 # Copyright (c) 1995-2006 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 #    Convert::EBCDIC->import;
21   }
22 }
23
24 my $doUTF8 = eval { require utf8 };
25
26 $VERSION = "2.27";
27 @ISA     = qw(Exporter);
28 @EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
29
30 sub CMD_INFO    { 1 }
31 sub CMD_OK      { 2 }
32 sub CMD_MORE    { 3 }
33 sub CMD_REJECT  { 4 }
34 sub CMD_ERROR   { 5 }
35 sub CMD_PENDING { 0 }
36
37 my %debug = ();
38
39 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
40
41 sub toebcdic
42 {
43  my $cmd = shift;
44
45  unless (exists ${*$cmd}{'net_cmd_asciipeer'})
46   {
47    my $string = $_[0];
48    my $ebcdicstr = $tr->toebcdic($string);
49    ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
50   }
51
52   ${*$cmd}{'net_cmd_asciipeer'}
53     ? $tr->toebcdic($_[0])
54     : $_[0];
55 }
56
57 sub toascii
58 {
59   my $cmd = shift;
60   ${*$cmd}{'net_cmd_asciipeer'}
61     ? $tr->toascii($_[0])
62     : $_[0];
63 }
64
65 sub _print_isa
66 {
67  no strict qw(refs);
68
69  my $pkg = shift;
70  my $cmd = $pkg;
71
72  $debug{$pkg} ||= 0;
73
74  my %done = ();
75  my @do   = ($pkg);
76  my %spc = ( $pkg , "");
77
78  while ($pkg = shift @do)
79   {
80    next if defined $done{$pkg};
81
82    $done{$pkg} = 1;
83
84    my $v = defined ${"${pkg}::VERSION"}
85                 ? "(" . ${"${pkg}::VERSION"} . ")"
86                 : "";
87
88    my $spc = $spc{$pkg};
89    $cmd->debug_print(1,"${spc}${pkg}${v}\n");
90
91    if(@{"${pkg}::ISA"})
92     {
93      @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
94      unshift(@do, @{"${pkg}::ISA"});
95     }
96   }
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_last_ch'});
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
272    my $select_ret = select($rout=$rin, undef, undef, $timeout);
273    if ($select_ret > 0)
274     {
275      unless (sysread($cmd, $buf="", 1024))
276       {
277        carp(ref($cmd) . ": Unexpected EOF on command channel")
278                 if $cmd->debug;
279        $cmd->close;
280        return undef;
281       } 
282
283      substr($buf,0,0) = $partial;       ## prepend from last sysread
284
285      my @buf = split(/\015?\012/, $buf, -1);    ## break into lines
286
287      $partial = pop @buf;
288
289      push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
290
291     }
292    else
293     {
294      my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
295      carp("$cmd: $msg") if($cmd->debug);
296      return undef;
297     }
298   }
299
300  ${*$cmd}{'net_cmd_partial'} = $partial;
301
302  if ($tr) 
303   {
304    foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) 
305     {
306      $ln = $cmd->toebcdic($ln);
307     }
308   }
309
310  shift @{${*$cmd}{'net_cmd_lines'}};
311 }
312
313 sub ungetline
314 {
315  my($cmd,$str) = @_;
316
317  ${*$cmd}{'net_cmd_lines'} ||= [];
318  unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
319 }
320
321 sub parse_response
322 {
323  return ()
324     unless $_[1] =~ s/^(\d\d\d)(.?)//o;
325  ($1, $2 eq "-");
326 }
327
328 sub response
329 {
330  my $cmd = shift;
331  my($code,$more) = (undef) x 2;
332
333  ${*$cmd}{'net_cmd_resp'} ||= [];
334
335  while(1)
336   {
337    my $str = $cmd->getline();
338
339    return CMD_ERROR
340         unless defined($str);
341
342    $cmd->debug_print(0,$str)
343      if ($cmd->debug);
344
345    ($code,$more) = $cmd->parse_response($str);
346    unless(defined $code)
347     {
348      $cmd->ungetline($str);
349      last;
350     }
351
352    ${*$cmd}{'net_cmd_code'} = $code;
353
354    push(@{${*$cmd}{'net_cmd_resp'}},$str);
355
356    last unless($more);
357   } 
358
359  substr($code,0,1);
360 }
361
362 sub read_until_dot
363 {
364  my $cmd = shift;
365  my $fh  = shift;
366  my $arr = [];
367
368  while(1)
369   {
370    my $str = $cmd->getline() or return undef;
371
372    $cmd->debug_print(0,$str)
373      if ($cmd->debug & 4);
374
375    last if($str =~ /^\.\r?\n/o);
376
377    $str =~ s/^\.\././o;
378
379    if (defined $fh)
380     {
381      print $fh $str;
382     }
383    else
384     {
385      push(@$arr,$str);
386     }
387   }
388
389  $arr;
390 }
391
392 sub datasend
393 {
394  my $cmd = shift;
395  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
396  my $line = join("" ,@$arr);
397
398  utf8::encode($line) if $doUTF8;
399
400  return 0 unless defined(fileno($cmd));
401
402  my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
403  $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
404
405  return 1 unless length $line;
406
407  if($cmd->debug) {
408    foreach my $b (split(/\n/,$line)) {
409      $cmd->debug_print(1, "$b\n");
410    }
411   }
412
413  $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
414
415   my $first_ch = '';
416
417   if ($last_ch eq "\015") {
418     $first_ch = "\012" if $line =~ s/^\012//;
419   }
420   elsif ($last_ch eq "\012") {
421     $first_ch = "." if $line =~ /^\./;
422   }
423
424  $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
425
426  substr($line,0,0) = $first_ch;
427
428  ${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
429
430  my $len = length($line);
431  my $offset = 0;
432  my $win = "";
433  vec($win,fileno($cmd),1) = 1;
434  my $timeout = $cmd->timeout || undef;
435
436  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
437
438  while($len)
439   {
440    my $wout;
441    my $s = select(undef,$wout=$win, undef, $timeout);
442    if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
443     {
444      my $w = syswrite($cmd, $line, $len, $offset);
445      unless (defined($w))
446       {
447        carp("$cmd: $!") if $cmd->debug;
448        return undef;
449       }
450      $len -= $w;
451      $offset += $w;
452     }
453    else
454     {
455      carp("$cmd: Timeout") if($cmd->debug);
456      return undef;
457     }
458   }
459
460  1;
461 }
462
463 sub rawdatasend
464 {
465  my $cmd = shift;
466  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
467  my $line = join("" ,@$arr);
468
469  return 0 unless defined(fileno($cmd));
470
471  return 1
472     unless length($line);
473
474  if($cmd->debug)
475   {
476    my $b = "$cmd>>> ";
477    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
478   }
479
480  my $len = length($line);
481  my $offset = 0;
482  my $win = "";
483  vec($win,fileno($cmd),1) = 1;
484  my $timeout = $cmd->timeout || undef;
485
486  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
487  while($len)
488   {
489    my $wout;
490    if (select(undef,$wout=$win, undef, $timeout) > 0)
491     {
492      my $w = syswrite($cmd, $line, $len, $offset);
493      unless (defined($w))
494       {
495        carp("$cmd: $!") if $cmd->debug;
496        return undef;
497       }
498      $len -= $w;
499      $offset += $w;
500     }
501    else
502     {
503      carp("$cmd: Timeout") if($cmd->debug);
504      return undef;
505     }
506   }
507
508  1;
509 }
510
511 sub dataend
512 {
513  my $cmd = shift;
514
515  return 0 unless defined(fileno($cmd));
516
517  my $ch = ${*$cmd}{'net_cmd_last_ch'};
518  my $tosend;
519
520  if (!defined $ch) {
521    return 1;
522  }
523  elsif ($ch ne "\012") {
524    $tosend = "\015\012";
525  }
526
527  $tosend .= ".\015\012";
528
529  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
530
531  $cmd->debug_print(1, ".\n")
532     if($cmd->debug);
533
534  syswrite($cmd,$tosend, length $tosend);
535
536  delete ${*$cmd}{'net_cmd_last_ch'};
537
538  $cmd->response() == CMD_OK;
539 }
540
541 # read and write to tied filehandle
542 sub tied_fh {
543   my $cmd = shift;
544   ${*$cmd}{'net_cmd_readbuf'} = '';
545   my $fh = gensym();
546   tie *$fh,ref($cmd),$cmd;
547   return $fh;
548 }
549
550 # tie to myself
551 sub TIEHANDLE {
552   my $class = shift;
553   my $cmd = shift;
554   return $cmd;
555 }
556
557 # Tied filehandle read.  Reads requested data length, returning
558 # end-of-file when the dot is encountered.
559 sub READ {
560   my $cmd = shift;
561   my ($len,$offset) = @_[1,2];
562   return unless exists ${*$cmd}{'net_cmd_readbuf'};
563   my $done = 0;
564   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
565      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
566      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
567   }
568
569   $_[0] = '';
570   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
571   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
572   delete ${*$cmd}{'net_cmd_readbuf'} if $done;
573
574   return length $_[0];
575 }
576
577 sub READLINE {
578   my $cmd = shift;
579   # in this context, we use the presence of readbuf to
580   # indicate that we have not yet reached the eof
581   return unless exists ${*$cmd}{'net_cmd_readbuf'};
582   my $line = $cmd->getline;
583   return if $line =~ /^\.\r?\n/;
584   $line;
585 }
586
587 sub PRINT {
588   my $cmd = shift;
589   my ($buf,$len,$offset) = @_;
590   $len    ||= length ($buf);
591   $offset += 0;
592   return unless $cmd->datasend(substr($buf,$offset,$len));
593   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()
594   return $len;
595 }
596
597 sub CLOSE {
598   my $cmd = shift;
599   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; 
600   delete ${*$cmd}{'net_cmd_readbuf'};
601   delete ${*$cmd}{'net_cmd_sending'};
602   $r;
603 }
604
605 1;
606
607 __END__
608
609
610 =head1 NAME
611
612 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
613
614 =head1 SYNOPSIS
615
616     use Net::Cmd;
617
618     @ISA = qw(Net::Cmd);
619
620 =head1 DESCRIPTION
621
622 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
623 of C<IO::Handle>. These methods implement the functionality required for a
624 command based protocol, for example FTP and SMTP.
625
626 =head1 USER METHODS
627
628 These methods provide a user interface to the C<Net::Cmd> object.
629
630 =over 4
631
632 =item debug ( VALUE )
633
634 Set the level of debug information for this object. If C<VALUE> is not given
635 then the current state is returned. Otherwise the state is changed to 
636 C<VALUE> and the previous state returned. 
637
638 Different packages
639 may implement different levels of debug but a non-zero value results in 
640 copies of all commands and responses also being sent to STDERR.
641
642 If C<VALUE> is C<undef> then the debug level will be set to the default
643 debug level for the class.
644
645 This method can also be called as a I<static> method to set/get the default
646 debug level for a given class.
647
648 =item message ()
649
650 Returns the text message returned from the last command
651
652 =item code ()
653
654 Returns the 3-digit code from the last command. If a command is pending
655 then the value 0 is returned
656
657 =item ok ()
658
659 Returns non-zero if the last code value was greater than zero and
660 less than 400. This holds true for most command servers. Servers
661 where this does not hold may override this method.
662
663 =item status ()
664
665 Returns the most significant digit of the current status code. If a command
666 is pending then C<CMD_PENDING> is returned.
667
668 =item datasend ( DATA )
669
670 Send data to the remote server, converting LF to CRLF. Any line starting
671 with a '.' will be prefixed with another '.'.
672 C<DATA> may be an array or a reference to an array.
673
674 =item dataend ()
675
676 End the sending of data to the remote server. This is done by ensuring that
677 the data already sent ends with CRLF then sending '.CRLF' to end the
678 transmission. Once this data has been sent C<dataend> calls C<response> and
679 returns true if C<response> returns CMD_OK.
680
681 =back
682
683 =head1 CLASS METHODS
684
685 These methods are not intended to be called by the user, but used or 
686 over-ridden by a sub-class of C<Net::Cmd>
687
688 =over 4
689
690 =item debug_print ( DIR, TEXT )
691
692 Print debugging information. C<DIR> denotes the direction I<true> being
693 data being sent to the server. Calls C<debug_text> before printing to
694 STDERR.
695
696 =item debug_text ( TEXT )
697
698 This method is called to print debugging information. TEXT is
699 the text being sent. The method should return the text to be printed
700
701 This is primarily meant for the use of modules such as FTP where passwords
702 are sent, but we do not want to display them in the debugging information.
703
704 =item command ( CMD [, ARGS, ... ])
705
706 Send a command to the command server. All arguments a first joined with
707 a space character and CRLF is appended, this string is then sent to the
708 command server.
709
710 Returns undef upon failure
711
712 =item unsupported ()
713
714 Sets the status code to 580 and the response text to 'Unsupported command'.
715 Returns zero.
716
717 =item response ()
718
719 Obtain a response from the server. Upon success the most significant digit
720 of the status code is returned. Upon failure, timeout etc., I<undef> is
721 returned.
722
723 =item parse_response ( TEXT )
724
725 This method is called by C<response> as a method with one argument. It should
726 return an array of 2 values, the 3-digit status code and a flag which is true
727 when this is part of a multi-line response and this line is not the list.
728
729 =item getline ()
730
731 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
732 upon failure.
733
734 B<NOTE>: If you do use this method for any reason, please remember to add
735 some C<debug_print> calls into your method.
736
737 =item ungetline ( TEXT )
738
739 Unget a line of text from the server.
740
741 =item rawdatasend ( DATA )
742
743 Send data to the remote server without performing any conversions. C<DATA>
744 is a scalar.
745
746 =item read_until_dot ()
747
748 Read data from the remote server until a line consisting of a single '.'.
749 Any lines starting with '..' will have one of the '.'s removed.
750
751 Returns a reference to a list containing the lines, or I<undef> upon failure.
752
753 =item tied_fh ()
754
755 Returns a filehandle tied to the Net::Cmd object.  After issuing a
756 command, you may read from this filehandle using read() or <>.  The
757 filehandle will return EOF when the final dot is encountered.
758 Similarly, you may write to the filehandle in order to send data to
759 the server after issuing a command that expects data to be written.
760
761 See the Net::POP3 and Net::SMTP modules for examples of this.
762
763 =back
764
765 =head1 EXPORTS
766
767 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
768 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
769 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
770
771 =head1 AUTHOR
772
773 Graham Barr <gbarr@pobox.com>
774
775 =head1 COPYRIGHT
776
777 Copyright (c) 1995-2006 Graham Barr. All rights reserved.
778 This program is free software; you can redistribute it and/or modify
779 it under the same terms as Perl itself.
780
781 =cut