DBD::Sponge corrected and lazy default PRECISION

lib/DBD/Sponge.pm

@@ -91,12 +91,13 @@
 		    || [ map { "col$_" } 1..$numFields ];
 	    $sth->{TYPE} = $attribs->{TYPE}
 		    || [ (DBI::SQL_VARCHAR()) x $numFields ];
-	    $sth->{PRECISION} = $attribs->{PRECISION}
-		    || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ];
 	    $sth->{SCALE} = $attribs->{SCALE}
 		    || [ (0) x $numFields ];
 	    $sth->{NULLABLE} = $attribs->{NULLABLE}
 		    || [ (2) x $numFields ];
+	    if ($attribs->{PRECISION}) {
+		    $sth->{PRECISION} = $attribs->{PRECISION};
+	    } # else FETCH will dynamically compute
 	}
 
 	$outer;
@@ -152,6 +153,7 @@
 	return $dbh->set_err(42, "not enough parameters") unless @args >= 2;
 	return \@args;
     }
+
 }
 
 
@@ -199,6 +201,10 @@
     sub FETCH {
 	my ($sth, $attrib) = @_;
 	# would normally validate and only fetch known attributes
+	if ($attrib eq 'PRECISION') {
+	    # prepare() did _not_ specify PRECISION.  We'll only get here once.
+	    return $sth->{PRECISION} = _max_col_lengths(@{$sth}{'NUM_OF_FIELDS', 'rows'});
+	}
 	# else pass up to DBI to handle
 	return $sth->SUPER::FETCH($attrib);
     }
@@ -209,6 +215,21 @@
 	# else pass up to DBI to handle
 	return $sth->SUPER::STORE($attrib, $value);
     }
+
+    sub _max_col_lengths {
+	# Compute result set PRECISION (data length) by looking for the
+	# max lengths of each column's data.
+	my ($numFields, $rows) = @_;
+	my @precision = (0,) x $numFields;
+	my $len;
+	for my $row (@$rows) {
+	    for my $i (0 .. $numFields - 1) {
+		next unless defined($len = length($row->[$i]));
+		$precision[$i] = $len if $len > $precision[$i];
+	    }
+	}
+	return wantarray ? @precision : \@precision;
+    }
 }
 
 1;
@@ -259,33 +280,38 @@ No username and password are needed.
 
 =item *
 
-The C<$statement> here is an arbitrary statement or name you want
-to provide as identity of your data. If you're using DBI::Profile
-it will appear in the profile data.
+The C<$statement> here is an arbitrary statement or name you want to
+provide as identity of your data. If you're using DBI::Profile it will
+appear in the profile data.
 
-Generally it's expected that you are preparing a statement handle
-as if a C<select> statement happened.
+Generally it's expected that you are preparing a statement handle as if
+a C<select> statement happened.
 
 =item *
 
-C<$data> is a reference to the data you are providing, given as an array of arrays.
+C<$data> is a reference to the data you are providing, given as an array
+of arrays.
 
 =item *
 
-C<$names> is a reference an array of column names for the C<$data> you are providing.
-The number and order should match the number and ordering of the C<$data> columns.
+C<$names> is a reference an array of column names for the C<$data> you
+are providing.  The number and order should match the number and
+ordering of the C<$data> columns.
 
 =item *
 
-C<%attr> is a hash of other standard DBI attributes that you might pass to a prepare statement.
+C<%attr> is a hash of other standard DBI attributes that you might pass
+to a prepare statement.
 
-Currently only NAME, TYPE, and PRECISION are supported.
+Currently only NAME, TYPE, and PRECISION are supported.  TYPE defaults
+to SQL_VARCHAR.  PRECISION will be lazily computed if not supplied.
 
 =back
 
 =head1 BUGS
 
-Using this module to prepare INSERT-like statements is not currently documented.
+Using this module to prepare INSERT-like statements is not currently
+documented.
 
 =head1 AUTHOR AND COPYRIGHT
 

t/xx_sponge.t

@@ -0,0 +1,66 @@
+#! /usr/bin/env perl
+
+# vim: noet ts=2 sw=2:
+
+use strict;
+use warnings;
+use Test::More tests => 17;
+
+use Storable qw(dclone);
+use DBI qw(:sql_types);
+
+# our reference table:
+#
+#   A1      B1        C2
+#  ------- --------- -------
+#  foo     NULL      bazooka
+#  foolery bar       NULL
+#  NULL    barrowman baz
+#
+
+our @NAMES = ( 'A0',      'B1',        'C2'      );
+our @ROWS  = (['foo',     undef,       'bazooka'],
+              ['foolery', 'bar',       undef    ],
+              [undef,     'barrowman', 'baz'    ]);
+
+my $dbh = DBI->connect("dbi:Sponge:", '', '');
+ok($dbh, "connect(dbi:Sponge:) succeeds");
+
+my $sth = $dbh->prepare("simple, correct sponge", {
+                        rows => dclone( \@ROWS ),
+                        NAME => [ @NAMES ],
+                        });
+
+ok($sth, "prepare() of 3x3 result succeeded");
+is_deeply($sth->{NAME}, ['A0', 'B1', 'C2'], "column NAMEs as expected");
+is_deeply($sth->{TYPE}, [SQL_VARCHAR, SQL_VARCHAR, SQL_VARCHAR],
+          "column TYPEs default to SQL_VARCHAR");
+#
+# Old versions of DBD-Sponge defaulted PRECISION (data "length") to
+# length of the field _names_ rather than the length of the _data_.
+#
+is_deeply($sth->{PRECISION}, [7, 9, 7],
+          "column PRECISION matches lengths of longest field data");
+is_deeply($sth->fetch(), $ROWS[0], "first row fetch as expected");
+is_deeply($sth->fetch(), $ROWS[1], "second row fetch as expected");
+is_deeply($sth->fetch(), $ROWS[2], "third row fetch as expected");
+ok(!defined($sth->fetch()), "fourth fetch returns undef");
+
+# Test that DBD-Sponge preserves bogus user-supplied attributes
+$sth = $dbh->prepare('user-supplied silly TYPE and PRECISION', {
+                     rows => dclone( \@ROWS ),
+                     NAME => [qw( first_col second_col third_col )],
+                     TYPE => [SQL_INTEGER, SQL_DATETIME, SQL_CHAR],
+                     PRECISION => [1, 100_000, 0],
+                     });
+ok($sth, "prepare() 3x3 result with TYPE and PRECISION succeeded");
+is_deeply($sth->{NAME}, ['first_col','second_col','third_col'],
+          "column NAMEs again as expected");
+is_deeply($sth->{TYPE}, [SQL_INTEGER, SQL_DATETIME, SQL_CHAR],
+          "column TYPEs not overwritten");
+is_deeply($sth->{PRECISION}, [1, 100_000, 0],
+          "column PRECISION not overwritten");
+is_deeply($sth->fetch(), $ROWS[0], "first row fetch as expected, despite bogus attributes");
+is_deeply($sth->fetch(), $ROWS[1], "second row fetch as expected, despite bogus attributes");
+is_deeply($sth->fetch(), $ROWS[2], "third row fetch as expected, despite bogus attributes");
+ok(!defined($sth->fetch()), "fourth fetch returns undef, despite bogus attributes");