Improve code()/message() initialization and error handling in Net::Cmd

Amongst other things, this fixes a problem of obsolete error codes being
returned after connection failure.

Patch by Tom Metro <tmetro@cpan.org> on CPAN RT#14875 with minor changes
by the committer to apply the patch to the current source.

1 files changed, 113 insertions, 38 deletions

diff --git a/lib/Net/Cmd.pm b/lib/Net/Cmd.pm
index 9bf9f4f..61e6956 100644
--- a/lib/Net/Cmd.pm
+++ b/lib/Net/Cmd.pm
@@ -52,6 +52,8 @@ use constant CMD_REJECT  => 4;
 use constant CMD_ERROR   => 5;
 use constant CMD_PENDING => 0;
 
+use constant DEF_REPLY_CODE => 421;
+
 my %debug = ();
 
 my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
@@ -171,7 +173,7 @@ sub code {
 
   my $cmd = shift;
 
-  ${*$cmd}{'net_cmd_code'} = "000"
+  ${*$cmd}{'net_cmd_code'} = $cmd->DEF_REPLY_CODE
     unless exists ${*$cmd}{'net_cmd_code'};
 
   ${*$cmd}{'net_cmd_code'};
@@ -202,14 +204,38 @@ sub set_status {
 }
 
 
-sub command {
+
+sub _set_status_timeout {
+  my $cmd = shift;
+  my $pkg = ref($cmd) || $cmd;
+
+  $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Timeout");
+  carp(ref($cmd) . ": " . (caller(1))[3] . "(): timeout") if $cmd->debug;
+}
+
+sub _set_status_closed {
   my $cmd = shift;
+  my $pkg = ref($cmd) || $cmd;
+
+  $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Connection closed");
+  carp(ref($cmd) . ": " . (caller(1))[3]
+    . "(): unexpected EOF on command channel: $!") if $cmd->debug;
+}
 
-  unless (defined fileno($cmd)) {
-    $cmd->set_status("599", "Connection closed");
-    return $cmd;
+sub _is_closed {
+  my $cmd = shift;
+  if (!defined fileno($cmd)) {
+     $cmd->_set_status_closed;
+     return 1;
   }
+  return 0;
+}
+
+sub command {
+  my $cmd = shift;
 
+  return $cmd
+    if $cmd->_is_closed;
 
   $cmd->dataend()
     if (exists ${*$cmd}{'net_cmd_last_ch'});
@@ -231,14 +257,14 @@ sub command {
     my $len = length $str;
     my $swlen;
 
-    $cmd->close
-      unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
-
     $cmd->debug_print(1, $str)
       if ($cmd->debug);
 
-    ${*$cmd}{'net_cmd_resp'} = [];       # the response
-    ${*$cmd}{'net_cmd_code'} = "000";    # Made this one up :-)
+    unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len) {
+      $cmd->close;
+      $cmd->_set_status_closed;
+      return $cmd;
+    }
   }
 
   $cmd;
@@ -256,8 +282,8 @@ sub ok {
 sub unsupported {
   my $cmd = shift;
 
-  ${*$cmd}{'net_cmd_resp'} = ['Unsupported command'];
-  ${*$cmd}{'net_cmd_code'} = 580;
+  $cmd->set_status(580, 'Unsupported command');
+
   0;
 }
 
@@ -271,11 +297,11 @@ sub getline {
     if scalar(@{${*$cmd}{'net_cmd_lines'}});
 
   my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
-  my $fd      = fileno($cmd);
 
   return
-    unless defined $fd;
+    if $cmd->_is_closed;
 
+  my $fd = fileno($cmd);
   my $rin = "";
   vec($rin, $fd, 1) = 1;
 
@@ -288,9 +314,8 @@ sub getline {
     my $select_ret = select($rout = $rin, undef, undef, $timeout);
     if ($select_ret > 0) {
       unless (sysread($cmd, $buf = "", 1024)) {
-        carp(ref($cmd) . ": Unexpected EOF on command channel")
-          if $cmd->debug;
         $cmd->close;
+        $cmd->_set_status_closed;
         return;
       }
 
@@ -304,8 +329,7 @@ sub getline {
 
     }
     else {
-      my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
-      carp("$cmd: $msg") if ($cmd->debug);
+      $cmd->_set_status_timeout;
       return;
     }
   }
@@ -341,7 +365,7 @@ sub response {
   my $cmd = shift;
   my ($code, $more) = (undef) x 2;
 
-  ${*$cmd}{'net_cmd_resp'} ||= [];
+  $cmd->set_status($cmd->DEF_REPLY_CODE, undef); # initialize the response
 
   while (1) {
     my $str = $cmd->getline();
@@ -354,9 +378,10 @@ sub response {
 
     ($code, $more) = $cmd->parse_response($str);
     unless (defined $code) {
+      carp("$cmd: response(): parse error in '$str'") if ($cmd->debug);
       $cmd->ungetline($str);
       $@ = $str;   # $@ used as tunneling hack
-      last;
+      return CMD_ERROR;
     }
 
     ${*$cmd}{'net_cmd_code'} = $code;
@@ -407,7 +432,8 @@ sub datasend {
   # $line is a string (in internal UTF-8)
   utf8::encode($line) if is_utf8($line);
 
-  return 0 unless defined(fileno($cmd));
+  return 0
+    if $cmd->_is_closed;
 
   my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
 
@@ -457,15 +483,16 @@ sub datasend {
     if ((defined $s and $s > 0) or -f $cmd)    # -f for testing on win32
     {
       my $w = syswrite($cmd, $line, $len, $offset);
-      unless (defined($w)) {
-        carp("$cmd: $!") if $cmd->debug;
+      unless (defined($w) && $w == $len) {
+        $cmd->close;
+        $cmd->_set_status_closed;
         return;
       }
       $len -= $w;
       $offset += $w;
     }
     else {
-      carp("$cmd: Timeout") if ($cmd->debug);
+      $cmd->_set_status_timeout;
       return;
     }
   }
@@ -479,7 +506,8 @@ sub rawdatasend {
   my $arr  = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
   my $line = join("", @$arr);
 
-  return 0 unless defined(fileno($cmd));
+  return 0
+    if $cmd->_is_closed;
 
   return 1
     unless length($line);
@@ -500,15 +528,16 @@ sub rawdatasend {
     my $wout;
     if (select(undef, $wout = $win, undef, $timeout) > 0) {
       my $w = syswrite($cmd, $line, $len, $offset);
-      unless (defined($w)) {
-        carp("$cmd: $!") if $cmd->debug;
+      unless (defined($w) && $w == $len) {
+        $cmd->close;
+        $cmd->_set_status_closed;
         return;
       }
       $len -= $w;
       $offset += $w;
     }
     else {
-      carp("$cmd: Timeout") if ($cmd->debug);
+      $cmd->_set_status_timeout;
       return;
     }
   }
@@ -520,7 +549,8 @@ sub rawdatasend {
 sub dataend {
   my $cmd = shift;
 
-  return 0 unless defined(fileno($cmd));
+  return 0
+    if $cmd->_is_closed;
 
   my $ch = ${*$cmd}{'net_cmd_last_ch'};
   my $tosend;
@@ -539,7 +569,14 @@ sub dataend {
   $cmd->debug_print(1, ".\n")
     if ($cmd->debug);
 
-  syswrite($cmd, $tosend, length $tosend);
+  my $len = length $tosend;
+  my $w = syswrite($cmd, $tosend, $len);
+  unless (defined($w) && $w == $len)
+  {
+    $cmd->close;
+    $cmd->_set_status_closed;
+    return 0;
+  }
 
   delete ${*$cmd}{'net_cmd_last_ch'};
 
@@ -661,12 +698,12 @@ debug level for a given class.
 
 Returns the text message returned from the last command. In a scalar
 context it returns a single string, in a list context it will return
-each line as a separate element
+each line as a separate element. (See L<PSEUDO RESPONSES> below.)
 
 =item code ()
 
 Returns the 3-digit code from the last command. If a command is pending
-then the value 0 is returned
+then the value 0 is returned. (See L<PSEUDO RESPONSES> below.)
 
 =item ok ()
 
@@ -707,21 +744,21 @@ Print debugging information. C<DIR> denotes the direction I<true> being
 data being sent to the server. Calls C<debug_text> before printing to
 STDERR.
 
-=item debug_text ( TEXT )
+=item debug_text ( DIR, TEXT )
 
 This method is called to print debugging information. TEXT is
-the text being sent. The method should return the text to be printed
+the text being sent. The method should return the text to be printed.
 
 This is primarily meant for the use of modules such as FTP where passwords
 are sent, but we do not want to display them in the debugging information.
 
 =item command ( CMD [, ARGS, ... ])
 
-Send a command to the command server. All arguments a first joined with
+Send a command to the command server. All arguments are first joined with
 a space character and CRLF is appended, this string is then sent to the
 command server.
 
-Returns undef upon failure
+Returns undef upon failure.
 
 =item unsupported ()
 
@@ -731,14 +768,14 @@ Returns zero.
 =item response ()
 
 Obtain a response from the server. Upon success the most significant digit
-of the status code is returned. Upon failure, timeout etc., I<undef> is
+of the status code is returned. Upon failure, timeout etc., I<CMD_ERROR> is
 returned.
 
 =item parse_response ( TEXT )
 
 This method is called by C<response> as a method with one argument. It should
 return an array of 2 values, the 3-digit status code and a flag which is true
-when this is part of a multi-line response and this line is not the list.
+when this is part of a multi-line response and this line is not the last.
 
 =item getline ()
 
@@ -776,6 +813,44 @@ See the Net::POP3 and Net::SMTP modules for examples of this.
 
 =back
 
+=head1 PSEUDO RESPONSES
+
+Normally the values returned by C<message()> and C<code()> are
+obtained from the remote server, but in a few circumstances, as
+detailed below, C<Net::Cmd> will return values that it sets. You
+can alter this behavior by overriding DEF_REPLY_CODE() to specify
+a different default reply code, or overriding one of the specific
+error handling methods below.
+
+=over 4
+
+=item Initial value
+
+Before any command has executed or if an unexpected error occurs
+C<code()> will return "421" (temporary connection failure) and
+C<message()> will return undef.
+
+=item Connection closed
+
+If the underlying C<IO::Handle> is closed, or if there are
+any read or write failures, the file handle will be forced closed,
+and C<code()> will return "421" (temporary connection failure)
+and C<message()> will return "[$pkg] Connection closed"
+(where $pkg is the name of the class that subclassed C<Net::Cmd>).
+The _set_status_closed() method can be overridden to set a different
+message (by calling set_status()) or otherwise trap this error.
+
+=item Timeout
+
+If there is a read or write timeout C<code()> will return "421"
+(temporary connection failure) and C<message()> will return
+"[$pkg] Timeout" (where $pkg is the name of the class
+that subclassed C<Net::Cmd>). The _set_status_timeout() method
+can be overridden to set a different message (by calling set_status())
+or otherwise trap this error.
+
+=back
+
 =head1 EXPORTS
 
 C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,