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