Add automatic naming of unique constraints
[dbsrgits/DBIx-Class.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     }
394   }
395   Class::C3->reinitialize();
396   {
397     no strict 'refs';
398     foreach my $meth (qw/class source resultset/) {
399       *{"${target}::${meth}"} =
400         sub { shift->schema->$meth(@_) };
401     }
402   }
403   return $schema;
404 }
405
406 =head2 setup_connection_class
407
408 =over 4
409
410 =item Arguments: $target, @info
411
412 =back
413
414 Sets up a database connection class to inject between the schema and the
415 subclasses that the schema creates.
416
417 =cut
418
419 sub setup_connection_class {
420   my ($class, $target, @info) = @_;
421   $class->inject_base($target => 'DBIx::Class::DB');
422   #$target->load_components('DB');
423   $target->connection(@info);
424 }
425
426 =head2 connection
427
428 =over 4
429
430 =item Arguments: @args
431
432 =item Return Value: $new_schema
433
434 =back
435
436 Instantiates a new Storage object of type
437 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
438 $storage->connect_info. Sets the connection in-place on the schema. See
439 L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
440
441 =cut
442
443 sub connection {
444   my ($self, @info) = @_;
445   return $self if !@info && $self->storage;
446   my $storage_class = $self->storage_type;
447   $storage_class = 'DBIx::Class::Storage'.$storage_class
448     if $storage_class =~ m/^::/;
449   eval "require ${storage_class};";
450   $self->throw_exception(
451     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
452   ) if $@;
453   my $storage = $storage_class->new;
454   $storage->connect_info(\@info);
455   $self->storage($storage);
456   return $self;
457 }
458
459 =head2 connect
460
461 =over 4
462
463 =item Arguments: @info
464
465 =item Return Value: $new_schema
466
467 =back
468
469 This is a convenience method. It is equivalent to calling
470 $schema->clone->connection(@info). See L</connection> and L</clone> for more
471 information.
472
473 =cut
474
475 sub connect { shift->clone->connection(@_) }
476
477 =head2 txn_begin
478
479 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
480 calling $schema->storage->txn_begin. See
481 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
482
483 =cut
484
485 sub txn_begin { shift->storage->txn_begin }
486
487 =head2 txn_commit
488
489 Commits the current transaction. Equivalent to calling
490 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
491 for more information.
492
493 =cut
494
495 sub txn_commit { shift->storage->txn_commit }
496
497 =head2 txn_rollback
498
499 Rolls back the current transaction. Equivalent to calling
500 $schema->storage->txn_rollback. See
501 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
502
503 =cut
504
505 sub txn_rollback { shift->storage->txn_rollback }
506
507 =head2 txn_do
508
509 =over 4
510
511 =item Arguments: C<$coderef>, @coderef_args?
512
513 =item Return Value: The return value of $coderef
514
515 =back
516
517 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
518 returning its result (if any). If an exception is caught, a rollback is issued
519 and the exception is rethrown. If the rollback fails, (i.e. throws an
520 exception) an exception is thrown that includes a "Rollback failed" message.
521
522 For example,
523
524   my $author_rs = $schema->resultset('Author')->find(1);
525   my @titles = qw/Night Day It/;
526
527   my $coderef = sub {
528     # If any one of these fails, the entire transaction fails
529     $author_rs->create_related('books', {
530       title => $_
531     }) foreach (@titles);
532
533     return $author->books;
534   };
535
536   my $rs;
537   eval {
538     $rs = $schema->txn_do($coderef);
539   };
540
541   if ($@) {                                  # Transaction failed
542     die "something terrible has happened!"   #
543       if ($@ =~ /Rollback failed/);          # Rollback failed
544
545     deal_with_failed_transaction();
546   }
547
548 In a nested transaction (calling txn_do() from within a txn_do() coderef) only
549 the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
550 the Schema's storage, and txn_do() can be called in void, scalar and list
551 context and it will behave as expected.
552
553 =cut
554
555 sub txn_do {
556   my ($self, $coderef, @args) = @_;
557
558   ref $self or $self->throw_exception
559     ('Cannot execute txn_do as a class method');
560   ref $coderef eq 'CODE' or $self->throw_exception
561     ('$coderef must be a CODE reference');
562
563   my (@return_values, $return_value);
564
565   $self->txn_begin; # If this throws an exception, no rollback is needed
566
567   my $wantarray = wantarray; # Need to save this since the context
568                              # inside the eval{} block is independent
569                              # of the context that called txn_do()
570   eval {
571
572     # Need to differentiate between scalar/list context to allow for
573     # returning a list in scalar context to get the size of the list
574     if ($wantarray) {
575       # list context
576       @return_values = $coderef->(@args);
577     } elsif (defined $wantarray) {
578       # scalar context
579       $return_value = $coderef->(@args);
580     } else {
581       # void context
582       $coderef->(@args);
583     }
584     $self->txn_commit;
585   };
586
587   if ($@) {
588     my $error = $@;
589
590     eval {
591       $self->txn_rollback;
592     };
593
594     if ($@) {
595       my $rollback_error = $@;
596       my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
597       $self->throw_exception($error)  # propagate nested rollback
598         if $rollback_error =~ /$exception_class/;
599
600       $self->throw_exception(
601         "Transaction aborted: $error. Rollback failed: ${rollback_error}"
602       );
603     } else {
604       $self->throw_exception($error); # txn failed but rollback succeeded
605     }
606   }
607
608   return $wantarray ? @return_values : $return_value;
609 }
610
611 =head2 clone
612
613 =over 4
614
615 =item Return Value: $new_schema
616
617 =back
618
619 Clones the schema and its associated result_source objects and returns the
620 copy.
621
622 =cut
623
624 sub clone {
625   my ($self) = @_;
626   my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
627   foreach my $moniker ($self->sources) {
628     my $source = $self->source($moniker);
629     my $new = $source->new($source);
630     $clone->register_source($moniker => $new);
631   }
632   return $clone;
633 }
634
635 =head2 populate
636
637 =over 4
638
639 =item Arguments: $moniker, \@data;
640
641 =back
642
643 Populates the source registered with the given moniker with the supplied data.
644 @data should be a list of listrefs -- the first containing column names, the
645 second matching values.
646
647 i.e.,
648
649   $schema->populate('Artist', [
650     [ qw/artistid name/ ],
651     [ 1, 'Popular Band' ],
652     [ 2, 'Indie Band' ],
653     ...
654   ]);
655
656 =cut
657
658 sub populate {
659   my ($self, $name, $data) = @_;
660   my $rs = $self->resultset($name);
661   my @names = @{shift(@$data)};
662   my @created;
663   foreach my $item (@$data) {
664     my %create;
665     @create{@names} = @$item;
666     push(@created, $rs->create(\%create));
667   }
668   return @created;
669 }
670
671 =head2 throw_exception
672
673 =over 4
674
675 =item Arguments: $message
676
677 =back
678
679 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
680 user's perspective.
681
682 =cut
683
684 sub throw_exception {
685   my ($self) = shift;
686   croak @_;
687 }
688
689 =head2 deploy (EXPERIMENTAL)
690
691 =over 4
692
693 =item Arguments: $sqlt_args
694
695 =back
696
697 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
698
699 Note that this feature is currently EXPERIMENTAL and may not work correctly
700 across all databases, or fully handle complex relationships.
701
702 =cut
703
704 sub deploy {
705   my ($self, $sqltargs) = @_;
706   $self->throw_exception("Can't deploy without storage") unless $self->storage;
707   $self->storage->deploy($self, undef, $sqltargs);
708 }
709
710 =head2 create_ddl_dir (EXPERIMENTAL)
711
712 =over 4
713
714 =item Arguments: \@databases, $version, $directory, $sqlt_args
715
716 =back
717
718 Creates an SQL file based on the Schema, for each of the specified
719 database types, in the given directory.
720
721 Note that this feature is currently EXPERIMENTAL and may not work correctly
722 across all databases, or fully handle complex relationships.
723
724 =cut
725
726 sub create_ddl_dir
727 {
728   my $self = shift;
729
730   $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
731   $self->storage->create_ddl_dir($self, @_);
732 }
733
734 sub ddl_filename
735 {
736     my ($self, $type, $dir, $version) = @_;
737
738     my $filename = ref($self);
739     $filename =~ s/^.*:://;
740     $filename = "$dir$filename-$version-$type.sql";
741
742     return $filename;
743 }
744
745 1;
746
747 =head1 AUTHORS
748
749 Matt S. Trout <mst@shadowcatsystems.co.uk>
750
751 =head1 LICENSE
752
753 You may distribute this code under the same terms as Perl itself.
754
755 =cut
756