This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a84b4da80efb063f520c2112084c5edf14ebc20b
[perl5.git] / lib / Net / Cmd.pm
1 # Net::Cmd.pm $Id: //depot/libnet/Net/Cmd.pm#34 $
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 use Symbol 'gensym';
16
17 BEGIN {
18   if ($^O eq 'os390') {
19     require Convert::EBCDIC;
20 #    Convert::EBCDIC->import;
21   }
22 }
23
24 $VERSION = "2.26";
25 @ISA     = qw(Exporter);
26 @EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
27
28 sub CMD_INFO    { 1 }
29 sub CMD_OK      { 2 }
30 sub CMD_MORE    { 3 }
31 sub CMD_REJECT  { 4 }
32 sub CMD_ERROR   { 5 }
33 sub CMD_PENDING { 0 }
34
35 my %debug = ();
36
37 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
38
39 sub toebcdic
40 {
41  my $cmd = shift;
42
43  unless (exists ${*$cmd}{'net_cmd_asciipeer'})
44   {
45    my $string = $_[0];
46    my $ebcdicstr = $tr->toebcdic($string);
47    ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
48   }
49
50   ${*$cmd}{'net_cmd_asciipeer'}
51     ? $tr->toebcdic($_[0])
52     : $_[0];
53 }
54
55 sub toascii
56 {
57   my $cmd = shift;
58   ${*$cmd}{'net_cmd_asciipeer'}
59     ? $tr->toascii($_[0])
60     : $_[0];
61 }
62
63 sub _print_isa
64 {
65  no strict qw(refs);
66
67  my $pkg = shift;
68  my $cmd = $pkg;
69
70  $debug{$pkg} ||= 0;
71
72  my %done = ();
73  my @do   = ($pkg);
74  my %spc = ( $pkg , "");
75
76  while ($pkg = shift @do)
77   {
78    next if defined $done{$pkg};
79
80    $done{$pkg} = 1;
81
82    my $v = defined ${"${pkg}::VERSION"}
83                 ? "(" . ${"${pkg}::VERSION"} . ")"
84                 : "";
85
86    my $spc = $spc{$pkg};
87    $cmd->debug_print(1,"${spc}${pkg}${v}\n");
88
89    if(@{"${pkg}::ISA"})
90     {
91      @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
92      unshift(@do, @{"${pkg}::ISA"});
93     }
94   }
95 }
96
97 sub debug
98 {
99  @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
100
101  my($cmd,$level) = @_;
102  my $pkg = ref($cmd) || $cmd;
103  my $oldval = 0;
104
105  if(ref($cmd))
106   {
107    $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
108   }
109  else
110   {
111    $oldval = $debug{$pkg} || 0;
112   }
113
114  return $oldval
115     unless @_ == 2;
116
117  $level = $debug{$pkg} || 0
118     unless defined $level;
119
120  _print_isa($pkg)
121     if($level && !exists $debug{$pkg});
122
123  if(ref($cmd))
124   {
125    ${*$cmd}{'net_cmd_debug'} = $level;
126   }
127  else
128   {
129    $debug{$pkg} = $level;
130   }
131
132  $oldval;
133 }
134
135 sub message
136 {
137  @_ == 1 or croak 'usage: $obj->message()';
138
139  my $cmd = shift;
140
141  wantarray ? @{${*$cmd}{'net_cmd_resp'}}
142            : join("", @{${*$cmd}{'net_cmd_resp'}});
143 }
144
145 sub debug_text { $_[2] }
146
147 sub debug_print
148 {
149  my($cmd,$out,$text) = @_;
150  print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
151 }
152
153 sub code
154 {
155  @_ == 1 or croak 'usage: $obj->code()';
156
157  my $cmd = shift;
158
159  ${*$cmd}{'net_cmd_code'} = "000"
160         unless exists ${*$cmd}{'net_cmd_code'};
161
162  ${*$cmd}{'net_cmd_code'};
163 }
164
165 sub status
166 {
167  @_ == 1 or croak 'usage: $obj->status()';
168
169  my $cmd = shift;
170
171  substr(${*$cmd}{'net_cmd_code'},0,1);
172 }
173
174 sub set_status
175 {
176  @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
177
178  my $cmd = shift;
179  my($code,$resp) = @_;
180
181  $resp = [ $resp ]
182         unless ref($resp);
183
184  (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
185
186  1;
187 }
188
189 sub command
190 {
191  my $cmd = shift;
192
193  unless (defined fileno($cmd))
194   {
195     $cmd->set_status("599", "Connection closed");
196     return $cmd;
197   }
198
199
200  $cmd->dataend()
201     if(exists ${*$cmd}{'net_cmd_last_ch'});
202
203  if (scalar(@_))
204   {
205    local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
206
207    my $str =  join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_);
208    $str = $cmd->toascii($str) if $tr;
209    $str .= "\015\012";
210
211    my $len = length $str;
212    my $swlen;
213
214    $cmd->close
215         unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);
216
217    $cmd->debug_print(1,$str)
218         if($cmd->debug);
219
220    ${*$cmd}{'net_cmd_resp'} = [];      # the response
221    ${*$cmd}{'net_cmd_code'} = "000";    # Made this one up :-)
222   }
223
224  $cmd;
225 }
226
227 sub ok
228 {
229  @_ == 1 or croak 'usage: $obj->ok()';
230
231  my $code = $_[0]->code;
232  0 < $code && $code < 400;
233 }
234
235 sub unsupported
236 {
237  my $cmd = shift;
238
239  ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
240  ${*$cmd}{'net_cmd_code'} = 580;
241  0;
242 }
243
244 sub getline
245 {
246  my $cmd = shift;
247
248  ${*$cmd}{'net_cmd_lines'} ||= [];
249
250  return shift @{${*$cmd}{'net_cmd_lines'}}
251     if scalar(@{${*$cmd}{'net_cmd_lines'}});
252
253  my $partial = defined(${*$cmd}{'net_cmd_partial'})
254                 ? ${*$cmd}{'net_cmd_partial'} : "";
255  my $fd = fileno($cmd);
256
257  return undef
258         unless defined $fd;
259
260  my $rin = "";
261  vec($rin,$fd,1) = 1;
262
263  my $buf;
264
265  until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
266   {
267    my $timeout = $cmd->timeout || undef;
268    my $rout;
269    if (select($rout=$rin, undef, undef, $timeout))
270     {
271      unless (sysread($cmd, $buf="", 1024))
272       {
273        carp(ref($cmd) . ": Unexpected EOF on command channel")
274                 if $cmd->debug;
275        $cmd->close;
276        return undef;
277       } 
278
279      substr($buf,0,0) = $partial;       ## prepend from last sysread
280
281      my @buf = split(/\015?\012/, $buf, -1);    ## break into lines
282
283      $partial = pop @buf;
284
285      push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);
286
287     }
288    else
289     {
290      carp("$cmd: Timeout") if($cmd->debug);
291      return undef;
292     }
293   }
294
295  ${*$cmd}{'net_cmd_partial'} = $partial;
296
297  if ($tr) 
298   {
299    foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) 
300     {
301      $ln = $cmd->toebcdic($ln);
302     }
303   }
304
305  shift @{${*$cmd}{'net_cmd_lines'}};
306 }
307
308 sub ungetline
309 {
310  my($cmd,$str) = @_;
311
312  ${*$cmd}{'net_cmd_lines'} ||= [];
313  unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
314 }
315
316 sub parse_response
317 {
318  return ()
319     unless $_[1] =~ s/^(\d\d\d)(.?)//o;
320  ($1, $2 eq "-");
321 }
322
323 sub response
324 {
325  my $cmd = shift;
326  my($code,$more) = (undef) x 2;
327
328  ${*$cmd}{'net_cmd_resp'} ||= [];
329
330  while(1)
331   {
332    my $str = $cmd->getline();
333
334    return CMD_ERROR
335         unless defined($str);
336
337    $cmd->debug_print(0,$str)
338      if ($cmd->debug);
339
340    ($code,$more) = $cmd->parse_response($str);
341    unless(defined $code)
342     {
343      $cmd->ungetline($str);
344      last;
345     }
346
347    ${*$cmd}{'net_cmd_code'} = $code;
348
349    push(@{${*$cmd}{'net_cmd_resp'}},$str);
350
351    last unless($more);
352   } 
353
354  substr($code,0,1);
355 }
356
357 sub read_until_dot
358 {
359  my $cmd = shift;
360  my $fh  = shift;
361  my $arr = [];
362
363  while(1)
364   {
365    my $str = $cmd->getline() or return undef;
366
367    $cmd->debug_print(0,$str)
368      if ($cmd->debug & 4);
369
370    last if($str =~ /^\.\r?\n/o);
371
372    $str =~ s/^\.\././o;
373
374    if (defined $fh)
375     {
376      print $fh $str;
377     }
378    else
379     {
380      push(@$arr,$str);
381     }
382   }
383
384  $arr;
385 }
386
387 sub datasend
388 {
389  my $cmd = shift;
390  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
391  my $line = join("" ,@$arr);
392
393  return 0 unless defined(fileno($cmd));
394
395  my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
396  $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
397
398  return 1 unless length $line;
399
400  if($cmd->debug) {
401    foreach my $b (split(/\n/,$line)) {
402      $cmd->debug_print(1, "$b\n");
403    }
404   }
405
406  $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
407
408   my $first_ch = '';
409
410   if ($last_ch eq "\015") {
411     $first_ch = "\012" if $line =~ s/^\012//;
412   }
413   elsif ($last_ch eq "\012") {
414     $first_ch = "." if $line =~ /^\./;
415   }
416
417  $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
418
419  substr($line,0,0) = $first_ch;
420
421  ${*$cmd}{'net_cmd_last_ch'} = substr($line,-1,1);
422
423  my $len = length($line);
424  my $offset = 0;
425  my $win = "";
426  vec($win,fileno($cmd),1) = 1;
427  my $timeout = $cmd->timeout || undef;
428
429  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
430
431  while($len)
432   {
433    my $wout;
434    if (select(undef,$wout=$win, undef, $timeout) > 0 or -f $cmd) # -f for testing on win32
435     {
436      my $w = syswrite($cmd, $line, $len, $offset);
437      unless (defined($w))
438       {
439        carp("$cmd: $!") if $cmd->debug;
440        return undef;
441       }
442      $len -= $w;
443      $offset += $w;
444     }
445    else
446     {
447      carp("$cmd: Timeout") if($cmd->debug);
448      return undef;
449     }
450   }
451
452  1;
453 }
454
455 sub rawdatasend
456 {
457  my $cmd = shift;
458  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
459  my $line = join("" ,@$arr);
460
461  return 0 unless defined(fileno($cmd));
462
463  return 1
464     unless length($line);
465
466  if($cmd->debug)
467   {
468    my $b = "$cmd>>> ";
469    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
470   }
471
472  my $len = length($line);
473  my $offset = 0;
474  my $win = "";
475  vec($win,fileno($cmd),1) = 1;
476  my $timeout = $cmd->timeout || undef;
477
478  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
479  while($len)
480   {
481    my $wout;
482    if (select(undef,$wout=$win, undef, $timeout) > 0)
483     {
484      my $w = syswrite($cmd, $line, $len, $offset);
485      unless (defined($w))
486       {
487        carp("$cmd: $!") if $cmd->debug;
488        return undef;
489       }
490      $len -= $w;
491      $offset += $w;
492     }
493    else
494     {
495      carp("$cmd: Timeout") if($cmd->debug);
496      return undef;
497     }
498   }
499
500  1;
501 }
502
503 sub dataend
504 {
505  my $cmd = shift;
506
507  return 0 unless defined(fileno($cmd));
508
509  my $ch = ${*$cmd}{'net_cmd_last_ch'};
510  my $tosend;
511
512  if (!defined $ch) {
513    return 1;
514  }
515  elsif ($ch ne "\012") {
516    $tosend = "\015\012";
517  }
518
519  $tosend .= ".\015\012";
520
521  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
522
523  $cmd->debug_print(1, ".\n")
524     if($cmd->debug);
525
526  syswrite($cmd,$tosend, length $tosend);
527
528  delete ${*$cmd}{'net_cmd_last_ch'};
529
530  $cmd->response() == CMD_OK;
531 }
532
533 # read and write to tied filehandle
534 sub tied_fh {
535   my $cmd = shift;
536   ${*$cmd}{'net_cmd_readbuf'} = '';
537   my $fh = gensym();
538   tie *$fh,ref($cmd),$cmd;
539   return $fh;
540 }
541
542 # tie to myself
543 sub TIEHANDLE {
544   my $class = shift;
545   my $cmd = shift;
546   return $cmd;
547 }
548
549 # Tied filehandle read.  Reads requested data length, returning
550 # end-of-file when the dot is encountered.
551 sub READ {
552   my $cmd = shift;
553   my ($len,$offset) = @_[1,2];
554   return unless exists ${*$cmd}{'net_cmd_readbuf'};
555   my $done = 0;
556   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
557      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
558      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
559   }
560
561   $_[0] = '';
562   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
563   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
564   delete ${*$cmd}{'net_cmd_readbuf'} if $done;
565
566   return length $_[0];
567 }
568
569 sub READLINE {
570   my $cmd = shift;
571   # in this context, we use the presence of readbuf to
572   # indicate that we have not yet reached the eof
573   return unless exists ${*$cmd}{'net_cmd_readbuf'};
574   my $line = $cmd->getline;
575   return if $line =~ /^\.\r?\n/;
576   $line;
577 }
578
579 sub PRINT {
580   my $cmd = shift;
581   my ($buf,$len,$offset) = @_;
582   $len    ||= length ($buf);
583   $offset += 0;
584   return unless $cmd->datasend(substr($buf,$offset,$len));
585   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()
586   return $len;
587 }
588
589 sub CLOSE {
590   my $cmd = shift;
591   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; 
592   delete ${*$cmd}{'net_cmd_readbuf'};
593   delete ${*$cmd}{'net_cmd_sending'};
594   $r;
595 }
596
597 1;
598
599 __END__
600
601
602 =head1 NAME
603
604 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
605
606 =head1 SYNOPSIS
607
608     use Net::Cmd;
609
610     @ISA = qw(Net::Cmd);
611
612 =head1 DESCRIPTION
613
614 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
615 of C<IO::Handle>. These methods implement the functionality required for a
616 command based protocol, for example FTP and SMTP.
617
618 =head1 USER METHODS
619
620 These methods provide a user interface to the C<Net::Cmd> object.
621
622 =over 4
623
624 =item debug ( VALUE )
625
626 Set the level of debug information for this object. If C<VALUE> is not given
627 then the current state is returned. Otherwise the state is changed to 
628 C<VALUE> and the previous state returned. 
629
630 Different packages
631 may implement different levels of debug but a non-zero value results in 
632 copies of all commands and responses also being sent to STDERR.
633
634 If C<VALUE> is C<undef> then the debug level will be set to the default
635 debug level for the class.
636
637 This method can also be called as a I<static> method to set/get the default
638 debug level for a given class.
639
640 =item message ()
641
642 Returns the text message returned from the last command
643
644 =item code ()
645
646 Returns the 3-digit code from the last command. If a command is pending
647 then the value 0 is returned
648
649 =item ok ()
650
651 Returns non-zero if the last code value was greater than zero and
652 less than 400. This holds true for most command servers. Servers
653 where this does not hold may override this method.
654
655 =item status ()
656
657 Returns the most significant digit of the current status code. If a command
658 is pending then C<CMD_PENDING> is returned.
659
660 =item datasend ( DATA )
661
662 Send data to the remote server, converting LF to CRLF. Any line starting
663 with a '.' will be prefixed with another '.'.
664 C<DATA> may be an array or a reference to an array.
665
666 =item dataend ()
667
668 End the sending of data to the remote server. This is done by ensuring that
669 the data already sent ends with CRLF then sending '.CRLF' to end the
670 transmission. Once this data has been sent C<dataend> calls C<response> and
671 returns true if C<response> returns CMD_OK.
672
673 =back
674
675 =head1 CLASS METHODS
676
677 These methods are not intended to be called by the user, but used or 
678 over-ridden by a sub-class of C<Net::Cmd>
679
680 =over 4
681
682 =item debug_print ( DIR, TEXT )
683
684 Print debugging information. C<DIR> denotes the direction I<true> being
685 data being sent to the server. Calls C<debug_text> before printing to
686 STDERR.
687
688 =item debug_text ( TEXT )
689
690 This method is called to print debugging information. TEXT is
691 the text being sent. The method should return the text to be printed
692
693 This is primarily meant for the use of modules such as FTP where passwords
694 are sent, but we do not want to display them in the debugging information.
695
696 =item command ( CMD [, ARGS, ... ])
697
698 Send a command to the command server. All arguments a first joined with
699 a space character and CRLF is appended, this string is then sent to the
700 command server.
701
702 Returns undef upon failure
703
704 =item unsupported ()
705
706 Sets the status code to 580 and the response text to 'Unsupported command'.
707 Returns zero.
708
709 =item response ()
710
711 Obtain a response from the server. Upon success the most significant digit
712 of the status code is returned. Upon failure, timeout etc., I<undef> is
713 returned.
714
715 =item parse_response ( TEXT )
716
717 This method is called by C<response> as a method with one argument. It should
718 return an array of 2 values, the 3-digit status code and a flag which is true
719 when this is part of a multi-line response and this line is not the list.
720
721 =item getline ()
722
723 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
724 upon failure.
725
726 B<NOTE>: If you do use this method for any reason, please remember to add
727 some C<debug_print> calls into your method.
728
729 =item ungetline ( TEXT )
730
731 Unget a line of text from the server.
732
733 =item rawdatasend ( DATA )
734
735 Send data to the remote server without performing any conversions. C<DATA>
736 is a scalar.
737
738 =item read_until_dot ()
739
740 Read data from the remote server until a line consisting of a single '.'.
741 Any lines starting with '..' will have one of the '.'s removed.
742
743 Returns a reference to a list containing the lines, or I<undef> upon failure.
744
745 =item tied_fh ()
746
747 Returns a filehandle tied to the Net::Cmd object.  After issuing a
748 command, you may read from this filehandle using read() or <>.  The
749 filehandle will return EOF when the final dot is encountered.
750 Similarly, you may write to the filehandle in order to send data to
751 the server after issuing a commmand that expects data to be written.
752
753 See the Net::POP3 and Net::SMTP modules for examples of this.
754
755 =back
756
757 =head1 EXPORTS
758
759 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
760 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
761 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
762
763 =head1 AUTHOR
764
765 Graham Barr <gbarr@pobox.com>
766
767 =head1 COPYRIGHT
768
769 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
770 This program is free software; you can redistribute it and/or modify
771 it under the same terms as Perl itself.
772
773 =for html <hr>
774
775 I<$Id: //depot/libnet/Net/Cmd.pm#34 $>
776
777 =cut