1 package DBIx::Class::Schema;
6 use Carp::Clan qw/^DBIx::Class/;
7 use Scalar::Util qw/weaken/;
10 use base qw/DBIx::Class/;
12 __PACKAGE__->mk_classdata('class_mappings' => {});
13 __PACKAGE__->mk_classdata('source_registrations' => {});
14 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
15 __PACKAGE__->mk_classdata('storage');
16 __PACKAGE__->mk_classdata('exception_action');
20 DBIx::Class::Schema - composable schemas
24 package Library::Schema;
25 use base qw/DBIx::Class::Schema/;
27 # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
28 __PACKAGE__->load_classes(qw/CD Book DVD/);
30 package Library::Schema::CD;
31 use base qw/DBIx::Class/;
32 __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
33 __PACKAGE__->table('cd');
35 # Elsewhere in your code:
36 my $schema1 = Library::Schema->connect(
43 my $schema2 = Library::Schema->connect($coderef_returning_dbh);
45 # fetch objects using Library::Schema::DVD
46 my $resultset = $schema1->resultset('DVD')->search( ... );
47 my @dvd_objects = $schema2->resultset('DVD')->search( ... );
51 Creates database classes based on a schema. This is the recommended way to
52 use L<DBIx::Class> and allows you to use more than one concurrent connection
55 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
56 carefully, as DBIx::Class does things a little differently. Note in
57 particular which module inherits off which.
65 =item Arguments: $moniker, $component_class
69 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
72 $schema->register_source($moniker, $component_class->result_source_instance);
77 my ($self, $moniker, $to_register) = @_;
78 $self->register_source($moniker => $to_register->result_source_instance);
81 =head2 register_source
85 =item Arguments: $moniker, $result_source
89 Registers the L<DBIx::Class::ResultSource> in the schema with the given
95 my ($self, $moniker, $source) = @_;
96 my %reg = %{$self->source_registrations};
97 $reg{$moniker} = $source;
98 $self->source_registrations(\%reg);
99 $source->schema($self);
100 weaken($source->{schema}) if ref($self);
101 if ($source->result_class) {
102 my %map = %{$self->class_mappings};
103 $map{$source->result_class} = $moniker;
104 $self->class_mappings(\%map);
112 =item Arguments: $moniker
114 =item Return Value: $classname
118 Retrieves the result class name for the given moniker. For example:
120 my $class = $schema->class('CD');
125 my ($self, $moniker) = @_;
126 return $self->source($moniker)->result_class;
133 =item Arguments: $moniker
135 =item Return Value: $result_source
139 my $source = $schema->source('Book');
141 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
146 my ($self, $moniker) = @_;
147 my $sreg = $self->source_registrations;
148 return $sreg->{$moniker} if exists $sreg->{$moniker};
150 # if we got here, they probably passed a full class name
151 my $mapped = $self->class_mappings->{$moniker};
152 $self->throw_exception("Can't find source for ${moniker}")
153 unless $mapped && exists $sreg->{$mapped};
154 return $sreg->{$mapped};
161 =item Return Value: @source_monikers
165 Returns the source monikers of all source registrations on this schema.
168 my @source_monikers = $schema->sources;
172 sub sources { return keys %{shift->source_registrations}; }
178 =item Arguments: $moniker
180 =item Return Value: $result_set
184 my $rs = $schema->resultset('DVD');
186 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
191 my ($self, $moniker) = @_;
192 return $self->source($moniker)->resultset;
199 =item Arguments: @classes?, { $namespace => [ @classes ] }+
203 With no arguments, this method uses L<Module::Find> to find all classes under
204 the schema's namespace. Otherwise, this method loads the classes you specify
205 (using L<use>), and registers them (using L</"register_class">).
207 It is possible to comment out classes with a leading C<#>, but note that perl
208 will think it's a mistake (trying to use a comment in a qw list), so you'll
209 need to add C<no warnings 'qw';> before your load_classes call.
213 My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
214 # etc. (anything under the My::Schema namespace)
216 # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
217 # not Other::Namespace::LinerNotes nor My::Schema::Track
218 My::Schema->load_classes(qw/ CD Artist #Track /, {
219 Other::Namespace => [qw/ Producer #LinerNotes /],
225 my ($class, @params) = @_;
230 foreach my $param (@params) {
231 if (ref $param eq 'ARRAY') {
232 # filter out commented entries
233 my @modules = grep { $_ !~ /^#/ } @$param;
235 push (@{$comps_for{$class}}, @modules);
237 elsif (ref $param eq 'HASH') {
238 # more than one namespace possible
239 for my $comp ( keys %$param ) {
240 # filter out commented entries
241 my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
243 push (@{$comps_for{$comp}}, @modules);
247 # filter out commented entries
248 push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
252 my @comp = map { substr $_, length "${class}::" }
253 Module::Find::findallmod($class);
254 $comps_for{$class} = \@comp;
259 no warnings qw/redefine/;
260 local *Class::C3::reinitialize = sub { };
261 foreach my $prefix (keys %comps_for) {
262 foreach my $comp (@{$comps_for{$prefix}||[]}) {
263 my $comp_class = "${prefix}::${comp}";
264 $class->ensure_class_loaded($comp_class);
265 $comp_class->source_name($comp) unless $comp_class->source_name;
267 push(@to_register, [ $comp_class->source_name, $comp_class ]);
271 Class::C3->reinitialize;
273 foreach my $to (@to_register) {
274 $class->register_class(@$to);
275 # if $class->can('result_source_instance');
279 =head2 load_namespaces
283 =item Arguments: %options?
287 This is an alternative to L</load_classes> above which assumes an alternative
288 layout for automatic class loading. It assumes that all result
289 classes are underneath a sub-namespace of the schema called C<Result>, any
290 corresponding ResultSet classes are underneath a sub-namespace of the schema
293 Both of the sub-namespaces are configurable if you don't like the defaults,
294 via the options C<result_namespace> and C<resultset_namespace>.
296 If (and only if) you specify the option C<default_resultset_class>, any found
297 Result classes for which we do not find a corresponding
298 ResultSet class will have their C<resultset_class> set to
299 C<default_resultset_class>.
301 C<load_namespaces> takes care of calling C<resultset_class> for you where
302 neccessary if you didn't do it for yourself.
304 All of the namespace and classname options to this method are relative to
305 the schema classname by default. To specify a fully-qualified name, prefix
306 it with a literal C<+>.
310 # load My::Schema::Result::CD, My::Schema::Result::Artist,
311 # My::Schema::ResultSet::CD, etc...
312 My::Schema->load_namespaces;
314 # Override everything to use ugly names.
315 # In this example, if there is a My::Schema::Res::Foo, but no matching
316 # My::Schema::RSets::Foo, then Foo will have its
317 # resultset_class set to My::Schema::RSetBase
318 My::Schema->load_namespaces(
319 result_namespace => 'Res',
320 resultset_namespace => 'RSets',
321 default_resultset_class => 'RSetBase',
324 # Put things in other namespaces
325 My::Schema->load_namespaces(
326 result_namespace => '+Some::Place::Results',
327 resultset_namespace => '+Another::Place::RSets',
330 If you'd like to use multiple namespaces of each type, simply use an arrayref
331 of namespaces for that option. In the case that the same result
332 (or resultset) class exists in multiple namespaces, the latter entries in
333 your list of namespaces will override earlier ones.
335 My::Schema->load_namespaces(
336 # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
337 result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
338 resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
343 # Pre-pends our classname to the given relative classname or
344 # class namespace, unless there is a '+' prefix, which will
346 sub _expand_relative_name {
347 my ($class, $name) = @_;
349 $name = $class . '::' . $name if ! ($name =~ s/^\+//);
353 # returns a hash of $shortname => $fullname for every package
354 # found in the given namespaces ($shortname is with the $fullname's
355 # namespace stripped off)
356 sub _map_namespaces {
357 my ($class, @namespaces) = @_;
360 foreach my $namespace (@namespaces) {
363 map { (substr($_, length "${namespace}::"), $_) }
364 Module::Find::findallmod($namespace)
371 sub load_namespaces {
372 my ($class, %args) = @_;
374 my $result_namespace = delete $args{result_namespace} || 'Result';
375 my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
376 my $default_resultset_class = delete $args{default_resultset_class};
378 $class->throw_exception('load_namespaces: unknown option(s): '
379 . join(q{,}, map { qq{'$_'} } keys %args))
380 if scalar keys %args;
382 $default_resultset_class
383 = $class->_expand_relative_name($default_resultset_class);
385 for my $arg ($result_namespace, $resultset_namespace) {
386 $arg = [ $arg ] if !ref($arg) && $arg;
388 $class->throw_exception('load_namespaces: namespace arguments must be '
389 . 'a simple string or an arrayref')
390 if ref($arg) ne 'ARRAY';
392 $_ = $class->_expand_relative_name($_) for (@$arg);
395 my %results = $class->_map_namespaces(@$result_namespace);
396 my %resultsets = $class->_map_namespaces(@$resultset_namespace);
400 no warnings 'redefine';
401 local *Class::C3::reinitialize = sub { };
402 use warnings 'redefine';
404 foreach my $result (keys %results) {
405 my $result_class = $results{$result};
406 $class->ensure_class_loaded($result_class);
407 $result_class->source_name($result) unless $result_class->source_name;
409 my $rs_class = delete $resultsets{$result};
410 my $rs_set = $result_class->resultset_class;
411 if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
412 if($rs_class && $rs_class ne $rs_set) {
413 warn "We found ResultSet class '$rs_class' for '$result', but it seems "
414 . "that you had already set '$result' to use '$rs_set' instead";
417 elsif($rs_class ||= $default_resultset_class) {
418 $class->ensure_class_loaded($rs_class);
419 $result_class->resultset_class($rs_class);
422 push(@to_register, [ $result_class->source_name, $result_class ]);
426 foreach (sort keys %resultsets) {
427 warn "load_namespaces found ResultSet class $_ with no "
428 . 'corresponding Result class';
431 Class::C3->reinitialize;
432 $class->register_class(@$_) for (@to_register);
437 =head2 compose_connection
441 =item Arguments: $target_namespace, @db_info
443 =item Return Value: $new_schema
447 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
448 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
449 then injects the L<DBix::Class::ResultSetProxy> component and a
450 resultset_instance classdata entry on all the new classes, in order to support
451 $target_namespaces::$class->search(...) method calls.
453 This is primarily useful when you have a specific need for class method access
454 to a connection. In normal usage it is preferred to call
455 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
456 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
461 sub compose_connection {
462 my ($self, $target, @info) = @_;
463 my $base = 'DBIx::Class::ResultSetProxy';
464 eval "require ${base};";
465 $self->throw_exception
466 ("No arguments to load_classes and couldn't load ${base} ($@)")
469 if ($self eq $target) {
470 # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
471 foreach my $moniker ($self->sources) {
472 my $source = $self->source($moniker);
473 my $class = $source->result_class;
474 $self->inject_base($class, $base);
475 $class->mk_classdata(resultset_instance => $source->resultset);
476 $class->mk_classdata(class_resolver => $self);
478 $self->connection(@info);
482 my $schema = $self->compose_namespace($target, $base);
485 *{"${target}::schema"} = sub { $schema };
488 $schema->connection(@info);
489 foreach my $moniker ($schema->sources) {
490 my $source = $schema->source($moniker);
491 my $class = $source->result_class;
492 #warn "$moniker $class $source ".$source->storage;
493 $class->mk_classdata(result_source_instance => $source);
494 $class->mk_classdata(resultset_instance => $source->resultset);
495 $class->mk_classdata(class_resolver => $schema);
500 =head2 compose_namespace
504 =item Arguments: $target_namespace, $additional_base_class?
506 =item Return Value: $new_schema
510 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
511 class in the target namespace (e.g. $target_namespace::CD,
512 $target_namespace::Artist) that inherits from the corresponding classes
513 attached to the current schema.
515 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
516 new $schema object. If C<$additional_base_class> is given, the new composed
517 classes will inherit from first the corresponding classe from the current
518 schema then the base class.
520 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
522 $schema->compose_namespace('My::DB', 'Base::Class');
523 print join (', ', @My::DB::CD::ISA) . "\n";
524 print join (', ', @My::DB::Artist::ISA) ."\n";
526 will produce the output
528 My::Schema::CD, Base::Class
529 My::Schema::Artist, Base::Class
533 sub compose_namespace {
534 my ($self, $target, $base) = @_;
535 my %reg = %{ $self->source_registrations };
538 my $schema = $self->clone;
540 no warnings qw/redefine/;
541 local *Class::C3::reinitialize = sub { };
542 foreach my $moniker ($schema->sources) {
543 my $source = $schema->source($moniker);
544 my $target_class = "${target}::${moniker}";
546 $target_class => $source->result_class, ($base ? $base : ())
548 $source->result_class($target_class);
549 $target_class->result_source_instance($source)
550 if $target_class->can('result_source_instance');
553 Class::C3->reinitialize();
556 foreach my $meth (qw/class source resultset/) {
557 *{"${target}::${meth}"} =
558 sub { shift->schema->$meth(@_) };
564 =head2 setup_connection_class
568 =item Arguments: $target, @info
572 Sets up a database connection class to inject between the schema and the
573 subclasses that the schema creates.
577 sub setup_connection_class {
578 my ($class, $target, @info) = @_;
579 $class->inject_base($target => 'DBIx::Class::DB');
580 #$target->load_components('DB');
581 $target->connection(@info);
588 =item Arguments: @args
590 =item Return Value: $new_schema
594 Instantiates a new Storage object of type
595 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
596 $storage->connect_info. Sets the connection in-place on the schema.
598 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
599 or L<DBIx::Class::Storage> in general.
604 my ($self, @info) = @_;
605 return $self if !@info && $self->storage;
606 my $storage_class = $self->storage_type;
607 $storage_class = 'DBIx::Class::Storage'.$storage_class
608 if $storage_class =~ m/^::/;
609 eval "require ${storage_class};";
610 $self->throw_exception(
611 "No arguments to load_classes and couldn't load ${storage_class} ($@)"
613 my $storage = $storage_class->new($self);
614 $storage->connect_info(\@info);
615 $self->storage($storage);
623 =item Arguments: @info
625 =item Return Value: $new_schema
629 This is a convenience method. It is equivalent to calling
630 $schema->clone->connection(@info). See L</connection> and L</clone> for more
635 sub connect { shift->clone->connection(@_) }
641 =item Arguments: C<$coderef>, @coderef_args?
643 =item Return Value: The return value of $coderef
647 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
648 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
649 See L<DBIx::Class::Storage/"txn_do"> for more information.
651 This interface is preferred over using the individual methods L</txn_begin>,
652 L</txn_commit>, and L</txn_rollback> below.
659 $self->storage or $self->throw_exception
660 ('txn_do called on $schema without storage');
662 $self->storage->txn_do(@_);
667 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
668 calling $schema->storage->txn_begin. See
669 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
676 $self->storage or $self->throw_exception
677 ('txn_begin called on $schema without storage');
679 $self->storage->txn_begin;
684 Commits the current transaction. Equivalent to calling
685 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
686 for more information.
693 $self->storage or $self->throw_exception
694 ('txn_commit called on $schema without storage');
696 $self->storage->txn_commit;
701 Rolls back the current transaction. Equivalent to calling
702 $schema->storage->txn_rollback. See
703 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
710 $self->storage or $self->throw_exception
711 ('txn_rollback called on $schema without storage');
713 $self->storage->txn_rollback;
720 =item Return Value: $new_schema
724 Clones the schema and its associated result_source objects and returns the
731 my $clone = { (ref $self ? %$self : ()) };
732 bless $clone, (ref $self || $self);
734 foreach my $moniker ($self->sources) {
735 my $source = $self->source($moniker);
736 my $new = $source->new($source);
737 $clone->register_source($moniker => $new);
739 $clone->storage->set_schema($clone) if $clone->storage;
747 =item Arguments: $moniker, \@data;
751 Populates the source registered with the given moniker with the supplied data.
752 @data should be a list of listrefs -- the first containing column names, the
753 second matching values.
757 $schema->populate('Artist', [
758 [ qw/artistid name/ ],
759 [ 1, 'Popular Band' ],
767 my ($self, $name, $data) = @_;
768 my $rs = $self->resultset($name);
769 my @names = @{shift(@$data)};
771 foreach my $item (@$data) {
773 @create{@names} = @$item;
774 push(@created, $rs->create(\%create));
779 =head2 exception_action
783 =item Arguments: $code_reference
787 If C<exception_action> is set for this class/object, L</throw_exception>
788 will prefer to call this code reference with the exception as an argument,
789 rather than its normal <croak> action.
791 Your subroutine should probably just wrap the error in the exception
792 object/class of your choosing and rethrow. If, against all sage advice,
793 you'd like your C<exception_action> to suppress a particular exception
794 completely, simply have it return true.
799 use base qw/DBIx::Class::Schema/;
800 use My::ExceptionClass;
801 __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
802 __PACKAGE__->load_classes;
805 my $schema_obj = My::Schema->connect( .... );
806 $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
808 # suppress all exceptions, like a moron:
809 $schema_obj->exception_action(sub { 1 });
811 =head2 throw_exception
815 =item Arguments: $message
819 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
820 user's perspective. See L</exception_action> for details on overriding
821 this method's behavior.
825 sub throw_exception {
827 croak @_ if !$self->exception_action || !$self->exception_action->(@_);
830 =head2 deploy (EXPERIMENTAL)
834 =item Arguments: $sqlt_args, $dir
838 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
840 Note that this feature is currently EXPERIMENTAL and may not work correctly
841 across all databases, or fully handle complex relationships.
843 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
844 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
845 produced include a DROP TABLE statement for each table created.
850 my ($self, $sqltargs, $dir) = @_;
851 $self->throw_exception("Can't deploy without storage") unless $self->storage;
852 $self->storage->deploy($self, undef, $sqltargs, $dir);
855 =head2 create_ddl_dir (EXPERIMENTAL)
859 =item Arguments: \@databases, $version, $directory, $sqlt_args
863 Creates an SQL file based on the Schema, for each of the specified
864 database types, in the given directory.
866 Note that this feature is currently EXPERIMENTAL and may not work correctly
867 across all databases, or fully handle complex relationships.
874 $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
875 $self->storage->create_ddl_dir($self, @_);
878 =head2 ddl_filename (EXPERIMENTAL)
880 my $filename = $table->ddl_filename($type, $dir, $version)
882 Creates a filename for a SQL file based on the table class name. Not
883 intended for direct end user use.
888 my ($self, $type, $dir, $version) = @_;
890 my $filename = ref($self);
891 $filename =~ s/::/-/;
892 $filename = "$dir$filename-$version-$type.sql";
901 Matt S. Trout <mst@shadowcatsystems.co.uk>
905 You may distribute this code under the same terms as Perl itself.