3103d29c250a991bbda7785d734f7851ec72fee5
[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 Carp::Clan qw/^DBIx::Class/;
7 use Scalar::Util qw/weaken/;
8 require Module::Find;
9
10 use base qw/DBIx::Class/;
11
12 __PACKAGE__->mk_classdata('class_mappings' => {});
13 __PACKAGE__->mk_classdata('source_registrations' => {});
14 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
15 __PACKAGE__->mk_classdata('storage');
16 __PACKAGE__->mk_classdata('exception_action');
17
18 =head1 NAME
19
20 DBIx::Class::Schema - composable schemas
21
22 =head1 SYNOPSIS
23
24   package Library::Schema;
25   use base qw/DBIx::Class::Schema/;
26
27   # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
28   __PACKAGE__->load_classes(qw/CD Book DVD/);
29
30   package Library::Schema::CD;
31   use base qw/DBIx::Class/;
32   __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
33   __PACKAGE__->table('cd');
34
35   # Elsewhere in your code:
36   my $schema1 = Library::Schema->connect(
37     $dsn,
38     $user,
39     $password,
40     { AutoCommit => 0 },
41   );
42
43   my $schema2 = Library::Schema->connect($coderef_returning_dbh);
44
45   # fetch objects using Library::Schema::DVD
46   my $resultset = $schema1->resultset('DVD')->search( ... );
47   my @dvd_objects = $schema2->resultset('DVD')->search( ... );
48
49 =head1 DESCRIPTION
50
51 Creates database classes based on a schema. This is the recommended way to
52 use L<DBIx::Class> and allows you to use more than one concurrent connection
53 with your classes.
54
55 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
56 carefully, as DBIx::Class does things a little differently. Note in
57 particular which module inherits off which.
58
59 =head1 METHODS
60
61 =head2 register_class
62
63 =over 4
64
65 =item Arguments: $moniker, $component_class
66
67 =back
68
69 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
70 calling:
71
72   $schema->register_source($moniker, $component_class->result_source_instance);
73
74 =cut
75
76 sub register_class {
77   my ($self, $moniker, $to_register) = @_;
78   $self->register_source($moniker => $to_register->result_source_instance);
79 }
80
81 =head2 register_source
82
83 =over 4
84
85 =item Arguments: $moniker, $result_source
86
87 =back
88
89 Registers the L<DBIx::Class::ResultSource> in the schema with the given
90 moniker.
91
92 =cut
93
94 sub register_source {
95   my ($self, $moniker, $source) = @_;
96   my %reg = %{$self->source_registrations};
97   $reg{$moniker} = $source;
98   $self->source_registrations(\%reg);
99   $source->schema($self);
100   weaken($source->{schema}) if ref($self);
101   if ($source->result_class) {
102     my %map = %{$self->class_mappings};
103     $map{$source->result_class} = $moniker;
104     $self->class_mappings(\%map);
105   }
106 }
107
108 =head2 class
109
110 =over 4
111
112 =item Arguments: $moniker
113
114 =item Return Value: $classname
115
116 =back
117
118 Retrieves the result class name for the given moniker. For example:
119
120   my $class = $schema->class('CD');
121
122 =cut
123
124 sub class {
125   my ($self, $moniker) = @_;
126   return $self->source($moniker)->result_class;
127 }
128
129 =head2 source
130
131 =over 4
132
133 =item Arguments: $moniker
134
135 =item Return Value: $result_source
136
137 =back
138
139   my $source = $schema->source('Book');
140
141 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
142
143 =cut
144
145 sub source {
146   my ($self, $moniker) = @_;
147   my $sreg = $self->source_registrations;
148   return $sreg->{$moniker} if exists $sreg->{$moniker};
149
150   # if we got here, they probably passed a full class name
151   my $mapped = $self->class_mappings->{$moniker};
152   $self->throw_exception("Can't find source for ${moniker}")
153     unless $mapped && exists $sreg->{$mapped};
154   return $sreg->{$mapped};
155 }
156
157 =head2 sources
158
159 =over 4
160
161 =item Return Value: @source_monikers
162
163 =back
164
165 Returns the source monikers of all source registrations on this schema.
166 For example:
167
168   my @source_monikers = $schema->sources;
169
170 =cut
171
172 sub sources { return keys %{shift->source_registrations}; }
173
174 =head2 resultset
175
176 =over 4
177
178 =item Arguments: $moniker
179
180 =item Return Value: $result_set
181
182 =back
183
184   my $rs = $schema->resultset('DVD');
185
186 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
187
188 =cut
189
190 sub resultset {
191   my ($self, $moniker) = @_;
192   return $self->source($moniker)->resultset;
193 }
194
195 =head2 load_classes
196
197 =over 4
198
199 =item Arguments: @classes?, { $namespace => [ @classes ] }+
200
201 =back
202
203 With no arguments, this method uses L<Module::Find> to find all classes under
204 the schema's namespace. Otherwise, this method loads the classes you specify
205 (using L<use>), and registers them (using L</"register_class">).
206
207 It is possible to comment out classes with a leading C<#>, but note that perl
208 will think it's a mistake (trying to use a comment in a qw list), so you'll
209 need to add C<no warnings 'qw';> before your load_classes call.
210
211 Example:
212
213   My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
214                               # etc. (anything under the My::Schema namespace)
215
216   # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
217   # not Other::Namespace::LinerNotes nor My::Schema::Track
218   My::Schema->load_classes(qw/ CD Artist #Track /, {
219     Other::Namespace => [qw/ Producer #LinerNotes /],
220   });
221
222 =cut
223
224 sub load_classes {
225   my ($class, @params) = @_;
226
227   my %comps_for;
228
229   if (@params) {
230     foreach my $param (@params) {
231       if (ref $param eq 'ARRAY') {
232         # filter out commented entries
233         my @modules = grep { $_ !~ /^#/ } @$param;
234
235         push (@{$comps_for{$class}}, @modules);
236       }
237       elsif (ref $param eq 'HASH') {
238         # more than one namespace possible
239         for my $comp ( keys %$param ) {
240           # filter out commented entries
241           my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
242
243           push (@{$comps_for{$comp}}, @modules);
244         }
245       }
246       else {
247         # filter out commented entries
248         push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
249       }
250     }
251   } else {
252     my @comp = map { substr $_, length "${class}::"  }
253                  Module::Find::findallmod($class);
254     $comps_for{$class} = \@comp;
255   }
256
257   my @to_register;
258   {
259     no warnings qw/redefine/;
260     local *Class::C3::reinitialize = sub { };
261     foreach my $prefix (keys %comps_for) {
262       foreach my $comp (@{$comps_for{$prefix}||[]}) {
263         my $comp_class = "${prefix}::${comp}";
264         $class->ensure_class_loaded($comp_class);
265         $comp_class->source_name($comp) unless $comp_class->source_name;
266
267         push(@to_register, [ $comp_class->source_name, $comp_class ]);
268       }
269     }
270   }
271   Class::C3->reinitialize;
272
273   foreach my $to (@to_register) {
274     $class->register_class(@$to);
275     #  if $class->can('result_source_instance');
276   }
277 }
278
279 =head2 load_namespaces
280
281 =over 4
282
283 =item Arguments: %options?
284
285 =back
286
287 This is an alternative to L</load_classes> above which assumes an alternative
288 layout for automatic class loading.  It assumes that all source-definition
289 classes are underneath a sub-namespace of the schema called C<Source>, any
290 corresponding ResultSet classes are underneath a sub-namespace of the schema
291 called C<ResultSet>.
292
293 Both of the sub-namespaces are configurable if you don't like the defaults,
294 via the options C<source_namespace> and C<resultset_namespace>.
295
296 If (and only if) you specify the option C<default_resultset_class>, any found
297 source-definition classes for which we do not find a corresponding
298 ResultSet class will have their C<resultset_class> set to
299 C<default_resultset_class>.
300
301 C<load_namespaces> takes care of calling C<resultset_class> for you where
302 neccessary if you didn't do it for yourself.
303
304 All of the namespace and classname options to this method are relative to
305 the schema classname by default.  To specify a fully-qualified name, prefix
306 it with a literal C<+>.
307
308 Examples:
309
310   # load My::Schema::Source::CD, My::Schema::Source::Artist,
311   #    My::Schema::ResultSet::CD, etc...
312   My::Schema->load_namespaces;
313
314   # Override everything...
315   My::Schema->load_namespaces(
316     source_namespace => 'Srcs',
317     resultset_namespace => 'RSets',
318     default_resultset_class => 'RSetBase',
319   );
320   # In the above, if there is a My::Schema::Srcs::Foo, but no matching
321   #   My::Schema::RSets::Foo, then the Foo source will have its
322   #   resultset_class set to My::Schema::RSetBase
323
324   # Put things in other namespaces
325   My::Schema->load_namespaces(
326     source_namespace => '+Some::Place::Sources',
327     resultset_namespace => '+Another::Place::RSets',
328   );
329
330 If you'd like to use multiple namespaces of each type, simply use an arrayref
331 of namespaces for that option.  In the case that the same source-definition
332 (or resultset) class exists in multiple namespaces, the latter entries in
333 your list of namespaces will override earlier ones.
334
335   My::Schema->load_namespaces(
336     # My::Schema::Sources_C::Foo takes precedence over My::Schema::Sources_B::Foo :
337     source_namespace => [ 'Sources_A', 'Sources_B', 'Sources_C' ],
338     resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
339   );
340
341 =cut
342
343 # Pre-pends our classname to the given relative classname or
344 #   class namespace, unless there is a '+' prefix, which will
345 #   be stripped.
346 sub _expand_relative_name {
347   my ($class, $name) = @_;
348   return if !$name;
349   $name = $class . '::' . $name if ! ($name =~ s/^\+//);
350   return $name;
351 }
352
353 # returns a hash of $shortname => $fullname for every package
354 #  found in the given namespaces ($shortname is with the $fullname's
355 #  namespace stripped off)
356 sub _map_namespaces {
357   my ($class, @namespaces) = @_;
358
359   my @results_hash;
360   foreach my $namespace (@namespaces) {
361     push(
362       @results_hash,
363       map { (substr($_, length "${namespace}::"), $_) }
364       Module::Find::findallmod($namespace)
365     );
366   }
367
368   @results_hash;
369 }
370
371 sub load_namespaces {
372   my ($class, %args) = @_;
373
374   my $source_namespace = delete $args{source_namespace} || 'Source';
375   my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
376   my $default_resultset_class = delete $args{default_resultset_class};
377
378   $class->throw_exception('load_namespaces: unknown option(s): '
379     . join(q{,}, map { qq{'$_'} } keys %args))
380       if scalar keys %args;
381
382   $default_resultset_class
383     = $class->_expand_relative_name($default_resultset_class);
384
385   for my $arg ($source_namespace, $resultset_namespace) {
386     $arg = [ $arg ] if !ref($arg) && $arg;
387
388     $class->throw_exception('load_namespaces: namespace arguments must be '
389       . 'a simple string or an arrayref')
390         if ref($arg) ne 'ARRAY';
391
392     $_ = $class->_expand_relative_name($_) for (@$arg);
393   }
394
395   my %sources = $class->_map_namespaces(@$source_namespace);
396   my %resultsets = $class->_map_namespaces(@$resultset_namespace);
397
398   my @to_register;
399   {
400     no warnings 'redefine';
401     local *Class::C3::reinitialize = sub { };
402     use warnings 'redefine';
403
404     foreach my $source (keys %sources) {
405       my $source_class = $sources{$source};
406       $class->ensure_class_loaded($source_class);
407       $source_class->source_name($source) unless $source_class->source_name;
408
409       my $rs_class = delete $resultsets{$source};
410       my $rs_set = $source_class->resultset_class;
411       if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
412         if($rs_class && $rs_class ne $rs_set) {
413           warn "We found ResultSet class '$rs_class' for '$source', but it seems "
414              . "that you had already set '$source' to use '$rs_set' instead";
415         }
416       }
417       elsif($rs_class ||= $default_resultset_class) {
418         $class->ensure_class_loaded($rs_class);
419         $source_class->resultset_class($rs_class);
420       }
421
422       push(@to_register, [ $source_class->source_name, $source_class ]);
423     }
424   }
425
426   foreach (sort keys %resultsets) {
427     warn "load_namespaces found ResultSet class $_ with no "
428       . 'corresponding source-definition class';
429   }
430
431   Class::C3->reinitialize;
432   $class->register_class(@$_) for (@to_register);
433
434   return;
435 }
436
437 =head2 compose_connection
438
439 =over 4
440
441 =item Arguments: $target_namespace, @db_info
442
443 =item Return Value: $new_schema
444
445 =back
446
447 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
448 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
449 then injects the L<DBix::Class::ResultSetProxy> component and a
450 resultset_instance classdata entry on all the new classes, in order to support
451 $target_namespaces::$class->search(...) method calls.
452
453 This is primarily useful when you have a specific need for class method access
454 to a connection. In normal usage it is preferred to call
455 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
456 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
457 more information.
458
459 =cut
460
461 sub compose_connection {
462   my ($self, $target, @info) = @_;
463   my $base = 'DBIx::Class::ResultSetProxy';
464   eval "require ${base};";
465   $self->throw_exception
466     ("No arguments to load_classes and couldn't load ${base} ($@)")
467       if $@;
468
469   if ($self eq $target) {
470     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
471     foreach my $moniker ($self->sources) {
472       my $source = $self->source($moniker);
473       my $class = $source->result_class;
474       $self->inject_base($class, $base);
475       $class->mk_classdata(resultset_instance => $source->resultset);
476       $class->mk_classdata(class_resolver => $self);
477     }
478     $self->connection(@info);
479     return $self;
480   }
481
482   my $schema = $self->compose_namespace($target, $base);
483   {
484     no strict 'refs';
485     *{"${target}::schema"} = sub { $schema };
486   }
487
488   $schema->connection(@info);
489   foreach my $moniker ($schema->sources) {
490     my $source = $schema->source($moniker);
491     my $class = $source->result_class;
492     #warn "$moniker $class $source ".$source->storage;
493     $class->mk_classdata(result_source_instance => $source);
494     $class->mk_classdata(resultset_instance => $source->resultset);
495     $class->mk_classdata(class_resolver => $schema);
496   }
497   return $schema;
498 }
499
500 =head2 compose_namespace
501
502 =over 4
503
504 =item Arguments: $target_namespace, $additional_base_class?
505
506 =item Return Value: $new_schema
507
508 =back
509
510 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
511 class in the target namespace (e.g. $target_namespace::CD,
512 $target_namespace::Artist) that inherits from the corresponding classes
513 attached to the current schema.
514
515 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
516 new $schema object. If C<$additional_base_class> is given, the new composed
517 classes will inherit from first the corresponding classe from the current
518 schema then the base class.
519
520 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
521
522   $schema->compose_namespace('My::DB', 'Base::Class');
523   print join (', ', @My::DB::CD::ISA) . "\n";
524   print join (', ', @My::DB::Artist::ISA) ."\n";
525
526 will produce the output
527
528   My::Schema::CD, Base::Class
529   My::Schema::Artist, Base::Class
530
531 =cut
532
533 sub compose_namespace {
534   my ($self, $target, $base) = @_;
535   my %reg = %{ $self->source_registrations };
536   my %target;
537   my %map;
538   my $schema = $self->clone;
539   {
540     no warnings qw/redefine/;
541     local *Class::C3::reinitialize = sub { };
542     foreach my $moniker ($schema->sources) {
543       my $source = $schema->source($moniker);
544       my $target_class = "${target}::${moniker}";
545       $self->inject_base(
546         $target_class => $source->result_class, ($base ? $base : ())
547       );
548       $source->result_class($target_class);
549       $target_class->result_source_instance($source)
550         if $target_class->can('result_source_instance');
551     }
552   }
553   Class::C3->reinitialize();
554   {
555     no strict 'refs';
556     foreach my $meth (qw/class source resultset/) {
557       *{"${target}::${meth}"} =
558         sub { shift->schema->$meth(@_) };
559     }
560   }
561   return $schema;
562 }
563
564 =head2 setup_connection_class
565
566 =over 4
567
568 =item Arguments: $target, @info
569
570 =back
571
572 Sets up a database connection class to inject between the schema and the
573 subclasses that the schema creates.
574
575 =cut
576
577 sub setup_connection_class {
578   my ($class, $target, @info) = @_;
579   $class->inject_base($target => 'DBIx::Class::DB');
580   #$target->load_components('DB');
581   $target->connection(@info);
582 }
583
584 =head2 connection
585
586 =over 4
587
588 =item Arguments: @args
589
590 =item Return Value: $new_schema
591
592 =back
593
594 Instantiates a new Storage object of type
595 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
596 $storage->connect_info. Sets the connection in-place on the schema. See
597 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
598
599 =cut
600
601 sub connection {
602   my ($self, @info) = @_;
603   return $self if !@info && $self->storage;
604   my $storage_class = $self->storage_type;
605   $storage_class = 'DBIx::Class::Storage'.$storage_class
606     if $storage_class =~ m/^::/;
607   eval "require ${storage_class};";
608   $self->throw_exception(
609     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
610   ) if $@;
611   my $storage = $storage_class->new($self);
612   $storage->connect_info(\@info);
613   $self->storage($storage);
614   return $self;
615 }
616
617 =head2 connect
618
619 =over 4
620
621 =item Arguments: @info
622
623 =item Return Value: $new_schema
624
625 =back
626
627 This is a convenience method. It is equivalent to calling
628 $schema->clone->connection(@info). See L</connection> and L</clone> for more
629 information.
630
631 =cut
632
633 sub connect { shift->clone->connection(@_) }
634
635 =head2 txn_begin
636
637 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
638 calling $schema->storage->txn_begin. See
639 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
640
641 =cut
642
643 sub txn_begin { shift->storage->txn_begin }
644
645 =head2 txn_commit
646
647 Commits the current transaction. Equivalent to calling
648 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
649 for more information.
650
651 =cut
652
653 sub txn_commit { shift->storage->txn_commit }
654
655 =head2 txn_rollback
656
657 Rolls back the current transaction. Equivalent to calling
658 $schema->storage->txn_rollback. See
659 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
660
661 =cut
662
663 sub txn_rollback { shift->storage->txn_rollback }
664
665 =head2 txn_do
666
667 =over 4
668
669 =item Arguments: C<$coderef>, @coderef_args?
670
671 =item Return Value: The return value of $coderef
672
673 =back
674
675 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
676 returning its result (if any). If an exception is caught, a rollback is issued
677 and the exception is rethrown. If the rollback fails, (i.e. throws an
678 exception) an exception is thrown that includes a "Rollback failed" message.
679
680 For example,
681
682   my $author_rs = $schema->resultset('Author')->find(1);
683   my @titles = qw/Night Day It/;
684
685   my $coderef = sub {
686     # If any one of these fails, the entire transaction fails
687     $author_rs->create_related('books', {
688       title => $_
689     }) foreach (@titles);
690
691     return $author->books;
692   };
693
694   my $rs;
695   eval {
696     $rs = $schema->txn_do($coderef);
697   };
698
699   if ($@) {                                  # Transaction failed
700     die "something terrible has happened!"   #
701       if ($@ =~ /Rollback failed/);          # Rollback failed
702
703     deal_with_failed_transaction();
704   }
705
706 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
707 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
708 the Schema's storage, and txn_do() can be called in void, scalar and list
709 context and it will behave as expected.
710
711 =cut
712
713 sub txn_do {
714   my ($self, $coderef, @args) = @_;
715
716   $self->storage or $self->throw_exception
717     ('txn_do called on $schema without storage');
718   ref $coderef eq 'CODE' or $self->throw_exception
719     ('$coderef must be a CODE reference');
720
721   my (@return_values, $return_value);
722
723   $self->txn_begin; # If this throws an exception, no rollback is needed
724
725   my $wantarray = wantarray; # Need to save this since the context
726                              # inside the eval{} block is independent
727                              # of the context that called txn_do()
728   eval {
729
730     # Need to differentiate between scalar/list context to allow for
731     # returning a list in scalar context to get the size of the list
732     if ($wantarray) {
733       # list context
734       @return_values = $coderef->(@args);
735     } elsif (defined $wantarray) {
736       # scalar context
737       $return_value = $coderef->(@args);
738     } else {
739       # void context
740       $coderef->(@args);
741     }
742     $self->txn_commit;
743   };
744
745   if ($@) {
746     my $error = $@;
747
748     eval {
749       $self->txn_rollback;
750     };
751
752     if ($@) {
753       my $rollback_error = $@;
754       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
755       $self->throw_exception($error)  # propagate nested rollback
756         if $rollback_error =~ /$exception_class/;
757
758       $self->throw_exception(
759         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
760       );
761     } else {
762       $self->throw_exception($error); # txn failed but rollback succeeded
763     }
764   }
765
766   return $wantarray ? @return_values : $return_value;
767 }
768
769 =head2 clone
770
771 =over 4
772
773 =item Return Value: $new_schema
774
775 =back
776
777 Clones the schema and its associated result_source objects and returns the
778 copy.
779
780 =cut
781
782 sub clone {
783   my ($self) = @_;
784   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
785   foreach my $moniker ($self->sources) {
786     my $source = $self->source($moniker);
787     my $new = $source->new($source);
788     $clone->register_source($moniker => $new);
789   }
790   $clone->storage->set_schema($clone) if $clone->storage;
791   return $clone;
792 }
793
794 =head2 populate
795
796 =over 4
797
798 =item Arguments: $moniker, \@data;
799
800 =back
801
802 Populates the source registered with the given moniker with the supplied data.
803 @data should be a list of listrefs -- the first containing column names, the
804 second matching values.
805
806 i.e.,
807
808   $schema->populate('Artist', [
809     [ qw/artistid name/ ],
810     [ 1, 'Popular Band' ],
811     [ 2, 'Indie Band' ],
812     ...
813   ]);
814
815 =cut
816
817 sub populate {
818   my ($self, $name, $data) = @_;
819   my $rs = $self->resultset($name);
820   my @names = @{shift(@$data)};
821   my @created;
822   foreach my $item (@$data) {
823     my %create;
824     @create{@names} = @$item;
825     push(@created, $rs->create(\%create));
826   }
827   return @created;
828 }
829
830 =head2 exception_action
831
832 =over 4
833
834 =item Arguments: $code_reference
835
836 =back
837
838 If C<exception_action> is set for this class/object, L</throw_exception>
839 will prefer to call this code reference with the exception as an argument,
840 rather than its normal <croak> action.
841
842 Your subroutine should probably just wrap the error in the exception
843 object/class of your choosing and rethrow.  If, against all sage advice,
844 you'd like your C<exception_action> to suppress a particular exception
845 completely, simply have it return true.
846
847 Example:
848
849    package My::Schema;
850    use base qw/DBIx::Class::Schema/;
851    use My::ExceptionClass;
852    __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
853    __PACKAGE__->load_classes;
854
855    # or:
856    my $schema_obj = My::Schema->connect( .... );
857    $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
858
859    # suppress all exceptions, like a moron:
860    $schema_obj->exception_action(sub { 1 });
861
862 =head2 throw_exception
863
864 =over 4
865
866 =item Arguments: $message
867
868 =back
869
870 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
871 user's perspective.  See L</exception_action> for details on overriding
872 this method's behavior.
873
874 =cut
875
876 sub throw_exception {
877   my $self = shift;
878   croak @_ if !$self->exception_action || !$self->exception_action->(@_);
879 }
880
881 =head2 deploy (EXPERIMENTAL)
882
883 =over 4
884
885 =item Arguments: $sqlt_args
886
887 =back
888
889 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
890
891 Note that this feature is currently EXPERIMENTAL and may not work correctly
892 across all databases, or fully handle complex relationships.
893
894 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
895 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
896 produced include a DROP TABLE statement for each table created.
897
898 =cut
899
900 sub deploy {
901   my ($self, $sqltargs) = @_;
902   $self->throw_exception("Can't deploy without storage") unless $self->storage;
903   $self->storage->deploy($self, undef, $sqltargs);
904 }
905
906 =head2 create_ddl_dir (EXPERIMENTAL)
907
908 =over 4
909
910 =item Arguments: \@databases, $version, $directory, $sqlt_args
911
912 =back
913
914 Creates an SQL file based on the Schema, for each of the specified
915 database types, in the given directory.
916
917 Note that this feature is currently EXPERIMENTAL and may not work correctly
918 across all databases, or fully handle complex relationships.
919
920 =cut
921
922 sub create_ddl_dir
923 {
924   my $self = shift;
925
926   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
927   $self->storage->create_ddl_dir($self, @_);
928 }
929
930 =head2 ddl_filename (EXPERIMENTAL)
931
932   my $filename = $table->ddl_filename($type, $dir, $version)
933
934 Creates a filename for a SQL file based on the table class name.  Not
935 intended for direct end user use.
936
937 =cut
938
939 sub ddl_filename
940 {
941     my ($self, $type, $dir, $version) = @_;
942
943     my $filename = ref($self);
944     $filename =~ s/::/-/;
945     $filename = "$dir$filename-$version-$type.sql";
946
947     return $filename;
948 }
949
950 1;
951
952 =head1 AUTHORS
953
954 Matt S. Trout <mst@shadowcatsystems.co.uk>
955
956 =head1 LICENSE
957
958 You may distribute this code under the same terms as Perl itself.
959
960 =cut
961