From: Peter Rabbitson Date: Tue, 5 Aug 2014 10:13:16 +0000 (+0200) Subject: Fix both a dubious test and a regression in populate args immutability X-Git-Tag: v0.082800~85 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a768c9067712d4f9512748c315c617367fe8dc4;p=dbsrgits%2FDBIx-Class.git Fix both a dubious test and a regression in populate args immutability The rewrite in d0cefd99 optimized populate enough that the same data structure would now make it all the way to the stringifier in ::Storage. This was not caught due to a deficient test. Read diff under -w for maximum sense --- diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index b3eda3e..fe503b4 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -2038,16 +2038,6 @@ sub insert { sub insert_bulk { my ($self, $source, $cols, $data) = @_; - # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD - # For the time being forcibly stringify whatever is stringifiable - # ResultSet::populate() hands us a copy - safe to mangle - for my $r (0 .. $#$data) { - for my $c (0 .. $#{$data->[$r]}) { - $data->[$r][$c] = "$data->[$r][$c]" - if ( length ref $data->[$r][$c] and is_plain_value $data->[$r][$c] ); - } - } - my $colinfos = $source->columns_info($cols); local $self->{_autoinc_supplied_for_op} = @@ -2282,7 +2272,7 @@ sub _dbh_execute_for_fetch { return undef if ++$fetch_row_idx > $#$data; return [ map { - ! defined $_->{_literal_bind_subindex} + my $v = ! defined $_->{_literal_bind_subindex} ? $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] @@ -2294,7 +2284,14 @@ sub _dbh_execute_for_fetch { [ ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]}->[ $_->{_literal_bind_subindex} ] ], {}, # a fake column_info bag )->[0][1] + ; + # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD + # For the time being forcibly stringify whatever is stringifiable + (length ref $v and is_plain_value $v) + ? "$v" + : $v + ; } map { $_->[0] } @$proto_bind ]; }; diff --git a/t/100populate.t b/t/100populate.t index 16c1e6d..57efc72 100644 --- a/t/100populate.t +++ b/t/100populate.t @@ -395,79 +395,108 @@ warnings_like { my $rank = Math::BigInt->new(42); my $args = { - 'stringifying objects after regular values' => [ map - { { name => $_, rank => $rank } } - ( + 'stringifying objects after regular values' => { AoA => [ + [qw( name rank )], + ( map { [ $_, $rank ] } ( 'supplied before stringifying objects', 'supplied before stringifying objects 2', $fn, $fn2, - ) - ], - 'stringifying objects before regular values' => [ map - { { name => $_, rank => $rank } } - ( + )), + ]}, + + 'stringifying objects before regular values' => { AoA => [ + [qw( rank name )], + ( map { [ $rank, $_ ] } ( $fn, $fn2, 'supplied after stringifying objects', 'supplied after stringifying objects 2', - ) - ], - 'stringifying objects between regular values' => [ map - { { name => $_, rank => $rank } } - ( + )), + ]}, + + 'stringifying objects between regular values' => { AoA => [ + [qw( name rank )], + ( map { [ $_, $rank ] } ( 'supplied before stringifying objects', $fn, $fn2, 'supplied after stringifying objects', - ) - ], - 'stringifying objects around regular values' => [ map - { { name => $_, rank => $rank } } - ( + )) + ]}, + + 'stringifying objects around regular values' => { AoA => [ + [qw( rank name )], + ( map { [ $rank, $_ ] } ( $fn, 'supplied between stringifying objects', $fn2, - ) - ], + )) + ]}, + + 'single stringifying object' => { AoA => [ + [qw( rank name )], + [ $rank, $fn ], + ]}, }; - local $Storable::canonical = 1; - my $preimage = nfreeze([$fn, $fn2, $rank, $args]); + # generate the AoH equivalent based on the AoAs above + for my $bag (values %$args) { + my @hdr = @{$bag->{AoA}[0]}; + for my $v ( @{$bag->{AoA}}[1..$#{$bag->{AoA}}] ) { + push @{$bag->{AoH}}, my $h = {}; + @{$h}{@hdr} = @$v; + } + } - for my $tst (keys %$args) { + local $Storable::canonical = 1; + my $preimage = nfreeze($args); - # test void ctx - $rs->delete; - $rs->populate($args->{$tst}); - is_deeply( - $rs->all_hri, - $args->{$tst}, - "Populate() $tst in void context" - ); - # test non-void ctx - $rs->delete; - my $dummy = $rs->populate($args->{$tst}); - is_deeply( - $rs->all_hri, - $args->{$tst}, - "Populate() $tst in non-void context" - ); + for my $tst (keys %$args) { + for my $type (qw(AoA AoH)) { + + # test void ctx + $rs->delete; + $rs->populate($args->{$tst}{$type}); + is_deeply( + $rs->all_hri, + $args->{$tst}{AoH}, + "Populate() $tst in void context" + ); + + # test scalar ctx + $rs->delete; + my $dummy = $rs->populate($args->{$tst}{$type}); + is_deeply( + $rs->all_hri, + $args->{$tst}{AoH}, + "Populate() $tst in non-void context" + ); + + # test list ctx + $rs->delete; + my @dummy = $rs->populate($args->{$tst}{$type}); + is_deeply( + $rs->all_hri, + $args->{$tst}{AoH}, + "Populate() $tst in non-void context" + ); + } # test create() as we have everything set up already $rs->delete; - $rs->create($_) for @{$args->{$tst}}; + $rs->create($_) for @{$args->{$tst}{AoH}}; is_deeply( $rs->all_hri, - $args->{$tst}, + $args->{$tst}{AoH}, "Create() $tst" ); } ok ( - ($preimage eq nfreeze( [$fn, $fn2, $rank, $args] )), + ($preimage eq nfreeze($args)), 'Arguments fed to populate()/create() unchanged' ); @@ -482,7 +511,7 @@ warnings_like { ) ? () # one unique for populate() and create() each - : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2 + : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 4 ], 'Data integrity warnings as planned'; $schema->is_executed_sql_bind(