1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#26 $
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);
18 require Convert::EBCDIC;
19 # Convert::EBCDIC->import;
25 @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
36 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
42 unless (exists ${*$cmd}{'net_cmd_asciipeer'})
45 my $ebcdicstr = $tr->toebcdic($string);
46 ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
49 ${*$cmd}{'net_cmd_asciipeer'}
50 ? $tr->toebcdic($_[0])
57 ${*$cmd}{'net_cmd_asciipeer'}
73 my %spc = ( $pkg , "");
76 while ($pkg = shift @do)
78 next if defined $done{$pkg};
82 my $v = defined ${"${pkg}::VERSION"}
83 ? "(" . ${"${pkg}::VERSION"} . ")"
87 print STDERR "$cmd: ${spc}${pkg}${v}\n";
91 @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
92 unshift(@do, @{"${pkg}::ISA"});
101 @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
103 my($cmd,$level) = @_;
104 my $pkg = ref($cmd) || $cmd;
109 $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
113 $oldval = $debug{$pkg} || 0;
119 $level = $debug{$pkg} || 0
120 unless defined $level;
123 if($level && !exists $debug{$pkg});
127 ${*$cmd}{'net_cmd_debug'} = $level;
131 $debug{$pkg} = $level;
139 @_ == 1 or croak 'usage: $obj->message()';
143 wantarray ? @{${*$cmd}{'net_cmd_resp'}}
144 : join("", @{${*$cmd}{'net_cmd_resp'}});
147 sub debug_text { $_[2] }
151 my($cmd,$out,$text) = @_;
152 print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
157 @_ == 1 or croak 'usage: $obj->code()';
161 ${*$cmd}{'net_cmd_code'} = "000"
162 unless exists ${*$cmd}{'net_cmd_code'};
164 ${*$cmd}{'net_cmd_code'};
169 @_ == 1 or croak 'usage: $obj->status()';
173 substr(${*$cmd}{'net_cmd_code'},0,1);
178 @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
181 my($code,$resp) = @_;
186 (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
195 unless (defined fileno($cmd))
197 $cmd->set_status("599", "Connection closed");
203 if(exists ${*$cmd}{'net_cmd_lastch'});
207 local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
209 my $str = join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
210 $str = $cmd->toascii($str) if $tr;
213 my $len = length $str;
217 unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
219 $cmd->debug_print(1,$str)
222 ${*$cmd}{'net_cmd_resp'} = []; # the response
223 ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
231 @_ == 1 or croak 'usage: $obj->ok()';
233 my $code = $_[0]->code;
234 0 < $code && $code < 400;
241 ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
242 ${*$cmd}{'net_cmd_code'} = 580;
250 ${*$cmd}{'net_cmd_lines'} ||= [];
252 return shift @{${*$cmd}{'net_cmd_lines'}}
253 if scalar(@{${*$cmd}{'net_cmd_lines'}});
255 my $partial = defined(${*$cmd}{'net_cmd_partial'})
256 ? ${*$cmd}{'net_cmd_partial'} : "";
257 my $fd = fileno($cmd);
267 until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
269 my $timeout = $cmd->timeout || undef;
271 if (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 carp("$cmd: Timeout") if($cmd->debug);
297 ${*$cmd}{'net_cmd_partial'} = $partial;
301 foreach my $ln (@{${*$cmd}{'net_cmd_lines'}})
303 $ln = $cmd->toebcdic($ln);
307 shift @{${*$cmd}{'net_cmd_lines'}};
314 ${*$cmd}{'net_cmd_lines'} ||= [];
315 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
321 unless $_[1] =~ s/^(\d\d\d)(.?)//o;
328 my($code,$more) = (undef) x 2;
330 ${*$cmd}{'net_cmd_resp'} ||= [];
334 my $str = $cmd->getline();
337 unless defined($str);
339 $cmd->debug_print(0,$str)
342 ($code,$more) = $cmd->parse_response($str);
343 unless(defined $code)
345 $cmd->ungetline($str);
349 ${*$cmd}{'net_cmd_code'} = $code;
351 push(@{${*$cmd}{'net_cmd_resp'}},$str);
367 my $str = $cmd->getline() or return undef;
369 $cmd->debug_print(0,$str)
370 if ($cmd->debug & 4);
372 last if($str =~ /^\.\r?\n/o);
392 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
393 my $line = join("" ,@$arr);
395 return 0 unless defined(fileno($cmd));
398 unless length($line);
403 print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
406 # Translate LF => CRLF, but not if the LF is
407 # already preceeded by a CR
408 $line =~ s/\G()\n|([^\r\n])\n/$+\015\012/sgo;
410 ${*$cmd}{'net_cmd_lastch'} ||= " ";
411 $line = ${*$cmd}{'net_cmd_lastch'} . $line;
413 $line =~ s/(\012\.)/$1./sog;
415 ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
417 my $len = length($line) - 1;
420 vec($win,fileno($cmd),1) = 1;
421 my $timeout = $cmd->timeout || undef;
426 if (select(undef,$wout=$win, undef, $timeout) > 0)
428 my $w = syswrite($cmd, $line, $len, $offset);
431 carp("$cmd: $!") if $cmd->debug;
439 carp("$cmd: Timeout") if($cmd->debug);
451 return 0 unless defined(fileno($cmd));
454 unless(exists ${*$cmd}{'net_cmd_lastch'});
456 if(${*$cmd}{'net_cmd_lastch'} eq "\015")
458 syswrite($cmd,"\012",1);
462 elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
464 syswrite($cmd,"\015\012",2);
469 print STDERR "$cmd>>> .\n"
472 syswrite($cmd,".\015\012",3);
474 delete ${*$cmd}{'net_cmd_lastch'};
476 $cmd->response() == CMD_OK;
486 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
496 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
497 of C<IO::Handle>. These methods implement the functionality required for a
498 command based protocol, for example FTP and SMTP.
502 These methods provide a user interface to the C<Net::Cmd> object.
506 =item debug ( VALUE )
508 Set the level of debug information for this object. If C<VALUE> is not given
509 then the current state is returned. Otherwise the state is changed to
510 C<VALUE> and the previous state returned.
512 Set the level of debug information for this object. If no argument is
513 given then the current state is returned. Otherwise the state is
514 changed to C<$value>and the previous state returned. Different packages
515 may implement different levels of debug but, a non-zero value result in
516 copies of all commands and responses also being sent to STDERR.
518 If C<VALUE> is C<undef> then the debug level will be set to the default
519 debug level for the class.
521 This method can also be called as a I<static> method to set/get the default
522 debug level for a given class.
526 Returns the text message returned from the last command
530 Returns the 3-digit code from the last command. If a command is pending
531 then the value 0 is returned
535 Returns non-zero if the last code value was greater than zero and
536 less than 400. This holds true for most command servers. Servers
537 where this does not hold may override this method.
541 Returns the most significant digit of the current status code. If a command
542 is pending then C<CMD_PENDING> is returned.
544 =item datasend ( DATA )
546 Send data to the remote server, converting LF to CRLF. Any line starting
547 with a '.' will be prefixed with another '.'.
548 C<DATA> may be an array or a reference to an array.
552 End the sending of data to the remote server. This is done by ensuring that
553 the data already sent ends with CRLF then sending '.CRLF' to end the
554 transmission. Once this data has been sent C<dataend> calls C<response> and
555 returns true if C<response> returns CMD_OK.
561 These methods are not intended to be called by the user, but used or
562 over-ridden by a sub-class of C<Net::Cmd>
566 =item debug_print ( DIR, TEXT )
568 Print debugging information. C<DIR> denotes the direction I<true> being
569 data being sent to the server. Calls C<debug_text> before printing to
572 =item debug_text ( TEXT )
574 This method is called to print debugging information. TEXT is
575 the text being sent. The method should return the text to be printed
577 This is primarily meant for the use of modules such as FTP where passwords
578 are sent, but we do not want to display them in the debugging information.
580 =item command ( CMD [, ARGS, ... ])
582 Send a command to the command server. All arguments a first joined with
583 a space character and CRLF is appended, this string is then sent to the
586 Returns undef upon failure
590 Sets the status code to 580 and the response text to 'Unsupported command'.
595 Obtain a response from the server. Upon success the most significant digit
596 of the status code is returned. Upon failure, timeout etc., I<undef> is
599 =item parse_response ( TEXT )
601 This method is called by C<response> as a method with one argument. It should
602 return an array of 2 values, the 3-digit status code and a flag which is true
603 when this is part of a multi-line response and this line is not the list.
607 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
610 B<NOTE>: If you do use this method for any reason, please remember to add
611 some C<debug_print> calls into your method.
613 =item ungetline ( TEXT )
615 Unget a line of text from the server.
617 =item read_until_dot ()
619 Read data from the remote server until a line consisting of a single '.'.
620 Any lines starting with '..' will have one of the '.'s removed.
622 Returns a reference to a list containing the lines, or I<undef> upon failure.
628 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
629 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
630 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
634 Graham Barr <gbarr@pobox.com>
638 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
639 This program is free software; you can redistribute it and/or modify
640 it under the same terms as Perl itself.
644 I<$Id: //depot/libnet/Net/Cmd.pm#26 $>