This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f7c74846c6defeff7494c558c687bf439cb883fd
[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_01";
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    my $s = select(undef,$wout=$win, undef, $timeout);
435    if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
436     {
437      my $w = syswrite($cmd, $line, $len, $offset);
438      unless (defined($w))
439       {
440        carp("$cmd: $!") if $cmd->debug;
441        return undef;
442       }
443      $len -= $w;
444      $offset += $w;
445     }
446    else
447     {
448      carp("$cmd: Timeout") if($cmd->debug);
449      return undef;
450     }
451   }
452
453  1;
454 }
455
456 sub rawdatasend
457 {
458  my $cmd = shift;
459  my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
460  my $line = join("" ,@$arr);
461
462  return 0 unless defined(fileno($cmd));
463
464  return 1
465     unless length($line);
466
467  if($cmd->debug)
468   {
469    my $b = "$cmd>>> ";
470    print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
471   }
472
473  my $len = length($line);
474  my $offset = 0;
475  my $win = "";
476  vec($win,fileno($cmd),1) = 1;
477  my $timeout = $cmd->timeout || undef;
478
479  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
480  while($len)
481   {
482    my $wout;
483    if (select(undef,$wout=$win, undef, $timeout) > 0)
484     {
485      my $w = syswrite($cmd, $line, $len, $offset);
486      unless (defined($w))
487       {
488        carp("$cmd: $!") if $cmd->debug;
489        return undef;
490       }
491      $len -= $w;
492      $offset += $w;
493     }
494    else
495     {
496      carp("$cmd: Timeout") if($cmd->debug);
497      return undef;
498     }
499   }
500
501  1;
502 }
503
504 sub dataend
505 {
506  my $cmd = shift;
507
508  return 0 unless defined(fileno($cmd));
509
510  my $ch = ${*$cmd}{'net_cmd_last_ch'};
511  my $tosend;
512
513  if (!defined $ch) {
514    return 1;
515  }
516  elsif ($ch ne "\012") {
517    $tosend = "\015\012";
518  }
519
520  $tosend .= ".\015\012";
521
522  local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
523
524  $cmd->debug_print(1, ".\n")
525     if($cmd->debug);
526
527  syswrite($cmd,$tosend, length $tosend);
528
529  delete ${*$cmd}{'net_cmd_last_ch'};
530
531  $cmd->response() == CMD_OK;
532 }
533
534 # read and write to tied filehandle
535 sub tied_fh {
536   my $cmd = shift;
537   ${*$cmd}{'net_cmd_readbuf'} = '';
538   my $fh = gensym();
539   tie *$fh,ref($cmd),$cmd;
540   return $fh;
541 }
542
543 # tie to myself
544 sub TIEHANDLE {
545   my $class = shift;
546   my $cmd = shift;
547   return $cmd;
548 }
549
550 # Tied filehandle read.  Reads requested data length, returning
551 # end-of-file when the dot is encountered.
552 sub READ {
553   my $cmd = shift;
554   my ($len,$offset) = @_[1,2];
555   return unless exists ${*$cmd}{'net_cmd_readbuf'};
556   my $done = 0;
557   while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
558      ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
559      $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
560   }
561
562   $_[0] = '';
563   substr($_[0],$offset+0) = substr(${*$cmd}{'net_cmd_readbuf'},0,$len);
564   substr(${*$cmd}{'net_cmd_readbuf'},0,$len) = '';
565   delete ${*$cmd}{'net_cmd_readbuf'} if $done;
566
567   return length $_[0];
568 }
569
570 sub READLINE {
571   my $cmd = shift;
572   # in this context, we use the presence of readbuf to
573   # indicate that we have not yet reached the eof
574   return unless exists ${*$cmd}{'net_cmd_readbuf'};
575   my $line = $cmd->getline;
576   return if $line =~ /^\.\r?\n/;
577   $line;
578 }
579
580 sub PRINT {
581   my $cmd = shift;
582   my ($buf,$len,$offset) = @_;
583   $len    ||= length ($buf);
584   $offset += 0;
585   return unless $cmd->datasend(substr($buf,$offset,$len));
586   ${*$cmd}{'net_cmd_sending'}++;  # flag that we should call dataend()
587   return $len;
588 }
589
590 sub CLOSE {
591   my $cmd = shift;
592   my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; 
593   delete ${*$cmd}{'net_cmd_readbuf'};
594   delete ${*$cmd}{'net_cmd_sending'};
595   $r;
596 }
597
598 1;
599
600 __END__
601
602
603 =head1 NAME
604
605 Net::Cmd - Network Command class (as used by FTP, SMTP etc)
606
607 =head1 SYNOPSIS
608
609     use Net::Cmd;
610
611     @ISA = qw(Net::Cmd);
612
613 =head1 DESCRIPTION
614
615 C<Net::Cmd> is a collection of methods that can be inherited by a sub class
616 of C<IO::Handle>. These methods implement the functionality required for a
617 command based protocol, for example FTP and SMTP.
618
619 =head1 USER METHODS
620
621 These methods provide a user interface to the C<Net::Cmd> object.
622
623 =over 4
624
625 =item debug ( VALUE )
626
627 Set the level of debug information for this object. If C<VALUE> is not given
628 then the current state is returned. Otherwise the state is changed to 
629 C<VALUE> and the previous state returned. 
630
631 Different packages
632 may implement different levels of debug but a non-zero value results in 
633 copies of all commands and responses also being sent to STDERR.
634
635 If C<VALUE> is C<undef> then the debug level will be set to the default
636 debug level for the class.
637
638 This method can also be called as a I<static> method to set/get the default
639 debug level for a given class.
640
641 =item message ()
642
643 Returns the text message returned from the last command
644
645 =item code ()
646
647 Returns the 3-digit code from the last command. If a command is pending
648 then the value 0 is returned
649
650 =item ok ()
651
652 Returns non-zero if the last code value was greater than zero and
653 less than 400. This holds true for most command servers. Servers
654 where this does not hold may override this method.
655
656 =item status ()
657
658 Returns the most significant digit of the current status code. If a command
659 is pending then C<CMD_PENDING> is returned.
660
661 =item datasend ( DATA )
662
663 Send data to the remote server, converting LF to CRLF. Any line starting
664 with a '.' will be prefixed with another '.'.
665 C<DATA> may be an array or a reference to an array.
666
667 =item dataend ()
668
669 End the sending of data to the remote server. This is done by ensuring that
670 the data already sent ends with CRLF then sending '.CRLF' to end the
671 transmission. Once this data has been sent C<dataend> calls C<response> and
672 returns true if C<response> returns CMD_OK.
673
674 =back
675
676 =head1 CLASS METHODS
677
678 These methods are not intended to be called by the user, but used or 
679 over-ridden by a sub-class of C<Net::Cmd>
680
681 =over 4
682
683 =item debug_print ( DIR, TEXT )
684
685 Print debugging information. C<DIR> denotes the direction I<true> being
686 data being sent to the server. Calls C<debug_text> before printing to
687 STDERR.
688
689 =item debug_text ( TEXT )
690
691 This method is called to print debugging information. TEXT is
692 the text being sent. The method should return the text to be printed
693
694 This is primarily meant for the use of modules such as FTP where passwords
695 are sent, but we do not want to display them in the debugging information.
696
697 =item command ( CMD [, ARGS, ... ])
698
699 Send a command to the command server. All arguments a first joined with
700 a space character and CRLF is appended, this string is then sent to the
701 command server.
702
703 Returns undef upon failure
704
705 =item unsupported ()
706
707 Sets the status code to 580 and the response text to 'Unsupported command'.
708 Returns zero.
709
710 =item response ()
711
712 Obtain a response from the server. Upon success the most significant digit
713 of the status code is returned. Upon failure, timeout etc., I<undef> is
714 returned.
715
716 =item parse_response ( TEXT )
717
718 This method is called by C<response> as a method with one argument. It should
719 return an array of 2 values, the 3-digit status code and a flag which is true
720 when this is part of a multi-line response and this line is not the list.
721
722 =item getline ()
723
724 Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
725 upon failure.
726
727 B<NOTE>: If you do use this method for any reason, please remember to add
728 some C<debug_print> calls into your method.
729
730 =item ungetline ( TEXT )
731
732 Unget a line of text from the server.
733
734 =item rawdatasend ( DATA )
735
736 Send data to the remote server without performing any conversions. C<DATA>
737 is a scalar.
738
739 =item read_until_dot ()
740
741 Read data from the remote server until a line consisting of a single '.'.
742 Any lines starting with '..' will have one of the '.'s removed.
743
744 Returns a reference to a list containing the lines, or I<undef> upon failure.
745
746 =item tied_fh ()
747
748 Returns a filehandle tied to the Net::Cmd object.  After issuing a
749 command, you may read from this filehandle using read() or <>.  The
750 filehandle will return EOF when the final dot is encountered.
751 Similarly, you may write to the filehandle in order to send data to
752 the server after issuing a command that expects data to be written.
753
754 See the Net::POP3 and Net::SMTP modules for examples of this.
755
756 =back
757
758 =head1 EXPORTS
759
760 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
761 C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
762 of C<response> and C<status>. The sixth is C<CMD_PENDING>.
763
764 =head1 AUTHOR
765
766 Graham Barr <gbarr@pobox.com>
767
768 =head1 COPYRIGHT
769
770 Copyright (c) 1995-1997 Graham Barr. All rights reserved.
771 This program is free software; you can redistribute it and/or modify
772 it under the same terms as Perl itself.
773
774 =for html <hr>
775
776 I<$Id: //depot/libnet/Net/Cmd.pm#34 $>
777
778 =cut