As clear as it gets
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Schema.pm
1 package DBIx::Class::Schema;
2
3 use strict;
4 use warnings;
5
6 use DBIx::Class::Exception;
7 use Carp::Clan qw/^DBIx::Class/;
8 use Scalar::Util qw/weaken/;
9 use File::Spec;
10 use Sub::Name ();
11 use Module::Find();
12
13 use base qw/DBIx::Class/;
14
15 __PACKAGE__->mk_classdata('class_mappings' => {});
16 __PACKAGE__->mk_classdata('source_registrations' => {});
17 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
18 __PACKAGE__->mk_classdata('storage');
19 __PACKAGE__->mk_classdata('exception_action');
20 __PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0);
21 __PACKAGE__->mk_classdata('default_resultset_attributes' => {});
22
23 =head1 NAME
24
25 DBIx::Class::Schema - composable schemas
26
27 =head1 SYNOPSIS
28
29   package Library::Schema;
30   use base qw/DBIx::Class::Schema/;
31
32   # load all Result classes in Library/Schema/Result/
33   __PACKAGE__->load_namespaces();
34
35   package Library::Schema::Result::CD;
36   use base qw/DBIx::Class::Core/;
37
38   __PACKAGE__->load_components(qw/InflateColumn::DateTime/); # for example
39   __PACKAGE__->table('cd');
40
41   # Elsewhere in your code:
42   my $schema1 = Library::Schema->connect(
43     $dsn,
44     $user,
45     $password,
46     { AutoCommit => 1 },
47   );
48
49   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
50
51   # fetch objects using Library::Schema::Result::DVD
52   my $resultset = $schema1->resultset('DVD')->search( ... );
53   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
54
55 =head1 DESCRIPTION
56
57 Creates database classes based on a schema. This is the recommended way to
58 use L<DBIx::Class> and allows you to use more than one concurrent connection
59 with your classes.
60
61 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
62 carefully, as DBIx::Class does things a little differently. Note in
63 particular which module inherits off which.
64
65 =head1 SETUP METHODS
66
67 =head2 load_namespaces
68
69 =over 4
70
71 =item Arguments: %options?
72
73 =back
74
75   __PACKAGE__->load_namespaces();
76
77   __PACKAGE__->load_namespaces(
78    result_namespace => 'Res',
79    resultset_namespace => 'RSet',
80    default_resultset_class => '+MyDB::Othernamespace::RSet',
81  );
82
83 With no arguments, this method uses L<Module::Find> to load all your
84 Result classes from a sub-namespace F<Result> under your Schema class'
85 namespace. Eg. With a Schema of I<MyDB::Schema> all files in
86 I<MyDB::Schema::Result> are assumed to be Result classes.
87
88 It also finds all ResultSet classes in the namespace F<ResultSet> and
89 loads them into the appropriate Result classes using for you. The
90 matching is done by assuming the package name of the ResultSet class
91 is the same as that of the Result class.
92
93 You will be warned if ResultSet classes are discovered for which there
94 are no matching Result classes like this:
95
96   load_namespaces found ResultSet class $classname with no corresponding Result class
97
98 If a Result class is found to already have a ResultSet class set using
99 L</resultset_class> to some other class, you will be warned like this:
100
101   We found ResultSet class '$rs_class' for '$result', but it seems 
102   that you had already set '$result' to use '$rs_set' instead
103
104 Both of the sub-namespaces are configurable if you don't like the defaults,
105 via the options C<result_namespace> and C<resultset_namespace>.
106
107 If (and only if) you specify the option C<default_resultset_class>, any found
108 Result classes for which we do not find a corresponding
109 ResultSet class will have their C<resultset_class> set to
110 C<default_resultset_class>.
111
112 All of the namespace and classname options to this method are relative to
113 the schema classname by default.  To specify a fully-qualified name, prefix
114 it with a literal C<+>.
115
116 Examples:
117
118   # load My::Schema::Result::CD, My::Schema::Result::Artist,
119   #    My::Schema::ResultSet::CD, etc...
120   My::Schema->load_namespaces;
121
122   # Override everything to use ugly names.
123   # In this example, if there is a My::Schema::Res::Foo, but no matching
124   #   My::Schema::RSets::Foo, then Foo will have its
125   #   resultset_class set to My::Schema::RSetBase
126   My::Schema->load_namespaces(
127     result_namespace => 'Res',
128     resultset_namespace => 'RSets',
129     default_resultset_class => 'RSetBase',
130   );
131
132   # Put things in other namespaces
133   My::Schema->load_namespaces(
134     result_namespace => '+Some::Place::Results',
135     resultset_namespace => '+Another::Place::RSets',
136   );
137
138 If you'd like to use multiple namespaces of each type, simply use an arrayref
139 of namespaces for that option.  In the case that the same result
140 (or resultset) class exists in multiple namespaces, the latter entries in
141 your list of namespaces will override earlier ones.
142
143   My::Schema->load_namespaces(
144     # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
145     result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
146     resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
147   );
148
149 =cut
150
151 # Pre-pends our classname to the given relative classname or
152 #   class namespace, unless there is a '+' prefix, which will
153 #   be stripped.
154 sub _expand_relative_name {
155   my ($class, $name) = @_;
156   return if !$name;
157   $name = $class . '::' . $name if ! ($name =~ s/^\+//);
158   return $name;
159 }
160
161 # Finds all modules in the supplied namespace, or if omitted in the
162 # namespace of $class. Untaints all findings as they can be assumed
163 # to be safe
164 sub _findallmod {
165   my $proto = shift;
166   my $ns = shift || ref $proto || $proto;
167
168   my @mods = Module::Find::findallmod($ns);
169
170   # try to untaint module names. mods where this fails
171   # are left alone so we don't have to change the old behavior
172   no locale; # localized \w doesn't untaint expression
173   return map { $_ =~ m/^( (?:\w+::)* \w+ )$/x ? $1 : $_ } @mods;
174 }
175
176 # returns a hash of $shortname => $fullname for every package
177 # found in the given namespaces ($shortname is with the $fullname's
178 # namespace stripped off)
179 sub _map_namespaces {
180   my ($class, @namespaces) = @_;
181
182   my @results_hash;
183   foreach my $namespace (@namespaces) {
184     push(
185       @results_hash,
186       map { (substr($_, length "${namespace}::"), $_) }
187       $class->_findallmod($namespace)
188     );
189   }
190
191   @results_hash;
192 }
193
194 # returns the result_source_instance for the passed class/object,
195 # or dies with an informative message (used by load_namespaces)
196 sub _ns_get_rsrc_instance {
197   my $class = shift;
198   my $rs = ref ($_[0]) || $_[0];
199
200   if ($rs->can ('result_source_instance') ) {
201     return $rs->result_source_instance;
202   }
203   else {
204     $class->throw_exception (
205       "Attempt to load_namespaces() class $rs failed - are you sure this is a real Result Class?"
206     );
207   }
208 }
209
210 sub load_namespaces {
211   my ($class, %args) = @_;
212
213   my $result_namespace = delete $args{result_namespace} || 'Result';
214   my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
215   my $default_resultset_class = delete $args{default_resultset_class};
216
217   $class->throw_exception('load_namespaces: unknown option(s): '
218     . join(q{,}, map { qq{'$_'} } keys %args))
219       if scalar keys %args;
220
221   $default_resultset_class
222     = $class->_expand_relative_name($default_resultset_class);
223
224   for my $arg ($result_namespace, $resultset_namespace) {
225     $arg = [ $arg ] if !ref($arg) && $arg;
226
227     $class->throw_exception('load_namespaces: namespace arguments must be '
228       . 'a simple string or an arrayref')
229         if ref($arg) ne 'ARRAY';
230
231     $_ = $class->_expand_relative_name($_) for (@$arg);
232   }
233
234   my %results = $class->_map_namespaces(@$result_namespace);
235   my %resultsets = $class->_map_namespaces(@$resultset_namespace);
236
237   my @to_register;
238   {
239     no warnings 'redefine';
240     local *Class::C3::reinitialize = sub { };
241     use warnings 'redefine';
242
243     # ensure classes are loaded and attached in inheritance order
244     $class->ensure_class_loaded($_) foreach(values %results);
245     my %inh_idx;
246     my @subclass_last = sort {
247
248       ($inh_idx{$a} ||=
249         scalar @{mro::get_linear_isa( $results{$a} )}
250       )
251
252           <=>
253
254       ($inh_idx{$b} ||=
255         scalar @{mro::get_linear_isa( $results{$b} )}
256       )
257
258     } keys(%results);
259
260     foreach my $result (@subclass_last) {
261       my $result_class = $results{$result};
262
263       my $rs_class = delete $resultsets{$result};
264       my $rs_set = $class->_ns_get_rsrc_instance ($result_class)->resultset_class;
265
266       if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
267         if($rs_class && $rs_class ne $rs_set) {
268           carp "We found ResultSet class '$rs_class' for '$result', but it seems "
269              . "that you had already set '$result' to use '$rs_set' instead";
270         }
271       }
272       elsif($rs_class ||= $default_resultset_class) {
273         $class->ensure_class_loaded($rs_class);
274         $class->_ns_get_rsrc_instance ($result_class)->resultset_class($rs_class);
275       }
276
277       my $source_name = $class->_ns_get_rsrc_instance ($result_class)->source_name || $result;
278
279       push(@to_register, [ $source_name, $result_class ]);
280     }
281   }
282
283   foreach (sort keys %resultsets) {
284     carp "load_namespaces found ResultSet class $_ with no "
285       . 'corresponding Result class';
286   }
287
288   Class::C3->reinitialize;
289   $class->register_class(@$_) for (@to_register);
290
291   return;
292 }
293
294 =head2 load_classes
295
296 =over 4
297
298 =item Arguments: @classes?, { $namespace => [ @classes ] }+
299
300 =back
301
302 L</load_classes> is an alternative method to L</load_namespaces>, both of
303 which serve similar purposes, each with different advantages and disadvantages.
304 In the general case you should use L</load_namespaces>, unless you need to
305 be able to specify that only specific classes are loaded at runtime.
306
307 With no arguments, this method uses L<Module::Find> to find all classes under
308 the schema's namespace. Otherwise, this method loads the classes you specify
309 (using L<use>), and registers them (using L</"register_class">).
310
311 It is possible to comment out classes with a leading C<#>, but note that perl
312 will think it's a mistake (trying to use a comment in a qw list), so you'll
313 need to add C<no warnings 'qw';> before your load_classes call.
314
315 If any classes found do not appear to be Result class files, you will
316 get the following warning:
317
318    Failed to load $comp_class. Can't find source_name method. Is 
319    $comp_class really a full DBIC result class? Fix it, move it elsewhere,
320    or make your load_classes call more specific.
321
322 Example:
323
324   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
325                               # etc. (anything under the My::Schema namespace)
326
327   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
328   # not Other::Namespace::LinerNotes nor My::Schema::Track
329   My::Schema->load_classes(qw/ CD Artist #Track /, {
330     Other::Namespace => [qw/ Producer #LinerNotes /],
331   });
332
333 =cut
334
335 sub load_classes {
336   my ($class, @params) = @_;
337
338   my %comps_for;
339
340   if (@params) {
341     foreach my $param (@params) {
342       if (ref $param eq 'ARRAY') {
343         # filter out commented entries
344         my @modules = grep { $_ !~ /^#/ } @$param;
345
346         push (@{$comps_for{$class}}, @modules);
347       }
348       elsif (ref $param eq 'HASH') {
349         # more than one namespace possible
350         for my $comp ( keys %$param ) {
351           # filter out commented entries
352           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
353
354           push (@{$comps_for{$comp}}, @modules);
355         }
356       }
357       else {
358         # filter out commented entries
359         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
360       }
361     }
362   } else {
363     my @comp = map { substr $_, length "${class}::"  }
364                  $class->_findallmod;
365     $comps_for{$class} = \@comp;
366   }
367
368   my @to_register;
369   {
370     no warnings qw/redefine/;
371     local *Class::C3::reinitialize = sub { };
372     foreach my $prefix (keys %comps_for) {
373       foreach my $comp (@{$comps_for{$prefix}||[]}) {
374         my $comp_class = "${prefix}::${comp}";
375         $class->ensure_class_loaded($comp_class);
376
377         my $snsub = $comp_class->can('source_name');
378         if(! $snsub ) {
379           carp "Failed to load $comp_class. Can't find source_name method. Is $comp_class really a full DBIC result class? Fix it, move it elsewhere, or make your load_classes call more specific.";
380           next;
381         }
382         $comp = $snsub->($comp_class) || $comp;
383
384         push(@to_register, [ $comp, $comp_class ]);
385       }
386     }
387   }
388   Class::C3->reinitialize;
389
390   foreach my $to (@to_register) {
391     $class->register_class(@$to);
392     #  if $class->can('result_source_instance');
393   }
394 }
395
396 =head2 storage_type
397
398 =over 4
399
400 =item Arguments: $storage_type|{$storage_type, \%args}
401
402 =item Return value: $storage_type|{$storage_type, \%args}
403
404 =item Default value: DBIx::Class::Storage::DBI
405
406 =back
407
408 Set the storage class that will be instantiated when L</connect> is called.
409 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
410 assumed by L</connect>.
411
412 You want to use this to set subclasses of L<DBIx::Class::Storage::DBI>
413 in cases where the appropriate subclass is not autodetected.
414
415 If your storage type requires instantiation arguments, those are
416 defined as a second argument in the form of a hashref and the entire
417 value needs to be wrapped into an arrayref or a hashref.  We support
418 both types of refs here in order to play nice with your
419 Config::[class] or your choice. See
420 L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
421
422 =head2 exception_action
423
424 =over 4
425
426 =item Arguments: $code_reference
427
428 =item Return value: $code_reference
429
430 =item Default value: None
431
432 =back
433
434 If C<exception_action> is set for this class/object, L</throw_exception>
435 will prefer to call this code reference with the exception as an argument,
436 rather than L<DBIx::Class::Exception/throw>.
437
438 Your subroutine should probably just wrap the error in the exception
439 object/class of your choosing and rethrow.  If, against all sage advice,
440 you'd like your C<exception_action> to suppress a particular exception
441 completely, simply have it return true.
442
443 Example:
444
445    package My::Schema;
446    use base qw/DBIx::Class::Schema/;
447    use My::ExceptionClass;
448    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
449    __PACKAGE__->load_classes;
450
451    # or:
452    my $schema_obj = My::Schema->connect( .... );
453    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
454
455    # suppress all exceptions, like a moron:
456    $schema_obj->exception_action(sub { 1 });
457
458 =head2 stacktrace
459
460 =over 4
461
462 =item Arguments: boolean
463
464 =back
465
466 Whether L</throw_exception> should include stack trace information.
467 Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
468 is true.
469
470 =head2 sqlt_deploy_hook
471
472 =over
473
474 =item Arguments: $sqlt_schema
475
476 =back
477
478 An optional sub which you can declare in your own Schema class that will get 
479 passed the L<SQL::Translator::Schema> object when you deploy the schema via
480 L</create_ddl_dir> or L</deploy>.
481
482 For an example of what you can do with this, see 
483 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
484
485 Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
486 is called before L</deploy>. Therefore the hook can be used only to manipulate
487 the L<SQL::Translator::Schema> object before it is turned into SQL fed to the
488 database. If you want to execute post-deploy statements which can not be generated
489 by L<SQL::Translator>, the currently suggested method is to overload L</deploy>
490 and use L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
491
492 =head1 METHODS
493
494 =head2 connect
495
496 =over 4
497
498 =item Arguments: @connectinfo
499
500 =item Return Value: $new_schema
501
502 =back
503
504 Creates and returns a new Schema object. The connection info set on it
505 is used to create a new instance of the storage backend and set it on
506 the Schema object.
507
508 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific
509 syntax on the C<@connectinfo> argument, or L<DBIx::Class::Storage> in
510 general.
511
512 Note that C<connect_info> expects an arrayref of arguments, but
513 C<connect> does not. C<connect> wraps its arguments in an arrayref
514 before passing them to C<connect_info>.
515
516 =head3 Overloading
517
518 C<connect> is a convenience method. It is equivalent to calling
519 $schema->clone->connection(@connectinfo). To write your own overloaded
520 version, overload L</connection> instead.
521
522 =cut
523
524 sub connect { shift->clone->connection(@_) }
525
526 =head2 resultset
527
528 =over 4
529
530 =item Arguments: $source_name
531
532 =item Return Value: $resultset
533
534 =back
535
536   my $rs = $schema->resultset('DVD');
537
538 Returns the L<DBIx::Class::ResultSet> object for the registered source
539 name.
540
541 =cut
542
543 sub resultset {
544   my ($self, $moniker) = @_;
545   $self->throw_exception('resultset() expects a source name')
546     unless defined $moniker;
547   return $self->source($moniker)->resultset;
548 }
549
550 =head2 sources
551
552 =over 4
553
554 =item Return Value: @source_names
555
556 =back
557
558   my @source_names = $schema->sources;
559
560 Lists names of all the sources registered on this Schema object.
561
562 =cut
563
564 sub sources { return keys %{shift->source_registrations}; }
565
566 =head2 source
567
568 =over 4
569
570 =item Arguments: $source_name
571
572 =item Return Value: $result_source
573
574 =back
575
576   my $source = $schema->source('Book');
577
578 Returns the L<DBIx::Class::ResultSource> object for the registered
579 source name.
580
581 =cut
582
583 sub source {
584   my ($self, $moniker) = @_;
585   my $sreg = $self->source_registrations;
586   return $sreg->{$moniker} if exists $sreg->{$moniker};
587
588   # if we got here, they probably passed a full class name
589   my $mapped = $self->class_mappings->{$moniker};
590   $self->throw_exception("Can't find source for ${moniker}")
591     unless $mapped && exists $sreg->{$mapped};
592   return $sreg->{$mapped};
593 }
594
595 =head2 class
596
597 =over 4
598
599 =item Arguments: $source_name
600
601 =item Return Value: $classname
602
603 =back
604
605   my $class = $schema->class('CD');
606
607 Retrieves the Result class name for the given source name.
608
609 =cut
610
611 sub class {
612   my ($self, $moniker) = @_;
613   return $self->source($moniker)->result_class;
614 }
615
616 =head2 txn_do
617
618 =over 4
619
620 =item Arguments: C<$coderef>, @coderef_args?
621
622 =item Return Value: The return value of $coderef
623
624 =back
625
626 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
627 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
628 See L<DBIx::Class::Storage/"txn_do"> for more information.
629
630 This interface is preferred over using the individual methods L</txn_begin>,
631 L</txn_commit>, and L</txn_rollback> below.
632
633 WARNING: If you are connected with C<< AutoCommit => 0 >> the transaction is
634 considered nested, and you will still need to call L</txn_commit> to write your
635 changes when appropriate. You will also want to connect with C<< auto_savepoint =>
636 1 >> to get partial rollback to work, if the storage driver for your database
637 supports it.
638
639 Connecting with C<< AutoCommit => 1 >> is recommended.
640
641 =cut
642
643 sub txn_do {
644   my $self = shift;
645
646   $self->storage or $self->throw_exception
647     ('txn_do called on $schema without storage');
648
649   $self->storage->txn_do(@_);
650 }
651
652 =head2 txn_scope_guard
653
654 Runs C<txn_scope_guard> on the schema's storage. See 
655 L<DBIx::Class::Storage/txn_scope_guard>.
656
657 =cut
658
659 sub txn_scope_guard {
660   my $self = shift;
661
662   $self->storage or $self->throw_exception
663     ('txn_scope_guard called on $schema without storage');
664
665   $self->storage->txn_scope_guard(@_);
666 }
667
668 =head2 txn_begin
669
670 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
671 calling $schema->storage->txn_begin. See
672 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
673
674 =cut
675
676 sub txn_begin {
677   my $self = shift;
678
679   $self->storage or $self->throw_exception
680     ('txn_begin called on $schema without storage');
681
682   $self->storage->txn_begin;
683 }
684
685 =head2 txn_commit
686
687 Commits the current transaction. Equivalent to calling
688 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
689 for more information.
690
691 =cut
692
693 sub txn_commit {
694   my $self = shift;
695
696   $self->storage or $self->throw_exception
697     ('txn_commit called on $schema without storage');
698
699   $self->storage->txn_commit;
700 }
701
702 =head2 txn_rollback
703
704 Rolls back the current transaction. Equivalent to calling
705 $schema->storage->txn_rollback. See
706 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
707
708 =cut
709
710 sub txn_rollback {
711   my $self = shift;
712
713   $self->storage or $self->throw_exception
714     ('txn_rollback called on $schema without storage');
715
716   $self->storage->txn_rollback;
717 }
718
719 =head2 storage
720
721   my $storage = $schema->storage;
722
723 Returns the L<DBIx::Class::Storage> object for this Schema. Grab this
724 if you want to turn on SQL statement debugging at runtime, or set the
725 quote character. For the default storage, the documentation can be
726 found in L<DBIx::Class::Storage::DBI>.
727
728 =head2 populate
729
730 =over 4
731
732 =item Arguments: $source_name, \@data;
733
734 =item Return value: \@$objects | nothing
735
736 =back
737
738 Pass this method a resultsource name, and an arrayref of
739 arrayrefs. The arrayrefs should contain a list of column names,
740 followed by one or many sets of matching data for the given columns. 
741
742 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
743 to insert the data, as this is a fast method. However, insert_bulk currently
744 assumes that your datasets all contain the same type of values, using scalar
745 references in a column in one row, and not in another will probably not work.
746
747 Otherwise, each set of data is inserted into the database using
748 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
749 objects is returned.
750
751 i.e.,
752
753   $schema->populate('Artist', [
754     [ qw/artistid name/ ],
755     [ 1, 'Popular Band' ],
756     [ 2, 'Indie Band' ],
757     ...
758   ]);
759
760 Since wantarray context is basically the same as looping over $rs->create(...) 
761 you won't see any performance benefits and in this case the method is more for
762 convenience. Void context sends the column information directly to storage
763 using <DBI>s bulk insert method. So the performance will be much better for 
764 storages that support this method.
765
766 Because of this difference in the way void context inserts rows into your 
767 database you need to note how this will effect any loaded components that
768 override or augment insert.  For example if you are using a component such 
769 as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use 
770 wantarray context if you want the PKs automatically created.
771
772 =cut
773
774 sub populate {
775   my ($self, $name, $data) = @_;
776   if(my $rs = $self->resultset($name)) {
777     if(defined wantarray) {
778         return $rs->populate($data);
779     } else {
780         $rs->populate($data);
781     }
782   } else {
783       $self->throw_exception("$name is not a resultset"); 
784   }
785 }
786
787 =head2 connection
788
789 =over 4
790
791 =item Arguments: @args
792
793 =item Return Value: $new_schema
794
795 =back
796
797 Similar to L</connect> except sets the storage object and connection
798 data in-place on the Schema class. You should probably be calling
799 L</connect> to get a proper Schema object instead.
800
801 =head3 Overloading
802
803 Overload C<connection> to change the behaviour of C<connect>.
804
805 =cut
806
807 sub connection {
808   my ($self, @info) = @_;
809   return $self if !@info && $self->storage;
810
811   my ($storage_class, $args) = ref $self->storage_type ? 
812     ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
813
814   $storage_class = 'DBIx::Class::Storage'.$storage_class
815     if $storage_class =~ m/^::/;
816   eval { $self->ensure_class_loaded ($storage_class) };
817   $self->throw_exception(
818     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
819   ) if $@;
820   my $storage = $storage_class->new($self=>$args);
821   $storage->connect_info(\@info);
822   $self->storage($storage);
823   return $self;
824 }
825
826 sub _normalize_storage_type {
827   my ($self, $storage_type) = @_;
828   if(ref $storage_type eq 'ARRAY') {
829     return @$storage_type;
830   } elsif(ref $storage_type eq 'HASH') {
831     return %$storage_type;
832   } else {
833     $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
834   }
835 }
836
837 =head2 compose_namespace
838
839 =over 4
840
841 =item Arguments: $target_namespace, $additional_base_class?
842
843 =item Retur Value: $new_schema
844
845 =back
846
847 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
848 class in the target namespace (e.g. $target_namespace::CD,
849 $target_namespace::Artist) that inherits from the corresponding classes
850 attached to the current schema.
851
852 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
853 new $schema object. If C<$additional_base_class> is given, the new composed
854 classes will inherit from first the corresponding classe from the current
855 schema then the base class.
856
857 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
858
859   $schema->compose_namespace('My::DB', 'Base::Class');
860   print join (', ', @My::DB::CD::ISA) . "\n";
861   print join (', ', @My::DB::Artist::ISA) ."\n";
862
863 will produce the output
864
865   My::Schema::CD, Base::Class
866   My::Schema::Artist, Base::Class
867
868 =cut
869
870 # this might be oversimplified
871 # sub compose_namespace {
872 #   my ($self, $target, $base) = @_;
873
874 #   my $schema = $self->clone;
875 #   foreach my $moniker ($schema->sources) {
876 #     my $source = $schema->source($moniker);
877 #     my $target_class = "${target}::${moniker}";
878 #     $self->inject_base(
879 #       $target_class => $source->result_class, ($base ? $base : ())
880 #     );
881 #     $source->result_class($target_class);
882 #     $target_class->result_source_instance($source)
883 #       if $target_class->can('result_source_instance');
884 #     $schema->register_source($moniker, $source);
885 #   }
886 #   return $schema;
887 # }
888
889 sub compose_namespace {
890   my ($self, $target, $base) = @_;
891   my $schema = $self->clone;
892   {
893     no warnings qw/redefine/;
894 #    local *Class::C3::reinitialize = sub { };
895     foreach my $moniker ($schema->sources) {
896       my $source = $schema->source($moniker);
897       my $target_class = "${target}::${moniker}";
898       $self->inject_base(
899         $target_class => $source->result_class, ($base ? $base : ())
900       );
901       $source->result_class($target_class);
902       $target_class->result_source_instance($source)
903         if $target_class->can('result_source_instance');
904      $schema->register_source($moniker, $source);
905     }
906   }
907 #  Class::C3->reinitialize();
908   {
909     no strict 'refs';
910     no warnings 'redefine';
911     foreach my $meth (qw/class source resultset/) {
912       *{"${target}::${meth}"} = Sub::Name::subname "${target}::${meth}" =>
913         sub { shift->schema->$meth(@_) };
914     }
915   }
916   return $schema;
917 }
918
919 sub setup_connection_class {
920   my ($class, $target, @info) = @_;
921   $class->inject_base($target => 'DBIx::Class::DB');
922   #$target->load_components('DB');
923   $target->connection(@info);
924 }
925
926 =head2 svp_begin
927
928 Creates a new savepoint (does nothing outside a transaction). 
929 Equivalent to calling $schema->storage->svp_begin.  See
930 L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
931
932 =cut
933
934 sub svp_begin {
935   my ($self, $name) = @_;
936
937   $self->storage or $self->throw_exception
938     ('svp_begin called on $schema without storage');
939
940   $self->storage->svp_begin($name);
941 }
942
943 =head2 svp_release
944
945 Releases a savepoint (does nothing outside a transaction). 
946 Equivalent to calling $schema->storage->svp_release.  See
947 L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
948
949 =cut
950
951 sub svp_release {
952   my ($self, $name) = @_;
953
954   $self->storage or $self->throw_exception
955     ('svp_release called on $schema without storage');
956
957   $self->storage->svp_release($name);
958 }
959
960 =head2 svp_rollback
961
962 Rollback to a savepoint (does nothing outside a transaction). 
963 Equivalent to calling $schema->storage->svp_rollback.  See
964 L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
965
966 =cut
967
968 sub svp_rollback {
969   my ($self, $name) = @_;
970
971   $self->storage or $self->throw_exception
972     ('svp_rollback called on $schema without storage');
973
974   $self->storage->svp_rollback($name);
975 }
976
977 =head2 clone
978
979 =over 4
980
981 =item Return Value: $new_schema
982
983 =back
984
985 Clones the schema and its associated result_source objects and returns the
986 copy.
987
988 =cut
989
990 sub clone {
991   my ($self) = @_;
992   my $clone = { (ref $self ? %$self : ()) };
993   bless $clone, (ref $self || $self);
994
995   $clone->class_mappings({ %{$clone->class_mappings} });
996   $clone->source_registrations({ %{$clone->source_registrations} });
997   foreach my $moniker ($self->sources) {
998     my $source = $self->source($moniker);
999     my $new = $source->new($source);
1000     # we use extra here as we want to leave the class_mappings as they are
1001     # but overwrite the source_registrations entry with the new source
1002     $clone->register_extra_source($moniker => $new);
1003   }
1004   $clone->storage->set_schema($clone) if $clone->storage;
1005   return $clone;
1006 }
1007
1008 =head2 throw_exception
1009
1010 =over 4
1011
1012 =item Arguments: $message
1013
1014 =back
1015
1016 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
1017 user's perspective.  See L</exception_action> for details on overriding
1018 this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>'s
1019 default behavior will provide a detailed stack trace.
1020
1021 =cut
1022
1023 sub throw_exception {
1024   my $self = shift;
1025
1026   DBIx::Class::Exception->throw($_[0], $self->stacktrace)
1027     if !$self->exception_action || !$self->exception_action->(@_);
1028 }
1029
1030 =head2 deploy
1031
1032 =over 4
1033
1034 =item Arguments: \%sqlt_args, $dir
1035
1036 =back
1037
1038 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
1039
1040 See L<SQL::Translator/METHODS> for a list of values for C<\%sqlt_args>.
1041 The most common value for this would be C<< { add_drop_table => 1 } >>
1042 to have the SQL produced include a C<DROP TABLE> statement for each table
1043 created. For quoting purposes supply C<quote_table_names> and
1044 C<quote_field_names>.
1045
1046 Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash 
1047 ref or an array ref, containing a list of source to deploy. If present, then 
1048 only the sources listed will get deployed. Furthermore, you can use the
1049 C<add_fk_index> parser parameter to prevent the parser from creating an index for each
1050 FK.
1051
1052 =cut
1053
1054 sub deploy {
1055   my ($self, $sqltargs, $dir) = @_;
1056   $self->throw_exception("Can't deploy without storage") unless $self->storage;
1057   $self->storage->deploy($self, undef, $sqltargs, $dir);
1058 }
1059
1060 =head2 deployment_statements
1061
1062 =over 4
1063
1064 =item Arguments: See L<DBIx::Class::Storage::DBI/deployment_statements>
1065
1066 =item Return value: $listofstatements
1067
1068 =back
1069
1070 A convenient shortcut to
1071 C<< $self->storage->deployment_statements($self, @args) >>.
1072 Returns the SQL statements used by L</deploy> and
1073 L<DBIx::Class::Schema::Storage/deploy>.
1074
1075 =cut
1076
1077 sub deployment_statements {
1078   my $self = shift;
1079
1080   $self->throw_exception("Can't generate deployment statements without a storage")
1081     if not $self->storage;
1082
1083   $self->storage->deployment_statements($self, @_);
1084 }
1085
1086 =head2 create_ddl_dir (EXPERIMENTAL)
1087
1088 =over 4
1089
1090 =item Arguments: See L<DBIx::Class::Storage::DBI/create_ddl_dir>
1091
1092 =back
1093
1094 A convenient shortcut to 
1095 C<< $self->storage->create_ddl_dir($self, @args) >>.
1096
1097 Creates an SQL file based on the Schema, for each of the specified
1098 database types, in the given directory.
1099
1100 =cut
1101
1102 sub create_ddl_dir {
1103   my $self = shift;
1104
1105   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
1106   $self->storage->create_ddl_dir($self, @_);
1107 }
1108
1109 =head2 ddl_filename
1110
1111 =over 4
1112
1113 =item Arguments: $database-type, $version, $directory, $preversion
1114
1115 =item Return value: $normalised_filename
1116
1117 =back
1118
1119   my $filename = $table->ddl_filename($type, $version, $dir, $preversion)
1120
1121 This method is called by C<create_ddl_dir> to compose a file name out of
1122 the supplied directory, database type and version number. The default file
1123 name format is: C<$dir$schema-$version-$type.sql>.
1124
1125 You may override this method in your schema if you wish to use a different
1126 format.
1127
1128  WARNING
1129
1130  Prior to DBIx::Class version 0.08100 this method had a different signature:
1131
1132     my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
1133
1134  In recent versions variables $dir and $version were reversed in order to
1135  bring the signature in line with other Schema/Storage methods. If you 
1136  really need to maintain backward compatibility, you can do the following
1137  in any overriding methods:
1138
1139     ($dir, $version) = ($version, $dir) if ($DBIx::Class::VERSION < 0.08100);
1140
1141 =cut
1142
1143 sub ddl_filename {
1144   my ($self, $type, $version, $dir, $preversion) = @_;
1145
1146   my $filename = ref($self);
1147   $filename =~ s/::/-/g;
1148   $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
1149   $filename =~ s/$version/$preversion-$version/ if($preversion);
1150
1151   return $filename;
1152 }
1153
1154 =head2 thaw
1155
1156 Provided as the recommended way of thawing schema objects. You can call 
1157 C<Storable::thaw> directly if you wish, but the thawed objects will not have a
1158 reference to any schema, so are rather useless
1159
1160 =cut
1161
1162 sub thaw {
1163   my ($self, $obj) = @_;
1164   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1165   return Storable::thaw($obj);
1166 }
1167
1168 =head2 freeze
1169
1170 This doesn't actualy do anything more than call L<Storable/freeze>, it is just
1171 provided here for symetry.
1172
1173 =cut
1174
1175 sub freeze {
1176   return Storable::freeze($_[1]);
1177 }
1178
1179 =head2 dclone
1180
1181 Recommeneded way of dcloning objects. This is needed to properly maintain
1182 references to the schema object (which itself is B<not> cloned.)
1183
1184 =cut
1185
1186 sub dclone {
1187   my ($self, $obj) = @_;
1188   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
1189   return Storable::dclone($obj);
1190 }
1191
1192 =head2 schema_version
1193
1194 Returns the current schema class' $VERSION in a normalised way.
1195
1196 =cut
1197
1198 sub schema_version {
1199   my ($self) = @_;
1200   my $class = ref($self)||$self;
1201
1202   # does -not- use $schema->VERSION
1203   # since that varies in results depending on if version.pm is installed, and if
1204   # so the perl or XS versions. If you want this to change, bug the version.pm
1205   # author to make vpp and vxs behave the same.
1206
1207   my $version;
1208   {
1209     no strict 'refs';
1210     $version = ${"${class}::VERSION"};
1211   }
1212   return $version;
1213 }
1214
1215
1216 =head2 register_class
1217
1218 =over 4
1219
1220 =item Arguments: $moniker, $component_class
1221
1222 =back
1223
1224 This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one. 
1225
1226 You will only need this method if you have your Result classes in
1227 files which are not named after the packages (or all in the same
1228 file). You may also need it to register classes at runtime.
1229
1230 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
1231 calling:
1232
1233   $schema->register_source($moniker, $component_class->result_source_instance);
1234
1235 =cut
1236
1237 sub register_class {
1238   my ($self, $moniker, $to_register) = @_;
1239   $self->register_source($moniker => $to_register->result_source_instance);
1240 }
1241
1242 =head2 register_source
1243
1244 =over 4
1245
1246 =item Arguments: $moniker, $result_source
1247
1248 =back
1249
1250 This method is called by L</register_class>.
1251
1252 Registers the L<DBIx::Class::ResultSource> in the schema with the given
1253 moniker.
1254
1255 =cut
1256
1257 sub register_source {
1258   my $self = shift;
1259
1260   $self->_register_source(@_);
1261 }
1262
1263 =head2 register_extra_source
1264
1265 =over 4
1266
1267 =item Arguments: $moniker, $result_source
1268
1269 =back
1270
1271 As L</register_source> but should be used if the result class already 
1272 has a source and you want to register an extra one.
1273
1274 =cut
1275
1276 sub register_extra_source {
1277   my $self = shift;
1278
1279   $self->_register_source(@_, { extra => 1 });
1280 }
1281
1282 sub _register_source {
1283   my ($self, $moniker, $source, $params) = @_;
1284
1285   my $orig_source = $source;
1286
1287   $source = $source->new({ %$source, source_name => $moniker });
1288   $source->schema($self);
1289   weaken($source->{schema}) if ref($self);
1290
1291   my $rs_class = $source->result_class;
1292
1293   my %reg = %{$self->source_registrations};
1294   $reg{$moniker} = $source;
1295   $self->source_registrations(\%reg);
1296
1297   return if ($params->{extra});
1298   return unless defined($rs_class) && $rs_class->can('result_source_instance');
1299
1300   my %map = %{$self->class_mappings};
1301   if (
1302     exists $map{$rs_class}
1303       and
1304     $map{$rs_class} ne $moniker
1305       and
1306     $rs_class->result_source_instance ne $orig_source
1307   ) {
1308     carp "$rs_class already has a source, use register_extra_source for additional sources";
1309   }
1310   $map{$rs_class} = $moniker;
1311   $self->class_mappings(\%map);
1312 }
1313
1314 sub _unregister_source {
1315     my ($self, $moniker) = @_;
1316     my %reg = %{$self->source_registrations}; 
1317
1318     my $source = delete $reg{$moniker};
1319     $self->source_registrations(\%reg);
1320     if ($source->result_class) {
1321         my %map = %{$self->class_mappings};
1322         delete $map{$source->result_class};
1323         $self->class_mappings(\%map);
1324     }
1325 }
1326
1327
1328 =head2 compose_connection (DEPRECATED)
1329
1330 =over 4
1331
1332 =item Arguments: $target_namespace, @db_info
1333
1334 =item Return Value: $new_schema
1335
1336 =back
1337
1338 DEPRECATED. You probably wanted compose_namespace.
1339
1340 Actually, you probably just wanted to call connect.
1341
1342 =begin hidden
1343
1344 (hidden due to deprecation)
1345
1346 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
1347 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
1348 then injects the L<DBix::Class::ResultSetProxy> component and a
1349 resultset_instance classdata entry on all the new classes, in order to support
1350 $target_namespaces::$class->search(...) method calls.
1351
1352 This is primarily useful when you have a specific need for class method access
1353 to a connection. In normal usage it is preferred to call
1354 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
1355 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
1356 more information.
1357
1358 =end hidden
1359
1360 =cut
1361
1362 {
1363   my $warn;
1364
1365   sub compose_connection {
1366     my ($self, $target, @info) = @_;
1367
1368     carp "compose_connection deprecated as of 0.08000"
1369       unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
1370
1371     my $base = 'DBIx::Class::ResultSetProxy';
1372     eval "require ${base};";
1373     $self->throw_exception
1374       ("No arguments to load_classes and couldn't load ${base} ($@)")
1375         if $@;
1376
1377     if ($self eq $target) {
1378       # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
1379       foreach my $moniker ($self->sources) {
1380         my $source = $self->source($moniker);
1381         my $class = $source->result_class;
1382         $self->inject_base($class, $base);
1383         $class->mk_classdata(resultset_instance => $source->resultset);
1384         $class->mk_classdata(class_resolver => $self);
1385       }
1386       $self->connection(@info);
1387       return $self;
1388     }
1389
1390     my $schema = $self->compose_namespace($target, $base);
1391     {
1392       no strict 'refs';
1393       my $name = join '::', $target, 'schema';
1394       *$name = Sub::Name::subname $name, sub { $schema };
1395     }
1396
1397     $schema->connection(@info);
1398     foreach my $moniker ($schema->sources) {
1399       my $source = $schema->source($moniker);
1400       my $class = $source->result_class;
1401       #warn "$moniker $class $source ".$source->storage;
1402       $class->mk_classdata(result_source_instance => $source);
1403       $class->mk_classdata(resultset_instance => $source->resultset);
1404       $class->mk_classdata(class_resolver => $schema);
1405     }
1406     return $schema;
1407   }
1408 }
1409
1410 1;
1411
1412 =head1 AUTHORS
1413
1414 Matt S. Trout <mst@shadowcatsystems.co.uk>
1415
1416 =head1 LICENSE
1417
1418 You may distribute this code under the same terms as Perl itself.
1419
1420 =cut