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.
13 use vars qw(@ISA @EXPORT $VERSION);
19 require Convert::EBCDIC;
21 # Convert::EBCDIC->import;
26 if (!eval { require utf8 }) {
29 elsif (eval { utf8::is_utf8(undef); 1 }) {
30 *is_utf8 = \&utf8::is_utf8;
32 elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) {
33 *is_utf8 = \&Encode::is_utf8;
36 *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ };
42 @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
54 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
60 unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
62 my $ebcdicstr = $tr->toebcdic($string);
63 ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
66 ${*$cmd}{'net_cmd_asciipeer'}
67 ? $tr->toebcdic($_[0])
74 ${*$cmd}{'net_cmd_asciipeer'}
92 while ($pkg = shift @do) {
93 next if defined $done{$pkg};
98 defined ${"${pkg}::VERSION"}
99 ? "(" . ${"${pkg}::VERSION"} . ")"
102 my $spc = $spc{$pkg};
103 $cmd->debug_print(1, "${spc}${pkg}${v}\n");
105 if (@{"${pkg}::ISA"}) {
106 @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
107 unshift(@do, @{"${pkg}::ISA"});
114 @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
116 my ($cmd, $level) = @_;
117 my $pkg = ref($cmd) || $cmd;
121 $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
124 $oldval = $debug{$pkg} || 0;
130 $level = $debug{$pkg} || 0
131 unless defined $level;
134 if ($level && !exists $debug{$pkg});
137 ${*$cmd}{'net_cmd_debug'} = $level;
140 $debug{$pkg} = $level;
148 @_ == 1 or croak 'usage: $obj->message()';
153 ? @{${*$cmd}{'net_cmd_resp'}}
154 : join("", @{${*$cmd}{'net_cmd_resp'}});
158 sub debug_text { $_[2] }
162 my ($cmd, $out, $text) = @_;
163 print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
168 @_ == 1 or croak 'usage: $obj->code()';
172 ${*$cmd}{'net_cmd_code'} = "000"
173 unless exists ${*$cmd}{'net_cmd_code'};
175 ${*$cmd}{'net_cmd_code'};
180 @_ == 1 or croak 'usage: $obj->status()';
184 substr(${*$cmd}{'net_cmd_code'}, 0, 1);
189 @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
192 my ($code, $resp) = @_;
197 (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
206 unless (defined fileno($cmd)) {
207 $cmd->set_status("599", "Connection closed");
213 if (exists ${*$cmd}{'net_cmd_last_ch'});
216 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
222 ? do { my $n = $_; $n =~ tr/\n/ /; $n }
226 $str = $cmd->toascii($str) if $tr;
229 my $len = length $str;
233 unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
235 $cmd->debug_print(1, $str)
238 ${*$cmd}{'net_cmd_resp'} = []; # the response
239 ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
247 @_ == 1 or croak 'usage: $obj->ok()';
249 my $code = $_[0]->code;
250 0 < $code && $code < 400;
257 ${*$cmd}{'net_cmd_resp'} = ['Unsupported command'];
258 ${*$cmd}{'net_cmd_code'} = 580;
266 ${*$cmd}{'net_cmd_lines'} ||= [];
268 return shift @{${*$cmd}{'net_cmd_lines'}}
269 if scalar(@{${*$cmd}{'net_cmd_lines'}});
271 my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
272 my $fd = fileno($cmd);
278 vec($rin, $fd, 1) = 1;
282 until (scalar(@{${*$cmd}{'net_cmd_lines'}})) {
283 my $timeout = $cmd->timeout || undef;
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")
295 substr($buf, 0, 0) = $partial; ## prepend from last sysread
297 my @buf = split(/\015?\012/, $buf, -1); ## break into lines
301 push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf);
305 my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
306 carp("$cmd: $msg") if ($cmd->debug);
311 ${*$cmd}{'net_cmd_partial'} = $partial;
314 foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) {
315 $ln = $cmd->toebcdic($ln);
319 shift @{${*$cmd}{'net_cmd_lines'}};
324 my ($cmd, $str) = @_;
326 ${*$cmd}{'net_cmd_lines'} ||= [];
327 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
333 unless $_[1] =~ s/^(\d\d\d)(.?)//o;
340 my ($code, $more) = (undef) x 2;
342 ${*$cmd}{'net_cmd_resp'} ||= [];
345 my $str = $cmd->getline();
348 unless defined($str);
350 $cmd->debug_print(0, $str)
353 ($code, $more) = $cmd->parse_response($str);
354 unless (defined $code) {
355 $cmd->ungetline($str);
359 ${*$cmd}{'net_cmd_code'} = $code;
361 push(@{${*$cmd}{'net_cmd_resp'}}, $str);
376 my $str = $cmd->getline() or return undef;
378 $cmd->debug_print(0, $str)
379 if ($cmd->debug & 4);
381 last if ($str =~ /^\.\r?\n/o);
399 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
400 my $line = join("", @$arr);
402 # encode to individual utf8 bytes if
403 # $line is a string (in internal UTF-8)
404 utf8::encode($line) if is_utf8($line);
406 return 0 unless defined(fileno($cmd));
408 my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
409 $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
411 return 1 unless length $line;
414 foreach my $b (split(/\n/, $line)) {
415 $cmd->debug_print(1, "$b\n");
419 $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
423 if ($last_ch eq "\015") {
424 $first_ch = "\012" if $line =~ s/^\012//;
426 elsif ($last_ch eq "\012") {
427 $first_ch = "." if $line =~ /^\./;
430 $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
432 substr($line, 0, 0) = $first_ch;
434 ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1);
436 my $len = length($line);
439 vec($win, fileno($cmd), 1) = 1;
440 my $timeout = $cmd->timeout || undef;
442 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
446 my $s = select(undef, $wout = $win, undef, $timeout);
447 if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
449 my $w = syswrite($cmd, $line, $len, $offset);
450 unless (defined($w)) {
451 carp("$cmd: $!") if $cmd->debug;
458 carp("$cmd: Timeout") if ($cmd->debug);
469 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
470 my $line = join("", @$arr);
472 return 0 unless defined(fileno($cmd));
475 unless length($line);
479 print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
482 my $len = length($line);
485 vec($win, fileno($cmd), 1) = 1;
486 my $timeout = $cmd->timeout || undef;
488 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
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;
501 carp("$cmd: Timeout") if ($cmd->debug);
513 return 0 unless defined(fileno($cmd));
515 my $ch = ${*$cmd}{'net_cmd_last_ch'};
521 elsif ($ch ne "\012") {
522 $tosend = "\015\012";
525 $tosend .= ".\015\012";
527 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
529 $cmd->debug_print(1, ".\n")
532 syswrite($cmd, $tosend, length $tosend);
534 delete ${*$cmd}{'net_cmd_last_ch'};
536 $cmd->response() == CMD_OK;
539 # read and write to tied filehandle
542 ${*$cmd}{'net_cmd_readbuf'} = '';
544 tie *$fh, ref($cmd), $cmd;
555 # Tied filehandle read. Reads requested data length, returning
556 # end-of-file when the dot is encountered.
559 my ($len, $offset) = @_[1, 2];
560 return unless exists ${*$cmd}{'net_cmd_readbuf'};
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;
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;
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/;
590 my ($buf, $len, $offset) = @_;
591 $len ||= length($buf);
593 return unless $cmd->datasend(substr($buf, $offset, $len));
594 ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
601 my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
602 delete ${*$cmd}{'net_cmd_readbuf'};
603 delete ${*$cmd}{'net_cmd_sending'};
614 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
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.
630 These methods provide a user interface to the C<Net::Cmd> object.
634 =item debug ( VALUE )
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.
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.
644 If C<VALUE> is C<undef> then the debug level will be set to the default
645 debug level for the class.
647 This method can also be called as a I<static> method to set/get the default
648 debug level for a given class.
652 Returns the text message returned from the last command
656 Returns the 3-digit code from the last command. If a command is pending
657 then the value 0 is returned
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.
667 Returns the most significant digit of the current status code. If a command
668 is pending then C<CMD_PENDING> is returned.
670 =item datasend ( DATA )
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.
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.
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>
692 =item debug_print ( DIR, TEXT )
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
698 =item debug_text ( TEXT )
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
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.
706 =item command ( CMD [, ARGS, ... ])
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
712 Returns undef upon failure
716 Sets the status code to 580 and the response text to 'Unsupported command'.
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
725 =item parse_response ( TEXT )
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.
733 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
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.
739 =item ungetline ( TEXT )
741 Unget a line of text from the server.
743 =item rawdatasend ( DATA )
745 Send data to the remote server without performing any conversions. C<DATA>
748 =item read_until_dot ()
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.
753 Returns a reference to a list containing the lines, or I<undef> upon failure.
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.
763 See the Net::POP3 and Net::SMTP modules for examples of this.
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>.
775 Graham Barr <gbarr@pobox.com>
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.