Allow wcols to obey FORMAT option.

The code to determine whether the output size agreed with the format string size was only activated when the format string was input as the first argument, not in the options hash. This change activates it for both cases. Added some tests as well.
PDLPorters · Aug 5, 2016 · e0c13c8 · e0c13c8
1 parent 3aff627
commit e0c13c8
Show file tree

Hide file tree

Showing 2 changed files with 34 additions and 13 deletions.
diff --git a/IO/Misc/misc.pd b/IO/Misc/misc.pd
@@ -787,10 +787,10 @@ wantarray ? return(@ret) : return $ret[0];
 Can take file name or *HANDLE, and if no file/filehandle is given defaults to STDOUT.
 
   Options (case insensitive):
-  
+
     HEADER - prints this string before the data. If the string
              is not terminated by a newline, one is added. (default B<''>).
-  
+
     COLSEP - prints this string between colums of data. Defaults to
              $PDL::IO::Misc::defcolsep.
 
@@ -806,7 +806,7 @@ Can take file name or *HANDLE, and if no file/filehandle is given defaults to ST
    or 2D piddles (as might be returned from rcols() with the [] column
    syntax and/or using the PERLCOLS option).  dim(0) of all piddles
    written must be the same size.  The printf-style $format_string,
-   if given, overrides a any FORMAT key settings in the option hash 
+   if given, overrides any FORMAT key settings in the option hash.
 
 e.g.,
 
@@ -833,11 +833,11 @@ e.g.,
   wcols $b, $a52, $c  # ...and mix and match with 1D listrefs as well
 
   NOTES:
-  
+
   1. Columns are separated by whitespace by default, use
      C<$PDL::IO::Misc::defcolsep> to modify the default value or
      the COLSEP option
-  
+
   2. Support for the C<$PDL::IO::Misc::colsep> global value
      of PDL-2.4.6 and earlier is maintained but the initial value
      of the global is undef until you set it.  The value will be
@@ -867,12 +867,14 @@ sub PDL::wcols {
 	   elsif ( $key =~ /^COLSEP/i ) { $usecolsep = $opt->{$key}; }  # option: COLSEP
 	   elsif ( $key =~ /^FORMAT/i ) { $format_string = $opt->{$key}; }  # option: FORMAT
            else {
-               print "Warning: wcols does not understand option <$key>.\n"; 
+               print "Warning: wcols does not understand option <$key>.\n";
            }
        }
    }
-   if (ref(\$_[0]) eq "SCALAR") {
-       $step = $format_string = shift; # 1st arg not piddle, explicit overrides option hash
+   if (ref(\$_[0]) eq "SCALAR" || $format_string) {
+       $format_string = shift if (ref(\$_[0]) eq "SCALAR");
+       # 1st arg not piddle, explicit format string overrides option hash FORMAT
+       $step = $format_string;
        $step =~ s/(%%|[^%])//g;  # use step to count number of format items
        $step = length ($step);
    }

diff --git a/t/misc.t b/t/misc.t
@@ -13,7 +13,7 @@ use File::Temp qw( tempfile tempdir );
 
 kill 'INT',$$  if $ENV{UNDER_DEBUGGER}; # Useful for debugging.
 
-use Test::More tests => 19;
+use Test::More tests => 23;
 
 sub tapprox {
         my($a,$b) = @_;
@@ -42,7 +42,7 @@ close($fileh);
 }
 
 is( (sum($a<0)==2 && $a->getdim(0)==5 && $a->getdim(1)==3), 1, "rcols with undefval and missing cols" );
-unlink $file;
+unlink $file || warn "Could not unlink $file: $!";
 
 ############# Test rcols with filename and pattern #############
 
@@ -142,7 +142,7 @@ is( abs($b->sum - 5.13147) < .01, 1, "rasc on existing piddle" );
 eval '$b->rasc("file_that_does_not_exist")';
 like( $@, qr/Can't open/, "rasc on non-existant file" );
 
-unlink $file; # clean up
+unlink $file || warn "Could not unlink $file: $!"; # clean up
 
 #######################################################
 # Tests of rcols() options
@@ -192,12 +192,31 @@ $PDL::IO::Misc::deftype = short;
 ($a,$b) = rcols $file;
 is( $a->get_datatype, short->[0], "rcols: can read in as 'short'" );
 
-unlink $file;
+unlink $file || warn "Could not unlink $file: $!";
 
 ($fileh,$file) = tempfile( DIR => $tempd );
 eval { wcols $a, $b, $fileh };
 is(!$@,1, "wcols" );
-unlink $fileh;
+unlink $file || warn "Could not unlink $file: $!";
+
+($fileh,$file) = tempfile( DIR => $tempd );
+eval { wcols $a, $b, $fileh, {FORMAT=>"%0.3d %0.3d"}};
+is(!$@,1, "wcols FORMAT option");
+unlink $file || warn "Could not unlink $file: $!";
+
+($fileh,$file) = tempfile( DIR => $tempd );
+eval { wcols "%d %d", $a, $b, $fileh;};
+is(!$@,1, "wcols format_string");
+unlink $file || warn "Could not unlink $file: $!";
+
+($fileh,$file) = tempfile( DIR => $tempd );
+eval { wcols "arg %d %d", $a, $b, $fileh, {FORMAT=>"option %d %d"};};
+is(!$@,1, "wcols format_string override");
+
+open($fileh,"<",$file) or warn "Can't open $file: $!";
+chomp(my $line=readline(*$fileh));
+like(my $line=readline($fileh),qr/^arg/, "wcols format_string obeyed");
+unlink $file || warn "Could not unlink $file: $!";
 
 1;