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}; }
176 my $storage = $schema->storage;
178 Returns the L<DBIx::Class::Storage> object for this Schema.
184 =item Arguments: $moniker
186 =item Return Value: $result_set
190 my $rs = $schema->resultset('DVD');
192 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
197 my ($self, $moniker) = @_;
198 return $self->source($moniker)->resultset;
205 =item Arguments: @classes?, { $namespace => [ @classes ] }+
209 With no arguments, this method uses L<Module::Find> to find all classes under
210 the schema's namespace. Otherwise, this method loads the classes you specify
211 (using L<use>), and registers them (using L</"register_class">).
213 It is possible to comment out classes with a leading C<#>, but note that perl
214 will think it's a mistake (trying to use a comment in a qw list), so you'll
215 need to add C<no warnings 'qw';> before your load_classes call.
219 My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
220 # etc. (anything under the My::Schema namespace)
222 # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
223 # not Other::Namespace::LinerNotes nor My::Schema::Track
224 My::Schema->load_classes(qw/ CD Artist #Track /, {
225 Other::Namespace => [qw/ Producer #LinerNotes /],
231 my ($class, @params) = @_;
236 foreach my $param (@params) {
237 if (ref $param eq 'ARRAY') {
238 # filter out commented entries
239 my @modules = grep { $_ !~ /^#/ } @$param;
241 push (@{$comps_for{$class}}, @modules);
243 elsif (ref $param eq 'HASH') {
244 # more than one namespace possible
245 for my $comp ( keys %$param ) {
246 # filter out commented entries
247 my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
249 push (@{$comps_for{$comp}}, @modules);
253 # filter out commented entries
254 push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
258 my @comp = map { substr $_, length "${class}::" }
259 Module::Find::findallmod($class);
260 $comps_for{$class} = \@comp;
265 no warnings qw/redefine/;
266 local *Class::C3::reinitialize = sub { };
267 foreach my $prefix (keys %comps_for) {
268 foreach my $comp (@{$comps_for{$prefix}||[]}) {
269 my $comp_class = "${prefix}::${comp}";
270 $class->ensure_class_loaded($comp_class);
271 $comp_class->source_name($comp) unless $comp_class->source_name;
273 push(@to_register, [ $comp_class->source_name, $comp_class ]);
277 Class::C3->reinitialize;
279 foreach my $to (@to_register) {
280 $class->register_class(@$to);
281 # if $class->can('result_source_instance');
285 =head2 load_namespaces
289 =item Arguments: %options?
293 This is an alternative to L</load_classes> above which assumes an alternative
294 layout for automatic class loading. It assumes that all result
295 classes are underneath a sub-namespace of the schema called C<Result>, any
296 corresponding ResultSet classes are underneath a sub-namespace of the schema
299 Both of the sub-namespaces are configurable if you don't like the defaults,
300 via the options C<result_namespace> and C<resultset_namespace>.
302 If (and only if) you specify the option C<default_resultset_class>, any found
303 Result classes for which we do not find a corresponding
304 ResultSet class will have their C<resultset_class> set to
305 C<default_resultset_class>.
307 C<load_namespaces> takes care of calling C<resultset_class> for you where
308 neccessary if you didn't do it for yourself.
310 All of the namespace and classname options to this method are relative to
311 the schema classname by default. To specify a fully-qualified name, prefix
312 it with a literal C<+>.
316 # load My::Schema::Result::CD, My::Schema::Result::Artist,
317 # My::Schema::ResultSet::CD, etc...
318 My::Schema->load_namespaces;
320 # Override everything to use ugly names.
321 # In this example, if there is a My::Schema::Res::Foo, but no matching
322 # My::Schema::RSets::Foo, then Foo will have its
323 # resultset_class set to My::Schema::RSetBase
324 My::Schema->load_namespaces(
325 result_namespace => 'Res',
326 resultset_namespace => 'RSets',
327 default_resultset_class => 'RSetBase',
330 # Put things in other namespaces
331 My::Schema->load_namespaces(
332 result_namespace => '+Some::Place::Results',
333 resultset_namespace => '+Another::Place::RSets',
336 If you'd like to use multiple namespaces of each type, simply use an arrayref
337 of namespaces for that option. In the case that the same result
338 (or resultset) class exists in multiple namespaces, the latter entries in
339 your list of namespaces will override earlier ones.
341 My::Schema->load_namespaces(
342 # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
343 result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
344 resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
349 # Pre-pends our classname to the given relative classname or
350 # class namespace, unless there is a '+' prefix, which will
352 sub _expand_relative_name {
353 my ($class, $name) = @_;
355 $name = $class . '::' . $name if ! ($name =~ s/^\+//);
359 # returns a hash of $shortname => $fullname for every package
360 # found in the given namespaces ($shortname is with the $fullname's
361 # namespace stripped off)
362 sub _map_namespaces {
363 my ($class, @namespaces) = @_;
366 foreach my $namespace (@namespaces) {
369 map { (substr($_, length "${namespace}::"), $_) }
370 Module::Find::findallmod($namespace)
377 sub load_namespaces {
378 my ($class, %args) = @_;
380 my $result_namespace = delete $args{result_namespace} || 'Result';
381 my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
382 my $default_resultset_class = delete $args{default_resultset_class};
384 $class->throw_exception('load_namespaces: unknown option(s): '
385 . join(q{,}, map { qq{'$_'} } keys %args))
386 if scalar keys %args;
388 $default_resultset_class
389 = $class->_expand_relative_name($default_resultset_class);
391 for my $arg ($result_namespace, $resultset_namespace) {
392 $arg = [ $arg ] if !ref($arg) && $arg;
394 $class->throw_exception('load_namespaces: namespace arguments must be '
395 . 'a simple string or an arrayref')
396 if ref($arg) ne 'ARRAY';
398 $_ = $class->_expand_relative_name($_) for (@$arg);
401 my %results = $class->_map_namespaces(@$result_namespace);
402 my %resultsets = $class->_map_namespaces(@$resultset_namespace);
406 no warnings 'redefine';
407 local *Class::C3::reinitialize = sub { };
408 use warnings 'redefine';
410 foreach my $result (keys %results) {
411 my $result_class = $results{$result};
412 $class->ensure_class_loaded($result_class);
413 $result_class->source_name($result) unless $result_class->source_name;
415 my $rs_class = delete $resultsets{$result};
416 my $rs_set = $result_class->resultset_class;
417 if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
418 if($rs_class && $rs_class ne $rs_set) {
419 warn "We found ResultSet class '$rs_class' for '$result', but it seems "
420 . "that you had already set '$result' to use '$rs_set' instead";
423 elsif($rs_class ||= $default_resultset_class) {
424 $class->ensure_class_loaded($rs_class);
425 $result_class->resultset_class($rs_class);
428 push(@to_register, [ $result_class->source_name, $result_class ]);
432 foreach (sort keys %resultsets) {
433 warn "load_namespaces found ResultSet class $_ with no "
434 . 'corresponding Result class';
437 Class::C3->reinitialize;
438 $class->register_class(@$_) for (@to_register);
443 =head2 compose_connection
447 =item Arguments: $target_namespace, @db_info
449 =item Return Value: $new_schema
453 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
454 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
455 then injects the L<DBix::Class::ResultSetProxy> component and a
456 resultset_instance classdata entry on all the new classes, in order to support
457 $target_namespaces::$class->search(...) method calls.
459 This is primarily useful when you have a specific need for class method access
460 to a connection. In normal usage it is preferred to call
461 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
462 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
467 sub compose_connection {
468 my ($self, $target, @info) = @_;
469 my $base = 'DBIx::Class::ResultSetProxy';
470 eval "require ${base};";
471 $self->throw_exception
472 ("No arguments to load_classes and couldn't load ${base} ($@)")
475 if ($self eq $target) {
476 # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
477 foreach my $moniker ($self->sources) {
478 my $source = $self->source($moniker);
479 my $class = $source->result_class;
480 $self->inject_base($class, $base);
481 $class->mk_classdata(resultset_instance => $source->resultset);
482 $class->mk_classdata(class_resolver => $self);
484 $self->connection(@info);
488 my $schema = $self->compose_namespace($target, $base);
491 *{"${target}::schema"} = sub { $schema };
494 $schema->connection(@info);
495 foreach my $moniker ($schema->sources) {
496 my $source = $schema->source($moniker);
497 my $class = $source->result_class;
498 #warn "$moniker $class $source ".$source->storage;
499 $class->mk_classdata(result_source_instance => $source);
500 $class->mk_classdata(resultset_instance => $source->resultset);
501 $class->mk_classdata(class_resolver => $schema);
506 =head2 compose_namespace
510 =item Arguments: $target_namespace, $additional_base_class?
512 =item Return Value: $new_schema
516 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
517 class in the target namespace (e.g. $target_namespace::CD,
518 $target_namespace::Artist) that inherits from the corresponding classes
519 attached to the current schema.
521 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
522 new $schema object. If C<$additional_base_class> is given, the new composed
523 classes will inherit from first the corresponding classe from the current
524 schema then the base class.
526 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
528 $schema->compose_namespace('My::DB', 'Base::Class');
529 print join (', ', @My::DB::CD::ISA) . "\n";
530 print join (', ', @My::DB::Artist::ISA) ."\n";
532 will produce the output
534 My::Schema::CD, Base::Class
535 My::Schema::Artist, Base::Class
539 sub compose_namespace {
540 my ($self, $target, $base) = @_;
541 my %reg = %{ $self->source_registrations };
544 my $schema = $self->clone;
546 no warnings qw/redefine/;
547 local *Class::C3::reinitialize = sub { };
548 foreach my $moniker ($schema->sources) {
549 my $source = $schema->source($moniker);
550 my $target_class = "${target}::${moniker}";
552 $target_class => $source->result_class, ($base ? $base : ())
554 $source->result_class($target_class);
555 $target_class->result_source_instance($source)
556 if $target_class->can('result_source_instance');
559 Class::C3->reinitialize();
562 foreach my $meth (qw/class source resultset/) {
563 *{"${target}::${meth}"} =
564 sub { shift->schema->$meth(@_) };
570 =head2 setup_connection_class
574 =item Arguments: $target, @info
578 Sets up a database connection class to inject between the schema and the
579 subclasses that the schema creates.
583 sub setup_connection_class {
584 my ($class, $target, @info) = @_;
585 $class->inject_base($target => 'DBIx::Class::DB');
586 #$target->load_components('DB');
587 $target->connection(@info);
594 =item Arguments: @args
596 =item Return Value: $new_schema
600 Instantiates a new Storage object of type
601 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
602 $storage->connect_info. Sets the connection in-place on the schema.
604 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
605 or L<DBIx::Class::Storage> in general.
610 my ($self, @info) = @_;
611 return $self if !@info && $self->storage;
612 my $storage_class = $self->storage_type;
613 $storage_class = 'DBIx::Class::Storage'.$storage_class
614 if $storage_class =~ m/^::/;
615 eval "require ${storage_class};";
616 $self->throw_exception(
617 "No arguments to load_classes and couldn't load ${storage_class} ($@)"
619 my $storage = $storage_class->new($self);
620 $storage->connect_info(\@info);
621 $self->storage($storage);
629 =item Arguments: @info
631 =item Return Value: $new_schema
635 This is a convenience method. It is equivalent to calling
636 $schema->clone->connection(@info). See L</connection> and L</clone> for more
641 sub connect { shift->clone->connection(@_) }
647 =item Arguments: C<$coderef>, @coderef_args?
649 =item Return Value: The return value of $coderef
653 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
654 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
655 See L<DBIx::Class::Storage/"txn_do"> for more information.
657 This interface is preferred over using the individual methods L</txn_begin>,
658 L</txn_commit>, and L</txn_rollback> below.
665 $self->storage or $self->throw_exception
666 ('txn_do called on $schema without storage');
668 $self->storage->txn_do(@_);
673 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
674 calling $schema->storage->txn_begin. See
675 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
682 $self->storage or $self->throw_exception
683 ('txn_begin called on $schema without storage');
685 $self->storage->txn_begin;
690 Commits the current transaction. Equivalent to calling
691 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
692 for more information.
699 $self->storage or $self->throw_exception
700 ('txn_commit called on $schema without storage');
702 $self->storage->txn_commit;
707 Rolls back the current transaction. Equivalent to calling
708 $schema->storage->txn_rollback. See
709 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
716 $self->storage or $self->throw_exception
717 ('txn_rollback called on $schema without storage');
719 $self->storage->txn_rollback;
726 =item Return Value: $new_schema
730 Clones the schema and its associated result_source objects and returns the
737 my $clone = { (ref $self ? %$self : ()) };
738 bless $clone, (ref $self || $self);
740 foreach my $moniker ($self->sources) {
741 my $source = $self->source($moniker);
742 my $new = $source->new($source);
743 $clone->register_source($moniker => $new);
745 $clone->storage->set_schema($clone) if $clone->storage;
753 =item Arguments: $moniker, \@data;
757 Populates the source registered with the given moniker with the supplied data.
758 @data should be a list of listrefs -- the first containing column names, the
759 second matching values.
763 $schema->populate('Artist', [
764 [ qw/artistid name/ ],
765 [ 1, 'Popular Band' ],
773 my ($self, $name, $data) = @_;
774 my $rs = $self->resultset($name);
775 my @names = @{shift(@$data)};
777 foreach my $item (@$data) {
779 @create{@names} = @$item;
780 push(@created, $rs->create(\%create));
785 =head2 exception_action
789 =item Arguments: $code_reference
793 If C<exception_action> is set for this class/object, L</throw_exception>
794 will prefer to call this code reference with the exception as an argument,
795 rather than its normal <croak> action.
797 Your subroutine should probably just wrap the error in the exception
798 object/class of your choosing and rethrow. If, against all sage advice,
799 you'd like your C<exception_action> to suppress a particular exception
800 completely, simply have it return true.
805 use base qw/DBIx::Class::Schema/;
806 use My::ExceptionClass;
807 __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
808 __PACKAGE__->load_classes;
811 my $schema_obj = My::Schema->connect( .... );
812 $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
814 # suppress all exceptions, like a moron:
815 $schema_obj->exception_action(sub { 1 });
817 =head2 throw_exception
821 =item Arguments: $message
825 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
826 user's perspective. See L</exception_action> for details on overriding
827 this method's behavior.
831 sub throw_exception {
833 croak @_ if !$self->exception_action || !$self->exception_action->(@_);
836 =head2 deploy (EXPERIMENTAL)
840 =item Arguments: $sqlt_args, $dir
844 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
846 Note that this feature is currently EXPERIMENTAL and may not work correctly
847 across all databases, or fully handle complex relationships.
849 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
850 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
851 produced include a DROP TABLE statement for each table created.
856 my ($self, $sqltargs, $dir) = @_;
857 $self->throw_exception("Can't deploy without storage") unless $self->storage;
858 $self->storage->deploy($self, undef, $sqltargs, $dir);
861 =head2 create_ddl_dir (EXPERIMENTAL)
865 =item Arguments: \@databases, $version, $directory, $sqlt_args
869 Creates an SQL file based on the Schema, for each of the specified
870 database types, in the given directory.
872 Note that this feature is currently EXPERIMENTAL and may not work correctly
873 across all databases, or fully handle complex relationships.
880 $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
881 $self->storage->create_ddl_dir($self, @_);
884 =head2 ddl_filename (EXPERIMENTAL)
886 my $filename = $table->ddl_filename($type, $dir, $version)
888 Creates a filename for a SQL file based on the table class name. Not
889 intended for direct end user use.
894 my ($self, $type, $dir, $version) = @_;
896 my $filename = ref($self);
897 $filename =~ s/::/-/;
898 $filename = "$dir$filename-$version-$type.sql";
907 Matt S. Trout <mst@shadowcatsystems.co.uk>
911 You may distribute this code under the same terms as Perl itself.