Merge pull request #12 from pilcrow/sponge-PRECISION

DBD::Sponge corrected and lazy default PRECISION

Author: Tux

lib/DBD/Sponge.pm

@@ -93,12 +93,15 @@ use warnings;
 		    || [ 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 ];
+	    # Allow user to specify precision, otherwise
+	    # FETCH will lazily compute if needed
+	    if ($attribs->{PRECISION}) {
+		    $sth->{PRECISION} = $attribs->{PRECISION};
+	    }
 	}
 
 	$outer;
@@ -154,6 +157,7 @@ use warnings;
 	return $dbh->set_err(42, "not enough parameters") unless @args >= 2;
 	return \@args;
     }
+
 }
 
 
@@ -202,6 +206,11 @@ use warnings;
 	my ($sth, $attrib) = @_;
 	# would normally validate and only fetch known attributes
 	# else pass up to DBI to handle
+
+	if ($attrib eq 'PRECISION') {
+	    # prepare() did _not_ specify PRECISION, so lazily compute it now
+	    return $sth->{PRECISION} = _max_col_lengths(@{$sth}{'NUM_OF_FIELDS', 'rows'});
+	}
 	return $sth->SUPER::FETCH($attrib);
     }
 
@@ -211,6 +220,22 @@ use warnings;
 	# else pass up to DBI to handle
 	return $sth->SUPER::STORE($attrib, $value);
     }
+
+    sub _max_col_lengths {
+	# compute our columns' PRECISION (data length) by looking for the
+	# max lengths of each column's data, row by row
+	my ($num_of_fields, $rows) = @_;
+	my @precision = (0,) x $num_of_fields;
+	my $n = $num_of_fields - 1;
+	my $len;
+	for my $row (@$rows) {
+	    for my $i (0 .. $n) {
+		next unless defined($len = length($row->[$i]));
+		$precision[$i] = $len if $len > $precision[$i];
+	    }
+	}
+	return \@precision;
+    }
 }
 
 1;
@@ -261,33 +286,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,72 @@
+#! /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:
+#
+#   A0      B1        C2
+#  ------- --------- -------
+#  foo     NULL      bazooka
+#  foolery bar       NULL
+#  NULL    barrowman baz
+#
+
+# Historically, DBD::Sponge defaulted an sth's PRECISION to the length
+# of its column names, meaning that some DBI shells could truncate row
+# display.  For example, formatting a row ('fo', NULL, 'ba') from our
+# reference table above.
+
+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 but
+# ignores them when returning rows
+$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");