Commit | Line | Data |
9f98c4b2 |
1 | package # hide from the pauses |
2 | DBIx::Class::ResultSource::RowParser::Util; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
9ceb04c6 |
7 | use DBIx::Class::_Util qw( perlstring dump_value ); |
9f98c4b2 |
8 | |
750a4ad2 |
9 | use constant HAS_DOR => ( "$]" < 5.010 ? 0 : 1 ); |
cd784aab |
10 | |
9f98c4b2 |
11 | use base 'Exporter'; |
12 | our @EXPORT_OK = qw( |
13 | assemble_simple_parser |
14 | assemble_collapsing_parser |
15 | ); |
16 | |
52864fbd |
17 | # working title - we are hoping to extract this eventually... |
18 | our $null_branch_class = 'DBIx::ResultParser::RelatedNullBranch'; |
19 | |
9f7d5590 |
20 | sub __wrap_in_strictured_scope { |
21 | " { use strict; use warnings; use warnings FATAL => 'uninitialized';\n$_[0]\n }" |
22 | } |
23 | |
9f98c4b2 |
24 | sub assemble_simple_parser { |
25 | #my ($args) = @_; |
26 | |
27 | # the non-collapsing assembler is easy |
28 | # FIXME SUBOPTIMAL there could be a yet faster way to do things here, but |
29 | # need to try an actual implementation and benchmark it: |
30 | # |
31 | # <timbunce_> First setup the nested data structure you want for each row |
32 | # Then call bind_col() to alias the row fields into the right place in |
33 | # the data structure, then to fetch the data do: |
34 | # push @rows, dclone($row_data_struct) while ($sth->fetchrow); |
35 | # |
9f98c4b2 |
36 | |
970d8ca1 |
37 | __wrap_in_strictured_scope( sprintf |
38 | '$_ = %s for @{$_[0]}', |
39 | __visit_infmap_simple( $_[0] ) |
40 | ); |
9f98c4b2 |
41 | } |
42 | |
43 | # the simple non-collapsing nested structure recursor |
44 | sub __visit_infmap_simple { |
45 | my $args = shift; |
46 | |
47 | my $my_cols = {}; |
48 | my $rel_cols; |
49 | for (keys %{$args->{val_index}}) { |
50 | if ($_ =~ /^ ([^\.]+) \. (.+) /x) { |
51 | $rel_cols->{$1}{$2} = $args->{val_index}{$_}; |
52 | } |
53 | else { |
54 | $my_cols->{$_} = $args->{val_index}{$_}; |
55 | } |
56 | } |
57 | |
58 | my @relperl; |
59 | for my $rel (sort keys %$rel_cols) { |
60 | |
52864fbd |
61 | my $rel_struct = __visit_infmap_simple({ %$args, |
9f98c4b2 |
62 | val_index => $rel_cols->{$rel}, |
9f98c4b2 |
63 | }); |
64 | |
52864fbd |
65 | if (keys %$my_cols) { |
ce556881 |
66 | |
52864fbd |
67 | my $branch_null_checks = join ' && ', map |
970d8ca1 |
68 | { "( ! defined \$_->[$_] )" } |
ce556881 |
69 | sort { $a <=> $b } values %{$rel_cols->{$rel}} |
70 | ; |
71 | |
79adc44f |
72 | if ($args->{prune_null_branches}) { |
52864fbd |
73 | $rel_struct = sprintf ( '( (%s) ? undef : %s )', |
74 | $branch_null_checks, |
75 | $rel_struct, |
76 | ); |
77 | } |
78 | else { |
79 | $rel_struct = sprintf ( '( (%s) ? bless( (%s), %s ) : %s )', |
80 | $branch_null_checks, |
81 | $rel_struct, |
82 | perlstring($null_branch_class), |
83 | $rel_struct, |
84 | ); |
85 | } |
ce556881 |
86 | } |
52864fbd |
87 | |
88 | push @relperl, sprintf '( %s => %s )', |
89 | perlstring($rel), |
90 | $rel_struct, |
91 | ; |
92 | |
9f98c4b2 |
93 | } |
94 | |
ce556881 |
95 | my $me_struct; |
a8f62ee0 |
96 | $me_struct = __result_struct_to_source($my_cols) if keys %$my_cols; |
9f98c4b2 |
97 | |
ce556881 |
98 | if ($args->{hri_style}) { |
99 | $me_struct =~ s/^ \s* \{ | \} \s* $//gx |
100 | if $me_struct; |
101 | |
102 | return sprintf '{ %s }', join (', ', $me_struct||(), @relperl); |
103 | } |
104 | else { |
105 | return sprintf '[%s]', join (',', |
106 | $me_struct || 'undef', |
107 | @relperl ? sprintf ('{ %s }', join (',', @relperl)) : (), |
108 | ); |
109 | } |
9f98c4b2 |
110 | } |
111 | |
112 | sub assemble_collapsing_parser { |
113 | my $args = shift; |
114 | |
c863e102 |
115 | my ($top_node_key, $top_node_key_assembler, $variant_idcols); |
9f98c4b2 |
116 | |
117 | if (scalar @{$args->{collapse_map}{-identifying_columns}}) { |
118 | $top_node_key = join ('', map |
970d8ca1 |
119 | { "{ \$cur_row_ids{$_} }" } |
9f98c4b2 |
120 | @{$args->{collapse_map}{-identifying_columns}} |
121 | ); |
5ff6d603 |
122 | |
123 | $top_node_key_assembler = ''; |
9f98c4b2 |
124 | } |
125 | elsif( my @variants = @{$args->{collapse_map}{-identifying_columns_variants}} ) { |
126 | |
127 | my @path_parts = map { sprintf |
970d8ca1 |
128 | "( ( defined \$cur_row_data->[%d] ) && (join qq(\xFF), '', %s, '') )", |
ce556881 |
129 | $_->[0], # checking just first is enough - one ID defined, all defined |
9ceb04c6 |
130 | ( join ', ', map { $variant_idcols->{$_} = 1; " \$cur_row_ids{$_} " } @$_ ), |
9f98c4b2 |
131 | } @variants; |
132 | |
133 | my $virtual_column_idx = (scalar keys %{$args->{val_index}} ) + 1; |
134 | |
970d8ca1 |
135 | $top_node_key = "{ \$cur_row_ids{$virtual_column_idx} }"; |
9f98c4b2 |
136 | |
05a5ca4b |
137 | $top_node_key_assembler = sprintf "( \$cur_row_ids{%d} = (%s) ),", |
7596ddca |
138 | $virtual_column_idx, |
139 | "\n" . join( "\n or\n", @path_parts, qq{"\0\$rows_pos\0"} ) |
140 | ; |
9f98c4b2 |
141 | |
142 | $args->{collapse_map} = { |
143 | %{$args->{collapse_map}}, |
144 | -custom_node_key => $top_node_key, |
145 | }; |
9f98c4b2 |
146 | } |
147 | else { |
9ceb04c6 |
148 | DBIx::Class::Exception->throw( |
149 | 'Unexpected collapse map contents: ' . dump_value $args->{collapse_map}, |
150 | 1, |
151 | ) |
9f98c4b2 |
152 | } |
153 | |
154 | my ($data_assemblers, $stats) = __visit_infmap_collapse ($args); |
155 | |
c863e102 |
156 | # variants do not necessarily overlap with true idcols |
157 | my @row_ids = sort { $a <=> $b } keys %{ { |
158 | %{ $variant_idcols || {} }, |
159 | %{ $stats->{idcols_seen} }, |
160 | } }; |
161 | |
05a5ca4b |
162 | my $row_id_defs = sprintf "( \@cur_row_ids{( %s )} = (\n%s\n ) ),", |
c863e102 |
163 | join (', ', @row_ids ), |
164 | # in case we prune - we will never hit undefs/NULLs as pigeon-hole-criteria |
165 | ( $args->{prune_null_branches} |
166 | ? sprintf( '@{$cur_row_data}[( %s )]', join ', ', @row_ids ) |
167 | : join (",\n", map { |
5ff6d603 |
168 | $stats->{nullchecks}{mandatory}{$_} |
169 | ? qq!( \$cur_row_data->[$_] )! |
170 | : do { |
171 | my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); |
172 | HAS_DOR |
173 | ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! |
174 | : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! |
175 | } |
c863e102 |
176 | } @row_ids) |
177 | ) |
178 | ; |
179 | |
5ff6d603 |
180 | my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler, $top_node_key, join( "\n", @$data_assemblers ) ); |
9f98c4b2 |
181 | ### BEGIN LITERAL STRING EVAL |
aa1d8a87 |
182 | my $rows_pos = 0; |
c863e102 |
183 | my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); |
aa1d8a87 |
184 | |
9f98c4b2 |
185 | # this loop is a bit arcane - the rationale is that the passed in |
186 | # $_[0] will either have only one row (->next) or will have all |
187 | # rows already pulled in (->all and/or unordered). Given that the |
188 | # result can be rather large - we reuse the same already allocated |
189 | # array, since the collapsed prefetch is smaller by definition. |
190 | # At the end we cut the leftovers away and move on. |
3b4cd124 |
191 | while ($cur_row_data = ( |
164aab8c |
192 | ( |
193 | $rows_pos >= 0 |
194 | and |
195 | ( |
196 | $_[0][$rows_pos++] |
197 | or |
198 | # It may be tempting to drop the -1 and undef $rows_pos instead |
199 | # thus saving the >= comparison above as well |
200 | # However NULL-handlers and underdefined root markers both use |
201 | # $rows_pos as a last-resort-uniqueness marker (it either is |
202 | # monotonically increasing while we parse ->all, or is set at |
203 | # a steady -1 when we are dealing with a single root node). For |
204 | # the time being the complication of changing all callsites seems |
205 | # overkill, for what is going to be a very modest saving of ops |
206 | ( ($rows_pos = -1), undef ) |
207 | ) |
208 | ) |
3b4cd124 |
209 | or |
164aab8c |
210 | ( $_[1] and $_[1]->() ) |
3b4cd124 |
211 | ) ) { |
212 | |
c863e102 |
213 | # the undef checks may or may not be there |
5e6d06f4 |
214 | # depending on whether we prune or not |
7596ddca |
215 | # |
9f98c4b2 |
216 | # due to left joins some of the ids may be NULL/undef, and |
217 | # won't play well when used as hash lookups |
218 | # we also need to differentiate NULLs on per-row/per-col basis |
ce556881 |
219 | # (otherwise folding of optional 1:1s will be greatly confused |
5ff6d603 |
220 | %s |
9f98c4b2 |
221 | |
7596ddca |
222 | # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) |
5ff6d603 |
223 | %s |
9f98c4b2 |
224 | |
aa1d8a87 |
225 | # if we were supplied a coderef - we are collapsing lazily (the set |
226 | # is ordered properly) |
227 | # as long as we have a result already and the next result is new we |
228 | # return the pre-read data and bail |
5ff6d603 |
229 | ( $_[1] and $result_pos and ! $collapse_idx[0]%s and (unshift @{$_[2]}, $cur_row_data) and last ), |
9f98c4b2 |
230 | |
231 | # the rel assemblers |
5ff6d603 |
232 | %s |
9f98c4b2 |
233 | |
9f98c4b2 |
234 | } |
235 | |
aa1d8a87 |
236 | $#{$_[0]} = $result_pos - 1; # truncate the passed in array to where we filled it with results |
9f98c4b2 |
237 | ### END LITERAL STRING EVAL |
238 | EOS |
239 | |
9f7d5590 |
240 | __wrap_in_strictured_scope($parser_src); |
9f98c4b2 |
241 | } |
242 | |
243 | |
244 | # the collapsing nested structure recursor |
245 | sub __visit_infmap_collapse { |
246 | my $args = {%{ shift() }}; |
247 | |
248 | my $cur_node_idx = ${ $args->{-node_idx_counter} ||= \do { my $x = 0} }++; |
249 | |
5ff6d603 |
250 | $args->{-mandatory_ids} ||= {}; |
251 | $args->{-seen_ids} ||= {}; |
252 | $args->{-all_or_nothing_sets} ||= []; |
253 | $args->{-null_from} ||= []; |
254 | |
255 | $args->{-seen_ids}{$_} = 1 |
256 | for @{$args->{collapse_map}->{-identifying_columns}}; |
257 | |
258 | my $node_specific_ids = { map { $_ => 1 } grep |
259 | { ! $args->{-parent_ids}{$_} } |
260 | @{$args->{collapse_map}->{-identifying_columns}} |
261 | }; |
262 | |
263 | if (not ( $args->{-chain_is_optional} ||= $args->{collapse_map}{-is_optional} ) ) { |
264 | $args->{-mandatory_ids}{$_} = 1 |
265 | for @{$args->{collapse_map}->{-identifying_columns}}; |
266 | } |
267 | elsif ( keys %$node_specific_ids > 1 ) { |
268 | push @{$args->{-all_or_nothing_sets}}, $node_specific_ids; |
269 | } |
270 | |
ce556881 |
271 | my ($my_cols, $rel_cols) = {}; |
9f98c4b2 |
272 | for ( keys %{$args->{val_index}} ) { |
273 | if ($_ =~ /^ ([^\.]+) \. (.+) /x) { |
274 | $rel_cols->{$1}{$2} = $args->{val_index}{$_}; |
275 | } |
276 | else { |
277 | $my_cols->{$_} = $args->{val_index}{$_}; |
278 | } |
279 | } |
280 | |
ce556881 |
281 | |
ce556881 |
282 | if ($args->{hri_style}) { |
283 | delete $my_cols->{$_} for grep { $rel_cols->{$_} } keys %$my_cols; |
284 | } |
9f98c4b2 |
285 | |
52864fbd |
286 | my $me_struct; |
970d8ca1 |
287 | $me_struct = __result_struct_to_source($my_cols, 1) if keys %$my_cols; |
ce556881 |
288 | |
52864fbd |
289 | $me_struct = sprintf( '[ %s ]', $me_struct||'' ) |
290 | unless $args->{hri_style}; |
291 | |
292 | |
293 | my $node_key = $args->{collapse_map}->{-custom_node_key} || join ('', map |
970d8ca1 |
294 | { "{ \$cur_row_ids{$_} }" } |
52864fbd |
295 | @{$args->{collapse_map}->{-identifying_columns}} |
296 | ); |
ce556881 |
297 | my $node_idx_slot = sprintf '$collapse_idx[%d]%s', $cur_node_idx, $node_key; |
9f98c4b2 |
298 | |
52864fbd |
299 | |
9f98c4b2 |
300 | my @src; |
ce556881 |
301 | |
9f98c4b2 |
302 | if ($cur_node_idx == 0) { |
05a5ca4b |
303 | push @src, sprintf( '( %s %s $_[0][$result_pos++] = %s ),', |
9f98c4b2 |
304 | $node_idx_slot, |
cd784aab |
305 | (HAS_DOR ? '//=' : '||='), |
aa1d8a87 |
306 | $me_struct || '{}', |
307 | ); |
9f98c4b2 |
308 | } |
9f98c4b2 |
309 | else { |
ce556881 |
310 | my $parent_attach_slot = sprintf( '$collapse_idx[%d]%s%s{%s}', |
311 | @{$args}{qw/-parent_node_idx -parent_node_key/}, |
312 | $args->{hri_style} ? '' : '[1]', |
a5f5e470 |
313 | perlstring($args->{-node_rel_name}), |
9f98c4b2 |
314 | ); |
ce556881 |
315 | |
316 | if ($args->{collapse_map}->{-is_single}) { |
40471d46 |
317 | push @src, sprintf ( '( %s %s %s = %s ),', |
ce556881 |
318 | $parent_attach_slot, |
cd784aab |
319 | (HAS_DOR ? '//=' : '||='), |
ce556881 |
320 | $node_idx_slot, |
40471d46 |
321 | $me_struct || '{}', |
ce556881 |
322 | ); |
323 | } |
324 | else { |
40471d46 |
325 | push @src, sprintf('( (! %s) and push @{%s}, %s = %s ),', |
ce556881 |
326 | $node_idx_slot, |
327 | $parent_attach_slot, |
328 | $node_idx_slot, |
40471d46 |
329 | $me_struct || '{}', |
ce556881 |
330 | ); |
331 | } |
9f98c4b2 |
332 | } |
333 | |
ce556881 |
334 | my $known_present_ids = { map { $_ => 1 } @{$args->{collapse_map}{-identifying_columns}} }; |
5ff6d603 |
335 | my $rel_src; |
ce556881 |
336 | |
9f98c4b2 |
337 | for my $rel (sort keys %$rel_cols) { |
338 | |
ce556881 |
339 | my $relinfo = $args->{collapse_map}{$rel}; |
9f98c4b2 |
340 | |
5ff6d603 |
341 | ($rel_src) = __visit_infmap_collapse({ %$args, |
9f98c4b2 |
342 | val_index => $rel_cols->{$rel}, |
ce556881 |
343 | collapse_map => $relinfo, |
9f98c4b2 |
344 | -parent_node_idx => $cur_node_idx, |
345 | -parent_node_key => $node_key, |
5ff6d603 |
346 | -parent_id_path => [ @{$args->{-parent_id_path}||[]}, sort { $a <=> $b } keys %$node_specific_ids ], |
347 | -parent_ids => { map { %$_ } $node_specific_ids, $args->{-parent_ids}||{} }, |
a5f5e470 |
348 | -node_rel_name => $rel, |
9f98c4b2 |
349 | }); |
350 | |
ce556881 |
351 | my $rel_src_pos = $#src + 1; |
352 | push @src, @$rel_src; |
353 | |
354 | if ( |
ce556881 |
355 | $relinfo->{-is_optional} |
9ceb04c6 |
356 | ) { |
357 | |
358 | my ($first_distinct_child_idcol) = grep |
ce556881 |
359 | { ! $known_present_ids->{$_} } |
360 | @{$relinfo->{-identifying_columns}} |
9ceb04c6 |
361 | ; |
362 | |
363 | DBIx::Class::Exception->throw( |
364 | "An optional node *without* a distinct identifying set shouldn't be possible: " . dump_value $args->{collapse_map}, |
365 | 1, |
366 | ) unless defined $first_distinct_child_idcol; |
ce556881 |
367 | |
79adc44f |
368 | if ($args->{prune_null_branches}) { |
ce556881 |
369 | |
7596ddca |
370 | # start of wrap of the entire chain in a conditional |
05a5ca4b |
371 | splice @src, $rel_src_pos, 0, sprintf "( ( ! defined %s )\n ? %s%s{%s} = %s\n : do {", |
970d8ca1 |
372 | "\$cur_row_data->[$first_distinct_child_idcol]", |
52864fbd |
373 | $node_idx_slot, |
79adc44f |
374 | $args->{hri_style} ? '' : '[1]', |
52864fbd |
375 | perlstring($rel), |
79adc44f |
376 | ($args->{hri_style} && $relinfo->{-is_single}) ? 'undef' : '[]' |
7596ddca |
377 | ; |
378 | |
379 | # end of wrap |
05a5ca4b |
380 | push @src, '} ),' |
52864fbd |
381 | } |
382 | else { |
383 | |
05a5ca4b |
384 | splice @src, $rel_src_pos + 1, 0, sprintf ( '( (defined %s) or bless (%s[1]{%s}, %s) ),', |
970d8ca1 |
385 | "\$cur_row_data->[$first_distinct_child_idcol]", |
52864fbd |
386 | $node_idx_slot, |
387 | perlstring($rel), |
388 | perlstring($null_branch_class), |
389 | ); |
390 | } |
ce556881 |
391 | } |
9f98c4b2 |
392 | } |
393 | |
5ff6d603 |
394 | if ( |
395 | |
396 | # calculation only valid for leaf nodes |
397 | ! values %$rel_cols |
398 | |
399 | and |
400 | |
401 | # child of underdefined path doesn't leave us anything to test |
402 | @{$args->{-parent_id_path} || []} |
403 | |
404 | and |
405 | |
406 | (my @nullable_portion = grep |
407 | { ! $args->{-mandatory_ids}{$_} } |
408 | ( |
409 | @{$args->{-parent_id_path}}, |
410 | sort { $a <=> $b } keys %$node_specific_ids |
411 | ) |
412 | ) > 1 |
413 | ) { |
414 | # there may be 1:1 overlap with a specific all_or_nothing |
415 | push @{$args->{-null_from}}, \@nullable_portion unless grep |
416 | { |
417 | my $a_o_n_set = $_; |
418 | |
419 | keys %$a_o_n_set == @nullable_portion |
420 | and |
421 | ! grep { ! $a_o_n_set->{$_} } @nullable_portion |
422 | } |
423 | @{ $args->{-all_or_nothing_sets} || [] } |
424 | ; |
425 | } |
426 | |
9f98c4b2 |
427 | return ( |
ce556881 |
428 | \@src, |
5ff6d603 |
429 | ( $cur_node_idx != 0 ) ? () : { |
430 | idcols_seen => $args->{-seen_ids}, |
431 | nullchecks => { |
432 | ( keys %{$args->{-mandatory_ids} } |
433 | ? ( mandatory => $args->{-mandatory_ids} ) |
434 | : () |
435 | ), |
436 | ( @{$args->{-all_or_nothing_sets}} |
437 | ? ( all_or_nothing => $args->{-all_or_nothing_sets} ) |
438 | : () |
439 | ), |
440 | ( @{$args->{-null_from}} |
441 | ? ( from_first_encounter => $args->{-null_from} ) |
442 | : () |
443 | ), |
444 | }, |
445 | }, |
9f98c4b2 |
446 | ); |
447 | } |
448 | |
a8f62ee0 |
449 | sub __result_struct_to_source { |
970d8ca1 |
450 | my ($data, $is_collapsing) = @_; |
451 | |
452 | sprintf( '{ %s }', |
453 | join (', ', map { |
454 | sprintf ( "%s => %s", |
455 | perlstring($_), |
456 | $is_collapsing |
457 | ? "\$cur_row_data->[$data->{$_}]" |
458 | : "\$_->[ $data->{$_} ]" |
459 | ) |
460 | } sort keys %{$data} |
461 | ) |
462 | ); |
9f98c4b2 |
463 | } |
464 | |
465 | 1; |