1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $
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;
20 # Convert::EBCDIC->import;
26 @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
37 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
43 unless (exists ${*$cmd}{'net_cmd_asciipeer'})
46 my $ebcdicstr = $tr->toebcdic($string);
47 ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
50 ${*$cmd}{'net_cmd_asciipeer'}
51 ? $tr->toebcdic($_[0])
58 ${*$cmd}{'net_cmd_asciipeer'}
74 my %spc = ( $pkg , "");
76 while ($pkg = shift @do)
78 next if defined $done{$pkg};
82 my $v = defined ${"${pkg}::VERSION"}
83 ? "(" . ${"${pkg}::VERSION"} . ")"
87 $cmd->debug_print(1,"${spc}${pkg}${v}\n");
91 @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
92 unshift(@do, @{"${pkg}::ISA"});
99 @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
101 my($cmd,$level) = @_;
102 my $pkg = ref($cmd) || $cmd;
107 $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
111 $oldval = $debug{$pkg} || 0;
117 $level = $debug{$pkg} || 0
118 unless defined $level;
121 if($level && !exists $debug{$pkg});
125 ${*$cmd}{'net_cmd_debug'} = $level;
129 $debug{$pkg} = $level;
137 @_ == 1 or croak 'usage: $obj->message()';
141 wantarray ? @{${*$cmd}{'net_cmd_resp'}}
142 : join("", @{${*$cmd}{'net_cmd_resp'}});
145 sub debug_text { $_[2] }
149 my($cmd,$out,$text) = @_;
150 print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
155 @_ == 1 or croak 'usage: $obj->code()';
159 ${*$cmd}{'net_cmd_code'} = "000"
160 unless exists ${*$cmd}{'net_cmd_code'};
162 ${*$cmd}{'net_cmd_code'};
167 @_ == 1 or croak 'usage: $obj->status()';
171 substr(${*$cmd}{'net_cmd_code'},0,1);
176 @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
179 my($code,$resp) = @_;
184 (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
193 unless (defined fileno($cmd))
195 $cmd->set_status("599", "Connection closed");
201 if(exists ${*$cmd}{'net_cmd_last_ch'});
205 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
207 my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
208 $str = $cmd->toascii($str) if $tr;
211 my $len = length $str;
215 unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
217 $cmd->debug_print(1,$str)
220 ${*$cmd}{'net_cmd_resp'} = []; # the response
221 ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
229 @_ == 1 or croak 'usage: $obj->ok()';
231 my $code = $_[0]->code;
232 0 < $code && $code < 400;
239 ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
240 ${*$cmd}{'net_cmd_code'} = 580;
248 ${*$cmd}{'net_cmd_lines'} ||= [];
250 return shift @{${*$cmd}{'net_cmd_lines'}}
251 if scalar(@{${*$cmd}{'net_cmd_lines'}});
253 my $partial = defined(${*$cmd}{'net_cmd_partial'})
254 ? ${*$cmd}{'net_cmd_partial'} : "";
255 my $fd = fileno($cmd);
265 until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
267 my $timeout = $cmd->timeout || undef;
270 my $select_ret = select($rout=$rin, undef, undef, $timeout);
273 unless (sysread($cmd, $buf="", 1024))
275 carp(ref($cmd) . ": Unexpected EOF on command channel")
281 substr($buf,0,0) = $partial; ## prepend from last sysread
283 my @buf = split(/\015?\012/, $buf, -1); ## break into lines
287 push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
292 my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
293 carp("$cmd: $msg") if($cmd->debug);
298 ${*$cmd}{'net_cmd_partial'} = $partial;
302 foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
304 $ln = $cmd->toebcdic($ln);
308 shift @{${*$cmd}{'net_cmd_lines'}};
315 ${*$cmd}{'net_cmd_lines'} ||= [];
316 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
322 unless $_[1] =~ s/^(\d\d\d)(.?)//o;
329 my($code,$more) = (undef) x 2;
331 ${*$cmd}{'net_cmd_resp'} ||= [];
335 my $str = $cmd->getline();
338 unless defined($str);
340 $cmd->debug_print(0,$str)
343 ($code,$more) = $cmd->parse_response($str);
344 unless(defined $code)
346 $cmd->ungetline($str);
350 ${*$cmd}{'net_cmd_code'} = $code;
352 push(@{${*$cmd}{'net_cmd_resp'}},$str);
368 my $str = $cmd->getline() or return undef;
370 $cmd->debug_print(0,$str)
371 if ($cmd->debug & 4);
373 last if($str =~ /^\.\r?\n/o);
393 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
394 my $line = join("" ,@$arr);
396 return 0 unless defined(fileno($cmd));
398 my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
399 $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
401 return 1 unless length $line;
404 foreach my $b (split(/\n/,$line)) {
405 $cmd->debug_print(1, "$b\n");
409 $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
413 if ($last_ch eq "\015") {
414 $first_ch = "\012" if $line =~ s/^\012//;
416 elsif ($last_ch eq "\012") {
417 $first_ch = "." if $line =~ /^\./;
420 $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
422 substr($line,0,0) = $first_ch;
424 ${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
426 my $len = length($line);
429 vec($win,fileno($cmd),1) = 1;
430 my $timeout = $cmd->timeout || undef;
432 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
437 my $s = select(undef,$wout=$win, undef, $timeout);
438 if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
440 my $w = syswrite($cmd, $line, $len, $offset);
443 carp("$cmd: $!") if $cmd->debug;
451 carp("$cmd: Timeout") if($cmd->debug);
462 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
463 my $line = join("" ,@$arr);
465 return 0 unless defined(fileno($cmd));
468 unless length($line);
473 print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
476 my $len = length($line);
479 vec($win,fileno($cmd),1) = 1;
480 my $timeout = $cmd->timeout || undef;
482 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
486 if (select(undef,$wout=$win, undef, $timeout) > 0)
488 my $w = syswrite($cmd, $line, $len, $offset);
491 carp("$cmd: $!") if $cmd->debug;
499 carp("$cmd: Timeout") if($cmd->debug);
511 return 0 unless defined(fileno($cmd));
513 my $ch = ${*$cmd}{'net_cmd_last_ch'};
519 elsif ($ch ne "\012") {
520 $tosend = "\015\012";
523 $tosend .= ".\015\012";
525 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
527 $cmd->debug_print(1, ".\n")
530 syswrite($cmd,$tosend, length $tosend);
532 delete ${*$cmd}{'net_cmd_last_ch'};
534 $cmd->response() == CMD_OK;
537 # read and write to tied filehandle
540 ${*$cmd}{'net_cmd_readbuf'} = '';
542 tie *$fh,ref($cmd),$cmd;
553 # Tied filehandle read. Reads requested data length, returning
554 # end-of-file when the dot is encountered.
557 my ($len,$offset) = @_[1,2];
558 return unless exists ${*$cmd}{'net_cmd_readbuf'};
560 while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
561 ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
562 $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
566 substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
567 substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
568 delete ${*$cmd}{'net_cmd_readbuf'} if $done;
575 # in this context, we use the presence of readbuf to
576 # indicate that we have not yet reached the eof
577 return unless exists ${*$cmd}{'net_cmd_readbuf'};
578 my $line = $cmd->getline;
579 return if $line =~ /^\.\r?\n/;
585 my ($buf,$len,$offset) = @_;
586 $len ||= length ($buf);
588 return unless $cmd->datasend(substr($buf,$offset,$len));
589 ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
595 my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
596 delete ${*$cmd}{'net_cmd_readbuf'};
597 delete ${*$cmd}{'net_cmd_sending'};
608 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
618 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
619 of C<IO::Handle>. These methods implement the functionality required for a
620 command based protocol, for example FTP and SMTP.
624 These methods provide a user interface to the C<Net::Cmd> object.
628 =item debug ( VALUE )
630 Set the level of debug information for this object. If C<VALUE> is not given
631 then the current state is returned. Otherwise the state is changed to
632 C<VALUE> and the previous state returned.
635 may implement different levels of debug but a non-zero value results in
636 copies of all commands and responses also being sent to STDERR.
638 If C<VALUE> is C<undef> then the debug level will be set to the default
639 debug level for the class.
641 This method can also be called as a I<static> method to set/get the default
642 debug level for a given class.
646 Returns the text message returned from the last command
650 Returns the 3-digit code from the last command. If a command is pending
651 then the value 0 is returned
655 Returns non-zero if the last code value was greater than zero and
656 less than 400. This holds true for most command servers. Servers
657 where this does not hold may override this method.
661 Returns the most significant digit of the current status code. If a command
662 is pending then C<CMD_PENDING> is returned.
664 =item datasend ( DATA )
666 Send data to the remote server, converting LF to CRLF. Any line starting
667 with a '.' will be prefixed with another '.'.
668 C<DATA> may be an array or a reference to an array.
672 End the sending of data to the remote server. This is done by ensuring that
673 the data already sent ends with CRLF then sending '.CRLF' to end the
674 transmission. Once this data has been sent C<dataend> calls C<response> and
675 returns true if C<response> returns CMD_OK.
681 These methods are not intended to be called by the user, but used or
682 over-ridden by a sub-class of C<Net::Cmd>
686 =item debug_print ( DIR, TEXT )
688 Print debugging information. C<DIR> denotes the direction I<true> being
689 data being sent to the server. Calls C<debug_text> before printing to
692 =item debug_text ( TEXT )
694 This method is called to print debugging information. TEXT is
695 the text being sent. The method should return the text to be printed
697 This is primarily meant for the use of modules such as FTP where passwords
698 are sent, but we do not want to display them in the debugging information.
700 =item command ( CMD [, ARGS, ... ])
702 Send a command to the command server. All arguments a first joined with
703 a space character and CRLF is appended, this string is then sent to the
706 Returns undef upon failure
710 Sets the status code to 580 and the response text to 'Unsupported command'.
715 Obtain a response from the server. Upon success the most significant digit
716 of the status code is returned. Upon failure, timeout etc., I<undef> is
719 =item parse_response ( TEXT )
721 This method is called by C<response> as a method with one argument. It should
722 return an array of 2 values, the 3-digit status code and a flag which is true
723 when this is part of a multi-line response and this line is not the list.
727 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
730 B<NOTE>: If you do use this method for any reason, please remember to add
731 some C<debug_print> calls into your method.
733 =item ungetline ( TEXT )
735 Unget a line of text from the server.
737 =item rawdatasend ( DATA )
739 Send data to the remote server without performing any conversions. C<DATA>
742 =item read_until_dot ()
744 Read data from the remote server until a line consisting of a single '.'.
745 Any lines starting with '..' will have one of the '.'s removed.
747 Returns a reference to a list containing the lines, or I<undef> upon failure.
751 Returns a filehandle tied to the Net::Cmd object. After issuing a
752 command, you may read from this filehandle using read() or <>. The
753 filehandle will return EOF when the final dot is encountered.
754 Similarly, you may write to the filehandle in order to send data to
755 the server after issuing a command that expects data to be written.
757 See the Net::POP3 and Net::SMTP modules for examples of this.
763 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
764 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
765 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
769 Graham Barr <gbarr@pobox.com>
773 Copyright (c) 1995-2006 Graham Barr. All rights reserved.
774 This program is free software; you can redistribute it and/or modify
775 it under the same terms as Perl itself.