File Coverage

blib/lib/Class/ReluctantORM/FetchDeep/Results.pm
Criterion Covered Total %
statement 12 134 8.9
branch 0 30 0.0
condition 0 3 0.0
subroutine 4 14 28.5
pod 0 6 0.0
total 16 187 8.5


line stmt bran cond sub pod time code
1             #==================================================================#
2             # FD Results Processing Support
3             #==================================================================#
4             # These are subroutines
5             #==================================================================#
6              
7             package Class::ReluctantORM::FetchDeep::Results;
8 1     1   6 use strict;
  1         1  
  1         32  
9 1     1   7 use warnings;
  1         2  
  1         28  
10 1     1   7 use base 'Exporter';
  1         1  
  1         72  
11 1     1   6 use Data::Diff;
  1         2  
  1         1953  
12             our @EXPORT;
13             our @EXPORT_OK;
14             our $DEBUG ||= 0;
15              
16             =begin devnotes
17              
18             The result merging algorithm is based on representing each row as a tree structure,
19             then merging that tree with the existing results.
20              
21             Example:
22             Ship->fetch_deep(where => q(gun_count > 12), with => { pirates => {}});
23              
24             Row output:
25             ship.ship_id, ship.name, ship.gun_count, pirate.pirate_id, pirate.name, pirate.ship_id
26             1 Lollipop 13 1 Red Beard 1
27             1 Lollipop 13 2 Wesley 1
28             2 Gldn Hind 24 3 Drake 2
29              
30             Though we see 3 rows, we need to produce 2 objects, the first with two children.
31             We transform the row into a tree, like so:
32             $tree = {
33             1 => { # this is a composite of the primary keys of the ship
34             name => 'Lollipop',
35             gun_count => 13,
36             ship_id => 1,
37             pirates => { # relationship name
38             1 => { # stringified primary keys of the pirate
39             pirate_id => 1,
40             name => 'Red Beard',
41             ship_id => 1,
42             },
43             },
44             },
45             };
46              
47             We process the second row in a similar manner, and the we merge as follows:
48             $tree = {
49             1 => {
50             ...
51             pirates => {
52             1 => { ... },
53             2 => { ... },
54             },
55             },
56             };
57             =cut
58              
59             push @EXPORT, 'fd_inflate';
60             push @EXPORT_OK, 'fd_inflate';
61             sub fd_inflate {
62 0     0 0   my ($sql, $with, $run_args) = @_;
63              
64 0           my ($ok, $exception) = $sql->is_inflatable(auto_reconcile => 0, auto_annotate => 0);
65 0 0         unless ($ok) { die $exception; }
  0            
66              
67             # Build with if not provided
68 0 0         unless ($with) { $with = fd_guess_with_clause($sql); }
  0            
69              
70             # Init hints
71 0           my $hints = fd_make_hints($sql, $with);
72              
73             # Init forest
74 0           my $forest = {};
75 0           my @ordering_trace = (); # Logs stringified PKs of top-level objects in order, so we can preserve query order
76              
77             # Create callback that merges each row into the forest
78             my $callback = sub {
79 0     0     my $sql = shift;
80 0           my $row = { map { $_->alias => $_->output_value() } $sql->output_columns() };
  0            
81 0           my $tree = fd_make_tree_from_row($row, $hints);
82 0           push @ordering_trace, (keys %$tree)[0];
83             # Merge each row with the existing results (the 'forest')
84 0           $forest = fd_merge_tree_into_forest($forest, $tree);
85 0           };
86 0           $sql->add_fetchrow_listener($callback);
87              
88             # Get driver from base class
89 0           my $base_class = $sql->base_table->class();
90 0           my $driver = $base_class->driver();
91              
92             # call run_sql on driver
93 0           $driver->run_sql($sql, $run_args);
94              
95             # Convert the forest into normal CRO objects
96 0 0         if ($DEBUG > 2) { print STDERR __PACKAGE__ . ':' . __LINE__ . "- Final forest:\n" . Dumper($forest); }
  0            
97 0           my @results = fd_convert_forest_to_objects($forest, $hints);
98              
99             # Sort the results in original query order
100 0           my %sort_rank_by_pk = ();
101 0           for (my $i = 0; $i < @ordering_trace; $i++) {
102 0           $sort_rank_by_pk{$ordering_trace[$i]} = $i;
103             }
104 0           @results =
105 0           map { $_->[0] }
106 0           sort { $a->[1] <=> $b->[1] }
107 0           map { [$_, $sort_rank_by_pk{__fd_stringify_key_from_obj($_)} ] }
108             @results;
109              
110 0           foreach my $obj (@results) {
111 0           $obj->__run_triggers('after_retrieve');
112             }
113              
114 0 0         if ($DEBUG > 2) { print STDERR __PACKAGE__ . ':' . __LINE__ . "- Final result:\n" . Dumper(\@results); }
  0            
115 0           return @results;
116             }
117              
118              
119             push @EXPORT_OK, 'fd_guess_with_clause';
120             sub fd_guess_with_clause {
121 0     0 0   my $sql = shift;
122 0           my $base_table = $sql->base_table();
123              
124 0 0 0       if ($sql->from && $sql->from->relationships()) {
125 0           return __fd_GWC_recursor($sql->from->root_relation(), $base_table);
126             } else {
127 0           my $with = { __upper_table => $base_table };
128 0           return $with;
129             }
130             }
131              
132             sub __fd_GWC_recursor {
133 0     0     my ($join, $upper_table) = @_;
134              
135             # Find all joins whose local table is the upper table
136 0 0         my @joins = grep { $_->relationship && $upper_table->is_the_same_table($_->relationship->local_sql_table) } $join->joins();
  0            
137              
138             # Filter out any joins who ALSO have the base table on the right-hand side (as that indicates it is a self-join, and we'll reach it later)
139 0           @joins = grep { !$_->_find_latest_table($upper_table) } @joins;
  0            
140              
141 0           my $with = { __upper_table => $upper_table };
142              
143 0           foreach my $j (@joins) {
144 0           my $next_table = $j->relationship->remote_sql_table();
145 0 0         if ($next_table) {
146 0           $with->{$j->relationship->name} = __fd_GWC_recursor($j, $next_table);
147             } else {
148 0           $with->{$j->relationship->name} = { };
149             }
150             }
151              
152 0           return $with;
153              
154             }
155              
156              
157             # $hints contains cached metadata about the query
158             # $hints->{table} is the Table on the upper end of the query (base table)
159             # $hints->{columns_by_alias} is a hash of the base table's Columns, keyed by their output column aliases
160             # $hints->{key_column_aliases} is a arraryref of the output column aliases of the base table's primary keys
161             # $hints->{children} is a hashref of Hint structures of the child relations, keyed by relationship name
162              
163             push @EXPORT_OK, 'fd_make_hints';
164             sub fd_make_hints {
165 0     0 0   my ($sql, $with) = @_;
166              
167 0           my $hints = {};
168              
169 0           $hints->{table} = $with->{__upper_table};
170              
171 0           my $ta = $hints->{table}->alias;
172 0           $hints->{columns_by_alias} =
173             {
174 0           map { $_->alias => $_->expression } # Construct hash mapping alias to Column
175 0           grep { $_->expression->table->alias eq $ta } # Filter to be only those Columns referring to the base table
176 0           grep { $_->expression->is_column() } # Filter down to those OutputColumns that are based on columns
177             $sql->output_columns() # List all outputs
178             };
179 0           my %key_columns = map { lc($_) => 1 } $hints->{table}->class->primary_key_columns;
  0            
180 0           $hints->{key_column_aliases} =
181 0           [ grep { exists($key_columns{lc($hints->{columns_by_alias}->{$_}->column)}) } keys %{$hints->{columns_by_alias}} ];
  0            
182              
183              
184 0           $hints->{children} = {};
185 0           foreach my $rel_name (keys %$with) {
186 0 0         next if ($rel_name eq '__upper_table');
187 0           my $rel = $hints->{table}->class->relationships($rel_name);
188              
189 0 0         if ($rel->join_depth == 0) {
190             # Do not recurse into same-join relations, like HasLazy
191             } else {
192 0           $hints->{children}->{$rel_name} = fd_make_hints($sql, $with->{$rel_name}->{with});
193             }
194              
195              
196             }
197 0           return $hints;
198             }
199              
200              
201             push @EXPORT_OK, 'fd_make_tree_from_sql_row';
202             sub fd_make_tree_from_row {
203 0     0 0   my ($row, $hints) = @_; #
204              
205             # Build a hash of the object with column aliases pointing to their values
206 0           my %obj;
207 0           foreach my $col (keys %{$hints->{columns_by_alias}}) {
  0            
208 0 0         if (exists $row->{$col}) {
209 0           $obj{$col} = $row->{$col};
210             }
211             }
212              
213             # Recurse into the relationships
214 0 0         foreach my $rel (keys %{$hints->{children} || {}}) {
  0            
215 0           $obj{$rel} = fd_make_tree_from_row($row, $hints->{children}{$rel});
216             }
217              
218 0           my $key = __fd_stringify_key_from_row($row, $hints->{key_column_aliases});
219 0           my $tree = { $key => \%obj };
220 0           return $tree;
221             }
222              
223             sub __fd_stringify_key_from_row {
224 0     0     my ($row, $key_list) = @_;
225 0 0         my $str = join '_', map { defined($_) ? $_ : 'NULL' } map { $row->{$_} } sort @$key_list;
  0            
  0            
226 0           return $str;
227             }
228              
229             sub __fd_stringify_key_from_obj {
230 0     0     my ($obj) = @_;
231             # Careful here - be sure to sort by column name, not by field name
232 0           my @pk_cols = sort $obj->primary_key_columns;
233 0           my %keys_by_col = map { $_ => $obj->get($obj->field_name($_)) } @pk_cols;
  0            
234 0 0         my $str = join '_', map { defined($_) ? $_ : 'NULL' } map { $keys_by_col{$_} } @pk_cols;
  0            
  0            
235 0           return $str;
236             }
237              
238              
239             push @EXPORT_OK, 'fd_merge_tree_into_forest';
240             sub fd_merge_tree_into_forest {
241 0     0 0   my ($forest, $tree) = @_;
242 0           my $diff = Data::Diff->new( $forest, $tree );
243 0           my $combined = $diff->apply();
244              
245             #print STDERR "Have combined object: \n" . Dumper($combined);
246              
247 0           return $combined;
248              
249             }
250              
251             push @EXPORT_OK, 'fd_convert_forest_to_objects';
252             sub fd_convert_forest_to_objects {
253 0     0 0   my ($forest, $hints) = @_;;
254 0           my $class = $hints->{table}->class();
255 0           my $rels = $class->relationships();
256 0           my %fields_by_col_alias = map { $_ => $class->field_name($hints->{columns_by_alias}{$_}->column) } keys %{$hints->{columns_by_alias}};
  0            
  0            
257              
258 0           my @objs;
259 0           foreach my $composite_pk_value (keys %$forest) {
260             # If the object is a null child (ie, the result of a left outer join
261             # for which there was no matching child), the composite_pk_value will be 'NULL'
262             # This is an artifact of the tree generator, and should be skipped
263 0 0         next if $composite_pk_value eq 'NULL';
264              
265 0           my $obj_ghost = $forest->{$composite_pk_value};
266 0           my %new_args;
267 0           foreach my $field_name (keys %$obj_ghost) {
268 0 0         if (exists $rels->{$field_name}) {
269 0           $new_args{$field_name} = [ fd_convert_forest_to_objects($obj_ghost->{$field_name}, $hints->{children}{$field_name}) ];
270             } else {
271 0           $new_args{$fields_by_col_alias{$field_name}} = $obj_ghost->{$field_name};
272             }
273             }
274 0           my $obj = $class->new(%new_args);
275 0           $obj->_is_inserted(1);
276 0           $obj->_mark_all_clean();
277 0           push @objs, $obj;
278             }
279 0           return @objs;
280             }
281              
282             1;