Cleaner error message for using source() without required argument
[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 $rsrc = $self->result_source;
637   my @pks = $rsrc->primary_columns
638     or next;
639
640   $_->{sequence} = $seq
641     for values %{ $rsrc->columns_info (\@pks) };
642 }
643
644
645 =head2 add_unique_constraint
646
647 =over 4
648
649 =item Arguments: $name?, \@colnames
650
651 =item Return value: undefined
652
653 =back
654
655 Declare a unique constraint on this source. Call once for each unique
656 constraint.
657
658   # For UNIQUE (column1, column2)
659   __PACKAGE__->add_unique_constraint(
660     constraint_name => [ qw/column1 column2/ ],
661   );
662
663 Alternatively, you can specify only the columns:
664
665   __PACKAGE__->add_unique_constraint([ qw/column1 column2/ ]);
666
667 This will result in a unique constraint named
668 C<table_column1_column2>, where C<table> is replaced with the table
669 name.
670
671 Unique constraints are used, for example, when you pass the constraint
672 name as the C<key> attribute to L<DBIx::Class::ResultSet/find>. Then
673 only columns in the constraint are searched.
674
675 Throws an error if any of the given column names do not yet exist on
676 the result source.
677
678 =cut
679
680 sub add_unique_constraint {
681   my $self = shift;
682
683   if (@_ > 2) {
684     $self->throw_exception(
685         'add_unique_constraint() does not accept multiple constraints, use '
686       . 'add_unique_constraints() instead'
687     );
688   }
689
690   my $cols = pop @_;
691   if (ref $cols ne 'ARRAY') {
692     $self->throw_exception (
693       'Expecting an arrayref of constraint columns, got ' . ($cols||'NOTHING')
694     );
695   }
696
697   my $name = shift @_;
698
699   $name ||= $self->name_unique_constraint($cols);
700
701   foreach my $col (@$cols) {
702     $self->throw_exception("No such column $col on table " . $self->name)
703       unless $self->has_column($col);
704   }
705
706   my %unique_constraints = $self->unique_constraints;
707   $unique_constraints{$name} = $cols;
708   $self->_unique_constraints(\%unique_constraints);
709 }
710
711 =head2 add_unique_constraints
712
713 =over 4
714
715 =item Arguments: @constraints
716
717 =item Return value: undefined
718
719 =back
720
721 Declare multiple unique constraints on this source.
722
723   __PACKAGE__->add_unique_constraints(
724     constraint_name1 => [ qw/column1 column2/ ],
725     constraint_name2 => [ qw/column2 column3/ ],
726   );
727
728 Alternatively, you can specify only the columns:
729
730   __PACKAGE__->add_unique_constraints(
731     [ qw/column1 column2/ ],
732     [ qw/column3 column4/ ]
733   );
734
735 This will result in unique constraints named C<table_column1_column2> and
736 C<table_column3_column4>, where C<table> is replaced with the table name.
737
738 Throws an error if any of the given column names do not yet exist on
739 the result source.
740
741 See also L</add_unique_constraint>.
742
743 =cut
744
745 sub add_unique_constraints {
746   my $self = shift;
747   my @constraints = @_;
748
749   if ( !(@constraints % 2) && first { ref $_ ne 'ARRAY' } @constraints ) {
750     # with constraint name
751     while (my ($name, $constraint) = splice @constraints, 0, 2) {
752       $self->add_unique_constraint($name => $constraint);
753     }
754   }
755   else {
756     # no constraint name
757     foreach my $constraint (@constraints) {
758       $self->add_unique_constraint($constraint);
759     }
760   }
761 }
762
763 =head2 name_unique_constraint
764
765 =over 4
766
767 =item Arguments: \@colnames
768
769 =item Return value: Constraint name
770
771 =back
772
773   $source->table('mytable');
774   $source->name_unique_constraint(['col1', 'col2']);
775   # returns
776   'mytable_col1_col2'
777
778 Return a name for a unique constraint containing the specified
779 columns. The name is created by joining the table name and each column
780 name, using an underscore character.
781
782 For example, a constraint on a table named C<cd> containing the columns
783 C<artist> and C<title> would result in a constraint name of C<cd_artist_title>.
784
785 This is used by L</add_unique_constraint> if you do not specify the
786 optional constraint name.
787
788 =cut
789
790 sub name_unique_constraint {
791   my ($self, $cols) = @_;
792
793   my $name = $self->name;
794   $name = $$name if (ref $name eq 'SCALAR');
795
796   return join '_', $name, @$cols;
797 }
798
799 =head2 unique_constraints
800
801 =over 4
802
803 =item Arguments: None
804
805 =item Return value: Hash of unique constraint data
806
807 =back
808
809   $source->unique_constraints();
810
811 Read-only accessor which returns a hash of unique constraints on this
812 source.
813
814 The hash is keyed by constraint name, and contains an arrayref of
815 column names as values.
816
817 =cut
818
819 sub unique_constraints {
820   return %{shift->_unique_constraints||{}};
821 }
822
823 =head2 unique_constraint_names
824
825 =over 4
826
827 =item Arguments: None
828
829 =item Return value: Unique constraint names
830
831 =back
832
833   $source->unique_constraint_names();
834
835 Returns the list of unique constraint names defined on this source.
836
837 =cut
838
839 sub unique_constraint_names {
840   my ($self) = @_;
841
842   my %unique_constraints = $self->unique_constraints;
843
844   return keys %unique_constraints;
845 }
846
847 =head2 unique_constraint_columns
848
849 =over 4
850
851 =item Arguments: $constraintname
852
853 =item Return value: List of constraint columns
854
855 =back
856
857   $source->unique_constraint_columns('myconstraint');
858
859 Returns the list of columns that make up the specified unique constraint.
860
861 =cut
862
863 sub unique_constraint_columns {
864   my ($self, $constraint_name) = @_;
865
866   my %unique_constraints = $self->unique_constraints;
867
868   $self->throw_exception(
869     "Unknown unique constraint $constraint_name on '" . $self->name . "'"
870   ) unless exists $unique_constraints{$constraint_name};
871
872   return @{ $unique_constraints{$constraint_name} };
873 }
874
875 =head2 sqlt_deploy_callback
876
877 =over
878
879 =item Arguments: $callback
880
881 =back
882
883   __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
884
885 An accessor to set a callback to be called during deployment of
886 the schema via L<DBIx::Class::Schema/create_ddl_dir> or
887 L<DBIx::Class::Schema/deploy>.
888
889 The callback can be set as either a code reference or the name of a
890 method in the current result class.
891
892 If not set, the L</default_sqlt_deploy_hook> is called.
893
894 Your callback will be passed the $source object representing the
895 ResultSource instance being deployed, and the
896 L<SQL::Translator::Schema::Table> object being created from it. The
897 callback can be used to manipulate the table object or add your own
898 customised indexes. If you need to manipulate a non-table object, use
899 the L<DBIx::Class::Schema/sqlt_deploy_hook>.
900
901 See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
902 Your SQL> for examples.
903
904 This sqlt deployment callback can only be used to manipulate
905 SQL::Translator objects as they get turned into SQL. To execute
906 post-deploy statements which SQL::Translator does not currently
907 handle, override L<DBIx::Class::Schema/deploy> in your Schema class
908 and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
909
910 =head2 default_sqlt_deploy_hook
911
912 =over
913
914 =item Arguments: $source, $sqlt_table
915
916 =item Return value: undefined
917
918 =back
919
920 This is the sensible default for L</sqlt_deploy_callback>.
921
922 If a method named C<sqlt_deploy_hook> exists in your Result class, it
923 will be called and passed the current C<$source> and the
924 C<$sqlt_table> being deployed.
925
926 =cut
927
928 sub default_sqlt_deploy_hook {
929   my $self = shift;
930
931   my $class = $self->result_class;
932
933   if ($class and $class->can('sqlt_deploy_hook')) {
934     $class->sqlt_deploy_hook(@_);
935   }
936 }
937
938 sub _invoke_sqlt_deploy_hook {
939   my $self = shift;
940   if ( my $hook = $self->sqlt_deploy_callback) {
941     $self->$hook(@_);
942   }
943 }
944
945 =head2 resultset
946
947 =over 4
948
949 =item Arguments: None
950
951 =item Return value: $resultset
952
953 =back
954
955 Returns a resultset for the given source. This will initially be created
956 on demand by calling
957
958   $self->resultset_class->new($self, $self->resultset_attributes)
959
960 but is cached from then on unless resultset_class changes.
961
962 =head2 resultset_class
963
964 =over 4
965
966 =item Arguments: $classname
967
968 =item Return value: $classname
969
970 =back
971
972   package My::Schema::ResultSet::Artist;
973   use base 'DBIx::Class::ResultSet';
974   ...
975
976   # In the result class
977   __PACKAGE__->resultset_class('My::Schema::ResultSet::Artist');
978
979   # Or in code
980   $source->resultset_class('My::Schema::ResultSet::Artist');
981
982 Set the class of the resultset. This is useful if you want to create your
983 own resultset methods. Create your own class derived from
984 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
985 this method returns the name of the existing resultset class, if one
986 exists.
987
988 =head2 resultset_attributes
989
990 =over 4
991
992 =item Arguments: \%attrs
993
994 =item Return value: \%attrs
995
996 =back
997
998   # In the result class
999   __PACKAGE__->resultset_attributes({ order_by => [ 'id' ] });
1000
1001   # Or in code
1002   $source->resultset_attributes({ order_by => [ 'id' ] });
1003
1004 Store a collection of resultset attributes, that will be set on every
1005 L<DBIx::Class::ResultSet> produced from this result source. For a full
1006 list see L<DBIx::Class::ResultSet/ATTRIBUTES>.
1007
1008 =cut
1009
1010 sub resultset {
1011   my $self = shift;
1012   $self->throw_exception(
1013     'resultset does not take any arguments. If you want another resultset, '.
1014     'call it on the schema instead.'
1015   ) if scalar @_;
1016
1017   $self->resultset_class->new(
1018     $self,
1019     {
1020       try { %{$self->schema->default_resultset_attributes} },
1021       %{$self->{resultset_attributes}},
1022     },
1023   );
1024 }
1025
1026 =head2 source_name
1027
1028 =over 4
1029
1030 =item Arguments: $source_name
1031
1032 =item Result value: $source_name
1033
1034 =back
1035
1036 Set an alternate name for the result source when it is loaded into a schema.
1037 This is useful if you want to refer to a result source by a name other than
1038 its class name.
1039
1040   package ArchivedBooks;
1041   use base qw/DBIx::Class/;
1042   __PACKAGE__->table('books_archive');
1043   __PACKAGE__->source_name('Books');
1044
1045   # from your schema...
1046   $schema->resultset('Books')->find(1);
1047
1048 =head2 from
1049
1050 =over 4
1051
1052 =item Arguments: None
1053
1054 =item Return value: FROM clause
1055
1056 =back
1057
1058   my $from_clause = $source->from();
1059
1060 Returns an expression of the source to be supplied to storage to specify
1061 retrieval from this source. In the case of a database, the required FROM
1062 clause contents.
1063
1064 =head2 schema
1065
1066 =over 4
1067
1068 =item Arguments: $schema
1069
1070 =item Return value: A schema object
1071
1072 =back
1073
1074   my $schema = $source->schema();
1075
1076 Sets and/or returns the L<DBIx::Class::Schema> object to which this
1077 result source instance has been attached to.
1078
1079 =cut
1080
1081 sub schema {
1082   if (@_ > 1) {
1083     $_[0]->{schema} = $_[1];
1084   }
1085   else {
1086     $_[0]->{schema} || do {
1087       my $name = $_[0]->{source_name} || '_unnamed_';
1088       my $err = 'Unable to perform storage-dependent operations with a detached result source '
1089               . "(source '$name' is not associated with a schema).";
1090
1091       $err .= ' You need to use $schema->thaw() or manually set'
1092             . ' $DBIx::Class::ResultSourceHandle::thaw_schema while thawing.'
1093         if $_[0]->{_detached_thaw};
1094
1095       DBIx::Class::Exception->throw($err);
1096     };
1097   }
1098 }
1099
1100 =head2 storage
1101
1102 =over 4
1103
1104 =item Arguments: None
1105
1106 =item Return value: A Storage object
1107
1108 =back
1109
1110   $source->storage->debug(1);
1111
1112 Returns the storage handle for the current schema.
1113
1114 See also: L<DBIx::Class::Storage>
1115
1116 =cut
1117
1118 sub storage { shift->schema->storage; }
1119
1120 =head2 add_relationship
1121
1122 =over 4
1123
1124 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
1125
1126 =item Return value: 1/true if it succeeded
1127
1128 =back
1129
1130   $source->add_relationship('relname', 'related_source', $cond, $attrs);
1131
1132 L<DBIx::Class::Relationship> describes a series of methods which
1133 create pre-defined useful types of relationships. Look there first
1134 before using this method directly.
1135
1136 The relationship name can be arbitrary, but must be unique for each
1137 relationship attached to this result source. 'related_source' should
1138 be the name with which the related result source was registered with
1139 the current schema. For example:
1140
1141   $schema->source('Book')->add_relationship('reviews', 'Review', {
1142     'foreign.book_id' => 'self.id',
1143   });
1144
1145 The condition C<$cond> needs to be an L<SQL::Abstract>-style
1146 representation of the join between the tables. For example, if you're
1147 creating a relation from Author to Book,
1148
1149   { 'foreign.author_id' => 'self.id' }
1150
1151 will result in the JOIN clause
1152
1153   author me JOIN book foreign ON foreign.author_id = me.id
1154
1155 You can specify as many foreign => self mappings as necessary.
1156
1157 Valid attributes are as follows:
1158
1159 =over 4
1160
1161 =item join_type
1162
1163 Explicitly specifies the type of join to use in the relationship. Any
1164 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
1165 the SQL command immediately before C<JOIN>.
1166
1167 =item proxy
1168
1169 An arrayref containing a list of accessors in the foreign class to proxy in
1170 the main class. If, for example, you do the following:
1171
1172   CD->might_have(liner_notes => 'LinerNotes', undef, {
1173     proxy => [ qw/notes/ ],
1174   });
1175
1176 Then, assuming LinerNotes has an accessor named notes, you can do:
1177
1178   my $cd = CD->find(1);
1179   # set notes -- LinerNotes object is created if it doesn't exist
1180   $cd->notes('Notes go here');
1181
1182 =item accessor
1183
1184 Specifies the type of accessor that should be created for the
1185 relationship. Valid values are C<single> (for when there is only a single
1186 related object), C<multi> (when there can be many), and C<filter> (for
1187 when there is a single related object, but you also want the relationship
1188 accessor to double as a column accessor). For C<multi> accessors, an
1189 add_to_* method is also created, which calls C<create_related> for the
1190 relationship.
1191
1192 =back
1193
1194 Throws an exception if the condition is improperly supplied, or cannot
1195 be resolved.
1196
1197 =cut
1198
1199 sub add_relationship {
1200   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
1201   $self->throw_exception("Can't create relationship without join condition")
1202     unless $cond;
1203   $attrs ||= {};
1204
1205   # Check foreign and self are right in cond
1206   if ( (ref $cond ||'') eq 'HASH') {
1207     for (keys %$cond) {
1208       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
1209         if /\./ && !/^foreign\./;
1210     }
1211   }
1212
1213   my %rels = %{ $self->_relationships };
1214   $rels{$rel} = { class => $f_source_name,
1215                   source => $f_source_name,
1216                   cond  => $cond,
1217                   attrs => $attrs };
1218   $self->_relationships(\%rels);
1219
1220   return $self;
1221
1222 # XXX disabled. doesn't work properly currently. skip in tests.
1223
1224   my $f_source = $self->schema->source($f_source_name);
1225   unless ($f_source) {
1226     $self->ensure_class_loaded($f_source_name);
1227     $f_source = $f_source_name->result_source;
1228     #my $s_class = ref($self->schema);
1229     #$f_source_name =~ m/^${s_class}::(.*)$/;
1230     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
1231     #$f_source = $self->schema->source($f_source_name);
1232   }
1233   return unless $f_source; # Can't test rel without f_source
1234
1235   try { $self->_resolve_join($rel, 'me', {}, []) }
1236   catch {
1237     # If the resolve failed, back out and re-throw the error
1238     delete $rels{$rel};
1239     $self->_relationships(\%rels);
1240     $self->throw_exception("Error creating relationship $rel: $_");
1241   };
1242
1243   1;
1244 }
1245
1246 =head2 relationships
1247
1248 =over 4
1249
1250 =item Arguments: None
1251
1252 =item Return value: List of relationship names
1253
1254 =back
1255
1256   my @relnames = $source->relationships();
1257
1258 Returns all relationship names for this source.
1259
1260 =cut
1261
1262 sub relationships {
1263   return keys %{shift->_relationships};
1264 }
1265
1266 =head2 relationship_info
1267
1268 =over 4
1269
1270 =item Arguments: $relname
1271
1272 =item Return value: Hashref of relation data,
1273
1274 =back
1275
1276 Returns a hash of relationship information for the specified relationship
1277 name. The keys/values are as specified for L</add_relationship>.
1278
1279 =cut
1280
1281 sub relationship_info {
1282   my ($self, $rel) = @_;
1283   return $self->_relationships->{$rel};
1284 }
1285
1286 =head2 has_relationship
1287
1288 =over 4
1289
1290 =item Arguments: $rel
1291
1292 =item Return value: 1/0 (true/false)
1293
1294 =back
1295
1296 Returns true if the source has a relationship of this name, false otherwise.
1297
1298 =cut
1299
1300 sub has_relationship {
1301   my ($self, $rel) = @_;
1302   return exists $self->_relationships->{$rel};
1303 }
1304
1305 =head2 reverse_relationship_info
1306
1307 =over 4
1308
1309 =item Arguments: $relname
1310
1311 =item Return value: Hashref of relationship data
1312
1313 =back
1314
1315 Looks through all the relationships on the source this relationship
1316 points to, looking for one whose condition is the reverse of the
1317 condition on this relationship.
1318
1319 A common use of this is to find the name of the C<belongs_to> relation
1320 opposing a C<has_many> relation. For definition of these look in
1321 L<DBIx::Class::Relationship>.
1322
1323 The returned hashref is keyed by the name of the opposing
1324 relationship, and contains its data in the same manner as
1325 L</relationship_info>.
1326
1327 =cut
1328
1329 sub reverse_relationship_info {
1330   my ($self, $rel) = @_;
1331   my $rel_info = $self->relationship_info($rel);
1332   my $ret = {};
1333
1334   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1335
1336   my @cond = keys(%{$rel_info->{cond}});
1337   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
1338   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
1339
1340   # Get the related result source for this relationship
1341   my $othertable = $self->related_source($rel);
1342
1343   # Get all the relationships for that source that related to this source
1344   # whose foreign column set are our self columns on $rel and whose self
1345   # columns are our foreign columns on $rel.
1346   my @otherrels = $othertable->relationships();
1347   my $otherrelationship;
1348   foreach my $otherrel (@otherrels) {
1349     my $otherrel_info = $othertable->relationship_info($otherrel);
1350
1351     my $back = $othertable->related_source($otherrel);
1352     next unless $back->source_name eq $self->source_name;
1353
1354     my @othertestconds;
1355
1356     if (ref $otherrel_info->{cond} eq 'HASH') {
1357       @othertestconds = ($otherrel_info->{cond});
1358     }
1359     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
1360       @othertestconds = @{$otherrel_info->{cond}};
1361     }
1362     else {
1363       next;
1364     }
1365
1366     foreach my $othercond (@othertestconds) {
1367       my @other_cond = keys(%$othercond);
1368       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
1369       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
1370       next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
1371                !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
1372       $ret->{$otherrel} =  $otherrel_info;
1373     }
1374   }
1375   return $ret;
1376 }
1377
1378 sub compare_relationship_keys {
1379   carp 'compare_relationship_keys is a private method, stop calling it';
1380   my $self = shift;
1381   $self->_compare_relationship_keys (@_);
1382 }
1383
1384 # Returns true if both sets of keynames are the same, false otherwise.
1385 sub _compare_relationship_keys {
1386   my ($self, $keys1, $keys2) = @_;
1387
1388   # Make sure every keys1 is in keys2
1389   my $found;
1390   foreach my $key (@$keys1) {
1391     $found = 0;
1392     foreach my $prim (@$keys2) {
1393       if ($prim eq $key) {
1394         $found = 1;
1395         last;
1396       }
1397     }
1398     last unless $found;
1399   }
1400
1401   # Make sure every key2 is in key1
1402   if ($found) {
1403     foreach my $prim (@$keys2) {
1404       $found = 0;
1405       foreach my $key (@$keys1) {
1406         if ($prim eq $key) {
1407           $found = 1;
1408           last;
1409         }
1410       }
1411       last unless $found;
1412     }
1413   }
1414
1415   return $found;
1416 }
1417
1418 # Returns the {from} structure used to express JOIN conditions
1419 sub _resolve_join {
1420   my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
1421
1422   # we need a supplied one, because we do in-place modifications, no returns
1423   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1424     unless ref $seen eq 'HASH';
1425
1426   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1427     unless ref $jpath eq 'ARRAY';
1428
1429   $jpath = [@$jpath]; # copy
1430
1431   if (not defined $join) {
1432     return ();
1433   }
1434   elsif (ref $join eq 'ARRAY') {
1435     return
1436       map {
1437         $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left);
1438       } @$join;
1439   }
1440   elsif (ref $join eq 'HASH') {
1441
1442     my @ret;
1443     for my $rel (keys %$join) {
1444
1445       my $rel_info = $self->relationship_info($rel)
1446         or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1447
1448       my $force_left = $parent_force_left;
1449       $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
1450
1451       # the actual seen value will be incremented by the recursion
1452       my $as = $self->storage->relname_to_table_alias(
1453         $rel, ($seen->{$rel} && $seen->{$rel} + 1)
1454       );
1455
1456       push @ret, (
1457         $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
1458         $self->related_source($rel)->_resolve_join(
1459           $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left
1460         )
1461       );
1462     }
1463     return @ret;
1464
1465   }
1466   elsif (ref $join) {
1467     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1468   }
1469   else {
1470     my $count = ++$seen->{$join};
1471     my $as = $self->storage->relname_to_table_alias(
1472       $join, ($count > 1 && $count)
1473     );
1474
1475     my $rel_info = $self->relationship_info($join)
1476       or $self->throw_exception("No such relationship $join on " . $self->source_name);
1477
1478     my $rel_src = $self->related_source($join);
1479     return [ { $as => $rel_src->from,
1480                -rsrc => $rel_src,
1481                -join_type => $parent_force_left
1482                   ? 'left'
1483                   : $rel_info->{attrs}{join_type}
1484                 ,
1485                -join_path => [@$jpath, { $join => $as } ],
1486                -is_single => (
1487                   $rel_info->{attrs}{accessor}
1488                     &&
1489                   first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
1490                 ),
1491                -alias => $as,
1492                -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
1493              },
1494              $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
1495   }
1496 }
1497
1498 sub pk_depends_on {
1499   carp 'pk_depends_on is a private method, stop calling it';
1500   my $self = shift;
1501   $self->_pk_depends_on (@_);
1502 }
1503
1504 # Determines whether a relation is dependent on an object from this source
1505 # having already been inserted. Takes the name of the relationship and a
1506 # hashref of columns of the related object.
1507 sub _pk_depends_on {
1508   my ($self, $relname, $rel_data) = @_;
1509
1510   my $relinfo = $self->relationship_info($relname);
1511
1512   # don't assume things if the relationship direction is specified
1513   return $relinfo->{attrs}{is_foreign_key_constraint}
1514     if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1515
1516   my $cond = $relinfo->{cond};
1517   return 0 unless ref($cond) eq 'HASH';
1518
1519   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1520   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1521
1522   # assume anything that references our PK probably is dependent on us
1523   # rather than vice versa, unless the far side is (a) defined or (b)
1524   # auto-increment
1525   my $rel_source = $self->related_source($relname);
1526
1527   foreach my $p ($self->primary_columns) {
1528     if (exists $keyhash->{$p}) {
1529       unless (defined($rel_data->{$keyhash->{$p}})
1530               || $rel_source->column_info($keyhash->{$p})
1531                             ->{is_auto_increment}) {
1532         return 0;
1533       }
1534     }
1535   }
1536
1537   return 1;
1538 }
1539
1540 sub resolve_condition {
1541   carp 'resolve_condition is a private method, stop calling it';
1542   my $self = shift;
1543   $self->_resolve_condition (@_);
1544 }
1545
1546 # Resolves the passed condition to a concrete query fragment. If given an alias,
1547 # returns a join condition; if given an object, inverts that object to produce
1548 # a related conditional from that object.
1549 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1550
1551 sub _resolve_condition {
1552   my ($self, $cond, $as, $for) = @_;
1553   if (ref $cond eq 'HASH') {
1554     my %ret;
1555     foreach my $k (keys %{$cond}) {
1556       my $v = $cond->{$k};
1557       # XXX should probably check these are valid columns
1558       $k =~ s/^foreign\.// ||
1559         $self->throw_exception("Invalid rel cond key ${k}");
1560       $v =~ s/^self\.// ||
1561         $self->throw_exception("Invalid rel cond val ${v}");
1562       if (ref $for) { # Object
1563         #warn "$self $k $for $v";
1564         unless ($for->has_column_loaded($v)) {
1565           if ($for->in_storage) {
1566             $self->throw_exception(sprintf
1567               "Unable to resolve relationship '%s' from object %s: column '%s' not "
1568             . 'loaded from storage (or not passed to new() prior to insert()). You '
1569             . 'probably need to call ->discard_changes to get the server-side defaults '
1570             . 'from the database.',
1571               $as,
1572               $for,
1573               $v,
1574             );
1575           }
1576           return $UNRESOLVABLE_CONDITION;
1577         }
1578         $ret{$k} = $for->get_column($v);
1579         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1580         #warn %ret;
1581       } elsif (!defined $for) { # undef, i.e. "no object"
1582         $ret{$k} = undef;
1583       } elsif (ref $as eq 'HASH') { # reverse hashref
1584         $ret{$v} = $as->{$k};
1585       } elsif (ref $as) { # reverse object
1586         $ret{$v} = $as->get_column($k);
1587       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1588         $ret{$v} = undef;
1589       } else {
1590         $ret{"${as}.${k}"} = "${for}.${v}";
1591       }
1592     }
1593     return \%ret;
1594   } elsif (ref $cond eq 'ARRAY') {
1595     return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
1596   } else {
1597    die("Can't handle condition $cond yet :(");
1598   }
1599 }
1600
1601
1602 # Accepts one or more relationships for the current source and returns an
1603 # array of column names for each of those relationships. Column names are
1604 # prefixed relative to the current source, in accordance with where they appear
1605 # in the supplied relationships.
1606
1607 sub _resolve_prefetch {
1608   my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
1609   $pref_path ||= [];
1610
1611   if (not defined $pre) {
1612     return ();
1613   }
1614   elsif( ref $pre eq 'ARRAY' ) {
1615     return
1616       map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
1617         @$pre;
1618   }
1619   elsif( ref $pre eq 'HASH' ) {
1620     my @ret =
1621     map {
1622       $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
1623       $self->related_source($_)->_resolve_prefetch(
1624                $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
1625     } keys %$pre;
1626     return @ret;
1627   }
1628   elsif( ref $pre ) {
1629     $self->throw_exception(
1630       "don't know how to resolve prefetch reftype ".ref($pre));
1631   }
1632   else {
1633     my $p = $alias_map;
1634     $p = $p->{$_} for (@$pref_path, $pre);
1635
1636     $self->throw_exception (
1637       "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: "
1638       . join (' -> ', @$pref_path, $pre)
1639     ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
1640
1641     my $as = shift @{$p->{-join_aliases}};
1642
1643     my $rel_info = $self->relationship_info( $pre );
1644     $self->throw_exception( $self->source_name . " has no such relationship '$pre'" )
1645       unless $rel_info;
1646     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1647     my $rel_source = $self->related_source($pre);
1648
1649     if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') {
1650       $self->throw_exception(
1651         "Can't prefetch has_many ${pre} (join cond too complex)")
1652         unless ref($rel_info->{cond}) eq 'HASH';
1653       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1654       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1655                          keys %{$collapse}) {
1656         my ($last) = ($fail =~ /([^\.]+)$/);
1657         carp (
1658           "Prefetching multiple has_many rels ${last} and ${pre} "
1659           .(length($as_prefix)
1660             ? "at the same level (${as_prefix}) "
1661             : "at top level "
1662           )
1663           . 'will explode the number of row objects retrievable via ->next or ->all. '
1664           . 'Use at your own risk.'
1665         );
1666       }
1667       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1668       #              values %{$rel_info->{cond}};
1669       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ];
1670         # action at a distance. prepending the '.' allows simpler code
1671         # in ResultSet->_collapse_result
1672       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1673                     keys %{$rel_info->{cond}};
1674       push @$order, map { "${as}.$_" } @key;
1675
1676       if (my $rel_order = $rel_info->{attrs}{order_by}) {
1677         # this is kludgy and incomplete, I am well aware
1678         # but the parent method is going away entirely anyway
1679         # so sod it
1680         my $sql_maker = $self->storage->sql_maker;
1681         my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars;
1682         my $sep = $sql_maker->name_sep;
1683
1684         # install our own quoter, so we can catch unqualified stuff
1685         local $sql_maker->{quote_char} = ["\x00", "\xFF"];
1686
1687         my $quoted_prefix = "\x00${as}\xFF";
1688
1689         for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) {
1690           my @bind;
1691           ($chunk, @bind) = @$chunk if ref $chunk;
1692
1693           $chunk = "${quoted_prefix}${sep}${chunk}"
1694             unless $chunk =~ /\Q$sep/;
1695
1696           $chunk =~ s/\x00/$orig_ql/g;
1697           $chunk =~ s/\xFF/$orig_qr/g;
1698           push @$order, \[$chunk, @bind];
1699         }
1700       }
1701     }
1702
1703     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1704       $rel_source->columns;
1705   }
1706 }
1707
1708 =head2 related_source
1709
1710 =over 4
1711
1712 =item Arguments: $relname
1713
1714 =item Return value: $source
1715
1716 =back
1717
1718 Returns the result source object for the given relationship.
1719
1720 =cut
1721
1722 sub related_source {
1723   my ($self, $rel) = @_;
1724   if( !$self->has_relationship( $rel ) ) {
1725     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1726   }
1727   return $self->schema->source($self->relationship_info($rel)->{source});
1728 }
1729
1730 =head2 related_class
1731
1732 =over 4
1733
1734 =item Arguments: $relname
1735
1736 =item Return value: $classname
1737
1738 =back
1739
1740 Returns the class name for objects in the given relationship.
1741
1742 =cut
1743
1744 sub related_class {
1745   my ($self, $rel) = @_;
1746   if( !$self->has_relationship( $rel ) ) {
1747     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1748   }
1749   return $self->schema->class($self->relationship_info($rel)->{source});
1750 }
1751
1752 =head2 handle
1753
1754 =over 4
1755
1756 =item Arguments: None
1757
1758 =item Return value: $source_handle
1759
1760 =back
1761
1762 Obtain a new L<result source handle instance|DBIx::Class::ResultSourceHandle>
1763 for this source. Used as a serializable pointer to this resultsource, as it is not
1764 easy (nor advisable) to serialize CODErefs which may very well be present in e.g.
1765 relationship definitions.
1766
1767 =cut
1768
1769 sub handle {
1770   return DBIx::Class::ResultSourceHandle->new({
1771     source_moniker => $_[0]->source_name,
1772
1773     # so that a detached thaw can be re-frozen
1774     $_[0]->{_detached_thaw}
1775       ? ( _detached_source  => $_[0]          )
1776       : ( schema            => $_[0]->schema  )
1777     ,
1778   });
1779 }
1780
1781 {
1782   my $global_phase_destroy;
1783
1784   END { $global_phase_destroy++ }
1785
1786   sub DESTROY {
1787     return if $global_phase_destroy;
1788
1789 ######
1790 # !!! ACHTUNG !!!!
1791 ######
1792 #
1793 # Under no circumstances shall $_[0] be stored anywhere else (like copied to
1794 # a lexical variable, or shifted, or anything else). Doing so will mess up
1795 # the refcount of this particular result source, and will allow the $schema
1796 # we are trying to save to reattach back to the source we are destroying.
1797 # The relevant code checking refcounts is in ::Schema::DESTROY()
1798
1799     # if we are not a schema instance holder - we don't matter
1800     return if(
1801       ! ref $_[0]->{schema}
1802         or
1803       isweak $_[0]->{schema}
1804     );
1805
1806     # weaken our schema hold forcing the schema to find somewhere else to live
1807     weaken $_[0]->{schema};
1808
1809     # if schema is still there reintroduce ourselves with strong refs back
1810     if ($_[0]->{schema}) {
1811       my $srcregs = $_[0]->{schema}->source_registrations;
1812       for (keys %$srcregs) {
1813         $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0];
1814       }
1815     }
1816   }
1817 }
1818
1819 sub STORABLE_freeze { nfreeze($_[0]->handle) }
1820
1821 sub STORABLE_thaw {
1822   my ($self, $cloning, $ice) = @_;
1823   %$self = %{ (thaw $ice)->resolve };
1824 }
1825
1826 =head2 throw_exception
1827
1828 See L<DBIx::Class::Schema/"throw_exception">.
1829
1830 =cut
1831
1832 sub throw_exception {
1833   my $self = shift;
1834
1835   $self->{schema}
1836     ? $self->{schema}->throw_exception(@_)
1837     : DBIx::Class::Exception->throw(@_)
1838   ;
1839 }
1840
1841 =head2 source_info
1842
1843 Stores a hashref of per-source metadata.  No specific key names
1844 have yet been standardized, the examples below are purely hypothetical
1845 and don't actually accomplish anything on their own:
1846
1847   __PACKAGE__->source_info({
1848     "_tablespace" => 'fast_disk_array_3',
1849     "_engine" => 'InnoDB',
1850   });
1851
1852 =head2 new
1853
1854   $class->new();
1855
1856   $class->new({attribute_name => value});
1857
1858 Creates a new ResultSource object.  Not normally called directly by end users.
1859
1860 =head2 column_info_from_storage
1861
1862 =over
1863
1864 =item Arguments: 1/0 (default: 0)
1865
1866 =item Return value: 1/0
1867
1868 =back
1869
1870   __PACKAGE__->column_info_from_storage(1);
1871
1872 Enables the on-demand automatic loading of the above column
1873 metadata from storage as necessary.  This is *deprecated*, and
1874 should not be used.  It will be removed before 1.0.
1875
1876
1877 =head1 AUTHORS
1878
1879 Matt S. Trout <mst@shadowcatsystems.co.uk>
1880
1881 =head1 LICENSE
1882
1883 You may distribute this code under the same terms as Perl itself.
1884
1885 =cut
1886
1887 1;