$attrs->{where}, $attrs
);
- return (@data ? ($self->_construct_object(@data))[0] : undef);
+ return @data
+ ? ($self->_construct_objects(@data))[0]
+ : undef
+ ;
}
: $self->cursor->next
);
return undef unless (@row);
- my ($row, @more) = $self->_construct_object(@row);
+ my ($row, @more) = $self->_construct_objects(@row);
$self->{stashed_objects} = \@more if @more;
return $row;
}
-sub _construct_object {
+# takes a single DBI-row of data and coinstructs as many objects
+# as the resultset attributes call for.
+# This can be a bit of an action at a distance - it takes as an argument
+# the *current* cursor-row (already taken off the $sth), but if
+# collapsing is requested it will keep advancing the cursor either
+# until the current row-object is assembled (the collapser was able to
+# order the result sensibly) OR until the cursor is exhausted (an
+# unordered collapsing resultset effectively triggers ->all)
+
+# FIXME: why the *FUCK* do we pass around DBI data by copy?! Sadly needs
+# assessment before changing...
+#
+sub _construct_objects {
my ($self, @row) = @_;
- my $info = $self->_collapse_result($self->{_attrs}{as}, \@row)
+ my $attrs = $self->_resolved_attrs;
+ my $keep_collapsing = $attrs->{collapse};
+
+ my $res_index;
+=begin
+ do {
+ my $me_pref_col = $attrs->{_row_parser}->($row_ref);
+
+ my $container;
+ if ($keep_collapsing) {
+
+ # FIXME - we should be able to remove these 2 checks after the design validates
+ $self->throw_exception ('Collapsing without a top-level collapse-set... can not happen')
+ unless @{$me_ref_col->[2]};
+ $self->throw_exception ('Top-level collapse-set contains a NULL-value... can not happen')
+ if grep { ! defined $_ } @{$me_pref_col->[2]};
+
+ my $main_ident = join "\x00", @{$me_pref_col->[2]};
+
+ if (! $res_index->{$main_ident}) {
+ # this is where we bail out IFF we are ordered, and the $main_ident changes
+
+ $res_index->{$main_ident} = {
+ all_me_pref => [,
+ index => scalar keys %$res_index,
+ };
+ }
+ }
+
+
+
+ $container = $res_index->{$main_ident}{container};
+ };
+
+ push @$container, [ @{$me_pref_col}[0,1] ];
+
+
+
+ } while (
+ $keep_collapsing
+ &&
+ do { $row_ref = [$self->cursor->next]; $self->{stashed_row} = $row_ref if @$row_ref; scalar @$row_ref }
+ );
+
+ # attempt collapse all rows with same collapse identity
+ if (@to_collapse > 1) {
+ my @collapsed;
+ while (@to_collapse) {
+ $self->_merge_result(\@collapsed, shift @to_collapse);
+ }
+ }
+=cut
+
+ my $mepref_structs = $self->_collapse_result(\@row)
or return ();
- my @new = $self->result_class->inflate_result($self->result_source, @$info);
- @new = $self->{_attrs}{record_filter}->(@new)
- if exists $self->{_attrs}{record_filter};
- return @new;
+
+ my $rsrc = $self->result_source;
+ my $res_class = $self->result_class;
+ my $inflator = $res_class->can ('inflate_result');
+
+ my @objs = map {
+ $res_class->$inflator ($rsrc, @$_)
+ } (@$mepref_structs);
+
+ if (my $f = $attrs->{record_filter}) {
+ @objs = map { $f->($_) } @objs;
+ }
+
+ return @objs;
}
=begin
+
# two arguments: $as_proto is an arrayref of column names,
# $row_ref is an arrayref of the data. If none of the row data
# is defined we return undef (that's copied from the old
return $to_collapse[0];
}
-=cut
+
# two arguments: $as_proto is an arrayref of 'as' column names,
# $row_ref is an arrayref of the data. The do-while loop will run
);
# attempt collapse all rows with same collapse identity
- if (@to_collapse > 1) {
- my @collapsed;
- while (@to_collapse) {
- $self->_merge_result(\@collapsed, shift @to_collapse);
- }
- }
-
- return 1;
}
+=cut
# Takes an arrayref of me/pref pairs and a new me/pref pair that should
# be merged on a preexisting matching me (or should be pushed into $merged
$self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()");
}
- return @{ $self->get_cache } if $self->get_cache;
+ if (my $c = $self->get_cache) {
+ return @$c;
+ }
- my @obj;
+ my @objects;
if ($self->_resolved_attrs->{collapse}) {
# Using $self->cursor->all is really just an optimisation.
# If we're collapsing has_many prefetches it probably makes
# very little difference, and this is cleaner than hacking
- # _construct_object to survive the approach
+ # _construct_objects to survive the approach
$self->cursor->reset;
my @row = $self->cursor->next;
while (@row) {
- push(@obj, $self->_construct_object(@row));
+ push(@objects, $self->_construct_objects(@row));
@row = (exists $self->{stashed_row}
? @{delete $self->{stashed_row}}
: $self->cursor->next);
}
} else {
- @obj = map { $self->_construct_object(@$_) } $self->cursor->all;
+ @objects = map { $self->_construct_objects($_) } $self->cursor->all;
}
- $self->set_cache(\@obj) if $self->{attrs}{cache};
+ $self->set_cache(\@objects) if $self->{attrs}{cache};
- return @obj;
+ return @objects;
}
=head2 reset
}
}
- # if collapsing (via prefetch or otherwise) calculate row-idents and necessary order_by
- if ($attrs->{collapse}) {
-
- # only consider real columns (not functions) during collapse resolution
- # this check shouldn't really be here, as fucktards are not supposed to
- # alias random crap to declared columns anyway, but still - just in
- # case
- my @plain_selects = map
- { ( ! ref $attrs->{select}[$_] && $attrs->{as}[$_] ) || () }
- ( 0 .. $#{$attrs->{select}} )
- ;
-
- @{$attrs}{qw/_collapse_ident _collapse_order/} =
- $source->_resolve_collapse( \@plain_selects );
- }
+ # the row parser generates differently depending on whether collapsing is requested
+ # the need to look at {select} is temporary
+ $attrs->{_row_parser} = $source->_mk_row_parser (
+ @{$attrs}{qw/as collapse select/}
+ );
# if both page and offset are specified, produce a combined offset
# even though it doesn't make much sense, this is what pre 081xx has
use strict;
use warnings;
+use base qw/DBIx::Class/;
+
use DBIx::Class::ResultSet;
use DBIx::Class::ResultSourceHandle;
use DBIx::Class::Exception;
use Carp::Clan qw/^DBIx::Class/;
-use base qw/DBIx::Class/;
-
__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
_columns _primaries _unique_constraints name resultset_attributes
schema from _relationships column_info_from_storage source_info
# Resolves the passed condition to a concrete query fragment. If given an alias,
# returns a join condition; if given an object, inverts that object to produce
# a related conditional from that object.
-our $UNRESOLVABLE_CONDITION = \'1 = 0';
+our $UNRESOLVABLE_CONDITION = \ '1 = 0';
sub _resolve_condition {
my ($self, $cond, $as, $for) = @_;
: (defined $rel_info->{attrs}{order_by}
? ($rel_info->{attrs}{order_by})
- : ()));
+ : ()
+ ));
push(@$order, map { "${as}.$_" } (@key, @ord));
}
# row-object fold-points. Every relationship is assigned a set of unique,
# non-nullable columns (which may *not even be* from the same resultset)
# and the collapser will use this information to correctly distinguish
-# data of individual to-be-row-objects. Also returns a sort criteria
-# for the entire resultset, such that when the resultset is sorted
-# this way ->next will just work
+# data of individual to-be-row-objects.
sub _resolve_collapse {
- my ($self, $as, $collapse_map, $rel_chain, $multi_join, $parent_underdefined) = @_;
+ my ($self, $as, $as_fq_idx, $rel_chain, $parent_info) = @_;
+
+ # for comprehensible error messages put ourselves at the head of the relationship chain
+ $rel_chain ||= [ $self->source_name ];
- my ($my_cols, $rel_cols, $rel_col_idx);
- for (@$as) {
+ # record top-level fully-qualified column index
+ $as_fq_idx ||= { %$as };
+
+ my ($my_cols, $rel_cols);
+ for (keys %$as) {
if ($_ =~ /^ ([^\.]+) \. (.+) /x) {
- push @{$rel_cols->{$1}}, $2;
- $rel_col_idx->{$1}{$2}++;
+ $rel_cols->{$1}{$2} = 1;
}
else {
$my_cols->{$_} = {}; # important for ||= below
}
my $relinfo;
- # run through relationships, collect metadata, inject fk-bridges immediately (if any)
+ # run through relationships, collect metadata, inject non-left fk-bridges from
+ # *INNER-JOINED* children (if any)
for my $rel (keys %$rel_cols) {
my $rel_src = $self->related_source ($rel);
my $inf = $self->relationship_info ($rel);
$relinfo->{$rel}{rsrc} = $rel_src;
my $cond = $inf->{cond};
+
if (
ref $cond eq 'HASH'
and
$relinfo->{$rel}{fk_map}{$s} = $f;
$my_cols->{$s} ||= { via_fk => "$rel.$f" } # need to know source from *our* pov
- if $rel_col_idx->{$rel}{$f}; # only if it is in fact selected of course
+ if ($relinfo->{$rel}{is_inner} && defined $rel_cols->{$rel}{$f}); # only if it is inner and in fact selected of course
}
}
}
+ # if the parent is already defined, assume all of its related FKs are selected
+ # (even if they in fact are NOT in the select list). Keep a record of what we
+ # assumed, and if any such phantom-column becomes part of our own collapser,
+ # throw everything assumed-from-parent away and replace with the collapser of
+ # the parent (whatever it may be)
+ my $assumed_from_parent;
+ unless ($parent_info->{underdefined}) {
+ $assumed_from_parent->{columns} = { map
+ # only add to the list if we do not already select said columns
+ { ! exists $my_cols->{$_} ? ( $_ => 1 ) : () }
+ values %{$parent_info->{rel_condition} || {}}
+ };
+
+ $my_cols->{$_} = { via_collapse => $parent_info->{collapse_on} }
+ for keys %{$assumed_from_parent->{columns}};
+ }
+
# get colinfo for everything
if ($my_cols) {
$my_cols->{$_}{colinfo} = (
) for keys %$my_cols;
}
- # if collapser not passed down try to resolve based on our columns
- # (plus already inserted FK bridges)
+ my $collapse_map;
+
+ # try to resolve based on our columns (plus already inserted FK bridges)
if (
$my_cols
and
- ! $collapse_map->{-collapse_on}
- and
my $uset = $self->_unique_column_set ($my_cols)
) {
- $collapse_map->{-collapse_on} = { map
- {
- join ('.',
- @{$rel_chain||[]},
- ( $my_cols->{$_}{via_fk} || $_ ),
- )
- =>
- 1
- }
- keys %$uset
+ # see if the resulting collapser relies on any implied columns,
+ # and fix stuff up if this is the case
+
+ my $parent_collapser_used;
+
+ if (List::Util::first
+ { exists $assumed_from_parent->{columns}{$_} }
+ keys %$uset
+ ) {
+ # remove implied stuff from the uset, we will inject the equivalent collapser a bit below
+ delete @{$uset}{keys %{$assumed_from_parent->{columns}}};
+ $parent_collapser_used = 1;
+ }
+
+ $collapse_map->{-collapse_on} = {
+ %{ $parent_collapser_used ? $parent_info->{collapse_on} : {} },
+ (map
+ {
+ my $fqc = join ('.',
+ @{$rel_chain}[1 .. $#$rel_chain],
+ ( $my_cols->{$_}{via_fk} || $_ ),
+ );
+
+ $fqc => $as_fq_idx->{$fqc};
+ }
+ keys %$uset
+ ),
};
}
- # still don't know how to collapse - keep descending down 1:1 chains - if
- # a related non-LEFT (or not-yet-multijoined) 1:1 is resolvable - it will collapse us too
+ # don't know how to collapse - keep descending down 1:1 chains - if
+ # a related non-LEFT 1:1 is resolvable - its condition will collapse us
+ # too
unless ($collapse_map->{-collapse_on}) {
+ my @candidates;
+
for my $rel (keys %$relinfo) {
- next unless $relinfo->{$rel}{is_single};
- next if ( $multi_join && ! $relinfo->{$rel}{is_inner} );
+ next unless ($relinfo->{$rel}{is_single} && $relinfo->{$rel}{is_inner});
- if ( my ($rel_collapse) = $relinfo->{$rel}{rsrc}->_resolve_collapse (
+ if ( my $rel_collapse = $relinfo->{$rel}{rsrc}->_resolve_collapse (
$rel_cols->{$rel},
- undef,
- [ @{$rel_chain||[]}, $rel],
- $multi_join || ! $relinfo->{$rel}{is_single},
- 'parent_underdefined',
+ $as_fq_idx,
+ [ @$rel_chain, $rel ],
+ { underdefined => 1 }
)) {
- $collapse_map->{-collapse_on} = $rel_collapse->{-collapse_on};
- last;
+ push @candidates, $rel_collapse->{-collapse_on};
}
}
+
+ # get the set with least amount of columns
+ # FIXME - maybe need to implement a data type order as well (i.e. prefer several ints
+ # to a single varchar)
+ if (@candidates) {
+ ($collapse_map->{-collapse_on}) = sort { keys %$a <=> keys %$b } (@candidates);
+ }
}
- # nothing down the chain resolves - can't calculate a collapse-map
+ # Still dont know how to collapse - see if the parent passed us anything
+ # (i.e. reuse collapser over 1:1)
unless ($collapse_map->{-collapse_on}) {
- # FIXME - error message is very vague
+ $collapse_map->{-collapse_on} = $parent_info->{collapse_on}
+ if $parent_info->{collapser_reusable};
+ }
+
+
+ # stop descending into children if we were called by a parent for first-pass
+ # and don't despair if nothing was found (there may be other parallel branches
+ # to dive into)
+ if ($parent_info->{underdefined}) {
+ return $collapse_map->{-collapse_on} ? $collapse_map : undef
+ }
+ # nothing down the chain resolved - can't calculate a collapse-map
+ elsif (! $collapse_map->{-collapse_on}) {
$self->throw_exception ( sprintf
- "Unable to calculate a definitive collapse column set for %s%s - fetch more unique non-nullable columns",
+ "Unable to calculate a definitive collapse column set for %s%s: fetch more unique non-nullable columns",
$self->source_name,
- $rel_chain ? sprintf (' (or a %s chain member)', join ' -> ', @$rel_chain ) : '',
+ @$rel_chain > 1
+ ? sprintf (' (last member of the %s chain)', join ' -> ', @$rel_chain )
+ : ''
+ ,
);
}
- return $collapse_map if $parent_underdefined; # we will come here again and go through the children then
- # now that we are collapsable - go down the entire chain a second time,
- # and fill in the rest
- for my $rel (keys %$relinfo) {
+ # If we got that far - we are collapsable - GREAT! Now go down all children
+ # a second time, and fill in the rest
- # inject *all* FK columns (even if we do not directly define them)
- # since us being defined means that we can cheat about having e.g.
- # a particular PK, which in turn will re-assemble with a unique
- # constraint on some related column and our bridged-fk
- # when/if the resolution comes back - we take back out everything
- # we injected and pass things back up the chain
-
- my $implied_defined = { map
- { $rel_col_idx->{$rel}{$_}
- ? ()
- : ( join ('.', @{$rel_chain||[]}, $rel, $_ ) => $_ )
- }
- values %{$relinfo->{$rel}{fk_map}}
- };
+ for my $rel (keys %$relinfo) {
- my ($rel_collapse) = $relinfo->{$rel}{rsrc}->_resolve_collapse (
- [ @{$rel_cols->{$rel}}, values %$implied_defined ],
+ $collapse_map->{$rel} = $relinfo->{$rel}{rsrc}->_resolve_collapse (
+ { map { $_ => 1 } ( keys %{$rel_cols->{$rel}} ) },
- $relinfo->{$rel}{is_single} # if this is a 1:1 - we simply pass our collapser to it
- ? { -collapse_on => { %{$collapse_map->{-collapse_on}} } }
- : undef
- ,
+ $as_fq_idx,
- [ @{$rel_chain||[]}, $rel],
+ [ @$rel_chain, $rel],
- $multi_join || ! $relinfo->{$rel}{is_single},
- );
-
- # if we implied our definition - we inject our own collapser in addition to whatever is left
- if (keys %$implied_defined) {
- $rel_collapse->{-collapse_on} = {
- ( map {( $_ => 1 )} keys %{$collapse_map->{-collapse_on}} ),
- ( map
- {( $_ => 1 )}
- grep
- { ! $implied_defined->{$_} }
- keys %{$rel_collapse->{-collapse_on}}
- ),
- };
- };
+ {
+ collapse_on => { %{$collapse_map->{-collapse_on}} },
- $collapse_map->{$rel} = $rel_collapse;
+ rel_condition => $relinfo->{$rel}{fk_map},
+ # if this is a 1:1 our own collapser can be used as a collapse-map
+ # (regardless of left or not)
+ collapser_reusable => $relinfo->{$rel}{is_single},
+ },
+ );
}
- # if no relchain (i.e. we are toplevel) - generate an order_by
- # here we can take the easy route and compose an order_by out of
- # actual unique column names, regardless of whether they were
- # selected or not. If nothing ... maybe bad idea
- my $order_by = do {
- undef;
- } if ! $rel_chain;
-
- return $collapse_map, ($order_by || () );
+ return $collapse_map;
}
sub _unique_column_set {
return undef;
}
-# Takes a hashref of $sth->fetchrow values keyed to the corresponding
-# {as} dbic aliases, and splits it into a native columns hashref
-# (as in $row->get_columns), followed by any non-native (prefetched)
-# columns, presented in a nested structure resembling an HRI dump.
-# The structure is constructed taking into account relationship metadata
-# (single vs multi).
-# The resulting arrayref resembles the arguments to ::Row::inflate_result
-# For an example look at t/prefetch/_util.t
+# Takes an arrayref of {as} dbic column aliases and the collapse and select
+# attributes from the same $rs (the slector requirement is a temporary
+# workaround), and returns a coderef capable of:
+# my $me_pref_clps = $coderef->([$rs->cursor->next])
+# Where the $me_pref_clps arrayref is the future argument to
+# ::ResultSet::_collapse_result.
+#
+# $me_pref_clps->[0] is always returned (even if as an empty hash with no
+# rowdata), however branches of related data in $me_pref_clps->[1] may be
+# pruned short of what was originally requested based on {as}, depending
+# on:
#
-# The will collapse flag is for backwards compatibility only - if it is
-# set, all relationship row-parts are returned as hashes, even if some
-# of these relationships are has_many's
+# * If collapse is requested, a definitive collapse map is calculated for
+# every relationship "fold-point", consisting of a set of values (which
+# may not even be contained in the future 'me' of said relationship
+# (for example a cd.artist_id defines the related inner-joined artist)).
+# Thus a definedness check is carried on all collapse-condition values
+# and if at least one is undef it is assumed that we are dealing with a
+# NULLed right-side of a left-join, so we don't return a related data
+# container at all, which implies no related objects
#
-sub _parse_row {
- my ( $self, $row, $will_collapse ) = @_;
+# * If we are not collapsing, there is no constraint on having a selector
+# uniquely identifying all possible objects, and the user might have very
+# well requested a column that just *happens* to be all NULLs. What we do
+# in this case is fallback to the old behavior (which is a potential FIXME)
+# by always returning a data container, but only filling it with columns
+# IFF at least one of them is defined. This way we do not get an object
+# with a bunch of has_column_loaded to undef, but at the same time do not
+# further relationships based off this "null" object (e.g. in case the user
+# deliberately skipped link-table values). I am pretty sure there are some
+# tests that codify this behavior, need to find the exact testname.
+#
+# For an example of this coderef in action (and to see its guts) look at
+# t/prefetch/_internals.t
+#
+# This is a huge performance win, as we call the same code for
+# every row returned from the db, thus avoiding repeated method
+# lookups when traversing relationships
+#
+# Also since the coderef is completely stateless (the returned structure is
+# always fresh on every new invocation) this is a very good opportunity for
+# memoization if further speed improvements are needed
+#
+# The way we construct this coderef is somewhat fugly, although I am not
+# sure if the string eval is *that* bad of an idea. The alternative is to
+# have a *very* large number of anon coderefs calling each other in a twisty
+# maze, whereas the current result is a nice, smooth, single-pass function.
+# In any case - the output of this thing is meticulously micro-tested, so
+# any sort of rewrite should be relatively easy
+#
+sub _mk_row_parser {
+ my ($self, $as, $with_collapse, $select) = @_;
+
+ my $as_indexed = { map
+ { $as->[$_] => $_ }
+ ( 0 .. $#$as )
+ };
+
+ # calculate collapse fold-points if needed
+ my $collapse_on = do {
+ # FIXME
+ # only consider real columns (not functions) during collapse resolution
+ # this check shouldn't really be here, as fucktards are not supposed to
+ # alias random crap to existing column names anyway, but still - just in
+ # case (also saves us from select/as mismatches which need fixing as well...)
+
+ my $plain_as = { %$as_indexed };
+ for (keys %$plain_as) {
+ delete $plain_as->{$_} if ref $select->[$plain_as->{$_}];
+ }
+ $self->_resolve_collapse ($plain_as);
- my ($me, $pref);
+ } if $with_collapse;
- foreach my $column ( keys %$row ) {
- if ( $column =~ /^ ([^\.]+) \. (.*) $/x ) {
- $pref->{$1}{$2} = $row->{$column};
- }
- else {
- $me->{$column} = $row->{$column};
- }
+ my $perl = $self->__visit_as ($as_indexed, $collapse_on);
+ my $cref = eval "sub { $perl }"
+ or die "Oops! _mk_row_parser generated invalid perl:\n$@\n\n$perl\n";
+ return $cref;
+}
+
+{
+ my $visit_as_dumper; # keep our own DD object around so we don't have to fitz with quoting
+
+ sub __visit_as {
+ my ($self, $as, $collapse_on, $known_defined) = @_;
+ $known_defined ||= {};
+
+ # prepopulate the known defined map with our own collapse value positions
+ # the rationale is that if an Artist needs column 0 to be uniquely
+ # identified, and related CDs need columns 0 and 1, by the time we get to
+ # CDs we already know that column 0 is defined (otherwise there would be
+ # no related CDs as there is no Artist in the 1st place). So we use this
+ # index to cut on repetitive defined() checks.
+ $known_defined->{$_}++ for ( values %{$collapse_on->{-collapse_on} || {}} );
+
+ my $my_cols = {};
+ my $rel_cols;
+ for (keys %$as) {
+ if ($_ =~ /^ ([^\.]+) \. (.+) /x) {
+ $rel_cols->{$1}{$2} = $as->{$_};
+ }
+ else {
+ $my_cols->{$_} = $as->{$_};
+ }
}
- foreach my $rel ( keys %{$pref||{}} ) {
- my $rel_info = $self->relationship_info($rel);
+ my @relperl;
+ for my $rel (sort keys %$rel_cols) {
+ my $rel_node = $self->__visit_as($rel_cols->{$rel}, $collapse_on->{$rel}, {%$known_defined} );
+
+ my @null_checks;
+ if ($collapse_on->{$rel}{-collapse_on}) {
+ @null_checks = map
+ { "(! defined '__VALPOS__${_}__')" }
+ ( grep
+ { ! $known_defined->{$_} }
+ ( sort
+ { $a <=> $b }
+ values %{$collapse_on->{$rel}{-collapse_on}}
+ )
+ )
+ ;
+ }
- $pref->{$rel} =
- $self->related_source($rel)->_parse_row( $pref->{$rel}, $will_collapse );
+ if (@null_checks) {
+ push @relperl, sprintf ( '(%s) ? () : ( %s => %s )',
+ join (' || ', @null_checks ),
+ $rel,
+ $rel_node,
+ );
+ }
+ else {
+ push @relperl, "$rel => $rel_node";
+ }
+ }
+ my $rels = @relperl
+ ? sprintf ('{ %s }', join (',', @relperl))
+ : 'undef'
+ ;
- $pref->{$rel} = [ $pref->{$rel} ]
- if ( $will_collapse
- && $rel_info->{attrs}{accessor}
- && $rel_info->{attrs}{accessor} eq 'multi'
- );
+ my $me = {
+ map { $_ => "__VALPOS__$my_cols->{$_}__" } (keys %$my_cols)
+ };
+
+ my $clps = [
+ map { "__VALPOS__${_}__" } ( sort { $a <=> $b } (values %{$collapse_on->{-collapse_on}}) )
+ ] if $collapse_on->{-collapse_on};
+
+ # 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!
+ $visit_as_dumper ||= do {
+ require Data::Dumper;
+ Data::Dumper->new([])
+ ->Purity (1)
+ ->Pad ('')
+ ->Useqq (0)
+ ->Terse (1)
+ ->Quotekeys (1)
+ ->Deepcopy (1)
+ ->Deparse (0)
+ ->Maxdepth (0)
+ ->Indent (0)
+ };
+ for ($me, $clps) {
+ $_ = $visit_as_dumper->Values ([$_])->Dump;
+ }
+
+ unless ($collapse_on->{-collapse_on}) { # we are not collapsing, insert a definedness check on 'me'
+ $me = sprintf ( '(%s) ? %s : {}',
+ join (' || ', map { "( defined '__VALPOS__${_}__')" } (sort { $a <=> $b } values %$my_cols) ),
+ $me,
+ );
}
- return [ $me||{}, $pref||() ];
+ my @rv_list = ($me, $rels, $clps);
+ pop @rv_list while ($rv_list[-1] eq 'undef'); # strip trailing undefs
+
+ # change the quoted placeholders to unquoted alias-references
+ $_ =~ s/ \' __VALPOS__(\d+)__ \' /sprintf ('$_[0][%d]', $1)/gex
+ for grep { defined $_ } @rv_list;
+
+ return sprintf '[%s]', join (',', @rv_list);
+ }
}
=head2 related_source
use strict;
use warnings;
+use Data::Dumper;
+BEGIN { $Data::Dumper::Sortkeys = 1 }; # so we can compare the deparsed coderefs below
+
use Test::More;
use lib qw(t/lib);
use DBICTest;
+use B::Deparse;
+
my $schema = DBICTest->init_schema(no_deploy => 1);
+my ($as, $vals, @pairs);
-my $irow = $schema->source ('Artwork')->_parse_row (
- {
- 'cd_id' => '1',
+# artwork-artist deliberately mixed around
+@pairs = (
+ 'artwork_to_artist.artist_id' => '2',
- 'artwork_to_artist.artist_id' => '2',
- 'artwork_to_artist.artwork_cd_id' => '1',
+ 'cd_id' => '1',
- 'cd.artist' => '1',
- 'cd.cdid' => '1',
- 'cd.title' => 'Spoonful of bees',
+ 'artwork_to_artist.artwork_cd_id' => '1',
- 'cd.artist.artistid' => '1',
- 'cd.artist.name' => 'Caterwauler McCrae',
- },
- 'will collapse'
+ 'cd.artist' => '1',
+ 'cd.cdid' => '1',
+ 'cd.title' => 'Spoonful of bees',
+
+ 'cd.artist.artistid' => '7',
+ 'cd.artist.name' => 'Caterwauler McCrae',
+ 'artwork_to_artist.artist.name' => 'xenowhinycide',
);
+while (@pairs) {
+ push @$as, shift @pairs;
+ push @$vals, shift @pairs;
+}
+
+my $parser = $schema->source ('Artwork')->_mk_row_parser($as, 'collapse requested');
is_deeply (
- $irow,
+ $parser->($vals),
[
{
- 'cd_id' => '1'
+ cd_id => 1,
},
+
{
- 'artwork_to_artist' => [
- [
- {
- 'artist_id' => '2',
- 'artwork_cd_id' => '1'
- }
- ]
+ artwork_to_artist => [
+ {
+ artist_id => 2,
+ artwork_cd_id => 1,
+ },
+ {
+ artist => [
+ {
+ name => 'xenowhinycide',
+ },
+ undef,
+ [ 2, 1 ], # inherited from artwork_to_artist (child-parent definition)
+ ],
+ },
+ [ 2, 1 ] # artwork_to_artist own data, in selection order
],
- 'cd' => [
+ cd => [
{
- 'artist' => '1',
- 'cdid' => '1',
- 'title' => 'Spoonful of bees',
+ artist => 1,
+ cdid => 1,
+ title => 'Spoonful of bees',
},
{
- 'artist' => [
+ artist => [
{
- 'artistid' => '1',
- 'name' => 'Caterwauler McCrae',
- }
+ artistid => 7,
+ name => 'Caterwauler McCrae',
+ },
+ undef,
+ [ 7 ], # our own id
]
- }
+ },
+ [ 1 ], # our cdid fk
]
- }
+ },
+ [ 1 ], # our id
],
- '_parse_row works as expected with expected collapse',
+ 'generated row parser works as expected',
);
-$irow = $schema->source ('Artist')->_parse_row (
- {
- 'name' => 'Caterwauler McCrae',
- 'cds.tracks.cd' => '3',
- 'cds.tracks.title' => 'Fowlin',
- 'cds.tracks.cd_single.title' => 'Awesome single',
- }
+undef $_ for ($as, $vals);
+@pairs = (
+ 'name' => 'Caterwauler McCrae',
+ 'cds.tracks.cd' => '3',
+ 'cds.tracks.title' => 'Fowlin',
+ 'cds.tracks.cd_single.title' => 'Awesome single',
);
+while (@pairs) {
+ push @$as, shift @pairs;
+ push @$vals, shift @pairs;
+}
+$parser = $schema->source ('Artist')->_mk_row_parser($as);
+
is_deeply (
- $irow,
+ $parser->($vals),
[
{
- 'name' => 'Caterwauler McCrae'
+ name => 'Caterwauler McCrae'
},
{
- 'cds' => [
+ cds => [
{},
{
- 'tracks' => [
+ tracks => [
{
- 'cd' => '3',
- 'title' => 'Fowlin'
+ cd => 3,
+ title => 'Fowlin'
},
{
- 'cd_single' => [
+ cd_single => [
{
title => 'Awesome single',
},
]
}
],
- '_parse_row works over missing joins without collapse',
+ 'generated parser works as expected over missing joins (no collapse)',
);
-my ($collapse_map, $order) = $schema->source ('CD')->_resolve_collapse (
- [
- 'year', # non-unique
- 'genreid', # nullable
- 'tracks.title', # non-unique (no me.id)
- 'single_track.cd.artist.cds.cdid', # to give uniquiness to ...tracks.title below
- 'single_track.cd.artist.cds.artist', # non-unique
- 'single_track.cd.artist.cds.year', # non-unique
- 'single_track.cd.artist.cds.genreid', # nullable
- 'single_track.cd.artist.cds.tracks.title',# unique when combined with ...cds.cdid above
- 'latest_cd', # random function
- ],
+undef $_ for ($as, $vals);
+@pairs = (
+ 'tracks.lyrics.lyric_versions.text' => 'unique when combined with the lyric collapsable by the 1:1 tracks-parent',
+ 'existing_single_track.cd.artist.artistid' => 'artist_id (gives uniq. to its entire parent chain)',
+ 'existing_single_track.cd.artist.cds.year' => 'non-unique cds col (year)',
+ 'year' => 'non unique main year',
+ 'genreid' => 'non-unique/nullable main genid',
+ 'tracks.title' => 'non-unique title (missing multicol const. part)',
+ 'existing_single_track.cd.artist.cds.cdid' => 'cds unique id col to give uniquiness to ...tracks.title below',
+ 'latest_cd' => 'random function (not a colname)',
+ 'existing_single_track.cd.artist.cds.tracks.title' => 'unique track title (when combined with ...cds.cdid above)',
+ 'existing_single_track.cd.artist.cds.genreid' => 'nullable cds col (genreid)',
);
+while (@pairs) {
+ push @$as, shift @pairs;
+ push @$vals, shift @pairs;
+}
is_deeply (
- $collapse_map,
+ $schema->source ('CD')->_resolve_collapse ( { map { $as->[$_] => $_ } (0 .. $#$as) } ),
{
-collapse_on => {
- "single_track.cd.artist.cds.artist" => 1
+ 'existing_single_track.cd.artist.artistid' => 1,
},
- single_track => {
+ existing_single_track => {
-collapse_on => {
- "single_track.cd.artist.cds.artist" => 1
+ 'existing_single_track.cd.artist.artistid' => 1,
},
cd => {
-collapse_on => {
- "single_track.cd.artist.cds.artist" => 1
+ 'existing_single_track.cd.artist.artistid' => 1,
},
artist => {
-collapse_on => {
- "single_track.cd.artist.cds.artist" => 1
+ 'existing_single_track.cd.artist.artistid' => 1,
},
cds => {
-collapse_on => {
- "single_track.cd.artist.cds.cdid" => 1
+ 'existing_single_track.cd.artist.cds.cdid' => 6,
},
tracks => {
-collapse_on => {
- "single_track.cd.artist.cds.cdid" => 1,
- "single_track.cd.artist.cds.tracks.title" => 1
+ 'existing_single_track.cd.artist.cds.cdid' => 6,
+ 'existing_single_track.cd.artist.cds.tracks.title' => 8,
}
}
}
},
tracks => {
-collapse_on => {
- "single_track.cd.artist.cds.artist" => 1,
- "tracks.title" => 1
- }
+ 'existing_single_track.cd.artist.artistid' => 1,
+ 'tracks.title' => 5,
+ },
+
+ lyrics => {
+ -collapse_on => {
+ 'existing_single_track.cd.artist.artistid' => 1,
+ 'tracks.title' => 5,
+ },
+
+ lyric_versions => {
+ -collapse_on => {
+ 'existing_single_track.cd.artist.artistid' => 1,
+ 'tracks.title' => 5,
+ 'tracks.lyrics.lyric_versions.text' => 0,
+ },
+ },
+ },
}
},
- "Proper collapse map constructed",
+ 'Correct collapse map constructed',
+);
+
+
+$parser = $schema->source ('CD')->_mk_row_parser ($as, 'add collapse data');
+
+is_deeply (
+ $parser->($vals),
+ [
+ {
+ latest_cd => 'random function (not a colname)',
+ year => 'non unique main year',
+ genreid => 'non-unique/nullable main genid'
+ },
+ {
+ existing_single_track => [
+ {},
+ {
+ cd => [
+ {},
+ {
+ artist => [
+ { artistid => 'artist_id (gives uniq. to its entire parent chain)' },
+ {
+ cds => [
+ {
+ cdid => 'cds unique id col to give uniquiness to ...tracks.title below',
+ year => 'non-unique cds col (year)',
+ genreid => 'nullable cds col (genreid)'
+ },
+ {
+ tracks => [
+ {
+ title => 'unique track title (when combined with ...cds.cdid above)'
+ },
+ undef,
+ [
+ 'cds unique id col to give uniquiness to ...tracks.title below',
+ 'unique track title (when combined with ...cds.cdid above)',
+ ],
+ ]
+ },
+ [ 'cds unique id col to give uniquiness to ...tracks.title below' ],
+ ]
+ },
+ [ 'artist_id (gives uniq. to its entire parent chain)' ],
+ ]
+ },
+ [ 'artist_id (gives uniq. to its entire parent chain)' ],
+ ]
+ },
+ [ 'artist_id (gives uniq. to its entire parent chain)' ],
+ ],
+ tracks => [
+ {
+ title => 'non-unique title (missing multicol const. part)'
+ },
+ {
+ lyrics => [
+ {},
+ {
+ lyric_versions => [
+ {
+ text => 'unique when combined with the lyric collapsable by the 1:1 tracks-parent',
+ },
+ undef,
+ [
+ 'unique when combined with the lyric collapsable by the 1:1 tracks-parent',
+ 'artist_id (gives uniq. to its entire parent chain)',
+ 'non-unique title (missing multicol const. part)',
+ ],
+ ],
+ },
+ [
+ 'artist_id (gives uniq. to its entire parent chain)',
+ 'non-unique title (missing multicol const. part)',
+ ],
+ ],
+ },
+ [
+ 'artist_id (gives uniq. to its entire parent chain)',
+ 'non-unique title (missing multicol const. part)',
+ ],
+ ],
+ },
+ [ 'artist_id (gives uniq. to its entire parent chain)' ],
+ ],
+ 'Proper row parser constructed',
+);
+
+# For extra insanity test/showcase the parser's guts:
+my $deparser = B::Deparse->new;
+is (
+ $deparser->coderef2text ($parser),
+ $deparser->coderef2text ( sub { package DBIx::Class::ResultSource;
+ [
+ {
+ genreid => $_[0][4],
+ latest_cd => $_[0][7],
+ year => $_[0][3]
+ },
+ {
+
+ existing_single_track => [
+ {},
+ {
+ cd => [
+ {},
+ {
+ artist => [
+ {
+ artistid => $_[0][1]
+ },
+ {
+
+ !defined($_[0][6]) ? () : (
+ cds => [
+ {
+ cdid => $_[0][6],
+ genreid => $_[0][9],
+ year => $_[0][2]
+ },
+ {
+
+ !defined($_[0][8]) ? () : (
+ tracks => [
+ {
+ title => $_[0][8]
+ },
+ undef,
+ [ $_[0][6], $_[0][8] ]
+ ])
+
+ },
+ [ $_[0][6] ]
+ ]),
+
+ },
+ [ $_[0][1] ],
+ ],
+ },
+ [ $_[0][1] ],
+ ],
+ },
+ [ $_[0][1] ],
+ ],
+
+ !defined($_[0][5]) ? () : (
+ tracks => [
+ {
+ title => $_[0][5],
+ },
+ {
+
+ lyrics => [
+ {},
+ {
+
+ !defined($_[0][0]) ? () : (
+ lyric_versions => [
+ {
+ text => $_[0][0]
+ },
+ undef,
+ [ $_[0][0], $_[0][1], $_[0][5] ],
+ ]),
+
+ },
+ [ $_[0][1], $_[0][5] ],
+ ],
+
+ },
+ [ $_[0][1], $_[0][5] ],
+ ]),
+ },
+ [ $_[0][1] ],
+ ];
+ }),
+ 'Deparsed version of the parser coderef looks correct',
);
done_testing;
projects / dbsrgits/DBIx-Class.git / commitdiff