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