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