first cut at sanitising multi-create/new_related etc., a couple things don't work...
[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
370f2ba2 771=head2 pk_depends_on
772
773=over 4
774
775=item Arguments: $relname, $rel_data
776
777=back
778
779Determines whether a relation is dependent on an object from this source
780having already been inserted. Takes the name of the relationship and a
781hashref of columns of the related object.
782
783=cut
784
785sub pk_depends_on {
786 my ($self, $relname, $rel_data) = @_;
787 my $cond = $self->relationship_info($relname)->{cond};
788
789 return 0 unless ref($cond) eq 'HASH';
790
791 # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
792
793 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
794
795 # assume anything that references our PK probably is dependent on us
796 # rather than vice versa, unless the far side is (a) defined or (b)
797 # auto-increment
798
799 my $rel_source = $self->related_source($relname);
800
801 foreach my $p ($self->primary_columns) {
802 if (exists $keyhash->{$p}) {
803 unless (defined($rel_data->{$keyhash->{$p}})
804 || $rel_source->column_info($keyhash->{$p})
805 ->{is_auto_increment}) {
806 return 0;
807 }
808 }
809 }
810
811 return 1;
812}
813
87c4e602 814=head2 resolve_condition
815
27f01d1f 816=over 4
817
ebc77b53 818=item Arguments: $cond, $as, $alias|$object
27f01d1f 819
820=back
953a18ef 821
3842b955 822Resolves the passed condition to a concrete query fragment. If given an alias,
953a18ef 823returns a join condition; if given an object, inverts that object to produce
824a related conditional from that object.
825
826=cut
827
8c368cf3 828our $UNRESOLVABLE_CONDITION = \'1 = 0';
829
953a18ef 830sub resolve_condition {
489709af 831 my ($self, $cond, $as, $for) = @_;
953a18ef 832 #warn %$cond;
833 if (ref $cond eq 'HASH') {
834 my %ret;
bd054cb4 835 foreach my $k (keys %{$cond}) {
836 my $v = $cond->{$k};
953a18ef 837 # XXX should probably check these are valid columns
27f01d1f 838 $k =~ s/^foreign\.// ||
75d07914 839 $self->throw_exception("Invalid rel cond key ${k}");
27f01d1f 840 $v =~ s/^self\.// ||
75d07914 841 $self->throw_exception("Invalid rel cond val ${v}");
953a18ef 842 if (ref $for) { # Object
3842b955 843 #warn "$self $k $for $v";
370f2ba2 844 unless ($for->has_column_loaded($v)) {
845 if ($for->in_storage) {
846 $self->throw_exception("Column ${v} not loaded on ${for} trying to reolve relationship");
847 }
8c368cf3 848 return [ $UNRESOLVABLE_CONDITION ];
370f2ba2 849 }
850 $ret{$k} = $for->get_column($v);
851 #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
3842b955 852 #warn %ret;
2c037e6b 853 } elsif (!defined $for) { # undef, i.e. "no object"
854 $ret{$k} = undef;
2ec8e594 855 } elsif (ref $as eq 'HASH') { # reverse hashref
856 $ret{$v} = $as->{$k};
fde6e28e 857 } elsif (ref $as) { # reverse object
858 $ret{$v} = $as->get_column($k);
2c037e6b 859 } elsif (!defined $as) { # undef, i.e. "no reverse object"
860 $ret{$v} = undef;
953a18ef 861 } else {
489709af 862 $ret{"${as}.${k}"} = "${for}.${v}";
953a18ef 863 }
953a18ef 864 }
865 return \%ret;
5efe4c79 866 } elsif (ref $cond eq 'ARRAY') {
489709af 867 return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
953a18ef 868 } else {
869 die("Can't handle this yet :(");
87772e46 870 }
871}
872
87c4e602 873=head2 resolve_prefetch
874
27f01d1f 875=over 4
876
ebc77b53 877=item Arguments: hashref/arrayref/scalar
27f01d1f 878
879=back
988bf309 880
b3e8ac9b 881Accepts one or more relationships for the current source and returns an
882array of column names for each of those relationships. Column names are
883prefixed relative to the current source, in accordance with where they appear
884in the supplied relationships. Examples:
885
5ac6a044 886 my $source = $schema->resultset('Tag')->source;
b3e8ac9b 887 @columns = $source->resolve_prefetch( { cd => 'artist' } );
888
889 # @columns =
890 #(
891 # 'cd.cdid',
892 # 'cd.artist',
893 # 'cd.title',
894 # 'cd.year',
895 # 'cd.artist.artistid',
896 # 'cd.artist.name'
897 #)
898
899 @columns = $source->resolve_prefetch( qw[/ cd /] );
900
901 # @columns =
902 #(
903 # 'cd.cdid',
904 # 'cd.artist',
905 # 'cd.title',
906 # 'cd.year'
907 #)
908
909 $source = $schema->resultset('CD')->source;
910 @columns = $source->resolve_prefetch( qw[/ artist producer /] );
911
912 # @columns =
913 #(
914 # 'artist.artistid',
915 # 'artist.name',
916 # 'producer.producerid',
917 # 'producer.name'
75d07914 918 #)
988bf309 919
b3e8ac9b 920=cut
921
922sub resolve_prefetch {
0f66a01b 923 my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
489709af 924 $seen ||= {};
b3e8ac9b 925 #$alias ||= $self->name;
926 #warn $alias, Dumper $pre;
927 if( ref $pre eq 'ARRAY' ) {
0f66a01b 928 return
929 map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
930 @$pre;
b3e8ac9b 931 }
932 elsif( ref $pre eq 'HASH' ) {
933 my @ret =
934 map {
0f66a01b 935 $self->resolve_prefetch($_, $alias, $seen, $order, $collapse),
489709af 936 $self->related_source($_)->resolve_prefetch(
0f66a01b 937 $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
938 } keys %$pre;
b3e8ac9b 939 #die Dumper \@ret;
940 return @ret;
941 }
942 elsif( ref $pre ) {
a86b1efe 943 $self->throw_exception(
944 "don't know how to resolve prefetch reftype ".ref($pre));
b3e8ac9b 945 }
946 else {
489709af 947 my $count = ++$seen->{$pre};
948 my $as = ($count > 1 ? "${pre}_${count}" : $pre);
b3e8ac9b 949 my $rel_info = $self->relationship_info( $pre );
a86b1efe 950 $self->throw_exception( $self->name . " has no such relationship '$pre'" )
951 unless $rel_info;
37f23589 952 my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
a86b1efe 953 my $rel_source = $self->related_source($pre);
0f66a01b 954
955 if (exists $rel_info->{attrs}{accessor}
956 && $rel_info->{attrs}{accessor} eq 'multi') {
957 $self->throw_exception(
958 "Can't prefetch has_many ${pre} (join cond too complex)")
959 unless ref($rel_info->{cond}) eq 'HASH';
cb136e67 960 my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
961 if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
962 keys %{$collapse}) {
963 my ($last) = ($fail =~ /([^\.]+)$/);
964 $self->throw_exception(
965 "Can't prefetch multiple has_many rels ${last} and ${pre}"
966 .(length($as_prefix) ? "at the same level (${as_prefix})"
967 : "at top level"
968 ));
969 }
b25e9fa0 970 #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
971 # values %{$rel_info->{cond}};
972 $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
973 # action at a distance. prepending the '.' allows simpler code
974 # in ResultSet->_collapse_result
37f23589 975 my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
0f66a01b 976 keys %{$rel_info->{cond}};
5a5bec6c 977 my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
978 ? @{$rel_info->{attrs}{order_by}}
979 : (defined $rel_info->{attrs}{order_by}
980 ? ($rel_info->{attrs}{order_by})
981 : ()));
982 push(@$order, map { "${as}.$_" } (@key, @ord));
0f66a01b 983 }
984
489709af 985 return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
a86b1efe 986 $rel_source->columns;
b3e8ac9b 987 #warn $alias, Dumper (\@ret);
489709af 988 #return @ret;
b3e8ac9b 989 }
990}
953a18ef 991
87c4e602 992=head2 related_source
993
27f01d1f 994=over 4
995
ebc77b53 996=item Arguments: $relname
27f01d1f 997
998=back
87772e46 999
2053ab2a 1000Returns the result source object for the given relationship.
87772e46 1001
1002=cut
1003
1004sub related_source {
1005 my ($self, $rel) = @_;
aea52c85 1006 if( !$self->has_relationship( $rel ) ) {
701da8c4 1007 $self->throw_exception("No such relationship '$rel'");
aea52c85 1008 }
87772e46 1009 return $self->schema->source($self->relationship_info($rel)->{source});
8452e496 1010}
1011
77254782 1012=head2 related_class
1013
27f01d1f 1014=over 4
1015
ebc77b53 1016=item Arguments: $relname
27f01d1f 1017
1018=back
77254782 1019
2053ab2a 1020Returns the class name for objects in the given relationship.
77254782 1021
1022=cut
1023
1024sub related_class {
1025 my ($self, $rel) = @_;
1026 if( !$self->has_relationship( $rel ) ) {
1027 $self->throw_exception("No such relationship '$rel'");
1028 }
1029 return $self->schema->class($self->relationship_info($rel)->{source});
1030}
1031
5ac6a044 1032=head2 resultset
1033
bcc5a210 1034Returns a resultset for the given source. This will initially be created
1035on demand by calling
5ac6a044 1036
988bf309 1037 $self->resultset_class->new($self, $self->resultset_attributes)
5ac6a044 1038
bcc5a210 1039but is cached from then on unless resultset_class changes.
1040
5ac6a044 1041=head2 resultset_class
1042
d7be2784 1043` package My::ResultSetClass;
1044 use base 'DBIx::Class::ResultSet';
1045 ...
1046
1047 $source->resultset_class('My::ResultSet::Class');
1048
988bf309 1049Set the class of the resultset, this is useful if you want to create your
1050own resultset methods. Create your own class derived from
e4773415 1051L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
1052this method returns the name of the existing resultset class, if one
1053exists.
5ac6a044 1054
1055=head2 resultset_attributes
1056
d7be2784 1057 $source->resultset_attributes({ order_by => [ 'id' ] });
1058
d84c7d78 1059Specify here any attributes you wish to pass to your specialised
1060resultset. For a full list of these, please see
1061L<DBIx::Class::ResultSet/ATTRIBUTES>.
5ac6a044 1062
1063=cut
1064
1065sub resultset {
1066 my $self = shift;
27f01d1f 1067 $self->throw_exception(
1068 'resultset does not take any arguments. If you want another resultset, '.
1069 'call it on the schema instead.'
1070 ) if scalar @_;
428c2b82 1071
428c2b82 1072 return $self->resultset_class->new(
e6c747fd 1073 $self,
1074 {
1075 %{$self->{resultset_attributes}},
1076 %{$self->schema->default_resultset_attributes}
1077 },
27f01d1f 1078 );
5ac6a044 1079}
1080
bab77431 1081=head2 source_name
1082
1083=over 4
1084
1085=item Arguments: $source_name
1086
1087=back
1088
1089Set the name of the result source when it is loaded into a schema.
1090This is usefull if you want to refer to a result source by a name other than
1091its class name.
1092
1093 package ArchivedBooks;
1094 use base qw/DBIx::Class/;
1095 __PACKAGE__->table('books_archive');
1096 __PACKAGE__->source_name('Books');
1097
1098 # from your schema...
1099 $schema->resultset('Books')->find(1);
1100
aec3eff1 1101=head2 handle
1102
1103Obtain a new handle to this source. Returns an instance of a
1104L<DBIx::Class::ResultSourceHandle>.
1105
1106=cut
1107
1108sub handle {
1109 return new DBIx::Class::ResultSourceHandle({
1110 schema => $_[0]->schema,
3441fd57 1111 source_moniker => $_[0]->source_name
aec3eff1 1112 });
1113}
1114
701da8c4 1115=head2 throw_exception
1116
2053ab2a 1117See L<DBIx::Class::Schema/"throw_exception">.
701da8c4 1118
1119=cut
1120
1121sub throw_exception {
1122 my $self = shift;
75d07914 1123 if (defined $self->schema) {
701da8c4 1124 $self->schema->throw_exception(@_);
1125 } else {
1126 croak(@_);
1127 }
1128}
1129
d2f3e87b 1130=head2 sqlt_deploy_hook($sqlt_table)
1131
1132An optional sub which you can declare in your own Schema class that will get
1133passed the L<SQL::Translator::Schema::Table> object when you deploy the schema
1134via L</create_ddl_dir> or L</deploy>.
1135
1136For an example of what you can do with this, see
1137L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
1138
9c992ba1 1139=head1 AUTHORS
1140
1141Matt S. Trout <mst@shadowcatsystems.co.uk>
1142
1143=head1 LICENSE
1144
1145You may distribute this code under the same terms as Perl itself.
1146
1147=cut
1148
b25e9fa0 11491;