This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from patch from perl5.003_12 to perl5.003_13]
[perl5.git] / lib / Net / Cmd.pm
1 # Net::Cmd.pm
2 #
3 # Copyright (c) 1995 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
4 # reserved. This program is free software; you can redistribute it and/or
5 # modify it under the same terms as Perl itself.
6
7 package Net::Cmd;
8
9 =head1 NAME
10
11 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
12
13 =head1 SYNOPSIS
14
15     use Net::Cmd;
16     
17     @ISA = qw(Net::Cmd);
18
19 =head1 DESCRIPTION
20
21 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
22 of C<IO::Handle>. These methods implement the functionality required for a
23 command based protocol, for example FTP and SMTP.
24
25 =head1 USER METHODS
26
27 These methods provide a user interface to the C<Net::Cmd> object.
28
29 =over 4
30
31 =item debug ( VALUE )
32
33 Set the level of debug information for this object. If C<VALUE> is not given
34 then the current state is returned. Otherwise the state is changed to 
35 C<VALUE> and the previous state returned. If C<VALUE> is C<undef> then
36 the debug level will be set to the default debug level for the class.
37
38 This method can also be called as a I<static> method to set/get the default
39 debug level for a given class.
40
41 =item message ()
42
43 Returns the text message returned from the last command
44
45 =item code ()
46
47 Returns the 3-digit code from the last command. If a command is pending
48 then the value 0 is returned
49
50 =item ok ()
51
52 Returns non-zero if the last code value was greater than zero and
53 less than 400. This holds true for most command servers. Servers
54 where this does not hold may override this method.
55
56 =item status ()
57
58 Returns the most significant digit of the current status code. If a command
59 is pending then C<CMD_PENDING> is returned.
60
61 =item datasend ( DATA )
62
63 Send data to the remote server, delimiting lines with CRLF. Any lin starting
64 with a '.' will be prefixed with another '.'.
65
66 =item dataend ()
67
68 End the sending of data to the remote server. This is done by ensureing that
69 the data already sent ends with CRLF then sending '.CRLF' to end the
70 transmission. Once this data has been sent C<dataend> calls C<response> and
71 returns true if C<response> returns CMD_OK.
72
73 =back
74
75 =head1 CLASS METHODS
76
77 These methods are not intended to be called by the user, but used or 
78 over-ridden by a sub-class of C<Net::Cmd>
79
80 =over 4
81
82 =item debug_print ( DIR, TEXT )
83
84 Print debugging information. C<DIR> denotes the direction I<true> being
85 data being sent to the server. Calls C<debug_text> before printing to
86 STDERR.
87
88 =item debug_text ( TEXT )
89
90 This method is called to print debugging information. TEXT is
91 the text being sent. The method should return the text to be printed
92
93 This is primarily meant for the use of modules such as FTP where passwords
94 are sent, but we do not want to display them in the debugging information.
95
96 =item command ( CMD [, ARGS, ... ])
97
98 Send a command to the command server. All arguments a first joined with
99 a space character and CRLF is appended, this string is then sent to the
100 command server.
101
102 Returns undef upon failure
103
104 =item unsupported ()
105
106 Sets the status code to 580 and the response text to 'Unsupported command'.
107 Returns zero.
108
109 =item responce ()
110
111 Obtain a responce from the server. Upon success the most significant digit
112 of the status code is returned. Upon failure, timeout etc., I<undef> is
113 returned.
114
115 =item parse_response ( TEXT )
116
117 This method is called by C<response> as a method with one argument. It should
118 return an array of 2 values, the 3-digit status code and a flag which is true
119 when this is part of a multi-line response and this line is not the list.
120
121 =item getline ()
122
123 Retreive one line, delimited by CRLF, from the remote server. Returns I<undef>
124 upon failure.
125
126 B<NOTE>: If you do use this method for any reason, please remember to add
127 some C<debug_print> calls into your method.
128
129 =item ungetline ( TEXT )
130
131 Unget a line of text from the server.
132
133 =item read_until_dot ()
134
135 Read data from the remote server until a line consisting of a single '.'.
136 Any lines starting with '..' will have one of the '.'s removed.
137
138 Returns a reference to a list containing the lines, or I<undef> upon failure.
139
140 =back
141
142 =head1 EXPORTS
143
144 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
145 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
146 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
147
148 =head1 AUTHOR
149
150 Graham Barr <Graham.Barr@tiuk.ti.com>
151
152 =head1 REVISION
153
154 $Revision: 2.2 $
155
156 =head1 COPYRIGHT
157
158 Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
159 software; you can redistribute it and/or modify it under the same terms
160 as Perl itself.
161
162 =cut
163
164 require 5.001;
165 require Exporter;
166
167 use strict;
168 use vars qw(@ISA @EXPORT $VERSION);
169 use Carp;
170
171 $VERSION = sprintf("%d.%02d", q$Revision: 2.2 $ =~ /(\d+)\.(\d+)/);
172 @ISA     = qw(Exporter);
173 @EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
174
175 sub CMD_INFO    { 1 }
176 sub CMD_OK      { 2 }
177 sub CMD_MORE    { 3 }
178 sub CMD_REJECT  { 4 }
179 sub CMD_ERROR   { 5 }
180 sub CMD_PENDING { 0 }
181
182 my %debug = ();
183
184 sub _print_isa
185 {
186  no strict qw(refs);
187
188  my $pkg = shift;
189  my $cmd = $pkg;
190
191  $debug{$pkg} ||= 0;
192
193  my %done = ();
194  my @do   = ($pkg);
195  my %spc = ( $pkg , "");
196
197  print STDERR "\n";
198  while ($pkg = shift @do)
199   {
200    next if defined $done{$pkg};
201
202    $done{$pkg} = 1;
203
204    my $v = defined ${"${pkg}::VERSION"}
205                 ? "(" . ${"${pkg}::VERSION"} . ")"
206                 : "";
207
208    my $spc = $spc{$pkg};
209    print STDERR "$cmd: ${spc}${pkg}${v}\n";
210
211    if(defined @{"${pkg}::ISA"})
212     {
213      @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
214      unshift(@do, @{"${pkg}::ISA"});
215     }
216   }
217
218  print STDERR "\n";
219 }
220
221 sub debug
222 {
223  @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
224
225  my($cmd,$level) = @_;
226  my $pkg = ref($cmd) || $cmd;
227  my $oldval = 0;
228
229  if(ref($cmd))
230   {
231    $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
232   }
233  else
234   {
235    $oldval = $debug{$pkg} || 0;
236   }
237
238  return $oldval
239     unless @_ == 2;
240
241  $level = $debug{$pkg} || 0
242     unless defined $level;
243
244  _print_isa($pkg)
245     if($level && !exists $debug{$pkg});
246
247  if(ref($cmd))
248   {
249    ${*$cmd}{'net_cmd_debug'} = $level;
250   }
251  else
252   {
253    $debug{$pkg} = $level;
254   }
255
256  $oldval;
257 }
258
259 sub message
260 {
261  @_ == 1 or croak 'usage: $obj->message()';
262
263  my $cmd = shift;
264
265  wantarray ? @{${*$cmd}{'net_cmd_resp'}}
266            : join("", @{${*$cmd}{'net_cmd_resp'}});
267 }
268
269 sub debug_text { $_[2] }
270
271 sub debug_print
272 {
273  my($cmd,$out,$text) = @_;
274  print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
275 }
276
277 sub code
278 {
279  @_ == 1 or croak 'usage: $obj->code()';
280
281  my $cmd = shift;
282
283  ${*$cmd}{'net_cmd_code'};
284 }
285
286 sub status
287 {
288  @_ == 1 or croak 'usage: $obj->code()';
289
290  my $cmd = shift;
291
292  substr(${*$cmd}{'net_cmd_code'},0,1);
293 }
294
295 sub set_status
296 {
297  @_ == 3 or croak 'usage: $obj->set_status( CODE, MESSAGE)';
298
299  my $cmd = shift;
300
301  (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = @_;
302
303  1;
304 }
305
306 sub command
307 {
308  my $cmd = shift;
309
310  $cmd->dataend()
311     if(exists ${*$cmd}{'net_cmd_lastch'});
312
313  if (scalar(@_))
314   {
315    my $str = join(" ", @_) . "\015\012";
316
317    syswrite($cmd,$str,length $str);
318
319    $cmd->debug_print(1,$str)
320         if($cmd->debug);
321
322    ${*$cmd}{'net_cmd_resp'} = [];       # the responce
323    ${*$cmd}{'net_cmd_code'} = "000";    # Made this one up :-)
324   }
325
326  $cmd;
327 }
328
329 sub ok
330 {
331  @_ == 1 or croak 'usage: $obj->ok()';
332
333  my $code = $_[0]->code;
334  0 < $code && $code < 400;
335 }
336
337 sub unsupported
338 {
339  my $cmd = shift;
340
341  ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
342  ${*$cmd}{'net_cmd_code'} = 580;
343  0;
344 }
345
346 sub getline
347 {
348  my $cmd = shift;
349
350  ${*$cmd}{'net_cmd_lines'} ||= [];
351
352  return shift @{${*$cmd}{'net_cmd_lines'}}
353     if scalar(@{${*$cmd}{'net_cmd_lines'}});
354
355  my $partial = ${*$cmd}{'net_cmd_partial'} || "";
356
357  my $rin = "";
358  vec($rin,fileno($cmd),1) = 1;
359
360  my $buf;
361
362  until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
363   {
364    my $timeout = $cmd->timeout || undef;
365    my $rout;
366    if (select($rout=$rin, undef, undef, $timeout))
367     {
368      unless (sysread($cmd, $buf="", 1024))
369       {
370        carp ref($cmd) . ": Unexpected EOF on command channel";
371        return undef;
372       } 
373
374      substr($buf,0,0) = $partial;       ## prepend from last sysread
375
376      my @buf = split(/\015?\012/, $buf);        ## break into lines
377
378      $partial = length($buf) == 0 || substr($buf, -1, 1) eq "\012"
379                 ? ''
380                 : pop(@buf);
381
382      map { $_ .= "\n" } @buf;
383
384      push(@{${*$cmd}{'net_cmd_lines'}},@buf);
385
386     }
387    else
388     {
389      carp "$cmd: Timeout" if($cmd->debug);
390      return undef;
391     }
392   }
393
394  ${*$cmd}{'net_cmd_partial'} = $partial;
395
396  shift @{${*$cmd}{'net_cmd_lines'}};
397 }
398
399 sub ungetline
400 {
401  my($cmd,$str) = @_;
402
403  ${*$cmd}{'net_cmd_lines'} ||= [];
404  unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
405 }
406
407 sub parse_response
408 {
409  return ()
410     unless $_[1] =~ s/^(\d\d\d)(.)//o;
411  ($1, $2 eq "-");
412 }
413
414 sub response
415 {
416  my $cmd = shift;
417  my($code,$more) = (undef) x 2;
418
419  ${*$cmd}{'net_cmd_resp'} ||= [];
420
421  while(1)
422   {
423    my $str = $cmd->getline();
424
425    $cmd->debug_print(0,$str)
426      if ($cmd->debug);
427  
428    if($str =~ s/^(\d\d\d)(.?)//o)
429     {
430      ($code,$more) = ($1,$2 && $2 eq "-");
431     }
432    elsif(!$more)
433     {
434      $cmd->ungetline($str);
435      last;
436     }
437
438    push(@{${*$cmd}{'net_cmd_resp'}},$str);
439
440    last unless($more);
441   } 
442
443  ${*$cmd}{'net_cmd_code'} = $code;
444
445  substr($code,0,1);
446 }
447
448 sub read_until_dot
449 {
450  my $cmd = shift;
451  my $arr = [];
452
453  while(1)
454   {
455    my $str = $cmd->getline();
456
457    $cmd->debug_print(0,$str)
458      if ($cmd->debug & 4);
459
460    last if($str =~ /^\.\n/o);
461
462    $str =~ s/^\.\././o;
463
464    push(@$arr,$str);
465   }
466
467  $arr;
468 }
469
470 sub datasend
471 {
472  my $cmd = shift;
473  my $lch = exists ${*$cmd}{'net_cmd_lastch'} ? ${*$cmd}{'net_cmd_lastch'}
474                                              : " ";
475  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
476  my $line = $lch . join("" ,@$arr);
477
478  ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);
479
480  return 1
481     unless length($line) > 1;
482
483  if($cmd->debug)
484   {
485    my $ln = substr($line,1);
486    my $b = "$cmd>>> ";
487    print STDERR $b,join("\n$b",split(/\n/,$ln)),"\n";
488   }
489
490  $line =~ s/\n/\015\012/sgo;
491  $line =~ s/(?=\012\.)/./sgo;
492  
493  my $len = length($line) - 1;
494
495  return $len < 1 ||
496         syswrite($cmd, $line, $len, 1) == $len;
497 }
498
499 sub dataend
500 {
501  my $cmd = shift;
502
503  return 1
504     unless(exists ${*$cmd}{'net_cmd_lastch'});
505
506  if(${*$cmd}{'net_cmd_lastch'} eq "\015")
507   {
508    syswrite($cmd,"\012",1);
509    print STDERR "\n"
510     if($cmd->debug);
511   }
512  elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
513   {
514    syswrite($cmd,"\015\012",2);
515    print STDERR "\n"
516     if($cmd->debug);
517   }
518
519  print STDERR "$cmd>>> .\n"
520     if($cmd->debug);
521
522  syswrite($cmd,".\015\012",3);
523
524  delete ${*$cmd}{'net_cmd_lastch'};
525
526  $cmd->response() == CMD_OK;
527 }
528
529 1;