1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#25 $
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 $line =~ s/\n/\015\012/sgo;
408 ${*$cmd}{'net_cmd_lastch'} ||= " ";
409 $line = ${*$cmd}{'net_cmd_lastch'} . $line;
411 $line =~ s/(\012\.)/$1./sog;
413 ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
415 my $len = length($line) - 1;
418 vec($win,fileno($cmd),1) = 1;
419 my $timeout = $cmd->timeout || undef;
424 if (select(undef,$wout=$win, undef, $timeout) > 0)
426 my $w = syswrite($cmd, $line, $len, $offset);
429 carp("$cmd: $!") if $cmd->debug;
437 carp("$cmd: Timeout") if($cmd->debug);
449 return 0 unless defined(fileno($cmd));
452 unless(exists ${*$cmd}{'net_cmd_lastch'});
454 if(${*$cmd}{'net_cmd_lastch'} eq "\015")
456 syswrite($cmd,"\012",1);
460 elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
462 syswrite($cmd,"\015\012",2);
467 print STDERR "$cmd>>> .\n"
470 syswrite($cmd,".\015\012",3);
472 delete ${*$cmd}{'net_cmd_lastch'};
474 $cmd->response() == CMD_OK;
484 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
494 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
495 of C<IO::Handle>. These methods implement the functionality required for a
496 command based protocol, for example FTP and SMTP.
500 These methods provide a user interface to the C<Net::Cmd> object.
504 =item debug ( VALUE )
506 Set the level of debug information for this object. If C<VALUE> is not given
507 then the current state is returned. Otherwise the state is changed to
508 C<VALUE> and the previous state returned.
510 Set the level of debug information for this object. If no argument is
511 given then the current state is returned. Otherwise the state is
512 changed to C<$value>and the previous state returned. Different packages
513 may implement different levels of debug but, a non-zero value result in
514 copies of all commands and responses also being sent to STDERR.
516 If C<VALUE> is C<undef> then the debug level will be set to the default
517 debug level for the class.
519 This method can also be called as a I<static> method to set/get the default
520 debug level for a given class.
524 Returns the text message returned from the last command
528 Returns the 3-digit code from the last command. If a command is pending
529 then the value 0 is returned
533 Returns non-zero if the last code value was greater than zero and
534 less than 400. This holds true for most command servers. Servers
535 where this does not hold may override this method.
539 Returns the most significant digit of the current status code. If a command
540 is pending then C<CMD_PENDING> is returned.
542 =item datasend ( DATA )
544 Send data to the remote server, converting LF to CRLF. Any line starting
545 with a '.' will be prefixed with another '.'.
546 C<DATA> may be an array or a reference to an array.
550 End the sending of data to the remote server. This is done by ensuring that
551 the data already sent ends with CRLF then sending '.CRLF' to end the
552 transmission. Once this data has been sent C<dataend> calls C<response> and
553 returns true if C<response> returns CMD_OK.
559 These methods are not intended to be called by the user, but used or
560 over-ridden by a sub-class of C<Net::Cmd>
564 =item debug_print ( DIR, TEXT )
566 Print debugging information. C<DIR> denotes the direction I<true> being
567 data being sent to the server. Calls C<debug_text> before printing to
570 =item debug_text ( TEXT )
572 This method is called to print debugging information. TEXT is
573 the text being sent. The method should return the text to be printed
575 This is primarily meant for the use of modules such as FTP where passwords
576 are sent, but we do not want to display them in the debugging information.
578 =item command ( CMD [, ARGS, ... ])
580 Send a command to the command server. All arguments a first joined with
581 a space character and CRLF is appended, this string is then sent to the
584 Returns undef upon failure
588 Sets the status code to 580 and the response text to 'Unsupported command'.
593 Obtain a response from the server. Upon success the most significant digit
594 of the status code is returned. Upon failure, timeout etc., I<undef> is
597 =item parse_response ( TEXT )
599 This method is called by C<response> as a method with one argument. It should
600 return an array of 2 values, the 3-digit status code and a flag which is true
601 when this is part of a multi-line response and this line is not the list.
605 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
608 B<NOTE>: If you do use this method for any reason, please remember to add
609 some C<debug_print> calls into your method.
611 =item ungetline ( TEXT )
613 Unget a line of text from the server.
615 =item read_until_dot ()
617 Read data from the remote server until a line consisting of a single '.'.
618 Any lines starting with '..' will have one of the '.'s removed.
620 Returns a reference to a list containing the lines, or I<undef> upon failure.
626 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
627 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
628 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
632 Graham Barr <gbarr@pobox.com>
636 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
637 This program is free software; you can redistribute it and/or modify
638 it under the same terms as Perl itself.
642 I<$Id: //depot/libnet/Net/Cmd.pm#25 $>