1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $
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.
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;
269 if (select($rout=$rin, undef, undef, $timeout))
271 unless (sysread($cmd, $buf="", 1024))
273 carp(ref($cmd) . ": Unexpected EOF on command channel")
279 substr($buf,0,0) = $partial; ## prepend from last sysread
281 my @buf = split(/\015?\012/, $buf, -1); ## break into lines
285 push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
290 carp("$cmd: Timeout") if($cmd->debug);
295 ${*$cmd}{'net_cmd_partial'} = $partial;
299 foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
301 $ln = $cmd->toebcdic($ln);
305 shift @{${*$cmd}{'net_cmd_lines'}};
312 ${*$cmd}{'net_cmd_lines'} ||= [];
313 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
319 unless $_[1] =~ s/^(\d\d\d)(.?)//o;
326 my($code,$more) = (undef) x 2;
328 ${*$cmd}{'net_cmd_resp'} ||= [];
332 my $str = $cmd->getline();
335 unless defined($str);
337 $cmd->debug_print(0,$str)
340 ($code,$more) = $cmd->parse_response($str);
341 unless(defined $code)
343 $cmd->ungetline($str);
347 ${*$cmd}{'net_cmd_code'} = $code;
349 push(@{${*$cmd}{'net_cmd_resp'}},$str);
365 my $str = $cmd->getline() or return undef;
367 $cmd->debug_print(0,$str)
368 if ($cmd->debug & 4);
370 last if($str =~ /^\.\r?\n/o);
390 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
391 my $line = join("" ,@$arr);
393 return 0 unless defined(fileno($cmd));
395 my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
396 $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
398 return 1 unless length $line;
401 foreach my $b (split(/\n/,$line)) {
402 $cmd->debug_print(1, "$b\n");
406 $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
410 if ($last_ch eq "\015") {
411 $first_ch = "\012" if $line =~ s/^\012//;
413 elsif ($last_ch eq "\012") {
414 $first_ch = "." if $line =~ /^\./;
417 $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
419 substr($line,0,0) = $first_ch;
421 ${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
423 my $len = length($line);
426 vec($win,fileno($cmd),1) = 1;
427 my $timeout = $cmd->timeout || undef;
429 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
434 my $s = select(undef,$wout=$win, undef, $timeout);
435 if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
437 my $w = syswrite($cmd, $line, $len, $offset);
440 carp("$cmd: $!") if $cmd->debug;
448 carp("$cmd: Timeout") if($cmd->debug);
459 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
460 my $line = join("" ,@$arr);
462 return 0 unless defined(fileno($cmd));
465 unless length($line);
470 print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
473 my $len = length($line);
476 vec($win,fileno($cmd),1) = 1;
477 my $timeout = $cmd->timeout || undef;
479 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
483 if (select(undef,$wout=$win, undef, $timeout) > 0)
485 my $w = syswrite($cmd, $line, $len, $offset);
488 carp("$cmd: $!") if $cmd->debug;
496 carp("$cmd: Timeout") if($cmd->debug);
508 return 0 unless defined(fileno($cmd));
510 my $ch = ${*$cmd}{'net_cmd_last_ch'};
516 elsif ($ch ne "\012") {
517 $tosend = "\015\012";
520 $tosend .= ".\015\012";
522 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
524 $cmd->debug_print(1, ".\n")
527 syswrite($cmd,$tosend, length $tosend);
529 delete ${*$cmd}{'net_cmd_last_ch'};
531 $cmd->response() == CMD_OK;
534 # read and write to tied filehandle
537 ${*$cmd}{'net_cmd_readbuf'} = '';
539 tie *$fh,ref($cmd),$cmd;
550 # Tied filehandle read. Reads requested data length, returning
551 # end-of-file when the dot is encountered.
554 my ($len,$offset) = @_[1,2];
555 return unless exists ${*$cmd}{'net_cmd_readbuf'};
557 while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
558 ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
559 $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
563 substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
564 substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
565 delete ${*$cmd}{'net_cmd_readbuf'} if $done;
572 # in this context, we use the presence of readbuf to
573 # indicate that we have not yet reached the eof
574 return unless exists ${*$cmd}{'net_cmd_readbuf'};
575 my $line = $cmd->getline;
576 return if $line =~ /^\.\r?\n/;
582 my ($buf,$len,$offset) = @_;
583 $len ||= length ($buf);
585 return unless $cmd->datasend(substr($buf,$offset,$len));
586 ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
592 my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
593 delete ${*$cmd}{'net_cmd_readbuf'};
594 delete ${*$cmd}{'net_cmd_sending'};
605 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
615 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
616 of C<IO::Handle>. These methods implement the functionality required for a
617 command based protocol, for example FTP and SMTP.
621 These methods provide a user interface to the C<Net::Cmd> object.
625 =item debug ( VALUE )
627 Set the level of debug information for this object. If C<VALUE> is not given
628 then the current state is returned. Otherwise the state is changed to
629 C<VALUE> and the previous state returned.
632 may implement different levels of debug but a non-zero value results in
633 copies of all commands and responses also being sent to STDERR.
635 If C<VALUE> is C<undef> then the debug level will be set to the default
636 debug level for the class.
638 This method can also be called as a I<static> method to set/get the default
639 debug level for a given class.
643 Returns the text message returned from the last command
647 Returns the 3-digit code from the last command. If a command is pending
648 then the value 0 is returned
652 Returns non-zero if the last code value was greater than zero and
653 less than 400. This holds true for most command servers. Servers
654 where this does not hold may override this method.
658 Returns the most significant digit of the current status code. If a command
659 is pending then C<CMD_PENDING> is returned.
661 =item datasend ( DATA )
663 Send data to the remote server, converting LF to CRLF. Any line starting
664 with a '.' will be prefixed with another '.'.
665 C<DATA> may be an array or a reference to an array.
669 End the sending of data to the remote server. This is done by ensuring that
670 the data already sent ends with CRLF then sending '.CRLF' to end the
671 transmission. Once this data has been sent C<dataend> calls C<response> and
672 returns true if C<response> returns CMD_OK.
678 These methods are not intended to be called by the user, but used or
679 over-ridden by a sub-class of C<Net::Cmd>
683 =item debug_print ( DIR, TEXT )
685 Print debugging information. C<DIR> denotes the direction I<true> being
686 data being sent to the server. Calls C<debug_text> before printing to
689 =item debug_text ( TEXT )
691 This method is called to print debugging information. TEXT is
692 the text being sent. The method should return the text to be printed
694 This is primarily meant for the use of modules such as FTP where passwords
695 are sent, but we do not want to display them in the debugging information.
697 =item command ( CMD [, ARGS, ... ])
699 Send a command to the command server. All arguments a first joined with
700 a space character and CRLF is appended, this string is then sent to the
703 Returns undef upon failure
707 Sets the status code to 580 and the response text to 'Unsupported command'.
712 Obtain a response from the server. Upon success the most significant digit
713 of the status code is returned. Upon failure, timeout etc., I<undef> is
716 =item parse_response ( TEXT )
718 This method is called by C<response> as a method with one argument. It should
719 return an array of 2 values, the 3-digit status code and a flag which is true
720 when this is part of a multi-line response and this line is not the list.
724 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
727 B<NOTE>: If you do use this method for any reason, please remember to add
728 some C<debug_print> calls into your method.
730 =item ungetline ( TEXT )
732 Unget a line of text from the server.
734 =item rawdatasend ( DATA )
736 Send data to the remote server without performing any conversions. C<DATA>
739 =item read_until_dot ()
741 Read data from the remote server until a line consisting of a single '.'.
742 Any lines starting with '..' will have one of the '.'s removed.
744 Returns a reference to a list containing the lines, or I<undef> upon failure.
748 Returns a filehandle tied to the Net::Cmd object. After issuing a
749 command, you may read from this filehandle using read() or <>. The
750 filehandle will return EOF when the final dot is encountered.
751 Similarly, you may write to the filehandle in order to send data to
752 the server after issuing a command that expects data to be written.
754 See the Net::POP3 and Net::SMTP modules for examples of this.
760 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
761 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
762 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
766 Graham Barr <gbarr@pobox.com>
770 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
771 This program is free software; you can redistribute it and/or modify
772 it under the same terms as Perl itself.
776 I<$Id: //depot/libnet/Net/Cmd.pm#34 $>