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