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