← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:47 2010

File/wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSource.pm
Statements Executed112073
Total Time1.13810700000064 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
55482220.553572.31128DBIx::Class::ResultSource::handle
27751320.235220.58129DBIx::Class::ResultSource::has_column
120220.001570.00573DBIx::Class::ResultSource::column_info
20320.000790.00079DBIx::Class::ResultSource::new
5110.000520.00071DBIx::Class::ResultSource::add_columns
2110.000100.00016DBIx::Class::ResultSource::add_relationship
4119.1e-50.00033DBIx::Class::ResultSource::add_unique_constraint
4118.8e-50.00060DBIx::Class::ResultSource::set_primary_key
3116.2e-50.00154DBIx::Class::ResultSource::resultset
3335.0e-55.0e-5DBIx::Class::ResultSource::columns
4114.0e-50.00025DBIx::Class::ResultSource::storage
4112.9e-58.0e-5DBIx::Class::ResultSource::unique_constraints
2112.6e-54.9e-5DBIx::Class::ResultSource::relationship_info
1118.0e-62.2e-5DBIx::Class::ResultSource::primary_columns
00000DBIx::Class::ResultSource::BEGIN
00000DBIx::Class::ResultSource::add_column
00000DBIx::Class::ResultSource::compare_relationship_keys
00000DBIx::Class::ResultSource::has_relationship
00000DBIx::Class::ResultSource::name_unique_constraint
00000DBIx::Class::ResultSource::related_class
00000DBIx::Class::ResultSource::related_source
00000DBIx::Class::ResultSource::relationships
00000DBIx::Class::ResultSource::remove_column
00000DBIx::Class::ResultSource::remove_columns
00000DBIx::Class::ResultSource::resolve_condition
00000DBIx::Class::ResultSource::resolve_join
00000DBIx::Class::ResultSource::resolve_prefetch
00000DBIx::Class::ResultSource::reverse_relationship_info
00000DBIx::Class::ResultSource::throw_exception
00000DBIx::Class::ResultSource::unique_constraint_columns
00000DBIx::Class::ResultSource::unique_constraint_names

