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