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