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