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 | ); |
122 | } |
123 | elsif( my @variants = @{$args->{collapse_map}{-identifying_columns_variants}} ) { |
124 | |
125 | my @path_parts = map { sprintf |
970d8ca1 |
126 | "( ( defined \$cur_row_data->[%d] ) && (join qq(\xFF), '', %s, '') )", |
ce556881 |
127 | $_->[0], # checking just first is enough - one ID defined, all defined |
9ceb04c6 |
128 | ( join ', ', map { $variant_idcols->{$_} = 1; " \$cur_row_ids{$_} " } @$_ ), |
9f98c4b2 |
129 | } @variants; |
130 | |
131 | my $virtual_column_idx = (scalar keys %{$args->{val_index}} ) + 1; |
132 | |
970d8ca1 |
133 | $top_node_key = "{ \$cur_row_ids{$virtual_column_idx} }"; |
9f98c4b2 |
134 | |
05a5ca4b |
135 | $top_node_key_assembler = sprintf "( \$cur_row_ids{%d} = (%s) ),", |
7596ddca |
136 | $virtual_column_idx, |
137 | "\n" . join( "\n or\n", @path_parts, qq{"\0\$rows_pos\0"} ) |
138 | ; |
9f98c4b2 |
139 | |
140 | $args->{collapse_map} = { |
141 | %{$args->{collapse_map}}, |
142 | -custom_node_key => $top_node_key, |
143 | }; |
9f98c4b2 |
144 | } |
145 | else { |
9ceb04c6 |
146 | DBIx::Class::Exception->throw( |
147 | 'Unexpected collapse map contents: ' . dump_value $args->{collapse_map}, |
148 | 1, |
149 | ) |
9f98c4b2 |
150 | } |
151 | |
152 | my ($data_assemblers, $stats) = __visit_infmap_collapse ($args); |
153 | |
c863e102 |
154 | # variants do not necessarily overlap with true idcols |
155 | my @row_ids = sort { $a <=> $b } keys %{ { |
156 | %{ $variant_idcols || {} }, |
157 | %{ $stats->{idcols_seen} }, |
158 | } }; |
159 | |
05a5ca4b |
160 | my $row_id_defs = sprintf "( \@cur_row_ids{( %s )} = (\n%s\n ) ),", |
c863e102 |
161 | join (', ', @row_ids ), |
162 | # in case we prune - we will never hit undefs/NULLs as pigeon-hole-criteria |
163 | ( $args->{prune_null_branches} |
164 | ? sprintf( '@{$cur_row_data}[( %s )]', join ', ', @row_ids ) |
165 | : join (",\n", map { |
05a5ca4b |
166 | my $quoted_null_val = qq("\0NULL\xFF\${rows_pos}\xFF${_}\0"); |
c863e102 |
167 | HAS_DOR |
05a5ca4b |
168 | ? qq!( \$cur_row_data->[$_] // $quoted_null_val )! |
169 | : qq!( defined(\$cur_row_data->[$_]) ? \$cur_row_data->[$_] : $quoted_null_val )! |
c863e102 |
170 | } @row_ids) |
171 | ) |
172 | ; |
173 | |
9ceb04c6 |
174 | my $parser_src = sprintf (<<'EOS', $row_id_defs, $top_node_key_assembler||'', $top_node_key, join( "\n", @$data_assemblers ) ); |
9f98c4b2 |
175 | ### BEGIN LITERAL STRING EVAL |
aa1d8a87 |
176 | my $rows_pos = 0; |
c863e102 |
177 | my ($result_pos, @collapse_idx, $cur_row_data, %%cur_row_ids ); |
aa1d8a87 |
178 | |
9f98c4b2 |
179 | # this loop is a bit arcane - the rationale is that the passed in |
180 | # $_[0] will either have only one row (->next) or will have all |
181 | # rows already pulled in (->all and/or unordered). Given that the |
182 | # result can be rather large - we reuse the same already allocated |
183 | # array, since the collapsed prefetch is smaller by definition. |
184 | # At the end we cut the leftovers away and move on. |
3b4cd124 |
185 | while ($cur_row_data = ( |
164aab8c |
186 | ( |
187 | $rows_pos >= 0 |
188 | and |
189 | ( |
190 | $_[0][$rows_pos++] |
191 | or |
192 | # It may be tempting to drop the -1 and undef $rows_pos instead |
193 | # thus saving the >= comparison above as well |
194 | # However NULL-handlers and underdefined root markers both use |
195 | # $rows_pos as a last-resort-uniqueness marker (it either is |
196 | # monotonically increasing while we parse ->all, or is set at |
197 | # a steady -1 when we are dealing with a single root node). For |
198 | # the time being the complication of changing all callsites seems |
199 | # overkill, for what is going to be a very modest saving of ops |
200 | ( ($rows_pos = -1), undef ) |
201 | ) |
202 | ) |
3b4cd124 |
203 | or |
164aab8c |
204 | ( $_[1] and $_[1]->() ) |
3b4cd124 |
205 | ) ) { |
206 | |
c863e102 |
207 | # the undef checks may or may not be there |
5e6d06f4 |
208 | # depending on whether we prune or not |
7596ddca |
209 | # |
9f98c4b2 |
210 | # due to left joins some of the ids may be NULL/undef, and |
211 | # won't play well when used as hash lookups |
212 | # we also need to differentiate NULLs on per-row/per-col basis |
ce556881 |
213 | # (otherwise folding of optional 1:1s will be greatly confused |
c863e102 |
214 | %1$s |
9f98c4b2 |
215 | |
7596ddca |
216 | # in the case of an underdefined root - calculate the virtual id (otherwise no code at all) |
c863e102 |
217 | %2$s |
9f98c4b2 |
218 | |
aa1d8a87 |
219 | # if we were supplied a coderef - we are collapsing lazily (the set |
220 | # is ordered properly) |
221 | # as long as we have a result already and the next result is new we |
222 | # return the pre-read data and bail |
05a5ca4b |
223 | ( $_[1] and $result_pos and ! $collapse_idx[0]%3$s and (unshift @{$_[2]}, $cur_row_data) and last ), |
9f98c4b2 |
224 | |
225 | # the rel assemblers |
c863e102 |
226 | %4$s |
9f98c4b2 |
227 | |
9f98c4b2 |
228 | } |
229 | |
aa1d8a87 |
230 | $#{$_[0]} = $result_pos - 1; # truncate the passed in array to where we filled it with results |
9f98c4b2 |
231 | ### END LITERAL STRING EVAL |
232 | EOS |
233 | |
9f7d5590 |
234 | __wrap_in_strictured_scope($parser_src); |
9f98c4b2 |
235 | } |
236 | |
237 | |
238 | # the collapsing nested structure recursor |
239 | sub __visit_infmap_collapse { |
240 | my $args = {%{ shift() }}; |
241 | |
242 | my $cur_node_idx = ${ $args->{-node_idx_counter} ||= \do { my $x = 0} }++; |
243 | |
ce556881 |
244 | my ($my_cols, $rel_cols) = {}; |
9f98c4b2 |
245 | for ( keys %{$args->{val_index}} ) { |
246 | if ($_ =~ /^ ([^\.]+) \. (.+) /x) { |
247 | $rel_cols->{$1}{$2} = $args->{val_index}{$_}; |
248 | } |
249 | else { |
250 | $my_cols->{$_} = $args->{val_index}{$_}; |
251 | } |
252 | } |
253 | |
ce556881 |
254 | |
ce556881 |
255 | if ($args->{hri_style}) { |
256 | delete $my_cols->{$_} for grep { $rel_cols->{$_} } keys %$my_cols; |
257 | } |
9f98c4b2 |
258 | |
52864fbd |
259 | my $me_struct; |
970d8ca1 |
260 | $me_struct = __result_struct_to_source($my_cols, 1) if keys %$my_cols; |
ce556881 |
261 | |
52864fbd |
262 | $me_struct = sprintf( '[ %s ]', $me_struct||'' ) |
263 | unless $args->{hri_style}; |
264 | |
265 | |
266 | my $node_key = $args->{collapse_map}->{-custom_node_key} || join ('', map |
970d8ca1 |
267 | { "{ \$cur_row_ids{$_} }" } |
52864fbd |
268 | @{$args->{collapse_map}->{-identifying_columns}} |
269 | ); |
ce556881 |
270 | my $node_idx_slot = sprintf '$collapse_idx[%d]%s', $cur_node_idx, $node_key; |
9f98c4b2 |
271 | |
52864fbd |
272 | |
9f98c4b2 |
273 | my @src; |
ce556881 |
274 | |
9f98c4b2 |
275 | if ($cur_node_idx == 0) { |
05a5ca4b |
276 | push @src, sprintf( '( %s %s $_[0][$result_pos++] = %s ),', |
9f98c4b2 |
277 | $node_idx_slot, |
cd784aab |
278 | (HAS_DOR ? '//=' : '||='), |
aa1d8a87 |
279 | $me_struct || '{}', |
280 | ); |
9f98c4b2 |
281 | } |
9f98c4b2 |
282 | else { |
ce556881 |
283 | my $parent_attach_slot = sprintf( '$collapse_idx[%d]%s%s{%s}', |
284 | @{$args}{qw/-parent_node_idx -parent_node_key/}, |
285 | $args->{hri_style} ? '' : '[1]', |
a5f5e470 |
286 | perlstring($args->{-node_rel_name}), |
9f98c4b2 |
287 | ); |
ce556881 |
288 | |
289 | if ($args->{collapse_map}->{-is_single}) { |
40471d46 |
290 | push @src, sprintf ( '( %s %s %s = %s ),', |
ce556881 |
291 | $parent_attach_slot, |
cd784aab |
292 | (HAS_DOR ? '//=' : '||='), |
ce556881 |
293 | $node_idx_slot, |
40471d46 |
294 | $me_struct || '{}', |
ce556881 |
295 | ); |
296 | } |
297 | else { |
40471d46 |
298 | push @src, sprintf('( (! %s) and push @{%s}, %s = %s ),', |
ce556881 |
299 | $node_idx_slot, |
300 | $parent_attach_slot, |
301 | $node_idx_slot, |
40471d46 |
302 | $me_struct || '{}', |
ce556881 |
303 | ); |
304 | } |
9f98c4b2 |
305 | } |
306 | |
ce556881 |
307 | my $known_present_ids = { map { $_ => 1 } @{$args->{collapse_map}{-identifying_columns}} }; |
308 | my ($stats, $rel_src); |
309 | |
9f98c4b2 |
310 | for my $rel (sort keys %$rel_cols) { |
311 | |
ce556881 |
312 | my $relinfo = $args->{collapse_map}{$rel}; |
9f98c4b2 |
313 | |
ce556881 |
314 | ($rel_src, $stats->{$rel}) = __visit_infmap_collapse({ %$args, |
9f98c4b2 |
315 | val_index => $rel_cols->{$rel}, |
ce556881 |
316 | collapse_map => $relinfo, |
9f98c4b2 |
317 | -parent_node_idx => $cur_node_idx, |
318 | -parent_node_key => $node_key, |
a5f5e470 |
319 | -node_rel_name => $rel, |
9f98c4b2 |
320 | }); |
321 | |
ce556881 |
322 | my $rel_src_pos = $#src + 1; |
323 | push @src, @$rel_src; |
324 | |
325 | if ( |
ce556881 |
326 | $relinfo->{-is_optional} |
9ceb04c6 |
327 | ) { |
328 | |
329 | my ($first_distinct_child_idcol) = grep |
ce556881 |
330 | { ! $known_present_ids->{$_} } |
331 | @{$relinfo->{-identifying_columns}} |
9ceb04c6 |
332 | ; |
333 | |
334 | DBIx::Class::Exception->throw( |
335 | "An optional node *without* a distinct identifying set shouldn't be possible: " . dump_value $args->{collapse_map}, |
336 | 1, |
337 | ) unless defined $first_distinct_child_idcol; |
ce556881 |
338 | |
79adc44f |
339 | if ($args->{prune_null_branches}) { |
ce556881 |
340 | |
7596ddca |
341 | # start of wrap of the entire chain in a conditional |
05a5ca4b |
342 | splice @src, $rel_src_pos, 0, sprintf "( ( ! defined %s )\n ? %s%s{%s} = %s\n : do {", |
970d8ca1 |
343 | "\$cur_row_data->[$first_distinct_child_idcol]", |
52864fbd |
344 | $node_idx_slot, |
79adc44f |
345 | $args->{hri_style} ? '' : '[1]', |
52864fbd |
346 | perlstring($rel), |
79adc44f |
347 | ($args->{hri_style} && $relinfo->{-is_single}) ? 'undef' : '[]' |
7596ddca |
348 | ; |
349 | |
350 | # end of wrap |
05a5ca4b |
351 | push @src, '} ),' |
52864fbd |
352 | } |
353 | else { |
354 | |
05a5ca4b |
355 | splice @src, $rel_src_pos + 1, 0, sprintf ( '( (defined %s) or bless (%s[1]{%s}, %s) ),', |
970d8ca1 |
356 | "\$cur_row_data->[$first_distinct_child_idcol]", |
52864fbd |
357 | $node_idx_slot, |
358 | perlstring($rel), |
359 | perlstring($null_branch_class), |
360 | ); |
361 | } |
ce556881 |
362 | } |
9f98c4b2 |
363 | } |
364 | |
365 | return ( |
ce556881 |
366 | \@src, |
9f98c4b2 |
367 | { |
368 | idcols_seen => { |
369 | ( map { %{ $_->{idcols_seen} } } values %$stats ), |
370 | ( map { $_ => 1 } @{$args->{collapse_map}->{-identifying_columns}} ), |
371 | } |
372 | } |
373 | ); |
374 | } |
375 | |
a8f62ee0 |
376 | sub __result_struct_to_source { |
970d8ca1 |
377 | my ($data, $is_collapsing) = @_; |
378 | |
379 | sprintf( '{ %s }', |
380 | join (', ', map { |
381 | sprintf ( "%s => %s", |
382 | perlstring($_), |
383 | $is_collapsing |
384 | ? "\$cur_row_data->[$data->{$_}]" |
385 | : "\$_->[ $data->{$_} ]" |
386 | ) |
387 | } sort keys %{$data} |
388 | ) |
389 | ); |
9f98c4b2 |
390 | } |
391 | |
392 | 1; |