LineStmts.Exclusive
Time		Avg.Code
1package DBIx::Class::ResultSource;
2
333.2e-51.1e-5use strict;
# spent 11µs making 1 call to strict::import
432.7e-59.0e-6use warnings;
# spent 32µs making 1 call to warnings::import
5
632.6e-58.7e-6use DBIx::Class::ResultSet;
# spent 6µs making 1 call to import
732.7e-59.0e-6use DBIx::Class::ResultSourceHandle;
# spent 4µs making 1 call to import
832.7e-59.0e-6use Carp::Clan qw/^DBIx::Class/;
# spent 92µs making 1 call to Carp::Clan::import
934.2e-51.4e-5use Storable;
# spent 44µs making 1 call to Exporter::import
10
1130.003220.00107use base qw/DBIx::Class/;
# spent 73µs making 1 call to base::import
12
1311.7e-51.7e-5__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
# spent 1.18ms making 1 call to Class::Accessor::Grouped::mk_group_accessors
14 _columns _primaries _unique_constraints name resultset_attributes
15 schema from _relationships column_info_from_storage source_info
16 source_name/);
17
1818.0e-68.0e-6__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
# spent 209µs making 1 call to Class::Accessor::Grouped::mk_group_accessors
19 result_class/);
20
21=head1 NAME
22
23DBIx::Class::ResultSource - Result source object
24
25=head1 SYNOPSIS
26
27=head1 DESCRIPTION
28
29A ResultSource is a component of a schema from which results can be directly
30retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
31
32=head1 METHODS
33
34=pod
35
36=head2 new
37
38 $class->new();
39
40 $class->new({attribute_name => value});
41
42Creates a new ResultSource object. Not normally called directly by end users.
43
44=cut
45
46
# spent 788µs within DBIx::Class::ResultSource::new which was called 20 times, avg 39µs/call: # 10 times (356µs+0) by DBIx::Class::Schema::register_source at line 101 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm, avg 36µs/call # 5 times (270µs+0) by DBIx::Class::Schema::clone at line 808 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm, avg 54µs/call # 5 times (162µs+0) by DBIx::Class::ResultSourceProxy::Table::table at line 47 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy/Table.pm, avg 32µs/call
sub new {
47203.2e-51.6e-6 my ($class, $attrs) = @_;
48203.1e-51.5e-6 $class = ref $class if ref $class;
49
50200.000211.0e-5 my $new = bless { %{$attrs || {}} }, $class;
51201.6e-58.0e-7 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
52206.4e-53.2e-6 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
53208.8e-54.4e-6 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
54200.000167.9e-6 $new->{_columns} = { %{$new->{_columns}||{}} };
55204.3e-52.1e-6 $new->{_relationships} = { %{$new->{_relationships}||{}} };
56201.7e-58.5e-7 $new->{name} ||= "!!NAME NOT SET!!";
57201.9e-59.5e-7 $new->{_columns_info_loaded} ||= 0;
58204.1e-52.0e-6 return $new;
59}
60
61=pod
62
63=head2 source_info
64
65Stores a hashref of per-source metadata. No specific key names
66have yet been standardized, the examples below are purely hypothetical
67and don't actually accomplish anything on their own:
68
69 __PACKAGE__->source_info({
70 "_tablespace" => 'fast_disk_array_3',
71 "_engine" => 'InnoDB',
72 });
73
74=head2 add_columns
75
76 $table->add_columns(qw/col1 col2 col3/);
77
78 $table->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
79
80Adds columns to the result source. If supplied key => hashref pairs, uses
81the hashref as the column_info for that column. Repeated calls of this
82method will add more columns, not replace them.
83
84The column names given will be created as accessor methods on your
85L<DBIx::Class::Row> objects, you can change the name of the accessor
86by supplying an L</accessor> in the column_info hash.
87
88The contents of the column_info are not set in stone. The following
89keys are currently recognised/used by DBIx::Class:
90
91=over 4
92
93=item accessor
94
95Use this to set the name of the accessor method for this column. If unset,
96the name of the column will be used.
97
98=item data_type
99
100This contains the column type. It is automatically filled by the
101L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
102L<DBIx::Class::Schema::Loader> module. If you do not enter a
103data_type, DBIx::Class will attempt to retrieve it from the
104database for you, using L<DBI>'s column_info method. The values of this
105key are typically upper-cased.
106
107Currently there is no standard set of values for the data_type. Use
108whatever your database supports.
109
110=item size
111
112The length of your column, if it is a column type that can have a size
113restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
114
115=item is_nullable
116
117Set this to a true value for a columns that is allowed to contain
118NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
119
120=item is_auto_increment
121
122Set this to a true value for a column whose value is somehow
123automatically set. This is used to determine which columns to empty
124when cloning objects using C<copy>. It is also used by
125L<DBIx::Class::Schema/deploy>.
126
127=item is_foreign_key
128
129Set this to a true value for a column that contains a key from a
130foreign table. This is currently only used by
131L<DBIx::Class::Schema/deploy>.
132
133=item default_value
134
135Set this to the default value which will be inserted into a column
136by the database. Can contain either a value or a function. This is
137currently only used by L<DBIx::Class::Schema/deploy>.
138
139=item sequence
140
141Set this on a primary key column to the name of the sequence used to
142generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
143will attempt to retrieve the name of the sequence from the database
144automatically.
145
146=item extra
147
148This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
149to add extra non-generic data to the column. For example: C<< extra
150=> { unsigned => 1} >> is used by the MySQL producer to set an integer
151column to unsigned. For more details, see
152L<SQL::Translator::Producer::MySQL>.
153
154=back
155
156=head2 add_column
157
158 $table->add_column('col' => \%info?);
159
160Convenience alias to add_columns.
161
162=cut
163
164
# spent 711µs (515+196) within DBIx::Class::ResultSource::add_columns which was called 5 times, avg 142µs/call: # 5 times (515µs+196µs) by DBIx::Class::ResultSourceProxy::add_columns at line 38 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm, avg 142µs/call
sub add_columns {
16556.1e-51.2e-5 my ($self, @cols) = @_;
16653.4e-56.8e-6 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
# spent 70µs making 5 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 14µs/call
167
16852.0e-64.0e-7 my @added;
16952.8e-55.6e-6 my $columns = $self->_columns;
# spent 62µs making 5 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
17050.000102.1e-5 while (my $col = shift @cols) {
171 # If next entry is { ... } use that for the column info, if not
172 # use an empty hashref
173736.3e-58.6e-7 my $column_info = ref $cols[0] ? shift(@cols) : {};
174737.1e-59.7e-7 push(@added, $col) unless exists $columns->{$col};
175730.000131.8e-6 $columns->{$col} = $column_info;
176 }
17754.8e-59.6e-6 push @{ $self->_ordered_columns }, @added;
# spent 64µs making 5 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 13µs/call
17851.2e-52.4e-6 return $self;
179}
180
181sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
182
183=head2 has_column
184
185 if ($obj->has_column($col)) { ... }
186
187Returns true if the source has a column of this name, false otherwise.
188
189=cut
190
191
# spent 581ms (235+346) within DBIx::Class::ResultSource::has_column which was called 27751 times, avg 21µs/call: # 27739 times (235ms+346ms) by DBIx::Class::ResultSourceProxy::has_column at line 47 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm, avg 21µs/call # 6 times (45µs+70µs) by DBIx::Class::ResultSource::set_primary_key at line 316, avg 19µs/call # 6 times (38µs+72µs) by DBIx::Class::ResultSource::add_unique_constraint at line 364, avg 18µs/call
sub has_column {
192277510.050011.8e-6 my ($self, $column) = @_;
193277510.180116.5e-6 return exists $self->_columns->{$column};
# spent 346ms making 27751 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
194}
195
196=head2 column_info
197
198 my $info = $obj->column_info($col);
199
200Returns the column metadata hashref for a column. See the description
201of add_column for information on the contents of the hashref.
202
203=cut
204
205
# spent 5.73ms (1.57+4.15) within DBIx::Class::ResultSource::column_info which was called 120 times, avg 48µs/call: # 73 times (936µs+2.54ms) by DBIx::Class::ResultSourceProxy::add_columns at line 40 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm, avg 48µs/call # 47 times (635µs+1.61ms) at line 523 of /wise/base/deliv/dev/bin/getfix, avg 48µs/call
sub column_info {
2061200.000211.8e-6 my ($self, $column) = @_;
2071200.000655.4e-6 $self->throw_exception("No such column $column")
# spent 1.42ms making 120 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
208 unless exists $self->_columns->{$column};
209 #warn $self->{_columns_info_loaded}, "\n";
2101200.000726.0e-6 if ( ! $self->_columns->{$column}{data_type}
# spent 1.40ms making 120 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
211 and $self->column_info_from_storage
212 and ! $self->{_columns_info_loaded}
213 and $self->schema and $self->storage )
214 {
215 $self->{_columns_info_loaded}++;
216 my $info = {};
217 my $lc_info = {};
218 # eval for the case of storage without table
219 eval { $info = $self->storage->columns_info_for( $self->from ) };
220 unless ($@) {
221 for my $realcol ( keys %{$info} ) {
222 $lc_info->{lc $realcol} = $info->{$realcol};
223 }
224 foreach my $col ( keys %{$self->_columns} ) {
225 $self->_columns->{$col} = {
226 %{ $self->_columns->{$col} },
227 %{ $info->{$col} || $lc_info->{lc $col} || {} }
228 };
229 }
230 }
231 }
2321200.000695.8e-6 return $self->_columns->{$column};
# spent 1.34ms making 120 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 11µs/call
233}
234
235=head2 column_info_from_storage
236
237Enables the on-demand automatic loading of the above column
238metadata from storage as neccesary. This is *deprecated*, and
239should not be used. It will be removed before 1.0.
240
241 __PACKAGE__->column_info_from_storage(1);
242
243=head2 columns
244
245 my @column_names = $obj->columns;
246
247Returns all column names in the order they were declared to add_columns.
248
249=cut
250
251
# spent 50µs within DBIx::Class::ResultSource::columns which was called 3 times, avg 17µs/call: # once (20µs+0) by DBIx::Class::ResultSourceProxy::columns at line 59 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm # once (20µs+0) at line 523 of /wise/base/deliv/dev/bin/getfix # once (10µs+0) by DBIx::Class::ResultSet::_resolved_attrs at line 1913 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSet.pm
sub columns {
25235.0e-61.7e-6 my $self = shift;
25331.3e-54.3e-6 $self->throw_exception(
254 "columns() is a read-only accessor, did you mean add_columns()?"
255 ) if (@_ > 1);
25631.7e-55.7e-6 return @{$self->{_ordered_columns}||[]};
257}
258
259=head2 remove_columns
260
261 $table->remove_columns(qw/col1 col2 col3/);
262
263Removes columns from the result source.
264
265=head2 remove_column
266
267 $table->remove_column('col');
268
269Convenience alias to remove_columns.
270
271=cut
272
273sub remove_columns {
274 my ($self, @cols) = @_;
275
276 return unless $self->_ordered_columns;
277
278 my $columns = $self->_columns;
279 my @remaining;
280
281 foreach my $col (@{$self->_ordered_columns}) {
282 push @remaining, $col unless grep(/$col/, @cols);
283 }
284
285 foreach (@cols) {
286 delete $columns->{$_};
287 };
288
289 $self->_ordered_columns(\@remaining);
290}
291
292sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
293
294=head2 set_primary_key
295
296=over 4
297
298=item Arguments: @cols
299
300=back
301
302Defines one or more columns as primary key for this source. Should be
303called after C<add_columns>.
304
305Additionally, defines a unique constraint named C<primary>.
306
307The primary key columns are used by L<DBIx::Class::PK::Auto> to
308retrieve automatically created values from the database.
309
310=cut
311
312
# spent 601µs (88+513) within DBIx::Class::ResultSource::set_primary_key which was called 4 times, avg 150µs/call: # 4 times (88µs+513µs) by DBIx::Class::ResultSourceProxy::set_primary_key at line 69 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm, avg 150µs/call
sub set_primary_key {
31341.1e-52.7e-6 my ($self, @cols) = @_;
314 # check if primary key columns are valid columns
31544.0e-61.0e-6 foreach my $col (@cols) {
31663.9e-56.5e-6 $self->throw_exception("No such column $col on table " . $self->name)
# spent 115µs making 6 calls to DBIx::Class::ResultSource::has_column, avg 19µs/call
317 unless $self->has_column($col);
318 }
31943.6e-59.0e-6 $self->_primaries(\@cols);
# spent 68µs making 4 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 17µs/call
320
32143.6e-59.0e-6 $self->add_unique_constraint(primary => \@cols);
# spent 330µs making 4 calls to DBIx::Class::ResultSource::add_unique_constraint, avg 82µs/call
322}
323
324=head2 primary_columns
325
326Read-only accessor which returns the list of primary keys.
327
328=cut
329
330
# spent 22µs (8+14) within DBIx::Class::ResultSource::primary_columns which was called # once (8µs+14µs) by DBIx::Class::ResultSourceProxy::primary_columns at line 73 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm
sub primary_columns {
33118.0e-68.0e-6 return @{shift->_primaries||[]};
# spent 14µs making 1 call to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8]
332}
333
334=head2 add_unique_constraint
335
336Declare a unique constraint on this source. Call once for each unique
337constraint.
338
339 # For UNIQUE (column1, column2)
340 __PACKAGE__->add_unique_constraint(
341 constraint_name => [ qw/column1 column2/ ],
342 );
343
344Alternatively, you can specify only the columns:
345
346 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
347
348This will result in a unique constraint named C<table_column1_column2>, where
349C<table> is replaced with the table name.
350
351Unique constraints are used, for example, when you call
352L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
353
354=cut
355
356
# spent 330µs (91+239) within DBIx::Class::ResultSource::add_unique_constraint which was called 4 times, avg 82µs/call: # 4 times (91µs+239µs) by DBIx::Class::ResultSource::set_primary_key at line 321, avg 82µs/call
sub add_unique_constraint {
35743.0e-67.5e-7 my $self = shift;
35843.0e-67.5e-7 my $cols = pop @_;
35943.0e-67.5e-7 my $name = shift;
360
36142.0e-65.0e-7 $name ||= $self->name_unique_constraint($cols);
362
36347.0e-61.7e-6 foreach my $col (@$cols) {
36463.2e-55.3e-6 $self->throw_exception("No such column $col on table " . $self->name)
# spent 110µs making 6 calls to DBIx::Class::ResultSource::has_column, avg 18µs/call
365 unless $self->has_column($col);
366 }
367
36842.5e-56.3e-6 my %unique_constraints = $self->unique_constraints;
# spent 80µs making 4 calls to DBIx::Class::ResultSource::unique_constraints, avg 20µs/call
36946.0e-61.5e-6 $unique_constraints{$name} = $cols;
37042.9e-57.3e-6 $self->_unique_constraints(\%unique_constraints);
# spent 49µs making 4 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
371}
372
373=head2 name_unique_constraint
374
375Return a name for a unique constraint containing the specified columns. These
376names consist of the table name and each column name, separated by underscores.
377
378For example, a constraint on a table named C<cd> containing the columns
379C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
380
381=cut
382
383sub name_unique_constraint {
384 my ($self, $cols) = @_;
385
386 return join '_', $self->name, @$cols;
387}
388
389=head2 unique_constraints
390
391Read-only accessor which returns the list of unique constraints on this source.
392
393=cut
394
395
# spent 80µs (29+51) within DBIx::Class::ResultSource::unique_constraints which was called 4 times, avg 20µs/call: # 4 times (29µs+51µs) by DBIx::Class::ResultSource::add_unique_constraint at line 368, avg 20µs/call
sub unique_constraints {
39643.2e-58.0e-6 return %{shift->_unique_constraints||{}};
# spent 51µs making 4 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 13µs/call
397}
398
399=head2 unique_constraint_names
400
401Returns the list of unique constraint names defined on this source.
402
403=cut
404
405sub unique_constraint_names {
406 my ($self) = @_;
407
408 my %unique_constraints = $self->unique_constraints;
409
410 return keys %unique_constraints;
411}
412
413=head2 unique_constraint_columns
414
415Returns the list of columns that make up the specified unique constraint.
416
417=cut
418
419sub unique_constraint_columns {
420 my ($self, $constraint_name) = @_;
421
422 my %unique_constraints = $self->unique_constraints;
423
424 $self->throw_exception(
425 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
426 ) unless exists $unique_constraints{$constraint_name};
427
428 return @{ $unique_constraints{$constraint_name} };
429}
430
431=head2 from
432
433Returns an expression of the source to be supplied to storage to specify
434retrieval from this source. In the case of a database, the required FROM
435clause contents.
436
437=head2 schema
438
439Returns the L<DBIx::Class::Schema> object that this result source
440belongs too.
441
442=head2 storage
443
444Returns the storage handle for the current schema.
445
446See also: L<DBIx::Class::Storage>
447
448=cut
449
45045.3e-51.3e-5
# spent 248µs (40+208) within DBIx::Class::ResultSource::storage which was called 4 times, avg 62µs/call: # 4 times (40µs+208µs) by DBIx::Class::ResultSet::cursor at line 514 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSet.pm, avg 62µs/call
sub storage { shift->schema->storage; }
# spent 208µs making 8 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 26µs/call
451
452=head2 add_relationship
453
454 $source->add_relationship('relname', 'related_source', $cond, $attrs);
455
456The relationship name can be arbitrary, but must be unique for each
457relationship attached to this result source. 'related_source' should
458be the name with which the related result source was registered with
459the current schema. For example:
460
461 $schema->source('Book')->add_relationship('reviews', 'Review', {
462 'foreign.book_id' => 'self.id',
463 });
464
465The condition C<$cond> needs to be an L<SQL::Abstract>-style
466representation of the join between the tables. For example, if you're
467creating a rel from Author to Book,
468
469 { 'foreign.author_id' => 'self.id' }
470
471will result in the JOIN clause
472
473 author me JOIN book foreign ON foreign.author_id = me.id
474
475You can specify as many foreign => self mappings as necessary.
476
477Valid attributes are as follows:
478
479=over 4
480
481=item join_type
482
483Explicitly specifies the type of join to use in the relationship. Any
484SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
485the SQL command immediately before C<JOIN>.
486
487=item proxy
488
489An arrayref containing a list of accessors in the foreign class to proxy in
490the main class. If, for example, you do the following:
491
492 CD->might_have(liner_notes => 'LinerNotes', undef, {
493 proxy => [ qw/notes/ ],
494 });
495
496Then, assuming LinerNotes has an accessor named notes, you can do:
497
498 my $cd = CD->find(1);
499 # set notes -- LinerNotes object is created if it doesn't exist
500 $cd->notes('Notes go here');
501
502=item accessor
503
504Specifies the type of accessor that should be created for the
505relationship. Valid values are C<single> (for when there is only a single
506related object), C<multi> (when there can be many), and C<filter> (for
507when there is a single related object, but you also want the relationship
508accessor to double as a column accessor). For C<multi> accessors, an
509add_to_* method is also created, which calls C<create_related> for the
510relationship.
511
512=back
513
514=cut
515
516
# spent 157µs (100+57) within DBIx::Class::ResultSource::add_relationship which was called 2 times, avg 79µs/call: # 2 times (100µs+57µs) by DBIx::Class::ResultSourceProxy::add_relationship at line 95 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm, avg 79µs/call
sub add_relationship {
51726.0e-63.0e-6 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
518200 $self->throw_exception("Can't create relationship without join condition")
519 unless $cond;
52022.0e-61.0e-6 $attrs ||= {};
521
522 # Check foreign and self are right in cond
52322.0e-61.0e-6 if ( (ref $cond ||'') eq 'HASH') {
52426.0e-63.0e-6 for (keys %$cond) {
52525.2e-52.6e-5 $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
526 if /\./ && !/^foreign\./;
527 }
528 }
529
53021.9e-59.5e-6 my %rels = %{ $self->_relationships };
# spent 32µs making 2 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 16µs/call
53128.0e-64.0e-6 $rels{$rel} = { class => $f_source_name,
532 source => $f_source_name,
533 cond => $cond,
534 attrs => $attrs };
53521.2e-56.0e-6 $self->_relationships(\%rels);
# spent 25µs making 2 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
536
53723.0e-61.5e-6 return $self;
538
539 # XXX disabled. doesn't work properly currently. skip in tests.
540
541 my $f_source = $self->schema->source($f_source_name);
542 unless ($f_source) {
543 $self->ensure_class_loaded($f_source_name);
544 $f_source = $f_source_name->result_source;
545 #my $s_class = ref($self->schema);
546 #$f_source_name =~ m/^${s_class}::(.*)$/;
547 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
548 #$f_source = $self->schema->source($f_source_name);
549 }
550 return unless $f_source; # Can't test rel without f_source
551
552 eval { $self->resolve_join($rel, 'me') };
553
554 if ($@) { # If the resolve failed, back out and re-throw the error
555 delete $rels{$rel}; #
556 $self->_relationships(\%rels);
557 $self->throw_exception("Error creating relationship $rel: $@");
558 }
559 1;
560}
561
562=head2 relationships
563
564Returns all relationship names for this source.
565
566=cut
567
568sub relationships {
569 return keys %{shift->_relationships};
570}
571
572=head2 relationship_info
573
574=over 4
575
576=item Arguments: $relname
577
578=back
579
580Returns a hash of relationship information for the specified relationship
581name.
582
583=cut
584
585
# spent 49µs (26+23) within DBIx::Class::ResultSource::relationship_info which was called 2 times, avg 24µs/call: # 2 times (26µs+23µs) by DBIx::Class::ResultSourceProxy::add_relationship at line 96 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSourceProxy.pm, avg 24µs/call
sub relationship_info {
58624.0e-62.0e-6 my ($self, $rel) = @_;
58721.6e-58.0e-6 return $self->_relationships->{$rel};
# spent 23µs making 2 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call
588}
589
590=head2 has_relationship
591
592=over 4
593
594=item Arguments: $rel
595
596=back
597
598Returns true if the source has a relationship of this name, false otherwise.
599
600=cut
601
602sub has_relationship {
603 my ($self, $rel) = @_;
604 return exists $self->_relationships->{$rel};
605}
606
607=head2 reverse_relationship_info
608
609=over 4
610
611=item Arguments: $relname
612
613=back
614
615Returns an array of hash references of relationship information for
616the other side of the specified relationship name.
617
618=cut
619
620sub reverse_relationship_info {
621 my ($self, $rel) = @_;
622 my $rel_info = $self->relationship_info($rel);
623 my $ret = {};
624
625 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
626
627 my @cond = keys(%{$rel_info->{cond}});
628 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
629 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
630
631 # Get the related result source for this relationship
632 my $othertable = $self->related_source($rel);
633
634 # Get all the relationships for that source that related to this source
635 # whose foreign column set are our self columns on $rel and whose self
636 # columns are our foreign columns on $rel.
637 my @otherrels = $othertable->relationships();
638 my $otherrelationship;
639 foreach my $otherrel (@otherrels) {
640 my $otherrel_info = $othertable->relationship_info($otherrel);
641
642 my $back = $othertable->related_source($otherrel);
643 next unless $back->source_name eq $self->source_name;
644
645 my @othertestconds;
646
647 if (ref $otherrel_info->{cond} eq 'HASH') {
648 @othertestconds = ($otherrel_info->{cond});
649 }
650 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
651 @othertestconds = @{$otherrel_info->{cond}};
652 }
653 else {
654 next;
655 }
656
657 foreach my $othercond (@othertestconds) {
658 my @other_cond = keys(%$othercond);
659 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
660 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
661 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
662 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
663 $ret->{$otherrel} = $otherrel_info;
664 }
665 }
666 return $ret;
667}
668
669=head2 compare_relationship_keys
670
671=over 4
672
673=item Arguments: $keys1, $keys2
674
675=back
676
677Returns true if both sets of keynames are the same, false otherwise.
678
679=cut
680
681sub compare_relationship_keys {
682 my ($self, $keys1, $keys2) = @_;
683
684 # Make sure every keys1 is in keys2
685 my $found;
686 foreach my $key (@$keys1) {
687 $found = 0;
688 foreach my $prim (@$keys2) {
689 if ($prim eq $key) {
690 $found = 1;
691 last;
692 }
693 }
694 last unless $found;
695 }
696
697 # Make sure every key2 is in key1
698 if ($found) {
699 foreach my $prim (@$keys2) {
700 $found = 0;
701 foreach my $key (@$keys1) {
702 if ($prim eq $key) {
703 $found = 1;
704 last;
705 }
706 }
707 last unless $found;
708 }
709 }
710
711 return $found;
712}
713
714=head2 resolve_join
715
716=over 4
717
718=item Arguments: $relation
719
720=back
721
722Returns the join structure required for the related result source.
723
724=cut
725
726sub resolve_join {
727 my ($self, $join, $alias, $seen, $force_left) = @_;
728 $seen ||= {};
729 $force_left ||= { force => 0 };
730 if (ref $join eq 'ARRAY') {
731 return map { $self->resolve_join($_, $alias, $seen) } @$join;
732 } elsif (ref $join eq 'HASH') {
733 return
734 map {
735 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
736 local $force_left->{force};
737 (
738 $self->resolve_join($_, $alias, $seen, $force_left),
739 $self->related_source($_)->resolve_join(
740 $join->{$_}, $as, $seen, $force_left
741 )
742 );
743 } keys %$join;
744 } elsif (ref $join) {
745 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
746 } else {
747 my $count = ++$seen->{$join};
748 #use Data::Dumper; warn Dumper($seen);
749 my $as = ($count > 1 ? "${join}_${count}" : $join);
750 my $rel_info = $self->relationship_info($join);
751 $self->throw_exception("No such relationship ${join}") unless $rel_info;
752 my $type;
753 if ($force_left->{force}) {
754 $type = 'left';
755 } else {
756 $type = $rel_info->{attrs}{join_type} || '';
757 $force_left->{force} = 1 if lc($type) eq 'left';
758 }
759 return [ { $as => $self->related_source($join)->from,
760 -join_type => $type },
761 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
762 }
763}
764
765=head2 resolve_condition
766
767=over 4
768
769=item Arguments: $cond, $as, $alias|$object
770
771=back
772
773Resolves the passed condition to a concrete query fragment. If given an alias,
774returns a join condition; if given an object, inverts that object to produce
775a related conditional from that object.
776
777=cut
778
779sub resolve_condition {
780 my ($self, $cond, $as, $for) = @_;
781 #warn %$cond;
782 if (ref $cond eq 'HASH') {
783 my %ret;
784 foreach my $k (keys %{$cond}) {
785 my $v = $cond->{$k};
786 # XXX should probably check these are valid columns
787 $k =~ s/^foreign\.// ||
788 $self->throw_exception("Invalid rel cond key ${k}");
789 $v =~ s/^self\.// ||
790 $self->throw_exception("Invalid rel cond val ${v}");
791 if (ref $for) { # Object
792 #warn "$self $k $for $v";
793 $ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
794 #warn %ret;
795 } elsif (!defined $for) { # undef, i.e. "no object"
796 $ret{$k} = undef;
797 } elsif (ref $as eq 'HASH') { # reverse hashref
798 $ret{$v} = $as->{$k};
799 } elsif (ref $as) { # reverse object
800 $ret{$v} = $as->get_column($k);
801 } elsif (!defined $as) { # undef, i.e. "no reverse object"
802 $ret{$v} = undef;
803 } else {
804 $ret{"${as}.${k}"} = "${for}.${v}";
805 }
806 }
807 return \%ret;
808 } elsif (ref $cond eq 'ARRAY') {
809 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
810 } else {
811 die("Can't handle this yet :(");
812 }
813}
814
815=head2 resolve_prefetch
816
817=over 4
818
819=item Arguments: hashref/arrayref/scalar
820
821=back
822
823Accepts one or more relationships for the current source and returns an
824array of column names for each of those relationships. Column names are
825prefixed relative to the current source, in accordance with where they appear
826in the supplied relationships. Examples:
827
828 my $source = $schema->resultset('Tag')->source;
829 @columns = $source->resolve_prefetch( { cd => 'artist' } );
830
831 # @columns =
832 #(
833 # 'cd.cdid',
834 # 'cd.artist',
835 # 'cd.title',
836 # 'cd.year',
837 # 'cd.artist.artistid',
838 # 'cd.artist.name'
839 #)
840
841 @columns = $source->resolve_prefetch( qw[/ cd /] );
842
843 # @columns =
844 #(
845 # 'cd.cdid',
846 # 'cd.artist',
847 # 'cd.title',
848 # 'cd.year'
849 #)
850
851 $source = $schema->resultset('CD')->source;
852 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
853
854 # @columns =
855 #(
856 # 'artist.artistid',
857 # 'artist.name',
858 # 'producer.producerid',
859 # 'producer.name'
860 #)
861
862=cut
863
864sub resolve_prefetch {
865 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
866 $seen ||= {};
867 #$alias ||= $self->name;
868 #warn $alias, Dumper $pre;
869 if( ref $pre eq 'ARRAY' ) {
870 return
871 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
872 @$pre;
873 }
874 elsif( ref $pre eq 'HASH' ) {
875 my @ret =
876 map {
877 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
878 $self->related_source($_)->resolve_prefetch(
879 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
880 } keys %$pre;
881 #die Dumper \@ret;
882 return @ret;
883 }
884 elsif( ref $pre ) {
885 $self->throw_exception(
886 "don't know how to resolve prefetch reftype ".ref($pre));
887 }
888 else {
889 my $count = ++$seen->{$pre};
890 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
891 my $rel_info = $self->relationship_info( $pre );
892 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
893 unless $rel_info;
894 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
895 my $rel_source = $self->related_source($pre);
896
897 if (exists $rel_info->{attrs}{accessor}
898 && $rel_info->{attrs}{accessor} eq 'multi') {
899 $self->throw_exception(
900 "Can't prefetch has_many ${pre} (join cond too complex)")
901 unless ref($rel_info->{cond}) eq 'HASH';
902 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
903 # values %{$rel_info->{cond}};
904 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
905 # action at a distance. prepending the '.' allows simpler code
906 # in ResultSet->_collapse_result
907 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
908 keys %{$rel_info->{cond}};
909 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
910 ? @{$rel_info->{attrs}{order_by}}
911 : (defined $rel_info->{attrs}{order_by}
912 ? ($rel_info->{attrs}{order_by})
913 : ()));
914 push(@$order, map { "${as}.$_" } (@key, @ord));
915 }
916
917 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
918 $rel_source->columns;
919 #warn $alias, Dumper (\@ret);
920 #return @ret;
921 }
922}
923
924=head2 related_source
925
926=over 4
927
928=item Arguments: $relname
929
930=back
931
932Returns the result source object for the given relationship.
933
934=cut
935
936sub related_source {
937 my ($self, $rel) = @_;
938 if( !$self->has_relationship( $rel ) ) {
939 $self->throw_exception("No such relationship '$rel'");
940 }
941 return $self->schema->source($self->relationship_info($rel)->{source});
942}
943
944=head2 related_class
945
946=over 4
947
948=item Arguments: $relname
949
950=back
951
952Returns the class name for objects in the given relationship.
953
954=cut
955
956sub related_class {
957 my ($self, $rel) = @_;
958 if( !$self->has_relationship( $rel ) ) {
959 $self->throw_exception("No such relationship '$rel'");
960 }
961 return $self->schema->class($self->relationship_info($rel)->{source});
962}
963
964=head2 resultset
965
966Returns a resultset for the given source. This will initially be created
967on demand by calling
968
969 $self->resultset_class->new($self, $self->resultset_attributes)
970
971but is cached from then on unless resultset_class changes.
972
973=head2 resultset_class
974
975` package My::ResultSetClass;
976 use base 'DBIx::Class::ResultSet';
977 ...
978
979 $source->resultset_class('My::ResultSet::Class');
980
981Set the class of the resultset, this is useful if you want to create your
982own resultset methods. Create your own class derived from
983L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
984this method returns the name of the existing resultset class, if one
985exists.
986
987=head2 resultset_attributes
988
989 $source->resultset_attributes({ order_by => [ 'id' ] });
990
991Specify here any attributes you wish to pass to your specialised
992resultset. For a full list of these, please see
993L<DBIx::Class::ResultSet/ATTRIBUTES>.
994
995=cut
996
997
# spent 1.54ms (62µs+1.47) within DBIx::Class::ResultSource::resultset which was called 3 times, avg 512µs/call: # 3 times (62µs+1.47ms) by DBIx::Class::Schema::resultset at line 220 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Schema.pm, avg 512µs/call
sub resultset {
99833.0e-61.0e-6 my $self = shift;
99933.0e-61.0e-6 $self->throw_exception(
1000 'resultset does not take any arguments. If you want another resultset, '.
1001 'call it on the schema instead.'
1002 ) if scalar @_;
1003
1004 return $self->resultset_class->new(
1005 $self,
1006 {
1007 %{$self->{resultset_attributes}},
100830.000113.7e-5 %{$self->schema->default_resultset_attributes}
# spent 1.18ms making 3 calls to DBIx::Class::ResultSet::new, avg 392µs/call # spent 297µs making 9 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 33µs/call
1009 },
1010 );
1011}
1012
1013=head2 source_name
1014
1015=over 4
1016
1017=item Arguments: $source_name
1018
1019=back
1020
1021Set the name of the result source when it is loaded into a schema.
1022This is usefull if you want to refer to a result source by a name other than
1023its class name.
1024
1025 package ArchivedBooks;
1026 use base qw/DBIx::Class/;
1027 __PACKAGE__->table('books_archive');
1028 __PACKAGE__->source_name('Books');
1029
1030 # from your schema...
1031 $schema->resultset('Books')->find(1);
1032
1033=head2 handle
1034
1035Obtain a new handle to this source. Returns an instance of a
1036L<DBIx::Class::ResultSourceHandle>.
1037
1038=cut
1039
1040
# spent 2.31s (554ms+1.76) within DBIx::Class::ResultSource::handle which was called 55482 times, avg 42µs/call: # 55476 times (553ms+1.76s) by DBIx::Class::Row::inflate_result at line 610 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/Row.pm, avg 42µs/call # 6 times (72µs+465µs) by DBIx::Class::ResultSet::new at line 89 of /wise/base/static/lib/perl5/site_perl/5.10.0/DBIx/Class/ResultSet.pm, avg 90µs/call
sub handle {
1041554820.900391.6e-5 return new DBIx::Class::ResultSourceHandle({
# spent 1.33s making 110964 calls to Class::Accessor::Grouped::__ANON__[(eval 0)[/wise/base/static/lib/perl5/site_perl/5.10.0/Class/Accessor/Grouped.pm:156]:8], avg 12µs/call # spent 424ms making 55482 calls to DBIx::Class::ResultSourceHandle::new, avg 8µs/call
1042 schema => $_[0]->schema,
1043 source_moniker => $_[0]->source_name
1044 });
1045}
1046
1047=head2 throw_exception
1048
1049See L<DBIx::Class::Schema/"throw_exception">.
1050
1051=cut
1052
1053sub throw_exception {
1054 my $self = shift;
1055 if (defined $self->schema) {
1056 $self->schema->throw_exception(@_);
1057 } else {
1058 croak(@_);
1059 }
1060}
1061
1062=head2 sqlt_deploy_hook($sqlt_table)
1063
1064An optional sub which you can declare in your own Schema class that will get
1065passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
1066via L</create_ddl_dir> or L</deploy>.
1067
1068For an example of what you can do with this, see
1069L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1070
1071=head1 AUTHORS
1072
1073Matt S. Trout <mst@shadowcatsystems.co.uk>
1074
1075=head1 LICENSE
1076
1077You may distribute this code under the same terms as Perl itself.
1078
1079=cut
1080
108116.0e-66.0e-61;

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.