1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#28 $
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 , "");
77 while ($pkg = shift @do)
79 next if defined $done{$pkg};
83 my $v = defined ${"${pkg}::VERSION"}
84 ? "(" . ${"${pkg}::VERSION"} . ")"
88 print STDERR "$cmd: ${spc}${pkg}${v}\n";
92 @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
93 unshift(@do, @{"${pkg}::ISA"});
102 @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
104 my($cmd,$level) = @_;
105 my $pkg = ref($cmd) || $cmd;
110 $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
114 $oldval = $debug{$pkg} || 0;
120 $level = $debug{$pkg} || 0
121 unless defined $level;
124 if($level && !exists $debug{$pkg});
128 ${*$cmd}{'net_cmd_debug'} = $level;
132 $debug{$pkg} = $level;
140 @_ == 1 or croak 'usage: $obj->message()';
144 wantarray ? @{${*$cmd}{'net_cmd_resp'}}
145 : join("", @{${*$cmd}{'net_cmd_resp'}});
148 sub debug_text { $_[2] }
152 my($cmd,$out,$text) = @_;
153 print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
158 @_ == 1 or croak 'usage: $obj->code()';
162 ${*$cmd}{'net_cmd_code'} = "000"
163 unless exists ${*$cmd}{'net_cmd_code'};
165 ${*$cmd}{'net_cmd_code'};
170 @_ == 1 or croak 'usage: $obj->status()';
174 substr(${*$cmd}{'net_cmd_code'},0,1);
179 @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
182 my($code,$resp) = @_;
187 (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
196 unless (defined fileno($cmd))
198 $cmd->set_status("599", "Connection closed");
204 if(exists ${*$cmd}{'net_cmd_lastch'});
208 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
210 my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
211 $str = $cmd->toascii($str) if $tr;
214 my $len = length $str;
218 unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
220 $cmd->debug_print(1,$str)
223 ${*$cmd}{'net_cmd_resp'} = []; # the response
224 ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
232 @_ == 1 or croak 'usage: $obj->ok()';
234 my $code = $_[0]->code;
235 0 < $code && $code < 400;
242 ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
243 ${*$cmd}{'net_cmd_code'} = 580;
251 ${*$cmd}{'net_cmd_lines'} ||= [];
253 return shift @{${*$cmd}{'net_cmd_lines'}}
254 if scalar(@{${*$cmd}{'net_cmd_lines'}});
256 my $partial = defined(${*$cmd}{'net_cmd_partial'})
257 ? ${*$cmd}{'net_cmd_partial'} : "";
258 my $fd = fileno($cmd);
268 until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
270 my $timeout = $cmd->timeout || undef;
272 if (select($rout=$rin, undef, undef, $timeout))
274 unless (sysread($cmd, $buf="", 1024))
276 carp(ref($cmd) . ": Unexpected EOF on command channel")
282 substr($buf,0,0) = $partial; ## prepend from last sysread
284 my @buf = split(/\015?\012/, $buf, -1); ## break into lines
288 push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
293 carp("$cmd: Timeout") 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));
399 unless length($line);
404 print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
407 # Translate LF => CRLF, but not if the LF is
408 # already preceeded by a CR
409 $line =~ s/\G()\n|([^\r\n])\n/$+\015\012/sgo;
411 ${*$cmd}{'net_cmd_lastch'} ||= " ";
412 $line = ${*$cmd}{'net_cmd_lastch'} . $line;
414 $line =~ s/(\012\.)/$1./sog;
416 ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
418 my $len = length($line) - 1;
421 vec($win,fileno($cmd),1) = 1;
422 my $timeout = $cmd->timeout || undef;
427 if (select(undef,$wout=$win, undef, $timeout) > 0)
429 my $w = syswrite($cmd, $line, $len, $offset);
432 carp("$cmd: $!") if $cmd->debug;
440 carp("$cmd: Timeout") if($cmd->debug);
452 return 0 unless defined(fileno($cmd));
455 unless(exists ${*$cmd}{'net_cmd_lastch'});
457 if(${*$cmd}{'net_cmd_lastch'} eq "\015")
459 syswrite($cmd,"\012",1);
463 elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
465 syswrite($cmd,"\015\012",2);
470 print STDERR "$cmd>>> .\n"
473 syswrite($cmd,".\015\012",3);
475 delete ${*$cmd}{'net_cmd_lastch'};
477 $cmd->response() == CMD_OK;
480 # read and write to tied filehandle
483 ${*$cmd}{'net_cmd_readbuf'} = '';
485 tie *$fh,ref($cmd),$cmd;
496 # Tied filehandle read. Reads requested data length, returning
497 # end-of-file when the dot is encountered.
500 my (undef,$len,$offset) = @_;
501 return unless exists ${*$cmd}{'net_cmd_readbuf'};
503 while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
504 ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
505 $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
509 substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
510 substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
511 delete ${*$cmd}{'net_cmd_readbuf'} if $done;
518 # in this context, we use the presence of readbuf to
519 # indicate that we have not yet reached the eof
520 return unless exists ${*$cmd}{'net_cmd_readbuf'};
521 my $line = $cmd->getline;
522 return if $line =~ /^\.\r?\n/;
528 my ($buf,$len,$offset) = @_;
529 $len ||= length ($buf);
531 return unless $cmd->datasend(substr($buf,$offset,$len));
532 ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
538 my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
539 delete ${*$cmd}{'net_cmd_readbuf'};
540 delete ${*$cmd}{'net_cmd_sending'};
551 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
561 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
562 of C<IO::Handle>. These methods implement the functionality required for a
563 command based protocol, for example FTP and SMTP.
567 These methods provide a user interface to the C<Net::Cmd> object.
571 =item debug ( VALUE )
573 Set the level of debug information for this object. If C<VALUE> is not given
574 then the current state is returned. Otherwise the state is changed to
575 C<VALUE> and the previous state returned.
578 may implement different levels of debug but a non-zero value results in
579 copies of all commands and responses also being sent to STDERR.
581 If C<VALUE> is C<undef> then the debug level will be set to the default
582 debug level for the class.
584 This method can also be called as a I<static> method to set/get the default
585 debug level for a given class.
589 Returns the text message returned from the last command
593 Returns the 3-digit code from the last command. If a command is pending
594 then the value 0 is returned
598 Returns non-zero if the last code value was greater than zero and
599 less than 400. This holds true for most command servers. Servers
600 where this does not hold may override this method.
604 Returns the most significant digit of the current status code. If a command
605 is pending then C<CMD_PENDING> is returned.
607 =item datasend ( DATA )
609 Send data to the remote server, converting LF to CRLF. Any line starting
610 with a '.' will be prefixed with another '.'.
611 C<DATA> may be an array or a reference to an array.
615 End the sending of data to the remote server. This is done by ensuring that
616 the data already sent ends with CRLF then sending '.CRLF' to end the
617 transmission. Once this data has been sent C<dataend> calls C<response> and
618 returns true if C<response> returns CMD_OK.
624 These methods are not intended to be called by the user, but used or
625 over-ridden by a sub-class of C<Net::Cmd>
629 =item debug_print ( DIR, TEXT )
631 Print debugging information. C<DIR> denotes the direction I<true> being
632 data being sent to the server. Calls C<debug_text> before printing to
635 =item debug_text ( TEXT )
637 This method is called to print debugging information. TEXT is
638 the text being sent. The method should return the text to be printed
640 This is primarily meant for the use of modules such as FTP where passwords
641 are sent, but we do not want to display them in the debugging information.
643 =item command ( CMD [, ARGS, ... ])
645 Send a command to the command server. All arguments a first joined with
646 a space character and CRLF is appended, this string is then sent to the
649 Returns undef upon failure
653 Sets the status code to 580 and the response text to 'Unsupported command'.
658 Obtain a response from the server. Upon success the most significant digit
659 of the status code is returned. Upon failure, timeout etc., I<undef> is
662 =item parse_response ( TEXT )
664 This method is called by C<response> as a method with one argument. It should
665 return an array of 2 values, the 3-digit status code and a flag which is true
666 when this is part of a multi-line response and this line is not the list.
670 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
673 B<NOTE>: If you do use this method for any reason, please remember to add
674 some C<debug_print> calls into your method.
676 =item ungetline ( TEXT )
678 Unget a line of text from the server.
680 =item read_until_dot ()
682 Read data from the remote server until a line consisting of a single '.'.
683 Any lines starting with '..' will have one of the '.'s removed.
685 Returns a reference to a list containing the lines, or I<undef> upon failure.
689 Returns a filehandle tied to the Net::Cmd object. After issuing a
690 command, you may read from this filehandle using read() or <>. The
691 filehandle will return EOF when the final dot is encountered.
692 Similarly, you may write to the filehandle in order to send data to
693 the server after issuing a commmand that expects data to be written.
695 See the Net::POP3 and Net::SMTP modules for examples of this.
701 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
702 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
703 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
707 Graham Barr <gbarr@pobox.com>
711 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
712 This program is free software; you can redistribute it and/or modify
713 it under the same terms as Perl itself.
717 I<$Id: //depot/libnet/Net/Cmd.pm#28 $>