Unqualify imported functions
[dbsrgits/DBIx-Class-Historic.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 namespace::clean;
14
15 use base qw/DBIx::Class/;
16
17 __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns
18   _columns _primaries _unique_constraints name resultset_attributes
19   schema from _relationships column_info_from_storage source_info
20   source_name sqlt_deploy_callback/);
21
22 __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
23   result_class/);
24
25 =head1 NAME
26
27 DBIx::Class::ResultSource - Result source object
28
29 =head1 SYNOPSIS
30
31   # Create a table based result source, in a result class.
32
33   package MyDB::Schema::Result::Artist;
34   use base qw/DBIx::Class::Core/;
35
36   __PACKAGE__->table('artist');
37   __PACKAGE__->add_columns(qw/ artistid name /);
38   __PACKAGE__->set_primary_key('artistid');
39   __PACKAGE__->has_many(cds => 'MyDB::Schema::Result::CD');
40
41   1;
42
43   # Create a query (view) based result source, in a result class
44   package MyDB::Schema::Result::Year2000CDs;
45   use base qw/DBIx::Class::Core/;
46
47   __PACKAGE__->load_components('InflateColumn::DateTime');
48   __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
49
50   __PACKAGE__->table('year2000cds');
51   __PACKAGE__->result_source_instance->is_virtual(1);
52   __PACKAGE__->result_source_instance->view_definition(
53       "SELECT cdid, artist, title FROM cd WHERE year ='2000'"
54       );
55
56
57 =head1 DESCRIPTION
58
59 A ResultSource is an object that represents a source of data for querying.
60
61 This class is a base class for various specialised types of result
62 sources, for example L<DBIx::Class::ResultSource::Table>. Table is the
63 default result source type, so one is created for you when defining a
64 result class as described in the synopsis above.
65
66 More specifically, the L<DBIx::Class::Core> base class pulls in the
67 L<DBIx::Class::ResultSourceProxy::Table> component, which defines
68 the L<table|DBIx::Class::ResultSourceProxy::Table/table> method.
69 When called, C<table> creates and stores an instance of
70 L<DBIx::Class::ResultSoure::Table>. Luckily, to use tables as result
71 sources, you don't need to remember any of this.
72
73 Result sources representing select queries, or views, can also be
74 created, see L<DBIx::Class::ResultSource::View> for full details.
75
76 =head2 Finding result source objects
77
78 As mentioned above, a result source instance is created and stored for
79 you when you define a L<Result Class|DBIx::Class::Manual::Glossary/Result Class>.
80
81 You can retrieve the result source at runtime in the following ways:
82
83 =over
84
85 =item From a Schema object:
86
87    $schema->source($source_name);
88
89 =item From a Row object:
90
91    $row->result_source;
92
93 =item From a ResultSet object:
94
95    $rs->result_source;
96
97 =back
98
99 =head1 METHODS
100
101 =pod
102
103 =cut
104
105 sub new {
106   my ($class, $attrs) = @_;
107   $class = ref $class if ref $class;
108
109   my $new = bless { %{$attrs || {}} }, $class;
110   $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
111   $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
112   $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
113   $new->{_columns} = { %{$new->{_columns}||{}} };
114   $new->{_relationships} = { %{$new->{_relationships}||{}} };
115   $new->{name} ||= "!!NAME NOT SET!!";
116   $new->{_columns_info_loaded} ||= 0;
117   $new->{sqlt_deploy_callback} ||= "default_sqlt_deploy_hook";
118   return $new;
119 }
120
121 =pod
122
123 =head2 add_columns
124
125 =over
126
127 =item Arguments: @columns
128
129 =item Return value: The ResultSource object
130
131 =back
132
133   $source->add_columns(qw/col1 col2 col3/);
134
135   $source->add_columns('col1' => \%col1_info, 'col2' => \%col2_info, ...);
136
137 Adds columns to the result source. If supplied colname => hashref
138 pairs, uses the hashref as the L</column_info> for that column. Repeated
139 calls of this method will add more columns, not replace them.
140
141 The column names given will be created as accessor methods on your
142 L<DBIx::Class::Row> objects. You can change the name of the accessor
143 by supplying an L</accessor> in the column_info hash.
144
145 If a column name beginning with a plus sign ('+col1') is provided, the
146 attributes provided will be merged with any existing attributes for the
147 column, with the new attributes taking precedence in the case that an
148 attribute already exists. Using this without a hashref
149 (C<< $source->add_columns(qw/+col1 +col2/) >>) is legal, but useless --
150 it does the same thing it would do without the plus.
151
152 The contents of the column_info are not set in stone. The following
153 keys are currently recognised/used by DBIx::Class:
154
155 =over 4
156
157 =item accessor
158
159    { accessor => '_name' }
160
161    # example use, replace standard accessor with one of your own:
162    sub name {
163        my ($self, $value) = @_;
164
165        die "Name cannot contain digits!" if($value =~ /\d/);
166        $self->_name($value);
167
168        return $self->_name();
169    }
170
171 Use this to set the name of the accessor method for this column. If unset,
172 the name of the column will be used.
173
174 =item data_type
175
176    { data_type => 'integer' }
177
178 This contains the column type. It is automatically filled if you use the
179 L<SQL::Translator::Producer::DBIx::Class::File> producer, or the
180 L<DBIx::Class::Schema::Loader> module.
181
182 Currently there is no standard set of values for the data_type. Use
183 whatever your database supports.
184
185 =item size
186
187    { size => 20 }
188
189 The length of your column, if it is a column type that can have a size
190 restriction. This is currently only used to create tables from your
191 schema, see L<DBIx::Class::Schema/deploy>.
192
193 =item is_nullable
194
195    { is_nullable => 1 }
196
197 Set this to a true value for a columns that is allowed to contain NULL
198 values, default is false. This is currently only used to create tables
199 from your schema, see L<DBIx::Class::Schema/deploy>.
200
201 =item is_auto_increment
202
203    { is_auto_increment => 1 }
204
205 Set this to a true value for a column whose value is somehow
206 automatically set, defaults to false. This is used to determine which
207 columns to empty when cloning objects using
208 L<DBIx::Class::Row/copy>. It is also used by
209 L<DBIx::Class::Schema/deploy>.
210
211 =item is_numeric
212
213    { is_numeric => 1 }
214
215 Set this to a true or false value (not C<undef>) to explicitly specify
216 if this column contains numeric data. This controls how set_column
217 decides whether to consider a column dirty after an update: if
218 C<is_numeric> is true a numeric comparison C<< != >> will take place
219 instead of the usual C<eq>
220
221 If not specified the storage class will attempt to figure this out on
222 first access to the column, based on the column C<data_type>. The
223 result will be cached in this attribute.
224
225 =item is_foreign_key
226
227    { is_foreign_key => 1 }
228
229 Set this to a true value for a column that contains a key from a
230 foreign table, defaults to false. This is currently only used to
231 create tables from your schema, see L<DBIx::Class::Schema/deploy>.
232
233 =item default_value
234
235    { default_value => \'now()' }
236
237 Set this to the default value which will be inserted into a column by
238 the database. Can contain either a value or a function (use a
239 reference to a scalar e.g. C<\'now()'> if you want a function). This
240 is currently only used to create tables from your schema, see
241 L<DBIx::Class::Schema/deploy>.
242
243 See the note on L<DBIx::Class::Row/new> for more information about possible
244 issues related to db-side default values.
245
246 =item sequence
247
248    { sequence => 'my_table_seq' }
249
250 Set this on a primary key column to the name of the sequence used to
251 generate a new key value. If not specified, L<DBIx::Class::PK::Auto>
252 will attempt to retrieve the name of the sequence from the database
253 automatically.
254
255 =item auto_nextval
256
257 Set this to a true value for a column whose value is retrieved automatically
258 from a sequence or function (if supported by your Storage driver.) For a
259 sequence, if you do not use a trigger to get the nextval, you have to set the
260 L</sequence> value as well.
261
262 Also set this for MSSQL columns with the 'uniqueidentifier'
263 L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to
264 automatically generate using C<NEWID()>, unless they are a primary key in which
265 case this will be done anyway.
266
267 =item extra
268
269 This is used by L<DBIx::Class::Schema/deploy> and L<SQL::Translator>
270 to add extra non-generic data to the column. For example: C<< extra
271 => { unsigned => 1} >> is used by the MySQL producer to set an integer
272 column to unsigned. For more details, see
273 L<SQL::Translator::Producer::MySQL>.
274
275 =back
276
277 =head2 add_column
278
279 =over
280
281 =item Arguments: $colname, \%columninfo?
282
283 =item Return value: 1/0 (true/false)
284
285 =back
286
287   $source->add_column('col' => \%info);
288
289 Add a single column and optional column info. Uses the same column
290 info keys as L</add_columns>.
291
292 =cut
293
294 sub add_columns {
295   my ($self, @cols) = @_;
296   $self->_ordered_columns(\@cols) unless $self->_ordered_columns;
297
298   my @added;
299   my $columns = $self->_columns;
300   while (my $col = shift @cols) {
301     my $column_info = {};
302     if ($col =~ s/^\+//) {
303       $column_info = $self->column_info($col);
304     }
305
306     # If next entry is { ... } use that for the column info, if not
307     # use an empty hashref
308     if (ref $cols[0]) {
309       my $new_info = shift(@cols);
310       %$column_info = (%$column_info, %$new_info);
311     }
312     push(@added, $col) unless exists $columns->{$col};
313     $columns->{$col} = $column_info;
314   }
315   push @{ $self->_ordered_columns }, @added;
316   return $self;
317 }
318
319 sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB
320
321 =head2 has_column
322
323 =over
324
325 =item Arguments: $colname
326
327 =item Return value: 1/0 (true/false)
328
329 =back
330
331   if ($source->has_column($colname)) { ... }
332
333 Returns true if the source has a column of this name, false otherwise.
334
335 =cut
336
337 sub has_column {
338   my ($self, $column) = @_;
339   return exists $self->_columns->{$column};
340 }
341
342 =head2 column_info
343
344 =over
345
346 =item Arguments: $colname
347
348 =item Return value: Hashref of info
349
350 =back
351
352   my $info = $source->column_info($col);
353
354 Returns the column metadata hashref for a column, as originally passed
355 to L</add_columns>. See L</add_columns> above for information on the
356 contents of the hashref.
357
358 =cut
359
360 sub column_info {
361   my ($self, $column) = @_;
362   $self->throw_exception("No such column $column")
363     unless exists $self->_columns->{$column};
364
365   if ( ! $self->_columns->{$column}{data_type}
366        and ! $self->{_columns_info_loaded}
367        and $self->column_info_from_storage
368        and $self->schema and my $stor = $self->storage )
369   {
370     $self->{_columns_info_loaded}++;
371
372     # try for the case of storage without table
373     try {
374       my $info = $stor->columns_info_for( $self->from );
375       my $lc_info = { map
376         { (lc $_) => $info->{$_} }
377         ( keys %$info )
378       };
379
380       foreach my $col ( keys %{$self->_columns} ) {
381         $self->_columns->{$col} = {
382           %{ $self->_columns->{$col} },
383           %{ $info->{$col} || $lc_info->{lc $col} || {} }
384         };
385       }
386     };
387   }
388
389   return $self->_columns->{$column};
390 }
391
392 =head2 columns
393
394 =over
395
396 =item Arguments: None
397
398 =item Return value: Ordered list of column names
399
400 =back
401
402   my @column_names = $source->columns;
403
404 Returns all column names in the order they were declared to L</add_columns>.
405
406 =cut
407
408 sub columns {
409   my $self = shift;
410   $self->throw_exception(
411     "columns() is a read-only accessor, did you mean add_columns()?"
412   ) if @_;
413   return @{$self->{_ordered_columns}||[]};
414 }
415
416 =head2 columns_info
417
418 =over
419
420 =item Arguments: \@colnames ?
421
422 =item Return value: Hashref of column name/info pairs
423
424 =back
425
426   my $columns_info = $source->columns_info;
427
428 Like L</column_info> but returns information for the requested columns. If
429 the optional column-list arrayref is ommitted it returns info on all columns
430 currently defined on the ResultSource via L</add_columns>.
431
432 =cut
433
434 sub columns_info {
435   my ($self, $columns) = @_;
436
437   my $colinfo = $self->_columns;
438
439   if (
440     first { ! $_->{data_type} } values %$colinfo
441       and
442     ! $self->{_columns_info_loaded}
443       and
444     $self->column_info_from_storage
445       and
446     $self->schema
447       and
448     my $stor = $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   return $self->resultset_class->new(
1018     $self,
1019     {
1020       %{$self->{resultset_attributes}},
1021       %{$self->schema->default_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: None
1069
1070 =item Return value: A schema object
1071
1072 =back
1073
1074   my $schema = $source->schema();
1075
1076 Returns the L<DBIx::Class::Schema> object that this result source
1077 belongs to.
1078
1079 =head2 storage
1080
1081 =over 4
1082
1083 =item Arguments: None
1084
1085 =item Return value: A Storage object
1086
1087 =back
1088
1089   $source->storage->debug(1);
1090
1091 Returns the storage handle for the current schema.
1092
1093 See also: L<DBIx::Class::Storage>
1094
1095 =cut
1096
1097 sub storage { shift->schema->storage; }
1098
1099 =head2 add_relationship
1100
1101 =over 4
1102
1103 =item Arguments: $relname, $related_source_name, \%cond, [ \%attrs ]
1104
1105 =item Return value: 1/true if it succeeded
1106
1107 =back
1108
1109   $source->add_relationship('relname', 'related_source', $cond, $attrs);
1110
1111 L<DBIx::Class::Relationship> describes a series of methods which
1112 create pre-defined useful types of relationships. Look there first
1113 before using this method directly.
1114
1115 The relationship name can be arbitrary, but must be unique for each
1116 relationship attached to this result source. 'related_source' should
1117 be the name with which the related result source was registered with
1118 the current schema. For example:
1119
1120   $schema->source('Book')->add_relationship('reviews', 'Review', {
1121     'foreign.book_id' => 'self.id',
1122   });
1123
1124 The condition C<$cond> needs to be an L<SQL::Abstract>-style
1125 representation of the join between the tables. For example, if you're
1126 creating a relation from Author to Book,
1127
1128   { 'foreign.author_id' => 'self.id' }
1129
1130 will result in the JOIN clause
1131
1132   author me JOIN book foreign ON foreign.author_id = me.id
1133
1134 You can specify as many foreign => self mappings as necessary.
1135
1136 Valid attributes are as follows:
1137
1138 =over 4
1139
1140 =item join_type
1141
1142 Explicitly specifies the type of join to use in the relationship. Any
1143 SQL join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in
1144 the SQL command immediately before C<JOIN>.
1145
1146 =item proxy
1147
1148 An arrayref containing a list of accessors in the foreign class to proxy in
1149 the main class. If, for example, you do the following:
1150
1151   CD->might_have(liner_notes => 'LinerNotes', undef, {
1152     proxy => [ qw/notes/ ],
1153   });
1154
1155 Then, assuming LinerNotes has an accessor named notes, you can do:
1156
1157   my $cd = CD->find(1);
1158   # set notes -- LinerNotes object is created if it doesn't exist
1159   $cd->notes('Notes go here');
1160
1161 =item accessor
1162
1163 Specifies the type of accessor that should be created for the
1164 relationship. Valid values are C<single> (for when there is only a single
1165 related object), C<multi> (when there can be many), and C<filter> (for
1166 when there is a single related object, but you also want the relationship
1167 accessor to double as a column accessor). For C<multi> accessors, an
1168 add_to_* method is also created, which calls C<create_related> for the
1169 relationship.
1170
1171 =back
1172
1173 Throws an exception if the condition is improperly supplied, or cannot
1174 be resolved.
1175
1176 =cut
1177
1178 sub add_relationship {
1179   my ($self, $rel, $f_source_name, $cond, $attrs) = @_;
1180   $self->throw_exception("Can't create relationship without join condition")
1181     unless $cond;
1182   $attrs ||= {};
1183
1184   # Check foreign and self are right in cond
1185   if ( (ref $cond ||'') eq 'HASH') {
1186     for (keys %$cond) {
1187       $self->throw_exception("Keys of condition should be of form 'foreign.col', not '$_'")
1188         if /\./ && !/^foreign\./;
1189     }
1190   }
1191
1192   my %rels = %{ $self->_relationships };
1193   $rels{$rel} = { class => $f_source_name,
1194                   source => $f_source_name,
1195                   cond  => $cond,
1196                   attrs => $attrs };
1197   $self->_relationships(\%rels);
1198
1199   return $self;
1200
1201 # XXX disabled. doesn't work properly currently. skip in tests.
1202
1203   my $f_source = $self->schema->source($f_source_name);
1204   unless ($f_source) {
1205     $self->ensure_class_loaded($f_source_name);
1206     $f_source = $f_source_name->result_source;
1207     #my $s_class = ref($self->schema);
1208     #$f_source_name =~ m/^${s_class}::(.*)$/;
1209     #$self->schema->register_class(($1 || $f_source_name), $f_source_name);
1210     #$f_source = $self->schema->source($f_source_name);
1211   }
1212   return unless $f_source; # Can't test rel without f_source
1213
1214   try { $self->_resolve_join($rel, 'me', {}, []) }
1215   catch {
1216     # If the resolve failed, back out and re-throw the error
1217     delete $rels{$rel};
1218     $self->_relationships(\%rels);
1219     $self->throw_exception("Error creating relationship $rel: $_");
1220   };
1221
1222   1;
1223 }
1224
1225 =head2 relationships
1226
1227 =over 4
1228
1229 =item Arguments: None
1230
1231 =item Return value: List of relationship names
1232
1233 =back
1234
1235   my @relnames = $source->relationships();
1236
1237 Returns all relationship names for this source.
1238
1239 =cut
1240
1241 sub relationships {
1242   return keys %{shift->_relationships};
1243 }
1244
1245 =head2 relationship_info
1246
1247 =over 4
1248
1249 =item Arguments: $relname
1250
1251 =item Return value: Hashref of relation data,
1252
1253 =back
1254
1255 Returns a hash of relationship information for the specified relationship
1256 name. The keys/values are as specified for L</add_relationship>.
1257
1258 =cut
1259
1260 sub relationship_info {
1261   my ($self, $rel) = @_;
1262   return $self->_relationships->{$rel};
1263 }
1264
1265 =head2 has_relationship
1266
1267 =over 4
1268
1269 =item Arguments: $rel
1270
1271 =item Return value: 1/0 (true/false)
1272
1273 =back
1274
1275 Returns true if the source has a relationship of this name, false otherwise.
1276
1277 =cut
1278
1279 sub has_relationship {
1280   my ($self, $rel) = @_;
1281   return exists $self->_relationships->{$rel};
1282 }
1283
1284 =head2 reverse_relationship_info
1285
1286 =over 4
1287
1288 =item Arguments: $relname
1289
1290 =item Return value: Hashref of relationship data
1291
1292 =back
1293
1294 Looks through all the relationships on the source this relationship
1295 points to, looking for one whose condition is the reverse of the
1296 condition on this relationship.
1297
1298 A common use of this is to find the name of the C<belongs_to> relation
1299 opposing a C<has_many> relation. For definition of these look in
1300 L<DBIx::Class::Relationship>.
1301
1302 The returned hashref is keyed by the name of the opposing
1303 relationship, and contains its data in the same manner as
1304 L</relationship_info>.
1305
1306 =cut
1307
1308 sub reverse_relationship_info {
1309   my ($self, $rel) = @_;
1310   my $rel_info = $self->relationship_info($rel);
1311   my $ret = {};
1312
1313   return $ret unless ((ref $rel_info->{cond}) eq 'HASH');
1314
1315   my @cond = keys(%{$rel_info->{cond}});
1316   my @refkeys = map {/^\w+\.(\w+)$/} @cond;
1317   my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
1318
1319   # Get the related result source for this relationship
1320   my $othertable = $self->related_source($rel);
1321
1322   # Get all the relationships for that source that related to this source
1323   # whose foreign column set are our self columns on $rel and whose self
1324   # columns are our foreign columns on $rel.
1325   my @otherrels = $othertable->relationships();
1326   my $otherrelationship;
1327   foreach my $otherrel (@otherrels) {
1328     my $otherrel_info = $othertable->relationship_info($otherrel);
1329
1330     my $back = $othertable->related_source($otherrel);
1331     next unless $back->source_name eq $self->source_name;
1332
1333     my @othertestconds;
1334
1335     if (ref $otherrel_info->{cond} eq 'HASH') {
1336       @othertestconds = ($otherrel_info->{cond});
1337     }
1338     elsif (ref $otherrel_info->{cond} eq 'ARRAY') {
1339       @othertestconds = @{$otherrel_info->{cond}};
1340     }
1341     else {
1342       next;
1343     }
1344
1345     foreach my $othercond (@othertestconds) {
1346       my @other_cond = keys(%$othercond);
1347       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
1348       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
1349       next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
1350                !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
1351       $ret->{$otherrel} =  $otherrel_info;
1352     }
1353   }
1354   return $ret;
1355 }
1356
1357 sub compare_relationship_keys {
1358   carp 'compare_relationship_keys is a private method, stop calling it';
1359   my $self = shift;
1360   $self->_compare_relationship_keys (@_);
1361 }
1362
1363 # Returns true if both sets of keynames are the same, false otherwise.
1364 sub _compare_relationship_keys {
1365   my ($self, $keys1, $keys2) = @_;
1366
1367   # Make sure every keys1 is in keys2
1368   my $found;
1369   foreach my $key (@$keys1) {
1370     $found = 0;
1371     foreach my $prim (@$keys2) {
1372       if ($prim eq $key) {
1373         $found = 1;
1374         last;
1375       }
1376     }
1377     last unless $found;
1378   }
1379
1380   # Make sure every key2 is in key1
1381   if ($found) {
1382     foreach my $prim (@$keys2) {
1383       $found = 0;
1384       foreach my $key (@$keys1) {
1385         if ($prim eq $key) {
1386           $found = 1;
1387           last;
1388         }
1389       }
1390       last unless $found;
1391     }
1392   }
1393
1394   return $found;
1395 }
1396
1397 # Returns the {from} structure used to express JOIN conditions
1398 sub _resolve_join {
1399   my ($self, $join, $alias, $seen, $jpath, $parent_force_left) = @_;
1400
1401   # we need a supplied one, because we do in-place modifications, no returns
1402   $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
1403     unless ref $seen eq 'HASH';
1404
1405   $self->throw_exception ('You must supply a joinpath arrayref as the 4th argument to _resolve_join')
1406     unless ref $jpath eq 'ARRAY';
1407
1408   $jpath = [@$jpath]; # copy
1409
1410   if (not defined $join) {
1411     return ();
1412   }
1413   elsif (ref $join eq 'ARRAY') {
1414     return
1415       map {
1416         $self->_resolve_join($_, $alias, $seen, $jpath, $parent_force_left);
1417       } @$join;
1418   }
1419   elsif (ref $join eq 'HASH') {
1420
1421     my @ret;
1422     for my $rel (keys %$join) {
1423
1424       my $rel_info = $self->relationship_info($rel)
1425         or $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1426
1427       my $force_left = $parent_force_left;
1428       $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left';
1429
1430       # the actual seen value will be incremented by the recursion
1431       my $as = $self->storage->relname_to_table_alias(
1432         $rel, ($seen->{$rel} && $seen->{$rel} + 1)
1433       );
1434
1435       push @ret, (
1436         $self->_resolve_join($rel, $alias, $seen, [@$jpath], $force_left),
1437         $self->related_source($rel)->_resolve_join(
1438           $join->{$rel}, $as, $seen, [@$jpath, { $rel => $as }], $force_left
1439         )
1440       );
1441     }
1442     return @ret;
1443
1444   }
1445   elsif (ref $join) {
1446     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
1447   }
1448   else {
1449     my $count = ++$seen->{$join};
1450     my $as = $self->storage->relname_to_table_alias(
1451       $join, ($count > 1 && $count)
1452     );
1453
1454     my $rel_info = $self->relationship_info($join)
1455       or $self->throw_exception("No such relationship $join on " . $self->source_name);
1456
1457     my $rel_src = $self->related_source($join);
1458     return [ { $as => $rel_src->from,
1459                -source_handle => $rel_src->handle,
1460                -join_type => $parent_force_left
1461                   ? 'left'
1462                   : $rel_info->{attrs}{join_type}
1463                 ,
1464                -join_path => [@$jpath, { $join => $as } ],
1465                -is_single => (
1466                   $rel_info->{attrs}{accessor}
1467                     &&
1468                   first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/)
1469                 ),
1470                -alias => $as,
1471                -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
1472              },
1473              $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
1474   }
1475 }
1476
1477 sub pk_depends_on {
1478   carp 'pk_depends_on is a private method, stop calling it';
1479   my $self = shift;
1480   $self->_pk_depends_on (@_);
1481 }
1482
1483 # Determines whether a relation is dependent on an object from this source
1484 # having already been inserted. Takes the name of the relationship and a
1485 # hashref of columns of the related object.
1486 sub _pk_depends_on {
1487   my ($self, $relname, $rel_data) = @_;
1488
1489   my $relinfo = $self->relationship_info($relname);
1490
1491   # don't assume things if the relationship direction is specified
1492   return $relinfo->{attrs}{is_foreign_key_constraint}
1493     if exists ($relinfo->{attrs}{is_foreign_key_constraint});
1494
1495   my $cond = $relinfo->{cond};
1496   return 0 unless ref($cond) eq 'HASH';
1497
1498   # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
1499   my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
1500
1501   # assume anything that references our PK probably is dependent on us
1502   # rather than vice versa, unless the far side is (a) defined or (b)
1503   # auto-increment
1504   my $rel_source = $self->related_source($relname);
1505
1506   foreach my $p ($self->primary_columns) {
1507     if (exists $keyhash->{$p}) {
1508       unless (defined($rel_data->{$keyhash->{$p}})
1509               || $rel_source->column_info($keyhash->{$p})
1510                             ->{is_auto_increment}) {
1511         return 0;
1512       }
1513     }
1514   }
1515
1516   return 1;
1517 }
1518
1519 sub resolve_condition {
1520   carp 'resolve_condition is a private method, stop calling it';
1521   my $self = shift;
1522   $self->_resolve_condition (@_);
1523 }
1524
1525 # Resolves the passed condition to a concrete query fragment. If given an alias,
1526 # returns a join condition; if given an object, inverts that object to produce
1527 # a related conditional from that object.
1528 our $UNRESOLVABLE_CONDITION = \'1 = 0';
1529
1530 sub _resolve_condition {
1531   my ($self, $cond, $as, $for) = @_;
1532   if (ref $cond eq 'HASH') {
1533     my %ret;
1534     foreach my $k (keys %{$cond}) {
1535       my $v = $cond->{$k};
1536       # XXX should probably check these are valid columns
1537       $k =~ s/^foreign\.// ||
1538         $self->throw_exception("Invalid rel cond key ${k}");
1539       $v =~ s/^self\.// ||
1540         $self->throw_exception("Invalid rel cond val ${v}");
1541       if (ref $for) { # Object
1542         #warn "$self $k $for $v";
1543         unless ($for->has_column_loaded($v)) {
1544           if ($for->in_storage) {
1545             $self->throw_exception(sprintf
1546               "Unable to resolve relationship '%s' from object %s: column '%s' not "
1547             . 'loaded from storage (or not passed to new() prior to insert()). You '
1548             . 'probably need to call ->discard_changes to get the server-side defaults '
1549             . 'from the database.',
1550               $as,
1551               $for,
1552               $v,
1553             );
1554           }
1555           return $UNRESOLVABLE_CONDITION;
1556         }
1557         $ret{$k} = $for->get_column($v);
1558         #$ret{$k} = $for->get_column($v) if $for->has_column_loaded($v);
1559         #warn %ret;
1560       } elsif (!defined $for) { # undef, i.e. "no object"
1561         $ret{$k} = undef;
1562       } elsif (ref $as eq 'HASH') { # reverse hashref
1563         $ret{$v} = $as->{$k};
1564       } elsif (ref $as) { # reverse object
1565         $ret{$v} = $as->get_column($k);
1566       } elsif (!defined $as) { # undef, i.e. "no reverse object"
1567         $ret{$v} = undef;
1568       } else {
1569         $ret{"${as}.${k}"} = "${for}.${v}";
1570       }
1571     }
1572     return \%ret;
1573   } elsif (ref $cond eq 'ARRAY') {
1574     return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
1575   } else {
1576    die("Can't handle condition $cond yet :(");
1577   }
1578 }
1579
1580
1581 # Accepts one or more relationships for the current source and returns an
1582 # array of column names for each of those relationships. Column names are
1583 # prefixed relative to the current source, in accordance with where they appear
1584 # in the supplied relationships.
1585
1586 sub _resolve_prefetch {
1587   my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
1588   $pref_path ||= [];
1589
1590   if (not defined $pre) {
1591     return ();
1592   }
1593   elsif( ref $pre eq 'ARRAY' ) {
1594     return
1595       map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
1596         @$pre;
1597   }
1598   elsif( ref $pre eq 'HASH' ) {
1599     my @ret =
1600     map {
1601       $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
1602       $self->related_source($_)->_resolve_prefetch(
1603                $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
1604     } keys %$pre;
1605     return @ret;
1606   }
1607   elsif( ref $pre ) {
1608     $self->throw_exception(
1609       "don't know how to resolve prefetch reftype ".ref($pre));
1610   }
1611   else {
1612     my $p = $alias_map;
1613     $p = $p->{$_} for (@$pref_path, $pre);
1614
1615     $self->throw_exception (
1616       "Unable to resolve prefetch '$pre' - join alias map does not contain an entry for path: "
1617       . join (' -> ', @$pref_path, $pre)
1618     ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
1619
1620     my $as = shift @{$p->{-join_aliases}};
1621
1622     my $rel_info = $self->relationship_info( $pre );
1623     $self->throw_exception( $self->source_name . " has no such relationship '$pre'" )
1624       unless $rel_info;
1625     my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
1626     my $rel_source = $self->related_source($pre);
1627
1628     if ($rel_info->{attrs}{accessor} && $rel_info->{attrs}{accessor} eq 'multi') {
1629       $self->throw_exception(
1630         "Can't prefetch has_many ${pre} (join cond too complex)")
1631         unless ref($rel_info->{cond}) eq 'HASH';
1632       my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
1633       if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
1634                          keys %{$collapse}) {
1635         my ($last) = ($fail =~ /([^\.]+)$/);
1636         carp (
1637           "Prefetching multiple has_many rels ${last} and ${pre} "
1638           .(length($as_prefix)
1639             ? "at the same level (${as_prefix}) "
1640             : "at top level "
1641           )
1642           . 'will explode the number of row objects retrievable via ->next or ->all. '
1643           . 'Use at your own risk.'
1644         );
1645       }
1646       #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
1647       #              values %{$rel_info->{cond}};
1648       $collapse->{".${as_prefix}${pre}"} = [ $rel_source->_pri_cols ];
1649         # action at a distance. prepending the '.' allows simpler code
1650         # in ResultSet->_collapse_result
1651       my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
1652                     keys %{$rel_info->{cond}};
1653       push @$order, map { "${as}.$_" } @key;
1654
1655       if (my $rel_order = $rel_info->{attrs}{order_by}) {
1656         # this is kludgy and incomplete, I am well aware
1657         # but the parent method is going away entirely anyway
1658         # so sod it
1659         my $sql_maker = $self->storage->sql_maker;
1660         my ($orig_ql, $orig_qr) = $sql_maker->_quote_chars;
1661         my $sep = $sql_maker->name_sep;
1662
1663         # install our own quoter, so we can catch unqualified stuff
1664         local $sql_maker->{quote_char} = ["\x00", "\xFF"];
1665
1666         my $quoted_prefix = "\x00${as}\xFF";
1667
1668         for my $chunk ( $sql_maker->_order_by_chunks ($rel_order) ) {
1669           my @bind;
1670           ($chunk, @bind) = @$chunk if ref $chunk;
1671
1672           $chunk = "${quoted_prefix}${sep}${chunk}"
1673             unless $chunk =~ /\Q$sep/;
1674
1675           $chunk =~ s/\x00/$orig_ql/g;
1676           $chunk =~ s/\xFF/$orig_qr/g;
1677           push @$order, \[$chunk, @bind];
1678         }
1679       }
1680     }
1681
1682     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
1683       $rel_source->columns;
1684   }
1685 }
1686
1687 =head2 related_source
1688
1689 =over 4
1690
1691 =item Arguments: $relname
1692
1693 =item Return value: $source
1694
1695 =back
1696
1697 Returns the result source object for the given relationship.
1698
1699 =cut
1700
1701 sub related_source {
1702   my ($self, $rel) = @_;
1703   if( !$self->has_relationship( $rel ) ) {
1704     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1705   }
1706   return $self->schema->source($self->relationship_info($rel)->{source});
1707 }
1708
1709 =head2 related_class
1710
1711 =over 4
1712
1713 =item Arguments: $relname
1714
1715 =item Return value: $classname
1716
1717 =back
1718
1719 Returns the class name for objects in the given relationship.
1720
1721 =cut
1722
1723 sub related_class {
1724   my ($self, $rel) = @_;
1725   if( !$self->has_relationship( $rel ) ) {
1726     $self->throw_exception("No such relationship '$rel' on " . $self->source_name);
1727   }
1728   return $self->schema->class($self->relationship_info($rel)->{source});
1729 }
1730
1731 =head2 handle
1732
1733 Obtain a new handle to this source. Returns an instance of a
1734 L<DBIx::Class::ResultSourceHandle>.
1735
1736 =cut
1737
1738 sub handle {
1739     return DBIx::Class::ResultSourceHandle->new({
1740         schema         => $_[0]->schema,
1741         source_moniker => $_[0]->source_name
1742     });
1743 }
1744
1745 =head2 throw_exception
1746
1747 See L<DBIx::Class::Schema/"throw_exception">.
1748
1749 =cut
1750
1751 sub throw_exception {
1752   my $self = shift;
1753
1754   if (defined $self->schema) {
1755     $self->schema->throw_exception(@_);
1756   }
1757   else {
1758     DBIx::Class::Exception->throw(@_);
1759   }
1760 }
1761
1762 =head2 source_info
1763
1764 Stores a hashref of per-source metadata.  No specific key names
1765 have yet been standardized, the examples below are purely hypothetical
1766 and don't actually accomplish anything on their own:
1767
1768   __PACKAGE__->source_info({
1769     "_tablespace" => 'fast_disk_array_3',
1770     "_engine" => 'InnoDB',
1771   });
1772
1773 =head2 new
1774
1775   $class->new();
1776
1777   $class->new({attribute_name => value});
1778
1779 Creates a new ResultSource object.  Not normally called directly by end users.
1780
1781 =head2 column_info_from_storage
1782
1783 =over
1784
1785 =item Arguments: 1/0 (default: 0)
1786
1787 =item Return value: 1/0
1788
1789 =back
1790
1791   __PACKAGE__->column_info_from_storage(1);
1792
1793 Enables the on-demand automatic loading of the above column
1794 metadata from storage as necessary.  This is *deprecated*, and
1795 should not be used.  It will be removed before 1.0.
1796
1797
1798 =head1 AUTHORS
1799
1800 Matt S. Trout <mst@shadowcatsystems.co.uk>
1801
1802 =head1 LICENSE
1803
1804 You may distribute this code under the same terms as Perl itself.
1805
1806 =cut
1807
1808 1;