X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource%2FRowParser%2FUtil.pm;h=7192e1b8c05fb0cf21205571963e54d73f0789ac;hb=5ff6d6034ddcb696d24c4b716b5c12f109004d1f;hp=a4e2eb5f72312689c44c3bb108c48cce7e7e0388;hpb=9f98c4b2ed917018f1587a48f72aeaf507118024;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource/RowParser/Util.pm b/lib/DBIx/Class/ResultSource/RowParser/Util.pm index a4e2eb5..7192e1b 100644 --- a/lib/DBIx/Class/ResultSource/RowParser/Util.pm +++ b/lib/DBIx/Class/ResultSource/RowParser/Util.pm @@ -4,7 +4,9 @@ package # hide from the pauses use strict; use warnings; -use B 'perlstring'; +use DBIx::Class::_Util qw( perlstring dump_value ); + +use constant HAS_DOR => ( "$]" < 5.010 ? 0 : 1 ); use base 'Exporter'; our @EXPORT_OK = qw( @@ -12,6 +14,13 @@ our @EXPORT_OK = qw( assemble_collapsing_parser ); +# working title - we are hoping to extract this eventually... +our $null_branch_class = 'DBIx::ResultParser::RelatedNullBranch'; + +sub __wrap_in_strictured_scope { + " { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" +} + sub assemble_simple_parser { #my ($args) = @_; @@ -24,12 +33,11 @@ sub assemble_simple_parser { # the data structure, then to fetch the data do: # push @rows, dclone($row_data_struct) while ($sth->fetchrow); # - my $parser_src = sprintf('$_ = %s for @{$_[0]}', __visit_infmap_simple($_[0]) ); - - # change the quoted placeholders to unquoted alias-references - $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$_->[$1]"/gex; - return $parser_src; + __wrap_in_strictured_scope( sprintf + '$_ = %s for @{$_[0]}', + __visit_infmap_simple( $_[0] ) + ); } # the simple non-collapsing nested structure recursor @@ -50,85 +58,129 @@ sub __visit_infmap_simple { my @relperl; for my $rel (sort keys %$rel_cols) { - # DISABLEPRUNE - #my $optional = $args->{is_optional}; - #$optional ||= ($args->{rsrc}->relationship_info($rel)->{attrs}{join_type} || '') =~ /^left/i; - - push @relperl, join ' => ', perlstring($rel), __visit_infmap_simple({ %$args, + my $rel_struct = __visit_infmap_simple({ %$args, val_index => $rel_cols->{$rel}, - # DISABLEPRUNE - #non_top => 1, - #is_optional => $optional, }); - # FIXME SUBOPTIMAL DISABLEPRUNE - disabled to satisfy t/resultset/inflate_result_api.t - #if ($optional and my @branch_null_checks = map - # { "(! defined '\xFF__VALPOS__${_}__\xFF')" } - # sort { $a <=> $b } values %{$rel_cols->{$rel}} - #) { - # $relperl[-1] = sprintf ( '(%s) ? ( %s => [] ) : ( %s )', - # join (' && ', @branch_null_checks ), - # perlstring($rel), - # $relperl[-1], - # ); - #} + if (keys %$my_cols) { + + my $branch_null_checks = join ' && ', map + { "( ! defined \$_->[$_] )" } + sort { $a <=> $b } values %{$rel_cols->{$rel}} + ; + + if ($args->{prune_null_branches}) { + $rel_struct = sprintf ( '( (%s) ? undef : %s )', + $branch_null_checks, + $rel_struct, + ); + } + else { + $rel_struct = sprintf ( '( (%s) ? bless( (%s), %s ) : %s )', + $branch_null_checks, + $rel_struct, + perlstring($null_branch_class), + $rel_struct, + ); + } + } + + push @relperl, sprintf '( %s => %s )', + perlstring($rel), + $rel_struct, + ; + } - my $me_struct = keys %$my_cols - ? __visit_dump({ map { $_ => "\xFF__VALPOS__$my_cols->{$_}__\xFF" } (keys %$my_cols) }) - : 'undef' - ; + my $me_struct; + $me_struct = __result_struct_to_source($my_cols) if keys %$my_cols; - return sprintf '[%s]', join (',', - $me_struct, - @relperl ? sprintf ('{ %s }', join (',', @relperl)) : (), - ); + if ($args->{hri_style}) { + $me_struct =~ s/^ \s* \{ | \} \s* $//gx + if $me_struct; + + return sprintf '{ %s }', join (', ', $me_struct||(), @relperl); + } + else { + return sprintf '[%s]', join (',', + $me_struct || 'undef', + @relperl ? sprintf ('{ %s }', join (',', @relperl)) : (), + ); + } } sub assemble_collapsing_parser { my $args = shift; - my ($top_node_key, $top_node_key_assembler); + my ($top_node_key, $top_node_key_assembler, $variant_idcols); if (scalar @{$args->{collapse_map}{-identifying_columns}}) { $top_node_key = join ('', map - { "{'\xFF__IDVALPOS__${_}__\xFF'}" } + { "{ \$cur_row_ids{$_} }" } @{$args->{collapse_map}{-identifying_columns}} ); + + $top_node_key_assembler = ''; } elsif( my @variants = @{$args->{collapse_map}{-identifying_columns_variants}} ) { my @path_parts = map { sprintf - "( ( defined '\xFF__VALPOS__%d__\xFF' ) && (join qq(\xFF), '', %s, '') )", - $_->[0], # checking just first is enough - one defined, all defined - ( join ', ', map { "'\xFF__VALPOS__${_}__\xFF'" } @$_ ), + "( ( defined \$cur_row_data->[%d] ) && (join qq(\xFF), '', %s, '') )", + $_->[0], # checking just first is enough - one ID defined, all defined + ( join ', ', map { $variant_idcols->{$_} = 1; " \$cur_row_ids{$_} " } @$_ ), } @variants; my $virtual_column_idx = (scalar keys %{$args->{val_index}} ) + 1; - $top_node_key_assembler = sprintf '$cur_row_ids{%d} = (%s);', - $virtual_column_idx, - "\n" . join( "\n or\n", @path_parts, qq{"\0\$rows_pos\0"} ); + $top_node_key = "{ \$cur_row_ids{$virtual_column_idx} }"; - $top_node_key = sprintf '{$cur_row_ids{%d}}', $virtual_column_idx; + $top_node_key_assembler = sprintf "( \$cur_row_ids{%d} = (%s) ),", + $virtual_column_idx, + "\n" . join( "\n or\n", @path_parts, qq{"\0\$rows_pos\0"} ) + ; $args->{collapse_map} = { %{$args->{collapse_map}}, -custom_node_key => $top_node_key, }; - } else { - die('Unexpected collapse map contents'); + DBIx::Class::Exception->throw( + 'Unexpected collapse map contents: ' . dump_value $args->{collapse_map}, + 1, + ) } my ($data_assemblers, $stats) = __visit_infmap_collapse ($args); - my $list_of_idcols = join(', ', sort { $a <=> $b } keys %{ $stats->{idcols_seen} } ); + # variants do not necessarily overlap with true idcols + my @row_ids = sort { $a <=> $b } keys %{ { + %{ $variant_idcols || {} }, + %{ $stats->{idcols_seen} }, + } }; + + my $row_id_defs = sprintf "( \@cur_row_ids{( %s )} = (\n%s\n ) ),", + join (', ', @row_ids ), + # in case we prune - we will never hit undefs/NULLs as pigeon-hole-criteria + ( $args->{prune_null_branches} + ? sprintf( '@{$cur_row_data}[( %s )]', join ', ', @row_ids ) + : join (",\n", map { + $stats->{nullchecks}{mandatory}{$_} + ? qq!( \$cur_row_data->[$_] )! + : do { + my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); + HAS_DOR + ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! + : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! + } + } @row_ids) + ) + ; - my $parser_src = sprintf (<<'EOS', $list_of_idcols, $top_node_key, $top_node_key_assembler||'', $data_assemblers); + my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler, $top_node_key, join( "\n", @$data_assemblers ) ); ### BEGIN LITERAL STRING EVAL - my ($rows_pos, $result_pos, $cur_row_data, %%cur_row_ids, @collapse_idx, $is_new_res) = (0,0); + my $rows_pos = 0; + my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); # this loop is a bit arcane - the rationale is that the passed in # $_[0] will either have only one row (->next) or will have all @@ -136,43 +188,56 @@ sub assemble_collapsing_parser { # result can be rather large - we reuse the same already allocated # array, since the collapsed prefetch is smaller by definition. # At the end we cut the leftovers away and move on. - while ($cur_row_data = - ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) or do { $rows_pos = -1; undef } ) - || - ($_[1] and $_[1]->()) - ) { - + while ($cur_row_data = ( + ( + $rows_pos >= 0 + and + ( + $_[0][$rows_pos++] + or + # It may be tempting to drop the -1 and undef $rows_pos instead + # thus saving the >= comparison above as well + # However NULL-handlers and underdefined root markers both use + # $rows_pos as a last-resort-uniqueness marker (it either is + # monotonically increasing while we parse ->all, or is set at + # a steady -1 when we are dealing with a single root node). For + # the time being the complication of changing all callsites seems + # overkill, for what is going to be a very modest saving of ops + ( ($rows_pos = -1), undef ) + ) + ) + or + ( $_[1] and $_[1]->() ) + ) ) { + + # the undef checks may or may not be there + # depending on whether we prune or not + # # due to left joins some of the ids may be NULL/undef, and # won't play well when used as hash lookups # we also need to differentiate NULLs on per-row/per-col basis - #(otherwise folding of optional 1:1s will be greatly confused - $cur_row_ids{$_} = defined $cur_row_data->[$_] ? $cur_row_data->[$_] : "\0NULL\xFF$rows_pos\xFF$_\0" - for (%1$s); + # (otherwise folding of optional 1:1s will be greatly confused +%s - # maybe(!) cache the top node id calculation - %3$s + # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) +%s - $is_new_res = ! $collapse_idx[0]%2$s and ( - $_[1] and $result_pos and (unshift @{$_[2]}, $cur_row_data) and last - ); + # if we were supplied a coderef - we are collapsing lazily (the set + # is ordered properly) + # as long as we have a result already and the next result is new we + # return the pre-read data and bail +( $_[1] and $result_pos and ! $collapse_idx[0]%s and (unshift @{$_[2]}, $cur_row_data) and last ), # the rel assemblers - %4$s +%s - $_[0][$result_pos++] = $collapse_idx[0]%2$s - if $is_new_res; } - splice @{$_[0]}, $result_pos; # truncate the passed in array for cases of collapsing ->all() + $#{$_[0]} = $result_pos - 1; # truncate the passed in array to where we filled it with results ### END LITERAL STRING EVAL EOS - # !!! note - different var than the one above - # change the quoted placeholders to unquoted alias-references - $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$cur_row_data->[$1]"/gex; - $parser_src =~ s/ \' \xFF__IDVALPOS__(\d+)__\xFF \' /"\$cur_row_ids{$1}"/gex; - - $parser_src; + __wrap_in_strictured_scope($parser_src); } @@ -182,7 +247,28 @@ sub __visit_infmap_collapse { my $cur_node_idx = ${ $args->{-node_idx_counter} ||= \do { my $x = 0} }++; - my ($my_cols, $rel_cols); + $args->{-mandatory_ids} ||= {}; + $args->{-seen_ids} ||= {}; + $args->{-all_or_nothing_sets} ||= []; + $args->{-null_from} ||= []; + + $args->{-seen_ids}{$_} = 1 + for @{$args->{collapse_map}->{-identifying_columns}}; + + my $node_specific_ids = { map { $_ => 1 } grep + { ! $args->{-parent_ids}{$_} } + @{$args->{collapse_map}->{-identifying_columns}} + }; + + if (not ( $args->{-chain_is_optional} ||= $args->{collapse_map}{-is_optional} ) ) { + $args->{-mandatory_ids}{$_} = 1 + for @{$args->{collapse_map}->{-identifying_columns}}; + } + elsif ( keys %$node_specific_ids > 1 ) { + push @{$args->{-all_or_nothing_sets}}, $node_specific_ids; + } + + my ($my_cols, $rel_cols) = {}; for ( keys %{$args->{val_index}} ) { if ($_ =~ /^ ([^\.]+) \. (.+) /x) { $rel_cols->{$1}{$2} = $args->{val_index}{$_}; @@ -192,108 +278,188 @@ sub __visit_infmap_collapse { } } + + if ($args->{hri_style}) { + delete $my_cols->{$_} for grep { $rel_cols->{$_} } keys %$my_cols; + } + + my $me_struct; + $me_struct = __result_struct_to_source($my_cols, 1) if keys %$my_cols; + + $me_struct = sprintf( '[ %s ]', $me_struct||'' ) + unless $args->{hri_style}; + + my $node_key = $args->{collapse_map}->{-custom_node_key} || join ('', map - { "{'\xFF__IDVALPOS__${_}__\xFF'}" } + { "{ \$cur_row_ids{$_} }" } @{$args->{collapse_map}->{-identifying_columns}} ); - - my $me_struct = $my_cols - ? __visit_dump([{ map { $_ => "\xFF__VALPOS__$my_cols->{$_}__\xFF" } (keys %$my_cols) }]) - : undef - ; my $node_idx_slot = sprintf '$collapse_idx[%d]%s', $cur_node_idx, $node_key; - my $parent_attach_slot = sprintf( '$collapse_idx[%d]%s[1]{%s}', - @{$args}{qw/-parent_node_idx -parent_node_key/}, - perlstring($args->{-node_relname}), - ) if $args->{-node_relname}; my @src; + if ($cur_node_idx == 0) { - push @src, sprintf( '%s ||= %s;', - $node_idx_slot, - $me_struct, - ) if $me_struct; - } - elsif ($args->{collapse_map}->{-is_single}) { - push @src, sprintf ( '%s ||= %s%s;', - $parent_attach_slot, + push @src, sprintf( '( %s %s $_[0][$result_pos++] = %s ),', $node_idx_slot, - $me_struct ? " ||= $me_struct" : '', + (HAS_DOR ? '//=' : '||='), + $me_struct || '{}', ); } else { - push @src, sprintf('push @{%s}, %s%s unless %s;', - $parent_attach_slot, - $node_idx_slot, - $me_struct ? " ||= $me_struct" : '', - $node_idx_slot, + my $parent_attach_slot = sprintf( '$collapse_idx[%d]%s%s{%s}', + @{$args}{qw/-parent_node_idx -parent_node_key/}, + $args->{hri_style} ? '' : '[1]', + perlstring($args->{-node_rel_name}), ); + + if ($args->{collapse_map}->{-is_single}) { + push @src, sprintf ( '( %s %s %s = %s ),', + $parent_attach_slot, + (HAS_DOR ? '//=' : '||='), + $node_idx_slot, + $me_struct || '{}', + ); + } + else { + push @src, sprintf('( (! %s) and push @{%s}, %s = %s ),', + $node_idx_slot, + $parent_attach_slot, + $node_idx_slot, + $me_struct || '{}', + ); + } } - # DISABLEPRUNE - #my $known_defined = { %{ $parent_info->{known_defined} || {} } }; - #$known_defined->{$_}++ for @{$args->{collapse_map}->{-identifying_columns}}; - my $stats; + my $known_present_ids = { map { $_ => 1 } @{$args->{collapse_map}{-identifying_columns}} }; + my $rel_src; + for my $rel (sort keys %$rel_cols) { -# push @src, sprintf( -# '%s[1]{%s} ||= [];', $node_idx_slot, perlstring($rel) -# ) unless $args->{collapse_map}->{$rel}{-is_single}; + my $relinfo = $args->{collapse_map}{$rel}; - ($src[$#src + 1], $stats->{$rel}) = __visit_infmap_collapse({ %$args, + ($rel_src) = __visit_infmap_collapse({ %$args, val_index => $rel_cols->{$rel}, - collapse_map => $args->{collapse_map}{$rel}, + collapse_map => $relinfo, -parent_node_idx => $cur_node_idx, -parent_node_key => $node_key, - -node_relname => $rel, + -parent_id_path => [ @{$args->{-parent_id_path}||[]}, sort { $a <=> $b } keys %$node_specific_ids ], + -parent_ids => { map { %$_ } $node_specific_ids, $args->{-parent_ids}||{} }, + -node_rel_name => $rel, }); - # FIXME SUBOPTIMAL DISABLEPRUNE - disabled to satisfy t/resultset/inflate_result_api.t - #if ($args->{collapse_map}->{$rel}{-is_optional} and my @null_checks = map - # { "(! defined '\xFF__IDVALPOS__${_}__\xFF')" } - # sort { $a <=> $b } grep - # { ! $known_defined->{$_} } - # @{$args->{collapse_map}->{$rel}{-identifying_columns}} - #) { - # $src[-1] = sprintf( '(%s) or %s', - # join (' || ', @null_checks ), - # $src[-1], - # ); - #} - } + my $rel_src_pos = $#src + 1; + push @src, @$rel_src; - return ( - join("\n", @src), - { - idcols_seen => { - ( map { %{ $_->{idcols_seen} } } values %$stats ), - ( map { $_ => 1 } @{$args->{collapse_map}->{-identifying_columns}} ), + if ( + $relinfo->{-is_optional} + ) { + + my ($first_distinct_child_idcol) = grep + { ! $known_present_ids->{$_} } + @{$relinfo->{-identifying_columns}} + ; + + DBIx::Class::Exception->throw( + "An optional node *without* a distinct identifying set shouldn't be possible: " . dump_value $args->{collapse_map}, + 1, + ) unless defined $first_distinct_child_idcol; + + if ($args->{prune_null_branches}) { + + # start of wrap of the entire chain in a conditional + splice @src, $rel_src_pos, 0, sprintf "( ( ! defined %s )\n ? %s%s{%s} = %s\n : do {", + "\$cur_row_data->[$first_distinct_child_idcol]", + $node_idx_slot, + $args->{hri_style} ? '' : '[1]', + perlstring($rel), + ($args->{hri_style} && $relinfo->{-is_single}) ? 'undef' : '[]' + ; + + # end of wrap + push @src, '} ),' + } + else { + + splice @src, $rel_src_pos + 1, 0, sprintf ( '( (defined %s) or bless (%s[1]{%s}, %s) ),', + "\$cur_row_data->[$first_distinct_child_idcol]", + $node_idx_slot, + perlstring($rel), + perlstring($null_branch_class), + ); } } + } + + if ( + + # calculation only valid for leaf nodes + ! values %$rel_cols + + and + + # child of underdefined path doesn't leave us anything to test + @{$args->{-parent_id_path} || []} + + and + + (my @nullable_portion = grep + { ! $args->{-mandatory_ids}{$_} } + ( + @{$args->{-parent_id_path}}, + sort { $a <=> $b } keys %$node_specific_ids + ) + ) > 1 + ) { + # there may be 1:1 overlap with a specific all_or_nothing + push @{$args->{-null_from}}, \@nullable_portion unless grep + { + my $a_o_n_set = $_; + + keys %$a_o_n_set == @nullable_portion + and + ! grep { ! $a_o_n_set->{$_} } @nullable_portion + } + @{ $args->{-all_or_nothing_sets} || [] } + ; + } + + return ( + \@src, + ( $cur_node_idx != 0 ) ? () : { + idcols_seen => $args->{-seen_ids}, + nullchecks => { + ( keys %{$args->{-mandatory_ids} } + ? ( mandatory => $args->{-mandatory_ids} ) + : () + ), + ( @{$args->{-all_or_nothing_sets}} + ? ( all_or_nothing => $args->{-all_or_nothing_sets} ) + : () + ), + ( @{$args->{-null_from}} + ? ( from_first_encounter => $args->{-null_from} ) + : () + ), + }, + }, ); } -# keep our own DD object around so we don't have to fitz with quoting -my $dumper_obj; -sub __visit_dump { - # we actually will be producing functional perl code here, - # thus no second-guessing of what these globals might have - # been set to. DO NOT CHANGE! - ($dumper_obj ||= do { - require Data::Dumper; - Data::Dumper->new([]) - ->Useperl (0) - ->Purity (1) - ->Pad ('') - ->Useqq (0) - ->Terse (1) - ->Quotekeys (1) - ->Deepcopy (0) - ->Deparse (0) - ->Maxdepth (0) - ->Indent (0) # faster but harder to read, perhaps leave at 1 ? - })->Values ([$_[0]])->Dump; +sub __result_struct_to_source { + my ($data, $is_collapsing) = @_; + + sprintf( '{ %s }', + join (', ', map { + sprintf ( "%s => %s", + perlstring($_), + $is_collapsing + ? "\$cur_row_data->[$data->{$_}]" + : "\$_->[ $data->{$_} ]" + ) + } sort keys %{$data} + ) + ); } 1;