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