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; |