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