9f973a9d53f14847c171dd99318851872f23b72b
[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 load_namespaces
282
283 =over 4
284
285 =item Arguments: None
286
287 =back
288
289 This is an alternative to L</load_classes> above which assumes an alternative
290 layout for automatic class loading.  This variant takes no arguments.  It
291 assumes that all ResultSource classes to be loaded are underneath a sub-
292 namespace of the schema called "ResultSource", and any corresponding
293 ResultSet classes to be underneath a sub-namespace of the schema called
294 "ResultSet".
295
296 Any missing ResultSet definitions will be created in memory as basic
297 inheritors of L<DBIx::Class::ResultSet>.  You don't need to explicitly
298 specify the result_class of the sources unless you wish to override
299 the naming convention above.
300
301 This method requires L<Module::Find> to be installed on the system.
302
303 Example:
304
305   My::Schema->load_namespaces;
306   # loads My::Schema::ResultSource::CD, My::Schema::ResultSource::Artist,
307   #    My::Schema::ResultSet::CD, etc...
308
309 =cut
310
311 sub load_namespaces {
312   my ($class) = @_;
313
314   my $source_namespace = $class . '::ResultSource';
315   my $resultset_namespace = $class . '::ResultSet';
316
317   eval "require Module::Find";
318   $class->throw_exception("Couldn't load Module::Find ($@)") if $@;
319
320   my %sources = map { (substr($_, length "${source_namespace}::"), $_) }
321       Module::Find::findallmod($source_namespace);
322
323   my %resultsets = map { (substr($_, length "${resultset_namespace}::"), $_) }
324       Module::Find::findallmod($resultset_namespace);
325
326   my @to_register;
327   {
328     no warnings qw/redefine/;
329     local *Class::C3::reinitialize = sub { };
330     foreach my $source (keys %sources) {
331       my $source_class = $sources{$source};
332       $class->ensure_class_loaded($source_class);
333       $source_class->source_name($source) unless $source_class->source_name;
334       unless($source_class->resultset_class) {
335         if(my $rs_class = delete $resultsets{$source}) {
336           $class->ensure_class_loaded($rs_class);
337           $source_class->resultset_class($rs_class);
338         }
339         else {
340           require DBIx::Class::ResultSet;
341           my $rs_class = "${class}::ResultSet::$source";
342           @{"$rs_class::ISA"} = 'DBIx::Class::ResultSet';
343           $source_class->resultset_class($rs_class);
344         }
345       }
346
347       push(@to_register, [ $source_class->source_name, $source_class ]);
348     }
349   }
350
351   foreach (keys %resultsets) {
352     warn "load_namespaces found ResultSet $_ with no "
353       . 'corresponding ResultSource';
354   }
355
356   Class::C3->reinitialize;
357
358   foreach my $to (@to_register) {
359     $class->register_class(@$to);
360     #  if $class->can('result_source_instance');
361   }
362 }
363
364 =head2 compose_connection
365
366 =over 4
367
368 =item Arguments: $target_namespace, @db_info
369
370 =item Return Value: $new_schema
371
372 =back
373
374 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
375 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
376 then injects the L<DBix::Class::ResultSetProxy> component and a
377 resultset_instance classdata entry on all the new classes, in order to support
378 $target_namespaces::$class->search(...) method calls.
379
380 This is primarily useful when you have a specific need for class method access
381 to a connection. In normal usage it is preferred to call
382 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
383 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
384 more information.
385
386 =cut
387
388 sub compose_connection {
389   my ($self, $target, @info) = @_;
390   my $base = 'DBIx::Class::ResultSetProxy';
391   eval "require ${base};";
392   $self->throw_exception
393     ("No arguments to load_classes and couldn't load ${base} ($@)")
394       if $@;
395
396   if ($self eq $target) {
397     # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
398     foreach my $moniker ($self->sources) {
399       my $source = $self->source($moniker);
400       my $class = $source->result_class;
401       $self->inject_base($class, $base);
402       $class->mk_classdata(resultset_instance => $source->resultset);
403       $class->mk_classdata(class_resolver => $self);
404     }
405     $self->connection(@info);
406     return $self;
407   }
408
409   my $schema = $self->compose_namespace($target, $base);
410   {
411     no strict 'refs';
412     *{"${target}::schema"} = sub { $schema };
413   }
414
415   $schema->connection(@info);
416   foreach my $moniker ($schema->sources) {
417     my $source = $schema->source($moniker);
418     my $class = $source->result_class;
419     #warn "$moniker $class $source ".$source->storage;
420     $class->mk_classdata(result_source_instance => $source);
421     $class->mk_classdata(resultset_instance => $source->resultset);
422     $class->mk_classdata(class_resolver => $schema);
423   }
424   return $schema;
425 }
426
427 =head2 compose_namespace
428
429 =over 4
430
431 =item Arguments: $target_namespace, $additional_base_class?
432
433 =item Return Value: $new_schema
434
435 =back
436
437 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
438 class in the target namespace (e.g. $target_namespace::CD,
439 $target_namespace::Artist) that inherits from the corresponding classes
440 attached to the current schema.
441
442 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
443 new $schema object. If C<$additional_base_class> is given, the new composed
444 classes will inherit from first the corresponding classe from the current
445 schema then the base class.
446
447 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
448
449   $schema->compose_namespace('My::DB', 'Base::Class');
450   print join (', ', @My::DB::CD::ISA) . "\n";
451   print join (', ', @My::DB::Artist::ISA) ."\n";
452
453 will produce the output
454
455   My::Schema::CD, Base::Class
456   My::Schema::Artist, Base::Class
457
458 =cut
459
460 sub compose_namespace {
461   my ($self, $target, $base) = @_;
462   my %reg = %{ $self->source_registrations };
463   my %target;
464   my %map;
465   my $schema = $self->clone;
466   {
467     no warnings qw/redefine/;
468     local *Class::C3::reinitialize = sub { };
469     foreach my $moniker ($schema->sources) {
470       my $source = $schema->source($moniker);
471       my $target_class = "${target}::${moniker}";
472       $self->inject_base(
473         $target_class => $source->result_class, ($base ? $base : ())
474       );
475       $source->result_class($target_class);
476       $target_class->result_source_instance($source)
477         if $target_class->can('result_source_instance');
478     }
479   }
480   Class::C3->reinitialize();
481   {
482     no strict 'refs';
483     foreach my $meth (qw/class source resultset/) {
484       *{"${target}::${meth}"} =
485         sub { shift->schema->$meth(@_) };
486     }
487   }
488   return $schema;
489 }
490
491 =head2 setup_connection_class
492
493 =over 4
494
495 =item Arguments: $target, @info
496
497 =back
498
499 Sets up a database connection class to inject between the schema and the
500 subclasses that the schema creates.
501
502 =cut
503
504 sub setup_connection_class {
505   my ($class, $target, @info) = @_;
506   $class->inject_base($target => 'DBIx::Class::DB');
507   #$target->load_components('DB');
508   $target->connection(@info);
509 }
510
511 =head2 connection
512
513 =over 4
514
515 =item Arguments: @args
516
517 =item Return Value: $new_schema
518
519 =back
520
521 Instantiates a new Storage object of type
522 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
523 $storage->connect_info. Sets the connection in-place on the schema. See
524 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
525
526 =cut
527
528 sub connection {
529   my ($self, @info) = @_;
530   return $self if !@info && $self->storage;
531   my $storage_class = $self->storage_type;
532   $storage_class = 'DBIx::Class::Storage'.$storage_class
533     if $storage_class =~ m/^::/;
534   eval "require ${storage_class};";
535   $self->throw_exception(
536     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
537   ) if $@;
538   my $storage = $storage_class->new;
539   $storage->connect_info(\@info);
540   $self->storage($storage);
541   return $self;
542 }
543
544 =head2 connect
545
546 =over 4
547
548 =item Arguments: @info
549
550 =item Return Value: $new_schema
551
552 =back
553
554 This is a convenience method. It is equivalent to calling
555 $schema->clone->connection(@info). See L</connection> and L</clone> for more
556 information.
557
558 =cut
559
560 sub connect { shift->clone->connection(@_) }
561
562 =head2 txn_begin
563
564 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
565 calling $schema->storage->txn_begin. See
566 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
567
568 =cut
569
570 sub txn_begin { shift->storage->txn_begin }
571
572 =head2 txn_commit
573
574 Commits the current transaction. Equivalent to calling
575 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
576 for more information.
577
578 =cut
579
580 sub txn_commit { shift->storage->txn_commit }
581
582 =head2 txn_rollback
583
584 Rolls back the current transaction. Equivalent to calling
585 $schema->storage->txn_rollback. See
586 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
587
588 =cut
589
590 sub txn_rollback { shift->storage->txn_rollback }
591
592 =head2 txn_do
593
594 =over 4
595
596 =item Arguments: C<$coderef>, @coderef_args?
597
598 =item Return Value: The return value of $coderef
599
600 =back
601
602 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
603 returning its result (if any). If an exception is caught, a rollback is issued
604 and the exception is rethrown. If the rollback fails, (i.e. throws an
605 exception) an exception is thrown that includes a "Rollback failed" message.
606
607 For example,
608
609   my $author_rs = $schema->resultset('Author')->find(1);
610   my @titles = qw/Night Day It/;
611
612   my $coderef = sub {
613     # If any one of these fails, the entire transaction fails
614     $author_rs->create_related('books', {
615       title => $_
616     }) foreach (@titles);
617
618     return $author->books;
619   };
620
621   my $rs;
622   eval {
623     $rs = $schema->txn_do($coderef);
624   };
625
626   if ($@) {                                  # Transaction failed
627     die "something terrible has happened!"   #
628       if ($@ =~ /Rollback failed/);          # Rollback failed
629
630     deal_with_failed_transaction();
631   }
632
633 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
634 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
635 the Schema's storage, and txn_do() can be called in void, scalar and list
636 context and it will behave as expected.
637
638 =cut
639
640 sub txn_do {
641   my ($self, $coderef, @args) = @_;
642
643   $self->storage or $self->throw_exception
644     ('txn_do called on $schema without storage');
645   ref $coderef eq 'CODE' or $self->throw_exception
646     ('$coderef must be a CODE reference');
647
648   my (@return_values, $return_value);
649
650   $self->txn_begin; # If this throws an exception, no rollback is needed
651
652   my $wantarray = wantarray; # Need to save this since the context
653                              # inside the eval{} block is independent
654                              # of the context that called txn_do()
655   eval {
656
657     # Need to differentiate between scalar/list context to allow for
658     # returning a list in scalar context to get the size of the list
659     if ($wantarray) {
660       # list context
661       @return_values = $coderef->(@args);
662     } elsif (defined $wantarray) {
663       # scalar context
664       $return_value = $coderef->(@args);
665     } else {
666       # void context
667       $coderef->(@args);
668     }
669     $self->txn_commit;
670   };
671
672   if ($@) {
673     my $error = $@;
674
675     eval {
676       $self->txn_rollback;
677     };
678
679     if ($@) {
680       my $rollback_error = $@;
681       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
682       $self->throw_exception($error)  # propagate nested rollback
683         if $rollback_error =~ /$exception_class/;
684
685       $self->throw_exception(
686         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
687       );
688     } else {
689       $self->throw_exception($error); # txn failed but rollback succeeded
690     }
691   }
692
693   return $wantarray ? @return_values : $return_value;
694 }
695
696 =head2 clone
697
698 =over 4
699
700 =item Return Value: $new_schema
701
702 =back
703
704 Clones the schema and its associated result_source objects and returns the
705 copy.
706
707 =cut
708
709 sub clone {
710   my ($self) = @_;
711   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
712   foreach my $moniker ($self->sources) {
713     my $source = $self->source($moniker);
714     my $new = $source->new($source);
715     $clone->register_source($moniker => $new);
716   }
717   return $clone;
718 }
719
720 =head2 populate
721
722 =over 4
723
724 =item Arguments: $moniker, \@data;
725
726 =back
727
728 Populates the source registered with the given moniker with the supplied data.
729 @data should be a list of listrefs -- the first containing column names, the
730 second matching values.
731
732 i.e.,
733
734   $schema->populate('Artist', [
735     [ qw/artistid name/ ],
736     [ 1, 'Popular Band' ],
737     [ 2, 'Indie Band' ],
738     ...
739   ]);
740
741 =cut
742
743 sub populate {
744   my ($self, $name, $data) = @_;
745   my $rs = $self->resultset($name);
746   my @names = @{shift(@$data)};
747   my @created;
748   foreach my $item (@$data) {
749     my %create;
750     @create{@names} = @$item;
751     push(@created, $rs->create(\%create));
752   }
753   return @created;
754 }
755
756 =head2 throw_exception
757
758 =over 4
759
760 =item Arguments: $message
761
762 =back
763
764 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
765 user's perspective.
766
767 =cut
768
769 sub throw_exception {
770   my ($self) = shift;
771   croak @_;
772 }
773
774 =head2 deploy (EXPERIMENTAL)
775
776 =over 4
777
778 =item Arguments: $sqlt_args
779
780 =back
781
782 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
783
784 Note that this feature is currently EXPERIMENTAL and may not work correctly
785 across all databases, or fully handle complex relationships.
786
787 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
788 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
789 produced include a DROP TABLE statement for each table created.
790
791 =cut
792
793 sub deploy {
794   my ($self, $sqltargs) = @_;
795   $self->throw_exception("Can't deploy without storage") unless $self->storage;
796   $self->storage->deploy($self, undef, $sqltargs);
797 }
798
799 =head2 create_ddl_dir (EXPERIMENTAL)
800
801 =over 4
802
803 =item Arguments: \@databases, $version, $directory, $sqlt_args
804
805 =back
806
807 Creates an SQL file based on the Schema, for each of the specified
808 database types, in the given directory.
809
810 Note that this feature is currently EXPERIMENTAL and may not work correctly
811 across all databases, or fully handle complex relationships.
812
813 =cut
814
815 sub create_ddl_dir
816 {
817   my $self = shift;
818
819   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
820   $self->storage->create_ddl_dir($self, @_);
821 }
822
823 =head2 ddl_filename (EXPERIMENTAL)
824
825   my $filename = $table->ddl_filename($type, $dir, $version)
826
827 Creates a filename for a SQL file based on the table class name.  Not
828 intended for direct end user use.
829
830 =cut
831
832 sub ddl_filename
833 {
834     my ($self, $type, $dir, $version) = @_;
835
836     my $filename = ref($self);
837     $filename =~ s/::/-/;
838     $filename = "$dir$filename-$version-$type.sql";
839
840     return $filename;
841 }
842
843 1;
844
845 =head1 AUTHORS
846
847 Matt S. Trout <mst@shadowcatsystems.co.uk>
848
849 =head1 LICENSE
850
851 You may distribute this code under the same terms as Perl itself.
852
853 =cut
854