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