1dca0a661f8bad81bb2e2b766f85a53e5c5f22a0
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSource.pm
1 package DBIx::Class::ResultSource;
2
3 use strict;
4 use warnings;
5
6 use DBIx::Class::ResultSet;
7 use DBIx::Class::ResultSourceHandle;
8
9 use DBIx::Class::Exception;
10 use Carp::Clan qw/^DBIx::Class/;
11 use Try::Tiny;
12 use List::Util 'first';
13 use Scalar::Util qw/weaken isweak/;
14 use Storable qw/nfreeze thaw/;
15 use namespace::clean;
16
17 use base qw/DBIx::Class/;
18
19 __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
20   _columns _primaries _unique_constraints name resultset_attributes
21   from _relationships column_info_from_storage source_info
22   source_name sqlt_deploy_callback/);
23
24 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
25   result_class/);
26
27 =head1 NAME
28
29 DBIx::Class::ResultSource - Result source object
30
31 =head1 SYNOPSIS
32
33   # Create a table based result source, in a result class.
34
35   package MyDB::Schema::Result::Artist;
36   use base qw/DBIx::Class::Core/;
37
38   __PACKAGE__->table('artist');
39   __PACKAGE__->add_columns(qw/ artistid name /);
40   __PACKAGE__->set_primary_key('artistid');
41   __PACKAGE__->has_many(cds => 'MyDB::Schema::Result::CD');
42
43   1;
44
45   # Create a query (view) based result source, in a result class
46   package MyDB::Schema::Result::Year2000CDs;
47   use base qw/DBIx::Class::Core/;
48
49   __PACKAGE__->load_components('InflateColumn::DateTime');
50   __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
51
52   __PACKAGE__->table('year2000cds');
53   __PACKAGE__->result_source_instance->is_virtual(1);
54   __PACKAGE__->result_source_instance->view_definition(
55       "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
56       );
57
58
59 =head1 DESCRIPTION
60
61 A ResultSource is an object that represents a source of data for querying.
62
63 This class is a base class for various specialised types of result
64 sources, for example L<DBIx::Class::ResultSource::Table>. Table is the
65 default result source type, so one is created for you when defining a
66 result class as described in the synopsis above.
67
68 More specifically, the L<DBIx::Class::Core> base class pulls in the
69 L<DBIx::Class::ResultSourceProxy::Table> component, which defines
70 the L<table|DBIx::Class::ResultSourceProxy::Table/table> method.
71 When called, C<table> creates and stores an instance of
72 L<DBIx::Class::ResultSoure::Table>. Luckily, to use tables as result
73 sources, you don't need to remember any of this.
74
75 Result sources representing select queries, or views, can also be
76 created, see L<DBIx::Class::ResultSource::View> for full details.
77
78 =head2 Finding result source objects
79
80 As mentioned above, a result source instance is created and stored for
81 you when you define a L<Result Class|DBIx::Class::Manual::Glossary/Result Class>.
82
83 You can retrieve the result source at runtime in the following ways:
84
85 =over
86
87 =item From a Schema object:
88
89    $schema->source($source_name);
90
91 =item From a Row object:
92
93    $row->result_source;
94
95 =item From a ResultSet object:
96
97    $rs->result_source;
98
99 =back
100
101 =head1 METHODS
102
103 =pod
104
105 =cut
106
107 sub new {
108   my ($class, $attrs) = @_;
109   $class = ref $class if ref $class;
110
111   my $new = bless { %{$attrs || {}} }, $class;
112   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
113   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
114   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
115   $new->{_columns} = { %{$new->{_columns}||{}} };
116   $new->{_relationships} = { %{$new->{_relationships}||{}} };
117   $new->{name} ||= "!!NAME NOT SET!!";
118   $new->{_columns_info_loaded} ||= 0;
119   $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
120   return $new;
121 }
122
123 =pod
124
125 =head2 add_columns
126
127 =over
128
129 =item Arguments: @columns
130
131 =item Return value: The ResultSource object
132
133 =back
134
135   $source->add_columns(qw/col1 col2 col3/);
136
137   $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
138
139 Adds columns to the result source. If supplied colname => hashref
140 pairs, uses the hashref as the L</column_info> for that column. Repeated
141 calls of this method will add more columns, not replace them.
142
143 The column names given will be created as accessor methods on your
144 L<DBIx::Class::Row> objects. You can change the name of the accessor
145 by supplying an L</accessor> in the column_info hash.
146
147 If a column name beginning with a plus sign ('+col1') is provided, the
148 attributes provided will be merged with any existing attributes for the
149 column, with the new attributes taking precedence in the case that an
150 attribute already exists. Using this without a hashref
151 (C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
152 it does the same thing it would do without the plus.
153
154 The contents of the column_info are not set in stone. The following
155 keys are currently recognised/used by DBIx::Class:
156
157 =over 4
158
159 =item accessor
160
161    { accessor => '_name' }
162
163    # example use, replace standard accessor with one of your own:
164    sub name {
165        my ($self, $value) = @_;
166
167        die "Name cannot contain digits!" if($value =~ /\d/);
168        $self->_name($value);
169
170        return $self->_name();
171    }
172
173 Use this to set the name of the accessor method for this column. If unset,
174 the name of the column will be used.
175
176 =item data_type
177
178    { data_type => 'integer' }
179
180 This contains the column type. It is automatically filled if you use the
181 L<SQL::Translator::Producer::DBIx::Class::File> producer, or the
182 L<DBIx::Class::Schema::Loader> module.
183
184 Currently there is no standard set of values for the data_type. Use
185 whatever your database supports.
186
187 =item size
188
189    { size => 20 }
190
191 The length of your column, if it is a column type that can have a size
192 restriction. This is currently only used to create tables from your
193 schema, see L<DBIx::Class::Schema/deploy>.
194
195 =item is_nullable
196
197    { is_nullable => 1 }
198
199 Set this to a true value for a columns that is allowed to contain NULL
200 values, default is false. This is currently only used to create tables
201 from your schema, see L<DBIx::Class::Schema/deploy>.
202
203 =item is_auto_increment
204
205    { is_auto_increment => 1 }
206
207 Set this to a true value for a column whose value is somehow
208 automatically set, defaults to false. This is used to determine which
209 columns to empty when cloning objects using
210 L<DBIx::Class::Row/copy>. It is also used by
211 L<DBIx::Class::Schema/deploy>.
212
213 =item is_numeric
214
215    { is_numeric => 1 }
216
217 Set this to a true or false value (not C<undef>) to explicitly specify
218 if this column contains numeric data. This controls how set_column
219 decides whether to consider a column dirty after an update: if
220 C<is_numeric> is true a numeric comparison C<< != >> will take place
221 instead of the usual C<eq>
222
223 If not specified the storage class will attempt to figure this out on
224 first access to the column, based on the column C<data_type>. The
225 result will be cached in this attribute.
226
227 =item is_foreign_key
228
229    { is_foreign_key => 1 }
230
231 Set this to a true value for a column that contains a key from a
232 foreign table, defaults to false. This is currently only used to
233 create tables from your schema, see L<DBIx::Class::Schema/deploy>.
234
235 =item default_value
236
237    { default_value => \'now()' }
238
239 Set this to the default value which will be inserted into a column by
240 the database. Can contain either a value or a function (use a
241 reference to a scalar e.g. C<\'now()'> if you want a function). This
242 is currently only used to create tables from your schema, see
243 L<DBIx::Class::Schema/deploy>.
244
245 See the note on L<DBIx::Class::Row/new> for more information about possible
246 issues related to db-side default values.
247
248 =item sequence
249
250    { sequence => 'my_table_seq' }
251
252 Set this on a primary key column to the name of the sequence used to
253 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
254 will attempt to retrieve the name of the sequence from the database
255 automatically.
256
257 =item auto_nextval
258
259 Set this to a true value for a column whose value is retrieved automatically
260 from a sequence or function (if supported by your Storage driver.) For a
261 sequence, if you do not use a trigger to get the nextval, you have to set the
262 L</sequence> value as well.
263
264 Also set this for MSSQL columns with the 'uniqueidentifier'
265 L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to
266 automatically generate using C<NEWID()>, unless they are a primary key in which
267 case this will be done anyway.
268
269 =item extra
270
271 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
272 to add extra non-generic data to the column. For example: C<< extra
273 => { unsigned => 1} >> is used by the MySQL producer to set an integer
274 column to unsigned. For more details, see
275 L<SQL::Translator::Producer::MySQL>.
276
277 =back
278
279 =head2 add_column
280
281 =over
282
283 =item Arguments: $colname, \%columninfo?
284
285 =item Return value: 1/0 (true/false)
286
287 =back
288
289   $source->add_column('col' => \%info);
290
291 Add a single column and optional column info. Uses the same column
292 info keys as L</add_columns>.
293
294 =cut
295
296 sub add_columns {
297   my ($self, @cols) = @_;
298   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
299
300   my @added;
301   my $columns = $self->_columns;
302   while (my $col = shift @cols) {
303     my $column_info = {};
304     if ($col =~ s/^\+//) {
305       $column_info = $self->column_info($col);
306     }
307
308     # If next entry is { ... } use that for the column info, if not
309     # use an empty hashref
310     if (ref $cols[0]) {
311       my $new_info = shift(@cols);
312       %$column_info = (%$column_info, %$new_info);
313     }
314     push(@added, $col) unless exists $columns->{$col};
315     $columns->{$col} = $column_info;
316   }
317   push @{ $self->_ordered_columns }, @added;
318   return $self;
319 }
320
321 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
322
323 =head2 has_column
324
325 =over
326
327 =item Arguments: $colname
328
329 =item Return value: 1/0 (true/false)
330
331 =back
332
333   if ($source->has_column($colname)) { ... }
334
335 Returns true if the source has a column of this name, false otherwise.
336
337 =cut
338
339 sub has_column {
340   my ($self, $column) = @_;
341   return exists $self->_columns->{$column};
342 }
343
344 =head2 column_info
345
346 =over
347
348 =item Arguments: $colname
349
350 =item Return value: Hashref of info
351
352 =back
353
354   my $info = $source->column_info($col);
355
356 Returns the column metadata hashref for a column, as originally passed
357 to L</add_columns>. See L</add_columns> above for information on the
358 contents of the hashref.
359
360 =cut
361
362 sub column_info {
363   my ($self, $column) = @_;
364   $self->throw_exception("No such column $column")
365     unless exists $self->_columns->{$column};
366
367   if ( ! $self->_columns->{$column}{data_type}
368        and ! $self->{_columns_info_loaded}
369        and $self->column_info_from_storage
370        and my $stor = try { $self->storage } )
371   {
372     $self->{_columns_info_loaded}++;
373
374     # try for the case of storage without table
375     try {
376       my $info = $stor->columns_info_for( $self->from );
377       my $lc_info = { map
378         { (lc $_) => $info->{$_} }
379         ( keys %$info )
380       };
381
382       foreach my $col ( keys %{$self->_columns} ) {
383         $self->_columns->{$col} = {
384           %{ $self->_columns->{$col} },
385           %{ $info->{$col} || $lc_info->{lc $col} || {} }
386         };
387       }
388     };
389   }
390
391   return $self->_columns->{$column};
392 }
393
394 =head2 columns
395
396 =over
397
398 =item Arguments: None
399
400 =item Return value: Ordered list of column names
401
402 =back
403
404   my @column_names = $source->columns;
405
406 Returns all column names in the order they were declared to L</add_columns>.
407
408 =cut
409
410 sub columns {
411   my $self = shift;
412   $self->throw_exception(
413     "columns() is a read-only accessor, did you mean add_columns()?"
414   ) if @_;
415   return @{$self->{_ordered_columns}||[]};
416 }
417
418 =head2 columns_info
419
420 =over
421
422 =item Arguments: \@colnames ?
423
424 =item Return value: Hashref of column name/info pairs
425
426 =back
427
428   my $columns_info = $source->columns_info;
429
430 Like L</column_info> but returns information for the requested columns. If
431 the optional column-list arrayref is ommitted it returns info on all columns
432 currently defined on the ResultSource via L</add_columns>.
433
434 =cut
435
436 sub columns_info {
437   my ($self, $columns) = @_;
438
439   my $colinfo = $self->_columns;
440
441   if (
442     first { ! $_->{data_type} } values %$colinfo
443       and
444     ! $self->{_columns_info_loaded}
445       and
446     $self->column_info_from_storage
447       and
448     my $stor = try { $self->storage }
449   ) {
450     $self->{_columns_info_loaded}++;
451
452     # try for the case of storage without table
453     try {
454       my $info = $stor->columns_info_for( $self->from );
455       my $lc_info = { map
456         { (lc $_) => $info->{$_} }
457         ( keys %$info )
458       };
459
460       foreach my $col ( keys %$colinfo ) {
461         $colinfo->{$col} = {
462           %{ $colinfo->{$col} },
463           %{ $info->{$col} || $lc_info->{lc $col} || {} }
464         };
465       }
466     };
467   }
468
469   my %ret;
470
471   if ($columns) {
472     for (@$columns) {
473       if (my $inf = $colinfo->{$_}) {
474         $ret{$_} = $inf;
475       }
476       else {
477         $self->throw_exception( sprintf (
478           "No such column '%s' on source %s",
479           $_,
480           $self->source_name,
481         ));
482       }
483     }
484   }
485   else {
486     %ret = %$colinfo;
487   }
488
489   return \%ret;
490 }
491
492 =head2 remove_columns
493
494 =over
495
496 =item Arguments: @colnames
497
498 =item Return value: undefined
499
500 =back
501
502   $source->remove_columns(qw/col1 col2 col3/);
503
504 Removes the given list of columns by name, from the result source.
505
506 B<Warning>: Removing a column that is also used in the sources primary
507 key, or in one of the sources unique constraints, B<will> result in a
508 broken result source.
509
510 =head2 remove_column
511
512 =over
513
514 =item Arguments: $colname
515
516 =item Return value: undefined
517
518 =back
519
520   $source->remove_column('col');
521
522 Remove a single column by name from the result source, similar to
523 L</remove_columns>.
524
525 B<Warning>: Removing a column that is also used in the sources primary
526 key, or in one of the sources unique constraints, B<will> result in a
527 broken result source.
528
529 =cut
530
531 sub remove_columns {
532   my ($self, @to_remove) = @_;
533
534   my $columns = $self->_columns
535     or return;
536
537   my %to_remove;
538   for (@to_remove) {
539     delete $columns->{$_};
540     ++$to_remove{$_};
541   }
542
543   $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
544 }
545
546 sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB
547
548 =head2 set_primary_key
549
550 =over 4
551
552 =item Arguments: @cols
553
554 =item Return value: undefined
555
556 =back
557
558 Defines one or more columns as primary key for this source. Must be
559 called after L</add_columns>.
560
561 Additionally, defines a L<unique constraint|add_unique_constraint>
562 named C<primary>.
563
564 Note: you normally do want to define a primary key on your sources
565 B<even if the underlying database table does not have a primary key>.
566 See
567 L<DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
568 for more info.
569
570 =cut
571
572 sub set_primary_key {
573   my ($self, @cols) = @_;
574   # check if primary key columns are valid columns
575   foreach my $col (@cols) {
576     $self->throw_exception("No such column $col on table " . $self->name)
577       unless $self->has_column($col);
578   }
579   $self->_primaries(\@cols);
580
581   $self->add_unique_constraint(primary => \@cols);
582 }
583
584 =head2 primary_columns
585
586 =over 4
587
588 =item Arguments: None
589
590 =item Return value: Ordered list of primary column names
591
592 =back
593
594 Read-only accessor which returns the list of primary keys, supplied by
595 L</set_primary_key>.
596
597 =cut
598
599 sub primary_columns {
600   return @{shift->_primaries||[]};
601 }
602
603 # a helper method that will automatically die with a descriptive message if
604 # no pk is defined on the source in question. For internal use to save
605 # on if @pks... boilerplate
606 sub _pri_cols {
607   my $self = shift;
608   my @pcols = $self->primary_columns
609     or $self->throw_exception (sprintf(
610       "Operation requires a primary key to be declared on '%s' via set_primary_key",
611       # source_name is set only after schema-registration
612       $self->source_name || $self->result_class || $self->name || 'Unknown source...?',
613     ));
614   return @pcols;
615 }
616
617 =head2 sequence
618
619 Manually define the correct sequence for your table, to avoid the overhead
620 associated with looking up the sequence automatically. The supplied sequence
621 will be applied to the L</column_info> of each L<primary_key|/set_primary_key>
622
623 =over 4
624
625 =item Arguments: $sequence_name
626
627 =item Return value: undefined
628
629 =back
630
631 =cut
632
633 sub sequence {
634   my ($self,$seq) = @_;
635
636   my @pks = $self->primary_columns
637     or next;
638
639   $_->{sequence} = $seq
640     for values %{ $self->columns_info (\@pks) };
641 }
642
643
644 =head2 add_unique_constraint
645
646 =over 4
647
648 =item Arguments: $name?, \@colnames
649
650 =item Return value: undefined
651
652 =back
653
654 Declare a unique constraint on this source. Call once for each unique
655 constraint.
656
657   # For UNIQUE (column1, column2)
658   __PACKAGE__->add_unique_constraint(
659     constraint_name => [ qw/column1 column2/ ],
660   );
661
662 Alternatively, you can specify only the columns:
663
664   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
665
666 This will result in a unique constraint named
667 C<table_column1_column2>, where C<table> is replaced with the table
668 name.
669
670 Unique constraints are used, for example, when you pass the constraint
671 name as the C<key> attribute to L<DBIx::Class::ResultSet/find>. Then
672 only columns in the constraint are searched.
673
674 Throws an error if any of the given column names do not yet exist on
675 the result source.
676
677 =cut
678
679 sub add_unique_constraint {
680   my $self = shift;
681
682   if (@_ > 2) {
683     $self->throw_exception(
684         'add_unique_constraint() does not accept multiple constraints, use '
685       . 'add_unique_constraints() instead'
686     );
687   }
688
689   my $cols = pop @_;
690   if (ref $cols ne 'ARRAY') {
691     $self->throw_exception (
692       'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING')
693     );
694   }
695
696   my $name = shift @_;
697
698   $name ||= $self->name_unique_constraint($cols);
699
700   foreach my $col (@$cols) {
701     $self->throw_exception("No such column $col on table " . $self->name)
702       unless $self->has_column($col);
703   }
704
705   my %unique_constraints = $self->unique_constraints;
706   $unique_constraints{$name} = $cols;
707   $self->_unique_constraints(\%unique_constraints);
708 }
709
710 =head2 add_unique_constraints
711
712 =over 4
713
714 =item Arguments: @constraints
715
716 =item Return value: undefined
717
718 =back
719
720 Declare multiple unique constraints on this source.
721
722   __PACKAGE__->add_unique_constraints(
723     constraint_name1 => [ qw/column1 column2/ ],
724     constraint_name2 => [ qw/column2 column3/ ],
725   );
726
727 Alternatively, you can specify only the columns:
728
729   __PACKAGE__->add_unique_constraints(
730     [ qw/column1 column2/ ],
731     [ qw/column3 column4/ ]
732   );
733
734 This will result in unique constraints named C<table_column1_column2> and
735 C<table_column3_column4>, where C<table> is replaced with the table name.
736
737 Throws an error if any of the given column names do not yet exist on
738 the result source.
739
740 See also L</add_unique_constraint>.
741
742 =cut
743
744 sub add_unique_constraints {
745   my $self = shift;
746   my @constraints = @_;
747
748   if ( !(@constraints % 2) && first { ref $_ ne 'ARRAY' } @constraints ) {
749     # with constraint name
750     while (my ($name, $constraint) = splice @constraints, 0, 2) {
751       $self->add_unique_constraint($name => $constraint);
752     }
753   }
754   else {
755     # no constraint name
756     foreach my $constraint (@constraints) {
757       $self->add_unique_constraint($constraint);
758     }
759   }
760 }
761
762 =head2 name_unique_constraint
763
764 =over 4
765
766 =item Arguments: \@colnames
767
768 =item Return value: Constraint name
769
770 =back
771
772   $source->table('mytable');
773   $source->name_unique_constraint(['col1', 'col2']);
774   # returns
775   'mytable_col1_col2'
776
777 Return a name for a unique constraint containing the specified
778 columns. The name is created by joining the table name and each column
779 name, using an underscore character.
780
781 For example, a constraint on a table named C<cd> containing the columns
782 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
783
784 This is used by L</add_unique_constraint> if you do not specify the
785 optional constraint name.
786
787 =cut
788
789 sub name_unique_constraint {
790   my ($self, $cols) = @_;
791
792   my $name = $self->name;
793   $name = $$name if (ref $name eq 'SCALAR');
794
795   return join '_', $name, @$cols;
796 }
797
798 =head2 unique_constraints
799
800 =over 4
801
802 =item Arguments: None
803
804 =item Return value: Hash of unique constraint data
805
806 =back
807
808   $source->unique_constraints();
809
810 Read-only accessor which returns a hash of unique constraints on this
811 source.
812
813 The hash is keyed by constraint name, and contains an arrayref of
814 column names as values.
815
816 =cut
817
818 sub unique_constraints {
819   return %{shift->_unique_constraints||{}};
820 }
821
822 =head2 unique_constraint_names
823
824 =over 4
825
826 =item Arguments: None
827
828 =item Return value: Unique constraint names
829
830 =back
831
832   $source->unique_constraint_names();
833
834 Returns the list of unique constraint names defined on this source.
835
836 =cut
837
838 sub unique_constraint_names {
839   my ($self) = @_;
840
841   my %unique_constraints = $self->unique_constraints;
842
843   return keys %unique_constraints;
844 }
845
846 =head2 unique_constraint_columns
847
848 =over 4
849
850 =item Arguments: $constraintname
851
852 =item Return value: List of constraint columns
853
854 =back
855
856   $source->unique_constraint_columns('myconstraint');
857
858 Returns the list of columns that make up the specified unique constraint.
859
860 =cut
861
862 sub unique_constraint_columns {
863   my ($self, $constraint_name) = @_;
864
865   my %unique_constraints = $self->unique_constraints;
866
867   $self->throw_exception(
868     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
869   ) unless exists $unique_constraints{$constraint_name};
870
871   return @{ $unique_constraints{$constraint_name} };
872 }
873
874 =head2 sqlt_deploy_callback
875
876 =over
877
878 =item Arguments: $callback
879
880 =back
881
882   __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
883
884 An accessor to set a callback to be called during deployment of
885 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
886 L<DBIx::Class::Schema/deploy>.
887
888 The callback can be set as either a code reference or the name of a
889 method in the current result class.
890
891 If not set, the L</default_sqlt_deploy_hook> is called.
892
893 Your callback will be passed the $source object representing the
894 ResultSource instance being deployed, and the
895 L<SQL::Translator::Schema::Table> object being created from it. The
896 callback can be used to manipulate the table object or add your own
897 customised indexes. If you need to manipulate a non-table object, use
898 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
899
900 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
901 Your SQL> for examples.
902
903 This sqlt deployment callback can only be used to manipulate
904 SQL::Translator objects as they get turned into SQL. To execute
905 post-deploy statements which SQL::Translator does not currently
906 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
907 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
908
909 =head2 default_sqlt_deploy_hook
910
911 =over
912
913 =item Arguments: $source, $sqlt_table
914
915 =item Return value: undefined
916
917 =back
918
919 This is the sensible default for L</sqlt_deploy_callback>.
920
921 If a method named C<sqlt_deploy_hook> exists in your Result class, it
922 will be called and passed the current C<$source> and the
923 C<$sqlt_table> being deployed.
924
925 =cut
926
927 sub default_sqlt_deploy_hook {
928   my $self = shift;
929
930   my $class = $self->result_class;
931
932   if ($class and $class->can('sqlt_deploy_hook')) {
933     $class->sqlt_deploy_hook(@_);
934   }
935 }
936
937 sub _invoke_sqlt_deploy_hook {
938   my $self = shift;
939   if ( my $hook = $self->sqlt_deploy_callback) {
940     $self->$hook(@_);
941   }
942 }
943
944 =head2 resultset
945
946 =over 4
947
948 =item Arguments: None
949
950 =item Return value: $resultset
951
952 =back
953
954 Returns a resultset for the given source. This will initially be created
955 on demand by calling
956
957   $self->resultset_class->new($self, $self->resultset_attributes)
958
959 but is cached from then on unless resultset_class changes.
960
961 =head2 resultset_class
962
963 =over 4
964
965 =item Arguments: $classname
966
967 =item Return value: $classname
968
969 =back
970
971   package My::Schema::ResultSet::Artist;
972   use base 'DBIx::Class::ResultSet';
973   ...
974
975   # In the result class
976   __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist');
977
978   # Or in code
979   $source->resultset_class('My::Schema::ResultSet::Artist');
980
981 Set the class of the resultset. This is useful if you want to create your
982 own resultset methods. Create your own class derived from
983 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
984 this method returns the name of the existing resultset class, if one
985 exists.
986
987 =head2 resultset_attributes
988
989 =over 4
990
991 =item Arguments: \%attrs
992
993 =item Return value: \%attrs
994
995 =back
996
997   # In the result class
998   __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] });
999
1000   # Or in code
1001   $source->resultset_attributes({ order_by => [ 'id' ] });
1002
1003 Store a collection of resultset attributes, that will be set on every
1004 L<DBIx::Class::ResultSet> produced from this result source. For a full
1005 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
1006
1007 =cut
1008
1009 sub resultset {
1010   my $self = shift;
1011   $self->throw_exception(
1012     'resultset does not take any arguments. If you want another resultset, '.
1013     'call it on the schema instead.'
1014   ) if scalar @_;
1015
1016   $self->resultset_class->new(
1017     $self,
1018     {
1019       try { %{$self->schema->default_resultset_attributes} },
1020       %{$self->{resultset_attributes}},
1021     },
1022   );
1023 }
1024
1025 =head2 source_name
1026
1027 =over 4
1028
1029 =item Arguments: $source_name
1030
1031 =item Result value: $source_name
1032
1033 =back
1034
1035 Set an alternate name for the result source when it is loaded into a schema.
1036 This is useful if you want to refer to a result source by a name other than
1037 its class name.
1038
1039   package ArchivedBooks;
1040   use base qw/DBIx::Class/;
1041   __PACKAGE__->table('books_archive');
1042   __PACKAGE__->source_name('Books');
1043
1044   # from your schema...
1045   $schema->resultset('Books')->find(1);
1046
1047 =head2 from
1048
1049 =over 4
1050
1051 =item Arguments: None
1052
1053 =item Return value: FROM clause
1054
1055 =back
1056
1057   my $from_clause = $source->from();
1058
1059 Returns an expression of the source to be supplied to storage to specify
1060 retrieval from this source. In the case of a database, the required FROM
1061 clause contents.
1062
1063 =head2 schema
1064
1065 =over 4
1066
1067 =item Arguments: $schema
1068
1069 =item Return value: A schema object
1070
1071 =back
1072
1073   my $schema = $source->schema();
1074
1075 Sets and/or returns the L<DBIx::Class::Schema> object to which this
1076 result source instance has been attached to.
1077
1078 =cut
1079
1080 sub schema {
1081   if (@_ > 1) {
1082     $_[0]->{schema} = $_[1];
1083   }
1084   else {
1085     $_[0]->{schema} || do {
1086       my $name = $_[0]->{source_name} || '_unnamed_';
1087       my $err = 'Unable to perform storage-dependent operations with a detached result source '
1088               . "(source '$name' is not associated with a schema).";
1089
1090       $err .= ' You need to use $schema->thaw() or manually set'
1091             . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.'
1092         if $_[0]->{_detached_thaw};
1093
1094       DBIx::Class::Exception->throw($err);
1095     };
1096   }
1097 }
1098
1099 =head2 storage
1100
1101 =over 4
1102
1103 =item Arguments: None
1104
1105 =item Return value: A Storage object
1106
1107 =back
1108
1109   $source->storage->debug(1);
1110
1111 Returns the storage handle for the current schema.
1112
1113 See also: L<DBIx::Class::Storage>
1114
1115 =cut
1116
1117 sub storage { shift->schema->storage; }
1118
1119 =head2 add_relationship
1120
1121 =over 4
1122
1123 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
1124
1125 =item Return value: 1/true if it succeeded
1126
1127 =back
1128
1129   $source->add_relationship('relname', 'related_source', $cond, $attrs);
1130
1131 L<DBIx::Class::Relationship> describes a series of methods which
1132 create pre-defined useful types of relationships. Look there first
1133 before using this method directly.
1134
1135 The relationship name can be arbitrary, but must be unique for each
1136 relationship attached to this result source. 'related_source' should
1137 be the name with which the related result source was registered with
1138 the current schema. For example:
1139
1140   $schema->source('Book')->add_relationship('reviews', 'Review', {
1141     'foreign.book_id' => 'self.id',
1142   });
1143
1144 The condition C<$cond> needs to be an L<SQL::Abstract>-style
1145 representation of the join between the tables. For example, if you're
1146 creating a relation from Author to Book,
1147
1148   { 'foreign.author_id' => 'self.id' }
1149
1150 will result in the JOIN clause
1151
1152   author me JOIN book foreign ON foreign.author_id = me.id
1153
1154 You can specify as many foreign => self mappings as necessary.
1155
1156 Valid attributes are as follows:
1157
1158 =over 4
1159
1160 =item join_type
1161
1162 Explicitly specifies the type of join to use in the relationship. Any
1163 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
1164 the SQL command immediately before C<JOIN>.
1165
1166 =item proxy
1167
1168 An arrayref containing a list of accessors in the foreign class to proxy in
1169 the main class. If, for example, you do the following:
1170
1171   CD->might_have(liner_notes => 'LinerNotes', undef, {
1172     proxy => [ qw/notes/ ],
1173   });
1174
1175 Then, assuming LinerNotes has an accessor named notes, you can do:
1176
1177   my $cd = CD->find(1);
1178   # set notes -- LinerNotes object is created if it doesn't exist
1179   $cd->notes('Notes go here');
1180
1181 =item accessor
1182
1183 Specifies the type of accessor that should be created for the
1184 relationship. Valid values are C<single> (for when there is only a single
1185 related object), C<multi> (when there can be many), and C<filter> (for
1186 when there is a single related object, but you also want the relationship
1187 accessor to double as a column accessor). For C<multi> accessors, an
1188 add_to_* method is also created, which calls C<create_related> for the
1189 relationship.
1190
1191 =back
1192
1193 Throws an exception if the condition is improperly supplied, or cannot
1194 be resolved.
1195
1196 =cut
1197
1198 sub add_relationship {
1199   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
1200   $self->throw_exception("Can't create relationship without join condition")
1201     unless $cond;
1202   $attrs ||= {};
1203
1204   # Check foreign and self are right in cond
1205   if ( (ref $cond ||'') eq 'HASH') {
1206     for (keys %$cond) {
1207       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
1208         if /\./ && !/^foreign\./;
1209     }
1210   }
1211
1212   my %rels = %{ $self->_relationships };
1213   $rels{$rel} = { class => $f_source_name,
1214                   source => $f_source_name,
1215                   cond  => $cond,
1216                   attrs => $attrs };
1217   $self->_relationships(\%rels);
1218
1219   return $self;
1220
1221 # XXX disabled. doesn't work properly currently. skip in tests.
1222
1223   my $f_source = $self->schema->source($f_source_name);
1224   unless ($f_source) {
1225     $self->ensure_class_loaded($f_source_name);
1226     $f_source = $f_source_name->result_source;
1227     #my $s_class = ref($self->schema);
1228     #$f_source_name =~ m/^${s_class}::(.*)$/;
1229     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
1230     #$f_source = $self->schema->source($f_source_name);
1231   }
1232   return unless $f_source; # Can't test rel without f_source
1233
1234   try { $self->_resolve_join($rel, 'me', {}, []) }
1235   catch {
1236     # If the resolve failed, back out and re-throw the error
1237     delete $rels{$rel};
1238     $self->_relationships(\%rels);
1239     $self->throw_exception("Error creating relationship $rel: $_");
1240   };
1241
1242   1;
1243 }
1244
1245 =head2 relationships
1246
1247 =over 4
1248
1249 =item Arguments: None
1250
1251 =item Return value: List of relationship names
1252
1253 =back
1254
1255   my @relnames = $source->relationships();
1256
1257 Returns all relationship names for this source.
1258
1259 =cut
1260
1261 sub relationships {
1262   return keys %{shift->_relationships};
1263 }
1264
1265 =head2 relationship_info
1266
1267 =over 4
1268
1269 =item Arguments: $relname
1270
1271 =item Return value: Hashref of relation data,
1272
1273 =back
1274
1275 Returns a hash of relationship information for the specified relationship
1276 name. The keys/values are as specified for L</add_relationship>.
1277
1278 =cut
1279
1280 sub relationship_info {
1281   my ($self, $rel) = @_;
1282   return $self->_relationships->{$rel};
1283 }
1284
1285 =head2 has_relationship
1286
1287 =over 4
1288
1289 =item Arguments: $rel
1290
1291 =item Return value: 1/0 (true/false)
1292
1293 =back
1294
1295 Returns true if the source has a relationship of this name, false otherwise.
1296
1297 =cut
1298
1299 sub has_relationship {
1300   my ($self, $rel) = @_;
1301   return exists $self->_relationships->{$rel};
1302 }
1303
1304 =head2 reverse_relationship_info
1305
1306 =over 4
1307
1308 =item Arguments: $relname
1309
1310 =item Return value: Hashref of relationship data
1311
1312 =back
1313
1314 Looks through all the relationships on the source this relationship
1315 points to, looking for one whose condition is the reverse of the
1316 condition on this relationship.
1317
1318 A common use of this is to find the name of the C<belongs_to> relation
1319 opposing a C<has_many> relation. For definition of these look in
1320 L<DBIx::Class::Relationship>.
1321
1322 The returned hashref is keyed by the name of the opposing
1323 relationship, and contains its data in the same manner as
1324 L</relationship_info>.
1325
1326 =cut
1327
1328 sub reverse_relationship_info {
1329   my ($self, $rel) = @_;
1330   my $rel_info = $self->relationship_info($rel);
1331   my $ret = {};
1332
1333   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1334
1335   my @cond = keys(%{$rel_info->{cond}});
1336   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
1337   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
1338
1339   # Get the related result source for this relationship
1340   my $othertable = $self->related_source($rel);
1341
1342   # Get all the relationships for that source that related to this source
1343   # whose foreign column set are our self columns on $rel and whose self
1344   # columns are our foreign columns on $rel.
1345   my @otherrels = $othertable->relationships();
1346   my $otherrelationship;
1347   foreach my $otherrel (@otherrels) {
1348     my $otherrel_info = $othertable->relationship_info($otherrel);
1349
1350     my $back = $othertable->related_source($otherrel);
1351     next unless $back->source_name eq $self->source_name;
1352
1353     my @othertestconds;
1354
1355     if (ref $otherrel_info->{cond} eq 'HASH') {
1356       @othertestconds = ($otherrel_info->{cond});
1357     }
1358     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
1359       @othertestconds = @{$otherrel_info->{cond}};
1360     }
1361     else {
1362       next;
1363     }
1364
1365     foreach my $othercond (@othertestconds) {
1366       my @other_cond = keys(%$othercond);
1367       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
1368       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
1369       next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
1370                !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
1371       $ret->{$otherrel} =  $otherrel_info;
1372     }
1373   }
1374   return $ret;
1375 }
1376
1377 sub compare_relationship_keys {
1378   carp 'compare_relationship_keys is a private method, stop calling it';
1379   my $self = shift;
1380   $self->_compare_relationship_keys (@_);
1381 }
1382
1383 # Returns true if both sets of keynames are the same, false otherwise.
1384 sub _compare_relationship_keys {
1385   my ($self, $keys1, $keys2) = @_;
1386
1387   # Make sure every keys1 is in keys2
1388   my $found;
1389   foreach my $key (@$keys1) {
1390     $found = 0;
1391     foreach my $prim (@$keys2) {
1392       if ($prim eq $key) {
1393         $found = 1;
1394         last;
1395       }
1396     }
1397     last unless $found;
1398   }
1399
1400   # Make sure every key2 is in key1
1401   if ($found) {
1402     foreach my $prim (@$keys2) {
1403       $found = 0;
1404       foreach my $key (@$keys1) {
1405         if ($prim eq $key) {
1406           $found = 1;
1407           last;
1408         }
1409       }
1410       last unless $found;
1411     }
1412   }
1413
1414   return $found;
1415 }
1416
1417 # Returns the {from} structure used to express JOIN conditions
1418 sub _resolve_join {
1419   my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
1420
1421   # we need a supplied one, because we do in-place modifications, no returns
1422   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1423     unless ref $seen eq 'HASH';
1424
1425   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1426     unless ref $jpath eq 'ARRAY';
1427
1428   $jpath = [@$jpath]; # copy
1429
1430   if (not defined $join) {
1431     return ();
1432   }
1433   elsif (ref $join eq 'ARRAY') {
1434     return
1435       map {
1436         $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left);
1437       } @$join;
1438   }
1439   elsif (ref $join eq 'HASH') {
1440
1441     my @ret;
1442     for my $rel (keys %$join) {
1443
1444       my $rel_info = $self->relationship_info($rel)
1445         or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1446
1447       my $force_left = $parent_force_left;
1448       $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
1449
1450       # the actual seen value will be incremented by the recursion
1451       my $as = $self->storage->relname_to_table_alias(
1452         $rel, ($seen->{$rel} && $seen->{$rel} + 1)
1453       );
1454
1455       push @ret, (
1456         $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
1457         $self->related_source($rel)->_resolve_join(
1458           $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left
1459         )
1460       );
1461     }
1462     return @ret;
1463
1464   }
1465   elsif (ref $join) {
1466     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1467   }
1468   else {
1469     my $count = ++$seen->{$join};
1470     my $as = $self->storage->relname_to_table_alias(
1471       $join, ($count > 1 && $count)
1472     );
1473
1474     my $rel_info = $self->relationship_info($join)
1475       or $self->throw_exception("No such relationship $join on " . $self->source_name);
1476
1477     my $rel_src = $self->related_source($join);
1478     return [ { $as => $rel_src->from,
1479                -rsrc => $rel_src,
1480                -join_type => $parent_force_left
1481                   ? 'left'
1482                   : $rel_info->{attrs}{join_type}
1483                 ,
1484                -join_path => [@$jpath, { $join => $as } ],
1485                -is_single => (
1486                   $rel_info->{attrs}{accessor}
1487                     &&
1488                   first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
1489                 ),
1490                -alias => $as,
1491                -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
1492              },
1493              $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
1494   }
1495 }
1496
1497 sub pk_depends_on {
1498   carp 'pk_depends_on is a private method, stop calling it';
1499   my $self = shift;
1500   $self->_pk_depends_on (@_);
1501 }
1502
1503 # Determines whether a relation is dependent on an object from this source
1504 # having already been inserted. Takes the name of the relationship and a
1505 # hashref of columns of the related object.
1506 sub _pk_depends_on {
1507   my ($self, $relname, $rel_data) = @_;
1508
1509   my $relinfo = $self->relationship_info($relname);
1510
1511   # don't assume things if the relationship direction is specified
1512   return $relinfo->{attrs}{is_foreign_key_constraint}
1513     if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1514
1515   my $cond = $relinfo->{cond};
1516   return 0 unless ref($cond) eq 'HASH';
1517
1518   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1519   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1520
1521   # assume anything that references our PK probably is dependent on us
1522   # rather than vice versa, unless the far side is (a) defined or (b)
1523   # auto-increment
1524   my $rel_source = $self->related_source($relname);
1525
1526   foreach my $p ($self->primary_columns) {
1527     if (exists $keyhash->{$p}) {
1528       unless (defined($rel_data->{$keyhash->{$p}})
1529               || $rel_source->column_info($keyhash->{$p})
1530                             ->{is_auto_increment}) {
1531         return 0;
1532       }
1533     }
1534   }
1535
1536   return 1;
1537 }
1538
1539 sub resolve_condition {
1540   carp 'resolve_condition is a private method, stop calling it';
1541   my $self = shift;
1542   $self->_resolve_condition (@_);
1543 }
1544
1545 # Resolves the passed condition to a concrete query fragment. If given an alias,
1546 # returns a join condition; if given an object, inverts that object to produce
1547 # a related conditional from that object.
1548 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1549
1550 sub _resolve_condition {
1551   my ($self, $cond, $as, $for) = @_;
1552   if (ref $cond eq 'HASH') {
1553     my %ret;
1554     foreach my $k (keys %{$cond}) {
1555       my $v = $cond->{$k};
1556       # XXX should probably check these are valid columns
1557       $k =~ s/^foreign\.// ||
1558         $self->throw_exception("Invalid rel cond key ${k}");
1559       $v =~ s/^self\.// ||
1560         $self->throw_exception("Invalid rel cond val ${v}");
1561       if (ref $for) { # Object
1562         #warn "$self $k $for $v";
1563         unless ($for->has_column_loaded($v)) {
1564           if ($for->in_storage) {
1565             $self->throw_exception(sprintf
1566               "Unable to resolve relationship '%s' from object %s: column '%s' not "
1567             . 'loaded from storage (or not passed to new() prior to insert()). You '
1568             . 'probably need to call ->discard_changes to get the server-side defaults '
1569             . 'from the database.',
1570               $as,
1571               $for,
1572               $v,
1573             );
1574           }
1575           return $UNRESOLVABLE_CONDITION;
1576         }
1577         $ret{$k} = $for->get_column($v);
1578         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1579         #warn %ret;
1580       } elsif (!defined $for) { # undef, i.e. "no object"
1581         $ret{$k} = undef;
1582       } elsif (ref $as eq 'HASH') { # reverse hashref
1583         $ret{$v} = $as->{$k};
1584       } elsif (ref $as) { # reverse object
1585         $ret{$v} = $as->get_column($k);
1586       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1587         $ret{$v} = undef;
1588       } else {
1589         $ret{"${as}.${k}"} = "${for}.${v}";
1590       }
1591     }
1592     return \%ret;
1593   } elsif (ref $cond eq 'ARRAY') {
1594     return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
1595   } else {
1596    die("Can't handle condition $cond yet :(");
1597   }
1598 }
1599
1600
1601 # Accepts one or more relationships for the current source and returns an
1602 # array of column names for each of those relationships. Column names are
1603 # prefixed relative to the current source, in accordance with where they appear
1604 # in the supplied relationships.
1605
1606 sub _resolve_prefetch {
1607   my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
1608   $pref_path ||= [];
1609
1610   if (not defined $pre) {
1611     return ();
1612   }
1613   elsif( ref $pre eq 'ARRAY' ) {
1614     return
1615       map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
1616         @$pre;
1617   }
1618   elsif( ref $pre eq 'HASH' ) {
1619     my @ret =
1620     map {
1621       $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
1622       $self->related_source($_)->_resolve_prefetch(
1623                $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
1624     } keys %$pre;
1625     return @ret;
1626   }
1627   elsif( ref $pre ) {
1628     $self->throw_exception(
1629       "don't know how to resolve prefetch reftype ".ref($pre));
1630   }
1631   else {
1632     my $p = $alias_map;
1633     $p = $p->{$_} for (@$pref_path, $pre);
1634
1635     $self->throw_exception (
1636       "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: "
1637       . join (' -> ', @$pref_path, $pre)
1638     ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
1639
1640     my $as = shift @{$p->{-join_aliases}};
1641
1642     my $rel_info = $self->relationship_info( $pre );
1643     $self->throw_exception( $self->source_name . " has no such relationship '$pre'" )
1644       unless $rel_info;
1645     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1646     my $rel_source = $self->related_source($pre);
1647
1648     if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') {
1649       $self->throw_exception(
1650         "Can't prefetch has_many ${pre} (join cond too complex)")
1651         unless ref($rel_info->{cond}) eq 'HASH';
1652       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1653       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1654                          keys %{$collapse}) {
1655         my ($last) = ($fail =~ /([^\.]+)$/);
1656         carp (
1657           "Prefetching multiple has_many rels ${last} and ${pre} "
1658           .(length($as_prefix)
1659             ? "at the same level (${as_prefix}) "
1660             : "at top level "
1661           )
1662           . 'will explode the number of row objects retrievable via ->next or ->all. '
1663           . 'Use at your own risk.'
1664         );
1665       }
1666       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1667       #              values %{$rel_info->{cond}};
1668       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ];
1669         # action at a distance. prepending the '.' allows simpler code
1670         # in ResultSet->_collapse_result
1671       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1672                     keys %{$rel_info->{cond}};
1673       push @$order, map { "${as}.$_" } @key;
1674
1675       if (my $rel_order = $rel_info->{attrs}{order_by}) {
1676         # this is kludgy and incomplete, I am well aware
1677         # but the parent method is going away entirely anyway
1678         # so sod it
1679         my $sql_maker = $self->storage->sql_maker;
1680         my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars;
1681         my $sep = $sql_maker->name_sep;
1682
1683         # install our own quoter, so we can catch unqualified stuff
1684         local $sql_maker->{quote_char} = ["\x00", "\xFF"];
1685
1686         my $quoted_prefix = "\x00${as}\xFF";
1687
1688         for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) {
1689           my @bind;
1690           ($chunk, @bind) = @$chunk if ref $chunk;
1691
1692           $chunk = "${quoted_prefix}${sep}${chunk}"
1693             unless $chunk =~ /\Q$sep/;
1694
1695           $chunk =~ s/\x00/$orig_ql/g;
1696           $chunk =~ s/\xFF/$orig_qr/g;
1697           push @$order, \[$chunk, @bind];
1698         }
1699       }
1700     }
1701
1702     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1703       $rel_source->columns;
1704   }
1705 }
1706
1707 =head2 related_source
1708
1709 =over 4
1710
1711 =item Arguments: $relname
1712
1713 =item Return value: $source
1714
1715 =back
1716
1717 Returns the result source object for the given relationship.
1718
1719 =cut
1720
1721 sub related_source {
1722   my ($self, $rel) = @_;
1723   if( !$self->has_relationship( $rel ) ) {
1724     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1725   }
1726   return $self->schema->source($self->relationship_info($rel)->{source});
1727 }
1728
1729 =head2 related_class
1730
1731 =over 4
1732
1733 =item Arguments: $relname
1734
1735 =item Return value: $classname
1736
1737 =back
1738
1739 Returns the class name for objects in the given relationship.
1740
1741 =cut
1742
1743 sub related_class {
1744   my ($self, $rel) = @_;
1745   if( !$self->has_relationship( $rel ) ) {
1746     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1747   }
1748   return $self->schema->class($self->relationship_info($rel)->{source});
1749 }
1750
1751 =head2 handle
1752
1753 =over 4
1754
1755 =item Arguments: None
1756
1757 =item Return value: $source_handle
1758
1759 =back
1760
1761 Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
1762 for this source. Used as a serializable pointer to this resultsource, as it is not
1763 easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
1764 relationship definitions.
1765
1766 =cut
1767
1768 sub handle {
1769   return DBIx::Class::ResultSourceHandle->new({
1770     source_moniker => $_[0]->source_name,
1771
1772     # so that a detached thaw can be re-frozen
1773     $_[0]->{_detached_thaw}
1774       ? ( _detached_source  => $_[0]          )
1775       : ( schema            => $_[0]->schema  )
1776     ,
1777   });
1778 }
1779
1780 {
1781   my $global_phase_destroy;
1782
1783   END { $global_phase_destroy++ }
1784
1785   sub DESTROY {
1786     return if $global_phase_destroy;
1787
1788 ######
1789 # !!! ACHTUNG !!!!
1790 ######
1791 #
1792 # Under no circumstances shall $_[0] be stored anywhere else (like copied to
1793 # a lexical variable, or shifted, or anything else). Doing so will mess up
1794 # the refcount of this particular result source, and will allow the $schema
1795 # we are trying to save to reattach back to the source we are destroying.
1796 # The relevant code checking refcounts is in ::Schema::DESTROY()
1797
1798     # if we are not a schema instance holder - we don't matter
1799     return if(
1800       ! ref $_[0]->{schema}
1801         or
1802       isweak $_[0]->{schema}
1803     );
1804
1805     # weaken our schema hold forcing the schema to find somewhere else to live
1806     weaken $_[0]->{schema};
1807
1808     # if schema is still there reintroduce ourselves with strong refs back
1809     if ($_[0]->{schema}) {
1810       my $srcregs = $_[0]->{schema}->source_registrations;
1811       for (keys %$srcregs) {
1812         $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
1813       }
1814     }
1815   }
1816 }
1817
1818 sub STORABLE_freeze { nfreeze($_[0]->handle) }
1819
1820 sub STORABLE_thaw {
1821   my ($self, $cloning, $ice) = @_;
1822   %$self = %{ (thaw $ice)->resolve };
1823 }
1824
1825 =head2 throw_exception
1826
1827 See L<DBIx::Class::Schema/"throw_exception">.
1828
1829 =cut
1830
1831 sub throw_exception {
1832   my $self = shift;
1833
1834   $self->{schema}
1835     ? $self->{schema}->throw_exception(@_)
1836     : DBIx::Class::Exception->throw(@_)
1837   ;
1838 }
1839
1840 =head2 source_info
1841
1842 Stores a hashref of per-source metadata.  No specific key names
1843 have yet been standardized, the examples below are purely hypothetical
1844 and don't actually accomplish anything on their own:
1845
1846   __PACKAGE__->source_info({
1847     "_tablespace" => 'fast_disk_array_3',
1848     "_engine" => 'InnoDB',
1849   });
1850
1851 =head2 new
1852
1853   $class->new();
1854
1855   $class->new({attribute_name => value});
1856
1857 Creates a new ResultSource object.  Not normally called directly by end users.
1858
1859 =head2 column_info_from_storage
1860
1861 =over
1862
1863 =item Arguments: 1/0 (default: 0)
1864
1865 =item Return value: 1/0
1866
1867 =back
1868
1869   __PACKAGE__->column_info_from_storage(1);
1870
1871 Enables the on-demand automatic loading of the above column
1872 metadata from storage as necessary.  This is *deprecated*, and
1873 should not be used.  It will be removed before 1.0.
1874
1875
1876 =head1 AUTHORS
1877
1878 Matt S. Trout <mst@shadowcatsystems.co.uk>
1879
1880 =head1 LICENSE
1881
1882 You may distribute this code under the same terms as Perl itself.
1883
1884 =cut
1885
1886 1;