Reduce the number of times $self->_dbh is called inside dbh_do() to speed
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / ResultSource.pm
CommitLineData
9c992ba1 1package DBIx::Class::ResultSource;
2
3use strict;
4use warnings;
5
6use DBIx::Class::ResultSet;
aec3eff1 7use DBIx::Class::ResultSourceHandle;
701da8c4 8use Carp::Clan qw/^DBIx::Class/;
6da5894c 9use Storable;
10
9c992ba1 11use base qw/DBIx::Class/;
9c992ba1 12
aa1088bf 13__PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
14 _columns _primaries _unique_constraints name resultset_attributes
acbe81cf 15 schema from _relationships column_info_from_storage source_info
aaf2403d 16 source_name/);
aa1088bf 17
fac560c2 18__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
b0dd0e03 19 result_class/);
9c992ba1 20
75d07914 21=head1 NAME
9c992ba1 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
7eb4ecc8 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
9c992ba1 44=cut
45
46sub new {
47 my ($class, $attrs) = @_;
48 $class = ref $class if ref $class;
04786a4c 49
6b051e14 50 my $new = bless { %{$attrs || {}} }, $class;
9c992ba1 51 $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
5ac6a044 52 $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
6da5894c 53 $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
54 $new->{_columns} = { %{$new->{_columns}||{}} };
55 $new->{_relationships} = { %{$new->{_relationships}||{}} };
9c992ba1 56 $new->{name} ||= "!!NAME NOT SET!!";
5afa2a15 57 $new->{_columns_info_loaded} ||= 0;
9c992ba1 58 return $new;
59}
60
988bf309 61=pod
62
a48e92d7 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
5ac6a044 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
2053ab2a 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.
5ac6a044 83
5d9d9e87 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
2053ab2a 88The contents of the column_info are not set in stone. The following
89keys are currently recognised/used by DBIx::Class:
988bf309 90
91=over 4
92
75d07914 93=item accessor
988bf309 94
5d9d9e87 95Use this to set the name of the accessor method for this column. If unset,
988bf309 96the name of the column will be used.
97
98=item data_type
99
2053ab2a 100This contains the column type. It is automatically filled by the
988bf309 101L<SQL::Translator::Producer::DBIx::Class::File> producer, and the
2053ab2a 102L<DBIx::Class::Schema::Loader> module. If you do not enter a
988bf309 103data_type, DBIx::Class will attempt to retrieve it from the
2053ab2a 104database for you, using L<DBI>'s column_info method. The values of this
988bf309 105key are typically upper-cased.
106
2053ab2a 107Currently there is no standard set of values for the data_type. Use
108whatever your database supports.
988bf309 109
110=item size
111
112The length of your column, if it is a column type that can have a size
d7be2784 113restriction. This is currently only used by L<DBIx::Class::Schema/deploy>.
988bf309 114
115=item is_nullable
116
2053ab2a 117Set this to a true value for a columns that is allowed to contain
d7be2784 118NULL values. This is currently only used by L<DBIx::Class::Schema/deploy>.
988bf309 119
120=item is_auto_increment
121
2053ab2a 122Set this to a true value for a column whose value is somehow
123automatically set. This is used to determine which columns to empty
d7be2784 124when cloning objects using C<copy>. It is also used by
125L<DBIx::Class::Schema/deploy>.
988bf309 126
127=item is_foreign_key
128
2053ab2a 129Set this to a true value for a column that contains a key from a
d7be2784 130foreign table. This is currently only used by
131L<DBIx::Class::Schema/deploy>.
988bf309 132
133=item default_value
134
2053ab2a 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
d7be2784 137currently only used by L<DBIx::Class::Schema/deploy>.
988bf309 138
139=item sequence
140
2053ab2a 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.
988bf309 145
838ef78d 146=item auto_nextval
147
148Set this to a true value for a column whose value is retrieved
149automatically from an oracle sequence. If you do not use an oracle
150trigger to get the nextval, you have to set sequence as well.
151
190615a7 152=item extra
d7be2784 153
154This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
190615a7 155to add extra non-generic data to the column. For example: C<< extra
d7be2784 156=> { unsigned => 1} >> is used by the MySQL producer to set an integer
157column to unsigned. For more details, see
158L<SQL::Translator::Producer::MySQL>.
159
988bf309 160=back
161
5ac6a044 162=head2 add_column
163
164 $table->add_column('col' => \%info?);
165
2053ab2a 166Convenience alias to add_columns.
5ac6a044 167
168=cut
169
9c992ba1 170sub add_columns {
171 my ($self, @cols) = @_;
8e04bf91 172 $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
002a359a 173
20518cb4 174 my @added;
175 my $columns = $self->_columns;
9c992ba1 176 while (my $col = shift @cols) {
8e04bf91 177 # If next entry is { ... } use that for the column info, if not
178 # use an empty hashref
30126ac7 179 my $column_info = ref $cols[0] ? shift(@cols) : {};
20518cb4 180 push(@added, $col) unless exists $columns->{$col};
20518cb4 181 $columns->{$col} = $column_info;
9c992ba1 182 }
20518cb4 183 push @{ $self->_ordered_columns }, @added;
30126ac7 184 return $self;
9c992ba1 185}
186
b25e9fa0 187sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
9c992ba1 188
3842b955 189=head2 has_column
190
988bf309 191 if ($obj->has_column($col)) { ... }
192
2053ab2a 193Returns true if the source has a column of this name, false otherwise.
988bf309 194
195=cut
9c992ba1 196
197sub has_column {
198 my ($self, $column) = @_;
199 return exists $self->_columns->{$column};
200}
201
87c4e602 202=head2 column_info
9c992ba1 203
988bf309 204 my $info = $obj->column_info($col);
9c992ba1 205
988bf309 206Returns the column metadata hashref for a column. See the description
207of add_column for information on the contents of the hashref.
9c992ba1 208
988bf309 209=cut
9c992ba1 210
211sub column_info {
212 my ($self, $column) = @_;
75d07914 213 $self->throw_exception("No such column $column")
701da8c4 214 unless exists $self->_columns->{$column};
5afa2a15 215 #warn $self->{_columns_info_loaded}, "\n";
75d07914 216 if ( ! $self->_columns->{$column}{data_type}
6eda9bcf 217 and $self->column_info_from_storage
75d07914 218 and ! $self->{_columns_info_loaded}
8e04bf91 219 and $self->schema and $self->storage )
220 {
221 $self->{_columns_info_loaded}++;
d51f93c8 222 my $info = {};
223 my $lc_info = {};
75d07914 224 # eval for the case of storage without table
955f1590 225 eval { $info = $self->storage->columns_info_for( $self->from ) };
8e04bf91 226 unless ($@) {
0b88a5bb 227 for my $realcol ( keys %{$info} ) {
228 $lc_info->{lc $realcol} = $info->{$realcol};
229 }
8e04bf91 230 foreach my $col ( keys %{$self->_columns} ) {
d51f93c8 231 $self->_columns->{$col} = {
232 %{ $self->_columns->{$col} },
233 %{ $info->{$col} || $lc_info->{lc $col} || {} }
234 };
a953d8d9 235 }
8e04bf91 236 }
a953d8d9 237 }
9c992ba1 238 return $self->_columns->{$column};
239}
240
d9916234 241=head2 column_info_from_storage
6eda9bcf 242
243Enables the on-demand automatic loading of the above column
c22c7625 244metadata from storage as neccesary. This is *deprecated*, and
245should not be used. It will be removed before 1.0.
6eda9bcf 246
d9916234 247 __PACKAGE__->column_info_from_storage(1);
6eda9bcf 248
9c992ba1 249=head2 columns
250
20518cb4 251 my @column_names = $obj->columns;
252
2053ab2a 253Returns all column names in the order they were declared to add_columns.
87f0da6a 254
255=cut
9c992ba1 256
257sub columns {
8e04bf91 258 my $self = shift;
aa1088bf 259 $self->throw_exception(
260 "columns() is a read-only accessor, did you mean add_columns()?"
261 ) if (@_ > 1);
701da8c4 262 return @{$self->{_ordered_columns}||[]};
571dced3 263}
264
002a359a 265=head2 remove_columns
266
267 $table->remove_columns(qw/col1 col2 col3/);
268
269Removes columns from the result source.
270
271=head2 remove_column
272
273 $table->remove_column('col');
274
275Convenience alias to remove_columns.
276
277=cut
278
279sub remove_columns {
280 my ($self, @cols) = @_;
281
282 return unless $self->_ordered_columns;
283
284 my $columns = $self->_columns;
285 my @remaining;
286
287 foreach my $col (@{$self->_ordered_columns}) {
288 push @remaining, $col unless grep(/$col/, @cols);
289 }
290
291 foreach (@cols) {
a918d901 292 delete $columns->{$_};
002a359a 293 };
294
295 $self->_ordered_columns(\@remaining);
296}
297
b25e9fa0 298sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
002a359a 299
87c4e602 300=head2 set_primary_key
301
27f01d1f 302=over 4
303
ebc77b53 304=item Arguments: @cols
27f01d1f 305
306=back
87f0da6a 307
9c992ba1 308Defines one or more columns as primary key for this source. Should be
309called after C<add_columns>.
87f0da6a 310
311Additionally, defines a unique constraint named C<primary>.
312
988bf309 313The primary key columns are used by L<DBIx::Class::PK::Auto> to
75d07914 314retrieve automatically created values from the database.
988bf309 315
87f0da6a 316=cut
9c992ba1 317
318sub set_primary_key {
319 my ($self, @cols) = @_;
320 # check if primary key columns are valid columns
8e04bf91 321 foreach my $col (@cols) {
322 $self->throw_exception("No such column $col on table " . $self->name)
323 unless $self->has_column($col);
9c992ba1 324 }
325 $self->_primaries(\@cols);
87f0da6a 326
327 $self->add_unique_constraint(primary => \@cols);
9c992ba1 328}
329
87f0da6a 330=head2 primary_columns
331
9c992ba1 332Read-only accessor which returns the list of primary keys.
30126ac7 333
87f0da6a 334=cut
9c992ba1 335
336sub primary_columns {
337 return @{shift->_primaries||[]};
338}
339
87f0da6a 340=head2 add_unique_constraint
341
342Declare a unique constraint on this source. Call once for each unique
58b5bb8c 343constraint.
27f01d1f 344
345 # For UNIQUE (column1, column2)
346 __PACKAGE__->add_unique_constraint(
347 constraint_name => [ qw/column1 column2/ ],
348 );
87f0da6a 349
368a5228 350Alternatively, you can specify only the columns:
351
352 __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
353
354This will result in a unique constraint named C<table_column1_column2>, where
355C<table> is replaced with the table name.
356
58b5bb8c 357Unique constraints are used, for example, when you call
358L<DBIx::Class::ResultSet/find>. Only columns in the constraint are searched.
359
87f0da6a 360=cut
361
362sub add_unique_constraint {
368a5228 363 my $self = shift;
364 my $cols = pop @_;
365 my $name = shift;
366
367 $name ||= $self->name_unique_constraint($cols);
87f0da6a 368
8e04bf91 369 foreach my $col (@$cols) {
370 $self->throw_exception("No such column $col on table " . $self->name)
371 unless $self->has_column($col);
87f0da6a 372 }
373
374 my %unique_constraints = $self->unique_constraints;
375 $unique_constraints{$name} = $cols;
376 $self->_unique_constraints(\%unique_constraints);
377}
378
d9c74322 379=head2 name_unique_constraint
368a5228 380
381Return a name for a unique constraint containing the specified columns. These
382names consist of the table name and each column name, separated by underscores.
383
384For example, a constraint on a table named C<cd> containing the columns
385C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
386
387=cut
388
389sub name_unique_constraint {
390 my ($self, $cols) = @_;
391
392 return join '_', $self->name, @$cols;
393}
394
87f0da6a 395=head2 unique_constraints
396
397Read-only accessor which returns the list of unique constraints on this source.
398
399=cut
400
401sub unique_constraints {
402 return %{shift->_unique_constraints||{}};
403}
404
e6a0e17c 405=head2 unique_constraint_names
406
407Returns the list of unique constraint names defined on this source.
408
409=cut
410
411sub unique_constraint_names {
412 my ($self) = @_;
413
414 my %unique_constraints = $self->unique_constraints;
415
416 return keys %unique_constraints;
417}
418
419=head2 unique_constraint_columns
420
421Returns the list of columns that make up the specified unique constraint.
422
423=cut
424
425sub unique_constraint_columns {
426 my ($self, $constraint_name) = @_;
427
428 my %unique_constraints = $self->unique_constraints;
429
430 $self->throw_exception(
431 "Unknown unique constraint $constraint_name on '" . $self->name . "'"
432 ) unless exists $unique_constraints{$constraint_name};
433
434 return @{ $unique_constraints{$constraint_name} };
435}
436
9c992ba1 437=head2 from
438
439Returns an expression of the source to be supplied to storage to specify
2053ab2a 440retrieval from this source. In the case of a database, the required FROM
441clause contents.
9c992ba1 442
f9b7bd6e 443=head2 schema
444
445Returns the L<DBIx::Class::Schema> object that this result source
446belongs too.
9c992ba1 447
448=head2 storage
449
75d07914 450Returns the storage handle for the current schema.
988bf309 451
452See also: L<DBIx::Class::Storage>
9c992ba1 453
454=cut
455
456sub storage { shift->schema->storage; }
457
8452e496 458=head2 add_relationship
459
460 $source->add_relationship('relname', 'related_source', $cond, $attrs);
461
24d67825 462The relationship name can be arbitrary, but must be unique for each
463relationship attached to this result source. 'related_source' should
464be the name with which the related result source was registered with
465the current schema. For example:
8452e496 466
24d67825 467 $schema->source('Book')->add_relationship('reviews', 'Review', {
468 'foreign.book_id' => 'self.id',
469 });
470
2053ab2a 471The condition C<$cond> needs to be an L<SQL::Abstract>-style
24d67825 472representation of the join between the tables. For example, if you're
473creating a rel from Author to Book,
988bf309 474
475 { 'foreign.author_id' => 'self.id' }
476
477will result in the JOIN clause
478
479 author me JOIN book foreign ON foreign.author_id = me.id
480
8452e496 481You can specify as many foreign => self mappings as necessary.
482
988bf309 483Valid attributes are as follows:
484
485=over 4
486
487=item join_type
488
489Explicitly specifies the type of join to use in the relationship. Any
490SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
491the SQL command immediately before C<JOIN>.
492
493=item proxy
494
24d67825 495An arrayref containing a list of accessors in the foreign class to proxy in
496the main class. If, for example, you do the following:
002a359a 497
24d67825 498 CD->might_have(liner_notes => 'LinerNotes', undef, {
499 proxy => [ qw/notes/ ],
500 });
002a359a 501
24d67825 502Then, assuming LinerNotes has an accessor named notes, you can do:
988bf309 503
24d67825 504 my $cd = CD->find(1);
2053ab2a 505 # set notes -- LinerNotes object is created if it doesn't exist
506 $cd->notes('Notes go here');
988bf309 507
508=item accessor
509
510Specifies the type of accessor that should be created for the
75d07914 511relationship. Valid values are C<single> (for when there is only a single
512related object), C<multi> (when there can be many), and C<filter> (for
513when there is a single related object, but you also want the relationship
514accessor to double as a column accessor). For C<multi> accessors, an
515add_to_* method is also created, which calls C<create_related> for the
988bf309 516relationship.
517
8452e496 518=back
519
520=cut
521
522sub add_relationship {
523 my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
27f01d1f 524 $self->throw_exception("Can't create relationship without join condition")
525 unless $cond;
8452e496 526 $attrs ||= {};
87772e46 527
eba322a7 528 # Check foreign and self are right in cond
529 if ( (ref $cond ||'') eq 'HASH') {
530 for (keys %$cond) {
531 $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
532 if /\./ && !/^foreign\./;
533 }
534 }
535
8452e496 536 my %rels = %{ $self->_relationships };
537 $rels{$rel} = { class => $f_source_name,
87772e46 538 source => $f_source_name,
8452e496 539 cond => $cond,
540 attrs => $attrs };
541 $self->_relationships(\%rels);
542
30126ac7 543 return $self;
87772e46 544
953a18ef 545 # XXX disabled. doesn't work properly currently. skip in tests.
546
8452e496 547 my $f_source = $self->schema->source($f_source_name);
548 unless ($f_source) {
c037c03a 549 $self->ensure_class_loaded($f_source_name);
8452e496 550 $f_source = $f_source_name->result_source;
87772e46 551 #my $s_class = ref($self->schema);
552 #$f_source_name =~ m/^${s_class}::(.*)$/;
553 #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
554 #$f_source = $self->schema->source($f_source_name);
8452e496 555 }
556 return unless $f_source; # Can't test rel without f_source
557
558 eval { $self->resolve_join($rel, 'me') };
559
560 if ($@) { # If the resolve failed, back out and re-throw the error
75d07914 561 delete $rels{$rel}; #
8452e496 562 $self->_relationships(\%rels);
701da8c4 563 $self->throw_exception("Error creating relationship $rel: $@");
8452e496 564 }
565 1;
566}
567
87c4e602 568=head2 relationships
8452e496 569
2053ab2a 570Returns all relationship names for this source.
8452e496 571
572=cut
573
574sub relationships {
575 return keys %{shift->_relationships};
576}
577
87c4e602 578=head2 relationship_info
579
27f01d1f 580=over 4
581
ebc77b53 582=item Arguments: $relname
27f01d1f 583
584=back
8452e496 585
2053ab2a 586Returns a hash of relationship information for the specified relationship
587name.
8452e496 588
589=cut
590
591sub relationship_info {
592 my ($self, $rel) = @_;
593 return $self->_relationships->{$rel};
75d07914 594}
8452e496 595
87c4e602 596=head2 has_relationship
597
27f01d1f 598=over 4
599
ebc77b53 600=item Arguments: $rel
27f01d1f 601
602=back
953a18ef 603
2053ab2a 604Returns true if the source has a relationship of this name, false otherwise.
988bf309 605
606=cut
953a18ef 607
608sub has_relationship {
609 my ($self, $rel) = @_;
610 return exists $self->_relationships->{$rel};
611}
612
de60a93d 613=head2 reverse_relationship_info
614
615=over 4
616
617=item Arguments: $relname
618
619=back
620
bab77431 621Returns an array of hash references of relationship information for
de60a93d 622the other side of the specified relationship name.
623
624=cut
625
626sub reverse_relationship_info {
627 my ($self, $rel) = @_;
628 my $rel_info = $self->relationship_info($rel);
629 my $ret = {};
630
631 return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
632
633 my @cond = keys(%{$rel_info->{cond}});
634 my @refkeys = map {/^\w+\.(\w+)$/} @cond;
635 my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
bab77431 636
de60a93d 637 # Get the related result source for this relationship
638 my $othertable = $self->related_source($rel);
639
640 # Get all the relationships for that source that related to this source
641 # whose foreign column set are our self columns on $rel and whose self
bab77431 642 # columns are our foreign columns on $rel.
de60a93d 643 my @otherrels = $othertable->relationships();
644 my $otherrelationship;
645 foreach my $otherrel (@otherrels) {
646 my $otherrel_info = $othertable->relationship_info($otherrel);
647
648 my $back = $othertable->related_source($otherrel);
f3fb2641 649 next unless $back->source_name eq $self->source_name;
de60a93d 650
651 my @othertestconds;
652
653 if (ref $otherrel_info->{cond} eq 'HASH') {
654 @othertestconds = ($otherrel_info->{cond});
655 }
656 elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
657 @othertestconds = @{$otherrel_info->{cond}};
658 }
659 else {
660 next;
661 }
662
663 foreach my $othercond (@othertestconds) {
664 my @other_cond = keys(%$othercond);
665 my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
666 my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
bab77431 667 next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
de60a93d 668 !$self->compare_relationship_keys(\@other_refkeys, \@keys));
669 $ret->{$otherrel} = $otherrel_info;
670 }
671 }
672 return $ret;
673}
674
675=head2 compare_relationship_keys
676
677=over 4
678
679=item Arguments: $keys1, $keys2
680
681=back
682
683Returns true if both sets of keynames are the same, false otherwise.
684
685=cut
686
687sub compare_relationship_keys {
688 my ($self, $keys1, $keys2) = @_;
689
690 # Make sure every keys1 is in keys2
691 my $found;
692 foreach my $key (@$keys1) {
693 $found = 0;
694 foreach my $prim (@$keys2) {
695 if ($prim eq $key) {
696 $found = 1;
697 last;
698 }
699 }
700 last unless $found;
701 }
702
703 # Make sure every key2 is in key1
704 if ($found) {
705 foreach my $prim (@$keys2) {
706 $found = 0;
707 foreach my $key (@$keys1) {
708 if ($prim eq $key) {
709 $found = 1;
710 last;
711 }
712 }
713 last unless $found;
714 }
715 }
716
717 return $found;
718}
719
87c4e602 720=head2 resolve_join
721
27f01d1f 722=over 4
723
ebc77b53 724=item Arguments: $relation
27f01d1f 725
726=back
8452e496 727
2053ab2a 728Returns the join structure required for the related result source.
8452e496 729
730=cut
731
732sub resolve_join {
24010dd8 733 my ($self, $join, $alias, $seen, $force_left) = @_;
489709af 734 $seen ||= {};
24010dd8 735 $force_left ||= { force => 0 };
87772e46 736 if (ref $join eq 'ARRAY') {
489709af 737 return map { $self->resolve_join($_, $alias, $seen) } @$join;
87772e46 738 } elsif (ref $join eq 'HASH') {
489709af 739 return
887ce227 740 map {
741 my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
24010dd8 742 local $force_left->{force};
743 (
744 $self->resolve_join($_, $alias, $seen, $force_left),
745 $self->related_source($_)->resolve_join(
746 $join->{$_}, $as, $seen, $force_left
747 )
748 );
887ce227 749 } keys %$join;
87772e46 750 } elsif (ref $join) {
701da8c4 751 $self->throw_exception("No idea how to resolve join reftype ".ref $join);
87772e46 752 } else {
489709af 753 my $count = ++$seen->{$join};
754 #use Data::Dumper; warn Dumper($seen);
755 my $as = ($count > 1 ? "${join}_${count}" : $join);
3842b955 756 my $rel_info = $self->relationship_info($join);
701da8c4 757 $self->throw_exception("No such relationship ${join}") unless $rel_info;
24010dd8 758 my $type;
759 if ($force_left->{force}) {
760 $type = 'left';
761 } else {
762 $type = $rel_info->{attrs}{join_type} || '';
763 $force_left->{force} = 1 if lc($type) eq 'left';
764 }
489709af 765 return [ { $as => $self->related_source($join)->from,
953a18ef 766 -join_type => $type },
489709af 767 $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
953a18ef 768 }
769}
770
87c4e602 771=head2 resolve_condition
772
27f01d1f 773=over 4
774
ebc77b53 775=item Arguments: $cond, $as, $alias|$object
27f01d1f 776
777=back
953a18ef 778
3842b955 779Resolves the passed condition to a concrete query fragment. If given an alias,
953a18ef 780returns a join condition; if given an object, inverts that object to produce
781a related conditional from that object.
782
783=cut
784
785sub resolve_condition {
489709af 786 my ($self, $cond, $as, $for) = @_;
953a18ef 787 #warn %$cond;
788 if (ref $cond eq 'HASH') {
789 my %ret;
bd054cb4 790 foreach my $k (keys %{$cond}) {
791 my $v = $cond->{$k};
953a18ef 792 # XXX should probably check these are valid columns
27f01d1f 793 $k =~ s/^foreign\.// ||
75d07914 794 $self->throw_exception("Invalid rel cond key ${k}");
27f01d1f 795 $v =~ s/^self\.// ||
75d07914 796 $self->throw_exception("Invalid rel cond val ${v}");
953a18ef 797 if (ref $for) { # Object
3842b955 798 #warn "$self $k $for $v";
ac8a5ba4 799 $ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
3842b955 800 #warn %ret;
2c037e6b 801 } elsif (!defined $for) { # undef, i.e. "no object"
802 $ret{$k} = undef;
2ec8e594 803 } elsif (ref $as eq 'HASH') { # reverse hashref
804 $ret{$v} = $as->{$k};
fde6e28e 805 } elsif (ref $as) { # reverse object
806 $ret{$v} = $as->get_column($k);
2c037e6b 807 } elsif (!defined $as) { # undef, i.e. "no reverse object"
808 $ret{$v} = undef;
953a18ef 809 } else {
489709af 810 $ret{"${as}.${k}"} = "${for}.${v}";
953a18ef 811 }
953a18ef 812 }
813 return \%ret;
5efe4c79 814 } elsif (ref $cond eq 'ARRAY') {
489709af 815 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
953a18ef 816 } else {
817 die("Can't handle this yet :(");
87772e46 818 }
819}
820
87c4e602 821=head2 resolve_prefetch
822
27f01d1f 823=over 4
824
ebc77b53 825=item Arguments: hashref/arrayref/scalar
27f01d1f 826
827=back
988bf309 828
b3e8ac9b 829Accepts one or more relationships for the current source and returns an
830array of column names for each of those relationships. Column names are
831prefixed relative to the current source, in accordance with where they appear
832in the supplied relationships. Examples:
833
5ac6a044 834 my $source = $schema->resultset('Tag')->source;
b3e8ac9b 835 @columns = $source->resolve_prefetch( { cd => 'artist' } );
836
837 # @columns =
838 #(
839 # 'cd.cdid',
840 # 'cd.artist',
841 # 'cd.title',
842 # 'cd.year',
843 # 'cd.artist.artistid',
844 # 'cd.artist.name'
845 #)
846
847 @columns = $source->resolve_prefetch( qw[/ cd /] );
848
849 # @columns =
850 #(
851 # 'cd.cdid',
852 # 'cd.artist',
853 # 'cd.title',
854 # 'cd.year'
855 #)
856
857 $source = $schema->resultset('CD')->source;
858 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
859
860 # @columns =
861 #(
862 # 'artist.artistid',
863 # 'artist.name',
864 # 'producer.producerid',
865 # 'producer.name'
75d07914 866 #)
988bf309 867
b3e8ac9b 868=cut
869
870sub resolve_prefetch {
0f66a01b 871 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
489709af 872 $seen ||= {};
b3e8ac9b 873 #$alias ||= $self->name;
874 #warn $alias, Dumper $pre;
875 if( ref $pre eq 'ARRAY' ) {
0f66a01b 876 return
877 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
878 @$pre;
b3e8ac9b 879 }
880 elsif( ref $pre eq 'HASH' ) {
881 my @ret =
882 map {
0f66a01b 883 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
489709af 884 $self->related_source($_)->resolve_prefetch(
0f66a01b 885 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
886 } keys %$pre;
b3e8ac9b 887 #die Dumper \@ret;
888 return @ret;
889 }
890 elsif( ref $pre ) {
a86b1efe 891 $self->throw_exception(
892 "don't know how to resolve prefetch reftype ".ref($pre));
b3e8ac9b 893 }
894 else {
489709af 895 my $count = ++$seen->{$pre};
896 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
b3e8ac9b 897 my $rel_info = $self->relationship_info( $pre );
a86b1efe 898 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
899 unless $rel_info;
37f23589 900 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
a86b1efe 901 my $rel_source = $self->related_source($pre);
0f66a01b 902
903 if (exists $rel_info->{attrs}{accessor}
904 && $rel_info->{attrs}{accessor} eq 'multi') {
905 $self->throw_exception(
906 "Can't prefetch has_many ${pre} (join cond too complex)")
907 unless ref($rel_info->{cond}) eq 'HASH';
b25e9fa0 908 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
909 # values %{$rel_info->{cond}};
910 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
911 # action at a distance. prepending the '.' allows simpler code
912 # in ResultSet->_collapse_result
37f23589 913 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
0f66a01b 914 keys %{$rel_info->{cond}};
5a5bec6c 915 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
916 ? @{$rel_info->{attrs}{order_by}}
917 : (defined $rel_info->{attrs}{order_by}
918 ? ($rel_info->{attrs}{order_by})
919 : ()));
920 push(@$order, map { "${as}.$_" } (@key, @ord));
0f66a01b 921 }
922
489709af 923 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
a86b1efe 924 $rel_source->columns;
b3e8ac9b 925 #warn $alias, Dumper (\@ret);
489709af 926 #return @ret;
b3e8ac9b 927 }
928}
953a18ef 929
87c4e602 930=head2 related_source
931
27f01d1f 932=over 4
933
ebc77b53 934=item Arguments: $relname
27f01d1f 935
936=back
87772e46 937
2053ab2a 938Returns the result source object for the given relationship.
87772e46 939
940=cut
941
942sub related_source {
943 my ($self, $rel) = @_;
aea52c85 944 if( !$self->has_relationship( $rel ) ) {
701da8c4 945 $self->throw_exception("No such relationship '$rel'");
aea52c85 946 }
87772e46 947 return $self->schema->source($self->relationship_info($rel)->{source});
8452e496 948}
949
77254782 950=head2 related_class
951
27f01d1f 952=over 4
953
ebc77b53 954=item Arguments: $relname
27f01d1f 955
956=back
77254782 957
2053ab2a 958Returns the class name for objects in the given relationship.
77254782 959
960=cut
961
962sub related_class {
963 my ($self, $rel) = @_;
964 if( !$self->has_relationship( $rel ) ) {
965 $self->throw_exception("No such relationship '$rel'");
966 }
967 return $self->schema->class($self->relationship_info($rel)->{source});
968}
969
5ac6a044 970=head2 resultset
971
bcc5a210 972Returns a resultset for the given source. This will initially be created
973on demand by calling
5ac6a044 974
988bf309 975 $self->resultset_class->new($self, $self->resultset_attributes)
5ac6a044 976
bcc5a210 977but is cached from then on unless resultset_class changes.
978
5ac6a044 979=head2 resultset_class
980
d7be2784 981` package My::ResultSetClass;
982 use base 'DBIx::Class::ResultSet';
983 ...
984
985 $source->resultset_class('My::ResultSet::Class');
986
988bf309 987Set the class of the resultset, this is useful if you want to create your
988own resultset methods. Create your own class derived from
e4773415 989L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
990this method returns the name of the existing resultset class, if one
991exists.
5ac6a044 992
993=head2 resultset_attributes
994
d7be2784 995 $source->resultset_attributes({ order_by => [ 'id' ] });
996
d84c7d78 997Specify here any attributes you wish to pass to your specialised
998resultset. For a full list of these, please see
999L<DBIx::Class::ResultSet/ATTRIBUTES>.
5ac6a044 1000
1001=cut
1002
1003sub resultset {
1004 my $self = shift;
27f01d1f 1005 $self->throw_exception(
1006 'resultset does not take any arguments. If you want another resultset, '.
1007 'call it on the schema instead.'
1008 ) if scalar @_;
428c2b82 1009
428c2b82 1010 return $self->resultset_class->new(
e6c747fd 1011 $self,
1012 {
1013 %{$self->{resultset_attributes}},
1014 %{$self->schema->default_resultset_attributes}
1015 },
27f01d1f 1016 );
5ac6a044 1017}
1018
bab77431 1019=head2 source_name
1020
1021=over 4
1022
1023=item Arguments: $source_name
1024
1025=back
1026
1027Set the name of the result source when it is loaded into a schema.
1028This is usefull if you want to refer to a result source by a name other than
1029its class name.
1030
1031 package ArchivedBooks;
1032 use base qw/DBIx::Class/;
1033 __PACKAGE__->table('books_archive');
1034 __PACKAGE__->source_name('Books');
1035
1036 # from your schema...
1037 $schema->resultset('Books')->find(1);
1038
aec3eff1 1039=head2 handle
1040
1041Obtain a new handle to this source. Returns an instance of a
1042L<DBIx::Class::ResultSourceHandle>.
1043
1044=cut
1045
1046sub handle {
1047 return new DBIx::Class::ResultSourceHandle({
1048 schema => $_[0]->schema,
3441fd57 1049 source_moniker => $_[0]->source_name
aec3eff1 1050 });
1051}
1052
701da8c4 1053=head2 throw_exception
1054
2053ab2a 1055See L<DBIx::Class::Schema/"throw_exception">.
701da8c4 1056
1057=cut
1058
1059sub throw_exception {
1060 my $self = shift;
75d07914 1061 if (defined $self->schema) {
701da8c4 1062 $self->schema->throw_exception(@_);
1063 } else {
1064 croak(@_);
1065 }
1066}
1067
d2f3e87b 1068=head2 sqlt_deploy_hook($sqlt_table)
1069
1070An optional sub which you can declare in your own Schema class that will get
1071passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
1072via L</create_ddl_dir> or L</deploy>.
1073
1074For an example of what you can do with this, see
1075L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1076
9c992ba1 1077=head1 AUTHORS
1078
1079Matt S. Trout <mst@shadowcatsystems.co.uk>
1080
1081=head1 LICENSE
1082
1083You may distribute this code under the same terms as Perl itself.
1084
1085=cut
1086
b25e9fa0 10871;