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