Commit | Line | Data |
76031e14 |
1 | package DBIx::Class::ResultSource::RowParser; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Try::Tiny; |
7 | use List::Util 'first'; |
8 | use B 'perlstring'; |
9 | |
10 | use namespace::clean; |
11 | |
12 | use base 'DBIx::Class'; |
13 | |
14 | # Accepts one or more relationships for the current source and returns an |
15 | # array of column names for each of those relationships. Column names are |
16 | # prefixed relative to the current source, in accordance with where they appear |
17 | # in the supplied relationships. |
18 | sub _resolve_prefetch { |
19 | my ($self, $pre, $alias, $alias_map, $order, $pref_path) = @_; |
20 | $pref_path ||= []; |
21 | |
22 | if (not defined $pre or not length $pre) { |
23 | return (); |
24 | } |
25 | elsif( ref $pre eq 'ARRAY' ) { |
26 | return |
27 | map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, [ @$pref_path ] ) } |
28 | @$pre; |
29 | } |
30 | elsif( ref $pre eq 'HASH' ) { |
31 | my @ret = |
32 | map { |
33 | $self->_resolve_prefetch($_, $alias, $alias_map, $order, [ @$pref_path ] ), |
34 | $self->related_source($_)->_resolve_prefetch( |
35 | $pre->{$_}, "${alias}.$_", $alias_map, $order, [ @$pref_path, $_] ) |
36 | } keys %$pre; |
37 | return @ret; |
38 | } |
39 | elsif( ref $pre ) { |
40 | $self->throw_exception( |
41 | "don't know how to resolve prefetch reftype ".ref($pre)); |
42 | } |
43 | else { |
44 | my $p = $alias_map; |
45 | $p = $p->{$_} for (@$pref_path, $pre); |
46 | |
47 | $self->throw_exception ( |
48 | "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: " |
49 | . join (' -> ', @$pref_path, $pre) |
50 | ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} ); |
51 | |
52 | my $as = shift @{$p->{-join_aliases}}; |
53 | |
54 | my $rel_info = $self->relationship_info( $pre ); |
55 | $self->throw_exception( $self->source_name . " has no such relationship '$pre'" ) |
56 | unless $rel_info; |
57 | |
58 | my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : ''); |
59 | my $rel_source = $self->related_source($pre); |
60 | |
61 | if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') { |
62 | $self->throw_exception( |
63 | "Can't prefetch has_many ${pre} (join cond too complex)") |
64 | unless ref($rel_info->{cond}) eq 'HASH'; |
65 | my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}" |
66 | |
67 | #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); } |
68 | # values %{$rel_info->{cond}}; |
69 | my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); } |
70 | keys %{$rel_info->{cond}}; |
71 | |
72 | push @$order, map { "${as}.$_" } @key; |
73 | |
74 | if (my $rel_order = $rel_info->{attrs}{order_by}) { |
75 | # this is kludgy and incomplete, I am well aware |
76 | # but the parent method is going away entirely anyway |
77 | # so sod it |
78 | my $sql_maker = $self->storage->sql_maker; |
79 | my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars; |
80 | my $sep = $sql_maker->name_sep; |
81 | |
82 | # install our own quoter, so we can catch unqualified stuff |
83 | local $sql_maker->{quote_char} = ["\x00", "\xFF"]; |
84 | |
85 | my $quoted_prefix = "\x00${as}\xFF"; |
86 | |
87 | for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) { |
88 | my @bind; |
89 | ($chunk, @bind) = @$chunk if ref $chunk; |
90 | |
91 | $chunk = "${quoted_prefix}${sep}${chunk}" |
92 | unless $chunk =~ /\Q$sep/; |
93 | |
94 | $chunk =~ s/\x00/$orig_ql/g; |
95 | $chunk =~ s/\xFF/$orig_qr/g; |
96 | push @$order, \[$chunk, @bind]; |
97 | } |
98 | } |
99 | } |
100 | |
101 | return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] } |
102 | $rel_source->columns; |
103 | } |
104 | } |
105 | |
106 | # Takes a selection list and generates a collapse-map representing |
107 | # row-object fold-points. Every relationship is assigned a set of unique, |
108 | # non-nullable columns (which may *not even be* from the same resultset) |
109 | # and the collapser will use this information to correctly distinguish |
110 | # data of individual to-be-row-objects. |
111 | sub _resolve_collapse { |
112 | my ($self, $as, $as_fq_idx, $rel_chain, $parent_info, $node_idx_ref) = @_; |
113 | |
114 | # for comprehensible error messages put ourselves at the head of the relationship chain |
115 | $rel_chain ||= [ $self->source_name ]; |
116 | |
117 | # record top-level fully-qualified column index |
118 | $as_fq_idx ||= { %$as }; |
119 | |
120 | my ($my_cols, $rel_cols); |
121 | for (keys %$as) { |
122 | if ($_ =~ /^ ([^\.]+) \. (.+) /x) { |
123 | $rel_cols->{$1}{$2} = 1; |
124 | } |
125 | else { |
126 | $my_cols->{$_} = {}; # important for ||= below |
127 | } |
128 | } |
129 | |
130 | my $relinfo; |
131 | # run through relationships, collect metadata, inject non-left fk-bridges from |
132 | # *INNER-JOINED* children (if any) |
133 | for my $rel (keys %$rel_cols) { |
134 | my $rel_src = __get_related_source($self, $rel, $rel_cols->{$rel}); |
135 | |
136 | my $inf = $self->relationship_info ($rel); |
137 | |
138 | $relinfo->{$rel}{is_single} = $inf->{attrs}{accessor} && $inf->{attrs}{accessor} ne 'multi'; |
139 | $relinfo->{$rel}{is_inner} = ( $inf->{attrs}{join_type} || '' ) !~ /^left/i; |
140 | $relinfo->{$rel}{rsrc} = $rel_src; |
141 | |
142 | my $cond = $inf->{cond}; |
143 | |
144 | if ( |
145 | ref $cond eq 'HASH' |
146 | and |
147 | keys %$cond |
148 | and |
149 | ! first { $_ !~ /^foreign\./ } (keys %$cond) |
150 | and |
151 | ! first { $_ !~ /^self\./ } (values %$cond) |
152 | ) { |
153 | for my $f (keys %$cond) { |
154 | my $s = $cond->{$f}; |
155 | $_ =~ s/^ (?: foreign | self ) \.//x for ($f, $s); |
156 | $relinfo->{$rel}{fk_map}{$s} = $f; |
157 | |
158 | # need to know source from *our* pov, hnce $rel. |
159 | $my_cols->{$s} ||= { via_fk => "$rel.$f" } if ( |
160 | defined $rel_cols->{$rel}{$f} # in fact selected |
161 | and |
162 | (! $node_idx_ref or $relinfo->{$rel}{is_inner}) # either top-level or an inner join |
163 | ); |
164 | } |
165 | } |
166 | } |
167 | |
168 | # if the parent is already defined, assume all of its related FKs are selected |
169 | # (even if they in fact are NOT in the select list). Keep a record of what we |
170 | # assumed, and if any such phantom-column becomes part of our own collapser, |
171 | # throw everything assumed-from-parent away and replace with the collapser of |
172 | # the parent (whatever it may be) |
173 | my $assumed_from_parent; |
174 | unless ($parent_info->{underdefined}) { |
175 | $assumed_from_parent->{columns} = { map |
176 | # only add to the list if we do not already select said columns |
177 | { ! exists $my_cols->{$_} ? ( $_ => 1 ) : () } |
178 | values %{$parent_info->{rel_condition} || {}} |
179 | }; |
180 | |
181 | $my_cols->{$_} = { via_collapse => $parent_info->{collapse_on} } |
182 | for keys %{$assumed_from_parent->{columns}}; |
183 | } |
184 | |
185 | # get colinfo for everything |
186 | if ($my_cols) { |
187 | my $ci = $self->columns_info; |
188 | $my_cols->{$_}{colinfo} = $ci->{$_} for keys %$my_cols; |
189 | } |
190 | |
191 | my $collapse_map; |
192 | |
193 | # try to resolve based on our columns (plus already inserted FK bridges) |
194 | if ( |
195 | $my_cols |
196 | and |
197 | my $uset = $self->_unique_column_set ($my_cols) |
198 | ) { |
199 | # see if the resulting collapser relies on any implied columns, |
200 | # and fix stuff up if this is the case |
201 | |
202 | my $parent_collapser_used = defined delete @{$uset}{keys %{$assumed_from_parent->{columns}}}; |
203 | $collapse_map->{-node_id} = __unique_numlist( |
204 | $parent_collapser_used ? @{$parent_info->{collapse_on}} : (), |
205 | (map |
206 | { |
207 | my $fqc = join ('.', |
208 | @{$rel_chain}[1 .. $#$rel_chain], |
209 | ( $my_cols->{$_}{via_fk} || $_ ), |
210 | ); |
211 | |
212 | $as_fq_idx->{$fqc}; |
213 | } |
214 | keys %$uset |
215 | ), |
216 | ); |
217 | } |
218 | |
219 | # Stil don't know how to collapse - keep descending down 1:1 chains - if |
220 | # a related non-LEFT 1:1 is resolvable - its condition will collapse us |
221 | # too |
222 | unless ($collapse_map->{-node_id}) { |
223 | my @candidates; |
224 | |
225 | for my $rel (keys %$relinfo) { |
226 | next unless ($relinfo->{$rel}{is_single} && $relinfo->{$rel}{is_inner}); |
227 | |
228 | if ( my $rel_collapse = $relinfo->{$rel}{rsrc}->_resolve_collapse ( |
229 | $rel_cols->{$rel}, |
230 | $as_fq_idx, |
231 | [ @$rel_chain, $rel ], |
232 | { underdefined => 1 } |
233 | )) { |
234 | push @candidates, $rel_collapse->{-node_id}; |
235 | } |
236 | } |
237 | |
238 | # get the set with least amount of columns |
239 | # FIXME - maybe need to implement a data type order as well (i.e. prefer several ints |
240 | # to a single varchar) |
241 | if (@candidates) { |
242 | ($collapse_map->{-node_id}) = sort { scalar @$a <=> scalar @$b } (@candidates); |
243 | } |
244 | } |
245 | |
246 | # Still dont know how to collapse - see if the parent passed us anything |
247 | # (i.e. reuse collapser over 1:1) |
248 | unless ($collapse_map->{-node_id}) { |
249 | $collapse_map->{-node_id} = $parent_info->{collapse_on} |
250 | if $parent_info->{collapser_reusable}; |
251 | } |
252 | |
253 | # stop descending into children if we were called by a parent for first-pass |
254 | # and don't despair if nothing was found (there may be other parallel branches |
255 | # to dive into) |
256 | if ($parent_info->{underdefined}) { |
257 | return $collapse_map->{-node_id} ? $collapse_map : undef |
258 | } |
259 | # nothing down the chain resolved - can't calculate a collapse-map |
260 | elsif (! $collapse_map->{-node_id}) { |
261 | $self->throw_exception ( sprintf |
262 | "Unable to calculate a definitive collapse column set for %s%s: fetch more unique non-nullable columns", |
263 | $self->source_name, |
264 | @$rel_chain > 1 |
265 | ? sprintf (' (last member of the %s chain)', join ' -> ', @$rel_chain ) |
266 | : '' |
267 | , |
268 | ); |
269 | } |
270 | |
271 | # If we got that far - we are collapsable - GREAT! Now go down all children |
272 | # a second time, and fill in the rest |
273 | |
274 | $collapse_map->{-is_optional} = 1 if $parent_info->{is_optional}; |
275 | $collapse_map->{-node_index} = ${ $node_idx_ref ||= \do { my $x = 1 } }++; # this is *deliberately* not 0-based |
276 | |
277 | my (@id_sets, $multis_in_chain); |
278 | for my $rel (sort keys %$relinfo) { |
279 | |
280 | $collapse_map->{$rel} = $relinfo->{$rel}{rsrc}->_resolve_collapse ( |
281 | { map { $_ => 1 } ( keys %{$rel_cols->{$rel}} ) }, |
282 | |
283 | $as_fq_idx, |
284 | |
285 | [ @$rel_chain, $rel], |
286 | |
287 | { |
288 | collapse_on => [ @{$collapse_map->{-node_id}} ], |
289 | |
290 | rel_condition => $relinfo->{$rel}{fk_map}, |
291 | |
292 | is_optional => $collapse_map->{-is_optional}, |
293 | |
294 | # if this is a 1:1 our own collapser can be used as a collapse-map |
295 | # (regardless of left or not) |
296 | collapser_reusable => $relinfo->{$rel}{is_single}, |
297 | }, |
298 | |
299 | $node_idx_ref, |
300 | ); |
301 | |
302 | $collapse_map->{$rel}{-is_single} = 1 if $relinfo->{$rel}{is_single}; |
303 | $collapse_map->{$rel}{-is_optional} ||= 1 unless $relinfo->{$rel}{is_inner}; |
304 | push @id_sets, @{ $collapse_map->{$rel}{-branch_id} }; |
305 | } |
306 | |
307 | $collapse_map->{-branch_id} = __unique_numlist( @id_sets, @{$collapse_map->{-node_id}} ); |
308 | |
309 | return $collapse_map; |
310 | } |
311 | |
312 | sub _unique_column_set { |
313 | my ($self, $cols) = @_; |
314 | |
315 | my %unique = $self->unique_constraints; |
316 | |
317 | # always prefer the PK first, and then shortest constraints first |
318 | USET: |
319 | for my $set (delete $unique{primary}, sort { @$a <=> @$b } (values %unique) ) { |
320 | next unless $set && @$set; |
321 | |
322 | for (@$set) { |
323 | next USET unless ($cols->{$_} && $cols->{$_}{colinfo} && !$cols->{$_}{colinfo}{is_nullable} ); |
324 | } |
325 | |
326 | return { map { $_ => 1 } @$set }; |
327 | } |
328 | |
329 | return undef; |
330 | } |
331 | |
332 | # Takes an arrayref of {as} dbic column aliases and the collapse and select |
333 | # attributes from the same $rs (the slector requirement is a temporary |
334 | # workaround), and returns a coderef capable of: |
335 | # my $me_pref_clps = $coderef->([$rs->cursor->next]) |
336 | # Where the $me_pref_clps arrayref is the future argument to |
337 | # ::ResultSet::_collapse_result. |
338 | # |
339 | # $me_pref_clps->[0] is always returned (even if as an empty hash with no |
340 | # rowdata), however branches of related data in $me_pref_clps->[1] may be |
341 | # pruned short of what was originally requested based on {as}, depending |
342 | # on: |
343 | # |
344 | # * If collapse is requested, a definitive collapse map is calculated for |
345 | # every relationship "fold-point", consisting of a set of values (which |
346 | # may not even be contained in the future 'me' of said relationship |
347 | # (for example a cd.artist_id defines the related inner-joined artist)). |
348 | # Thus a definedness check is carried on all collapse-condition values |
349 | # and if at least one is undef it is assumed that we are dealing with a |
350 | # NULLed right-side of a left-join, so we don't return a related data |
351 | # container at all, which implies no related objects |
352 | # |
353 | # * If we are not collapsing, there is no constraint on having a selector |
354 | # uniquely identifying all possible objects, and the user might have very |
355 | # well requested a column that just *happens* to be all NULLs. What we do |
356 | # in this case is fallback to the old behavior (which is a potential FIXME) |
357 | # by always returning a data container, but only filling it with columns |
358 | # IFF at least one of them is defined. This way we do not get an object |
359 | # with a bunch of has_column_loaded to undef, but at the same time do not |
360 | # further relationships based off this "null" object (e.g. in case the user |
361 | # deliberately skipped link-table values). I am pretty sure there are some |
362 | # tests that codify this behavior, need to find the exact testname. |
363 | # |
364 | # For an example of this coderef in action (and to see its guts) look at |
365 | # t/prefetch/_internals.t |
366 | # |
367 | # This is a huge performance win, as we call the same code for |
368 | # every row returned from the db, thus avoiding repeated method |
369 | # lookups when traversing relationships |
370 | # |
371 | # Also since the coderef is completely stateless (the returned structure is |
372 | # always fresh on every new invocation) this is a very good opportunity for |
373 | # memoization if further speed improvements are needed |
374 | # |
375 | # The way we construct this coderef is somewhat fugly, although I am not |
376 | # sure if the string eval is *that* bad of an idea. The alternative is to |
377 | # have a *very* large number of anon coderefs calling each other in a twisty |
378 | # maze, whereas the current result is a nice, smooth, single-pass function. |
379 | # In any case - the output of this thing is meticulously micro-tested, so |
380 | # any sort of rewrite should be relatively easy |
381 | # |
382 | sub _mk_row_parser { |
383 | my ($self, $args) = @_; |
384 | |
385 | my $inflate_index = { map |
386 | { $args->{inflate_map}[$_] => $_ } |
387 | ( 0 .. $#{$args->{inflate_map}} ) |
388 | }; |
389 | |
390 | my ($parser_src); |
391 | if ($args->{collapse}) { |
392 | # FIXME - deal with unorderedness |
393 | # unordered => $unordered |
394 | |
395 | my $collapse_map = $self->_resolve_collapse ( |
396 | # FIXME |
397 | # only consider real columns (not functions) during collapse resolution |
398 | # this check shouldn't really be here, as fucktards are not supposed to |
399 | # alias random crap to existing column names anyway, but still - just in |
400 | # case |
401 | # FIXME !!!! - this does not yet deal with unbalanced selectors correctly |
402 | # (it is now trivial as the attrs specify where things go out of sync) |
403 | { map |
404 | { ref $args->{selection}[$inflate_index->{$_}] ? () : ( $_ => $inflate_index->{$_} ) } |
405 | keys %$inflate_index |
406 | } |
407 | ); |
408 | |
409 | my $unrolled_top_branch_id_indexes = join (', ', @{$collapse_map->{-branch_id}}); |
410 | |
411 | my ($sequenced_top_branch_id, $sequenced_top_node_id) = map |
412 | { join ('', map { "{'\xFF__IDVALPOS__${_}__\xFF'}" } @$_ ) } |
413 | $collapse_map->{-branch_id}, $collapse_map->{-node_id} |
414 | ; |
415 | |
416 | my $rolled_out_assemblers = __visit_infmap_collapse ( |
417 | $inflate_index, $collapse_map |
418 | ); |
419 | my @sprintf_args = ( |
420 | $unrolled_top_branch_id_indexes, |
421 | $sequenced_top_branch_id, |
422 | $sequenced_top_node_id, |
423 | $rolled_out_assemblers, |
424 | ); |
425 | |
426 | $parser_src = sprintf (<<'EOS', @sprintf_args); |
427 | |
428 | ### BEGIN STRING EVAL |
429 | my ($rows_pos, $result_pos, $cur_row, @cur_row_id_values, $is_new_res, @collapse_idx) = (0,0); |
430 | |
431 | # this loop is a bit arcane - the rationale is that the passed in |
432 | # $_[0] will either have only one row (->next) or will have all |
433 | # rows already pulled in (->all and/or unordered). Given that the |
434 | # result can be rather large - we reuse the same already allocated |
435 | # array, since the collapsed prefetch is smaller by definition. |
436 | # At the end we cut the leftovers away and move on. |
437 | while ($cur_row = |
438 | ( ( $rows_pos >= 0 and $_[0][$rows_pos++] ) or do { $rows_pos = -1; 0 } ) |
439 | || |
440 | ($_[1] and $_[1]->()) |
441 | ) { |
442 | |
443 | # FIXME |
444 | # optimize this away when we know we have no undefs in the collapse map |
445 | $cur_row_id_values[$_] = defined $cur_row->[$_] ? $cur_row->[$_] : "\xFF\xFFN\xFFU\xFFL\xFFL\xFF\xFF" |
446 | for (%1$s); # the top branch_id includes all id values |
447 | |
448 | # check top branch for doubling via a has_many non-selecting join or something |
449 | # 0 is reserved for this (node indexes start from 1) |
450 | next if $collapse_idx[0]%2$s++; |
451 | |
452 | $is_new_res = ! $collapse_idx[1]%3$s; |
453 | |
454 | # lazify |
455 | # fire on ordered only |
456 | # if ($is_new_res = ! $collapse_idx[1]{$cur_row_id_values[2]}) { |
457 | # } |
458 | |
459 | %4$s |
460 | |
461 | $_[0][$result_pos++] = $collapse_idx[1]%3$s |
462 | if $is_new_res; |
463 | } |
464 | |
465 | splice @{$_[0]}, $result_pos; # truncate the passed in array for cases of collapsing ->all() |
466 | ### END STRING EVAL |
467 | EOS |
468 | |
469 | # change the quoted placeholders to unquoted alias-references |
470 | $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$cur_row->[$1]"/gex; |
471 | $parser_src =~ s/ \' \xFF__IDVALPOS__(\d+)__\xFF \' /"\$cur_row_id_values[$1]"/gex; |
472 | } |
473 | |
474 | else { |
475 | $parser_src = sprintf('$_ = %s for @{$_[0]}', __visit_infmap_simple( |
476 | $inflate_index, { rsrc => $self }), # need the $rsrc to determine left-ness |
477 | ); |
478 | |
479 | # change the quoted placeholders to unquoted alias-references |
480 | # !!! note - different var than the one above |
481 | $parser_src =~ s/ \' \xFF__VALPOS__(\d+)__\xFF \' /"\$_->[$1]"/gex; |
482 | } |
483 | |
484 | $parser_src; |
485 | } |
486 | |
487 | sub __visit_infmap_simple { |
488 | my ($val_idx, $args) = @_; |
489 | |
490 | my $my_cols = {}; |
491 | my $rel_cols; |
492 | for (keys %$val_idx) { |
493 | if ($_ =~ /^ ([^\.]+) \. (.+) /x) { |
494 | $rel_cols->{$1}{$2} = $val_idx->{$_}; |
495 | } |
496 | else { |
497 | $my_cols->{$_} = $val_idx->{$_}; |
498 | } |
499 | } |
500 | my @relperl; |
501 | for my $rel (sort keys %$rel_cols) { |
502 | |
503 | my $rel_rsrc = __get_related_source($args->{rsrc}, $rel, $rel_cols->{$rel}); |
504 | |
505 | #my $optional = $args->{is_optional}; |
506 | #$optional ||= ($args->{rsrc}->relationship_info($rel)->{attrs}{join_type} || '') =~ /^left/i; |
507 | |
508 | push @relperl, join ' => ', perlstring($rel), __visit_infmap_simple($rel_cols->{$rel}, { |
509 | non_top => 1, |
510 | #is_optional => $optional, |
511 | rsrc => $rel_rsrc, |
512 | }); |
513 | |
514 | # FIXME SUBOPTIMAL - disabled to satisfy t/resultset/inflate_result_api.t |
515 | #if ($optional and my @branch_null_checks = map |
516 | # { "(! defined '\xFF__VALPOS__${_}__\xFF')" } |
517 | # sort { $a <=> $b } values %{$rel_cols->{$rel}} |
518 | #) { |
519 | # $relperl[-1] = sprintf ( '(%s) ? ( %s => [] ) : ( %s )', |
520 | # join (' && ', @branch_null_checks ), |
521 | # perlstring($rel), |
522 | # $relperl[-1], |
523 | # ); |
524 | #} |
525 | } |
526 | |
527 | my $me_struct = keys %$my_cols |
528 | ? __visit_dump({ map { $_ => "\xFF__VALPOS__$my_cols->{$_}__\xFF" } (keys %$my_cols) }) |
529 | : 'undef' |
530 | ; |
531 | |
532 | return sprintf '[%s]', join (',', |
533 | $me_struct, |
534 | @relperl ? sprintf ('{ %s }', join (',', @relperl)) : (), |
535 | ); |
536 | } |
537 | |
538 | sub __visit_infmap_collapse { |
539 | |
540 | my ($val_idx, $collapse_map, $parent_info) = @_; |
541 | |
542 | my $my_cols = {}; |
543 | my $rel_cols; |
544 | for (keys %$val_idx) { |
545 | if ($_ =~ /^ ([^\.]+) \. (.+) /x) { |
546 | $rel_cols->{$1}{$2} = $val_idx->{$_}; |
547 | } |
548 | else { |
549 | $my_cols->{$_} = $val_idx->{$_}; |
550 | } |
551 | } |
552 | |
553 | my $sequenced_node_id = join ('', map |
554 | { "{'\xFF__IDVALPOS__${_}__\xFF'}" } |
555 | @{$collapse_map->{-node_id}} |
556 | ); |
557 | |
558 | my $me_struct = keys %$my_cols |
559 | ? __visit_dump([{ map { $_ => "\xFF__VALPOS__$my_cols->{$_}__\xFF" } (keys %$my_cols) }]) |
560 | : 'undef' |
561 | ; |
562 | my $node_idx_ref = sprintf '$collapse_idx[%d]%s', $collapse_map->{-node_index}, $sequenced_node_id; |
563 | |
564 | my $parent_idx_ref = sprintf( '$collapse_idx[%d]%s[1]{%s}', |
565 | @{$parent_info}{qw/node_idx sequenced_node_id/}, |
566 | perlstring($parent_info->{relname}), |
567 | ) if $parent_info; |
568 | |
569 | my @src; |
570 | if ($collapse_map->{-node_index} == 1) { |
571 | push @src, sprintf( '%s ||= %s;', |
572 | $node_idx_ref, |
573 | $me_struct, |
574 | ); |
575 | } |
576 | elsif ($collapse_map->{-is_single}) { |
577 | push @src, sprintf ( '%s = %s ||= %s;', |
578 | $parent_idx_ref, |
579 | $node_idx_ref, |
580 | $me_struct, |
581 | ); |
582 | } |
583 | else { |
584 | push @src, sprintf('push @{%s}, %s = %s if !%s;', |
585 | $parent_idx_ref, |
586 | $node_idx_ref, |
587 | $me_struct, |
588 | $node_idx_ref, |
589 | ); |
590 | } |
591 | |
592 | #my $known_defined = { %{ $parent_info->{known_defined} || {} } }; |
593 | #$known_defined->{$_}++ for @{$collapse_map->{-node_id}}; |
594 | |
595 | for my $rel (sort keys %$rel_cols) { |
596 | |
597 | push @src, sprintf( '%s[1]{%s} ||= [];', $node_idx_ref, perlstring($rel) ); |
598 | |
599 | push @src, __visit_infmap_collapse($rel_cols->{$rel}, $collapse_map->{$rel}, { |
600 | node_idx => $collapse_map->{-node_index}, |
601 | sequenced_node_id => $sequenced_node_id, |
602 | relname => $rel, |
603 | #known_defined => $known_defined, |
604 | }); |
605 | |
606 | # FIXME SUBOPTIMAL - disabled to satisfy t/resultset/inflate_result_api.t |
607 | #if ($collapse_map->{$rel}{-is_optional} and my @null_checks = map |
608 | # { "(! defined '\xFF__VALPOS__${_}__\xFF')" } |
609 | # sort { $a <=> $b } grep |
610 | # { ! $known_defined->{$_} } |
611 | # @{$collapse_map->{$rel}{-node_id}} |
612 | #) { |
613 | # $src[-1] = sprintf( '(%s) or %s', |
614 | # join (' || ', @null_checks ), |
615 | # $src[-1], |
616 | # ); |
617 | #} |
618 | } |
619 | |
620 | join "\n", @src; |
621 | } |
622 | |
623 | # adding a dep on MoreUtils *just* for this is retarded |
624 | sub __unique_numlist { |
625 | [ sort { $a <=> $b } keys %{ {map { $_ => 1 } @_ }} ] |
626 | } |
627 | |
628 | # This error must be thrown from two distinct codepaths, joining them is |
629 | # rather hard. Go for this hack instead. |
630 | sub __get_related_source { |
631 | my ($rsrc, $rel, $relcols) = @_; |
632 | try { |
633 | $rsrc->related_source ($rel) |
634 | } catch { |
635 | $rsrc->throw_exception(sprintf( |
636 | "Can't inflate prefetch into non-existent relationship '%s' from '%s', " |
637 | . "check the inflation specification (columns/as) ending in '...%s.%s'.", |
638 | $rel, |
639 | $rsrc->source_name, |
640 | $rel, |
641 | (sort { length($a) <=> length ($b) } keys %$relcols)[0], |
642 | ))}; |
643 | } |
644 | |
645 | # keep our own DD object around so we don't have to fitz with quoting |
646 | my $dumper_obj; |
647 | sub __visit_dump { |
648 | # we actually will be producing functional perl code here, |
649 | # thus no second-guessing of what these globals might have |
650 | # been set to. DO NOT CHANGE! |
651 | ($dumper_obj ||= do { |
652 | require Data::Dumper; |
653 | Data::Dumper->new([]) |
654 | ->Useperl (1) |
655 | ->Purity (1) |
656 | ->Pad ('') |
657 | ->Useqq (0) |
658 | ->Terse (1) |
659 | ->Quotekeys (1) |
660 | ->Deepcopy (0) |
661 | ->Deparse (0) |
662 | ->Maxdepth (0) |
663 | ->Indent (0) # faster but harder to read, perhaps leave at 1 ? |
664 | })->Values ([$_[0]])->Dump; |
665 | } |
666 | |
667 | 1; |