1 package DBIx::Class::Schema;
6 use Carp::Clan qw/^DBIx::Class/;
7 use Scalar::Util qw/weaken/;
11 use base qw/DBIx::Class/;
13 __PACKAGE__->mk_classdata('class_mappings' => {});
14 __PACKAGE__->mk_classdata('source_registrations' => {});
15 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
16 __PACKAGE__->mk_classdata('storage');
17 __PACKAGE__->mk_classdata('exception_action');
21 DBIx::Class::Schema - composable schemas
25 package Library::Schema;
26 use base qw/DBIx::Class::Schema/;
28 # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD
29 __PACKAGE__->load_classes(qw/CD Book DVD/);
31 package Library::Schema::CD;
32 use base qw/DBIx::Class/;
33 __PACKAGE__->load_components(qw/PK::Auto Core/); # for example
34 __PACKAGE__->table('cd');
36 # Elsewhere in your code:
37 my $schema1 = Library::Schema->connect(
44 my $schema2 = Library::Schema->connect($coderef_returning_dbh);
46 # fetch objects using Library::Schema::DVD
47 my $resultset = $schema1->resultset('DVD')->search( ... );
48 my @dvd_objects = $schema2->resultset('DVD')->search( ... );
52 Creates database classes based on a schema. This is the recommended way to
53 use L<DBIx::Class> and allows you to use more than one concurrent connection
56 NB: If you're used to L<Class::DBI> it's worth reading the L</SYNOPSIS>
57 carefully, as DBIx::Class does things a little differently. Note in
58 particular which module inherits off which.
66 =item Arguments: $moniker, $component_class
70 Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to
73 $schema->register_source($moniker, $component_class->result_source_instance);
78 my ($self, $moniker, $to_register) = @_;
79 $self->register_source($moniker => $to_register->result_source_instance);
82 =head2 register_source
86 =item Arguments: $moniker, $result_source
90 Registers the L<DBIx::Class::ResultSource> in the schema with the given
96 my ($self, $moniker, $source) = @_;
98 %$source = %{ $source->new( { %$source, source_name => $moniker }) };
100 $self->source_registrations->{$moniker} = $source;
102 $source->schema($self);
104 weaken($source->{schema}) if ref($self);
105 if ($source->result_class) {
106 $self->class_mappings->{$source->result_class} = $moniker;
110 sub _unregister_source {
111 my ($self, $moniker) = @_;
112 my %reg = %{$self->source_registrations};
114 my $source = delete $reg{$moniker};
115 $self->source_registrations(\%reg);
116 if ($source->result_class) {
117 my %map = %{$self->class_mappings};
118 delete $map{$source->result_class};
119 $self->class_mappings(\%map);
127 =item Arguments: $moniker
129 =item Return Value: $classname
133 Retrieves the result class name for the given moniker. For example:
135 my $class = $schema->class('CD');
140 my ($self, $moniker) = @_;
141 return $self->source($moniker)->result_class;
148 =item Arguments: $moniker
150 =item Return Value: $result_source
154 my $source = $schema->source('Book');
156 Returns the L<DBIx::Class::ResultSource> object for the registered moniker.
161 my ($self, $moniker) = @_;
162 my $sreg = $self->source_registrations;
163 return $sreg->{$moniker} if exists $sreg->{$moniker};
165 # if we got here, they probably passed a full class name
166 my $mapped = $self->class_mappings->{$moniker};
167 $self->throw_exception("Can't find source for ${moniker}")
168 unless $mapped && exists $sreg->{$mapped};
169 return $sreg->{$mapped};
176 =item Return Value: @source_monikers
180 Returns the source monikers of all source registrations on this schema.
183 my @source_monikers = $schema->sources;
187 sub sources { return keys %{shift->source_registrations}; }
191 my $storage = $schema->storage;
193 Returns the L<DBIx::Class::Storage> object for this Schema.
199 =item Arguments: $moniker
201 =item Return Value: $result_set
205 my $rs = $schema->resultset('DVD');
207 Returns the L<DBIx::Class::ResultSet> object for the registered moniker.
212 my ($self, $moniker) = @_;
213 return $self->source($moniker)->resultset;
220 =item Arguments: @classes?, { $namespace => [ @classes ] }+
224 With no arguments, this method uses L<Module::Find> to find all classes under
225 the schema's namespace. Otherwise, this method loads the classes you specify
226 (using L<use>), and registers them (using L</"register_class">).
228 It is possible to comment out classes with a leading C<#>, but note that perl
229 will think it's a mistake (trying to use a comment in a qw list), so you'll
230 need to add C<no warnings 'qw';> before your load_classes call.
234 My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist,
235 # etc. (anything under the My::Schema namespace)
237 # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but
238 # not Other::Namespace::LinerNotes nor My::Schema::Track
239 My::Schema->load_classes(qw/ CD Artist #Track /, {
240 Other::Namespace => [qw/ Producer #LinerNotes /],
246 my ($class, @params) = @_;
251 foreach my $param (@params) {
252 if (ref $param eq 'ARRAY') {
253 # filter out commented entries
254 my @modules = grep { $_ !~ /^#/ } @$param;
256 push (@{$comps_for{$class}}, @modules);
258 elsif (ref $param eq 'HASH') {
259 # more than one namespace possible
260 for my $comp ( keys %$param ) {
261 # filter out commented entries
262 my @modules = grep { $_ !~ /^#/ } @{$param->{$comp}};
264 push (@{$comps_for{$comp}}, @modules);
268 # filter out commented entries
269 push (@{$comps_for{$class}}, $param) if $param !~ /^#/;
273 my @comp = map { substr $_, length "${class}::" }
274 Module::Find::findallmod($class);
275 $comps_for{$class} = \@comp;
280 no warnings qw/redefine/;
281 local *Class::C3::reinitialize = sub { };
282 foreach my $prefix (keys %comps_for) {
283 foreach my $comp (@{$comps_for{$prefix}||[]}) {
284 my $comp_class = "${prefix}::${comp}";
285 { # try to untaint module name. mods where this fails
286 # are left alone so we don't have to change the old behavior
287 no locale; # localized \w doesn't untaint expression
288 if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) {
292 $class->ensure_class_loaded($comp_class);
294 $comp = $comp_class->source_name || $comp;
296 push(@to_register, [ $comp, $comp_class ]);
300 Class::C3->reinitialize;
302 foreach my $to (@to_register) {
303 $class->register_class(@$to);
304 # if $class->can('result_source_instance');
308 =head2 load_namespaces
312 =item Arguments: %options?
316 This is an alternative to L</load_classes> above which assumes an alternative
317 layout for automatic class loading. It assumes that all result
318 classes are underneath a sub-namespace of the schema called C<Result>, any
319 corresponding ResultSet classes are underneath a sub-namespace of the schema
322 Both of the sub-namespaces are configurable if you don't like the defaults,
323 via the options C<result_namespace> and C<resultset_namespace>.
325 If (and only if) you specify the option C<default_resultset_class>, any found
326 Result classes for which we do not find a corresponding
327 ResultSet class will have their C<resultset_class> set to
328 C<default_resultset_class>.
330 C<load_namespaces> takes care of calling C<resultset_class> for you where
331 neccessary if you didn't do it for yourself.
333 All of the namespace and classname options to this method are relative to
334 the schema classname by default. To specify a fully-qualified name, prefix
335 it with a literal C<+>.
339 # load My::Schema::Result::CD, My::Schema::Result::Artist,
340 # My::Schema::ResultSet::CD, etc...
341 My::Schema->load_namespaces;
343 # Override everything to use ugly names.
344 # In this example, if there is a My::Schema::Res::Foo, but no matching
345 # My::Schema::RSets::Foo, then Foo will have its
346 # resultset_class set to My::Schema::RSetBase
347 My::Schema->load_namespaces(
348 result_namespace => 'Res',
349 resultset_namespace => 'RSets',
350 default_resultset_class => 'RSetBase',
353 # Put things in other namespaces
354 My::Schema->load_namespaces(
355 result_namespace => '+Some::Place::Results',
356 resultset_namespace => '+Another::Place::RSets',
359 If you'd like to use multiple namespaces of each type, simply use an arrayref
360 of namespaces for that option. In the case that the same result
361 (or resultset) class exists in multiple namespaces, the latter entries in
362 your list of namespaces will override earlier ones.
364 My::Schema->load_namespaces(
365 # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
366 result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
367 resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
372 # Pre-pends our classname to the given relative classname or
373 # class namespace, unless there is a '+' prefix, which will
375 sub _expand_relative_name {
376 my ($class, $name) = @_;
378 $name = $class . '::' . $name if ! ($name =~ s/^\+//);
382 # returns a hash of $shortname => $fullname for every package
383 # found in the given namespaces ($shortname is with the $fullname's
384 # namespace stripped off)
385 sub _map_namespaces {
386 my ($class, @namespaces) = @_;
389 foreach my $namespace (@namespaces) {
392 map { (substr($_, length "${namespace}::"), $_) }
393 Module::Find::findallmod($namespace)
400 sub load_namespaces {
401 my ($class, %args) = @_;
403 my $result_namespace = delete $args{result_namespace} || 'Result';
404 my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
405 my $default_resultset_class = delete $args{default_resultset_class};
407 $class->throw_exception('load_namespaces: unknown option(s): '
408 . join(q{,}, map { qq{'$_'} } keys %args))
409 if scalar keys %args;
411 $default_resultset_class
412 = $class->_expand_relative_name($default_resultset_class);
414 for my $arg ($result_namespace, $resultset_namespace) {
415 $arg = [ $arg ] if !ref($arg) && $arg;
417 $class->throw_exception('load_namespaces: namespace arguments must be '
418 . 'a simple string or an arrayref')
419 if ref($arg) ne 'ARRAY';
421 $_ = $class->_expand_relative_name($_) for (@$arg);
424 my %results = $class->_map_namespaces(@$result_namespace);
425 my %resultsets = $class->_map_namespaces(@$resultset_namespace);
429 no warnings 'redefine';
430 local *Class::C3::reinitialize = sub { };
431 use warnings 'redefine';
433 foreach my $result (keys %results) {
434 my $result_class = $results{$result};
435 $class->ensure_class_loaded($result_class);
436 $result_class->source_name($result) unless $result_class->source_name;
438 my $rs_class = delete $resultsets{$result};
439 my $rs_set = $result_class->resultset_class;
440 if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
441 if($rs_class && $rs_class ne $rs_set) {
442 warn "We found ResultSet class '$rs_class' for '$result', but it seems "
443 . "that you had already set '$result' to use '$rs_set' instead";
446 elsif($rs_class ||= $default_resultset_class) {
447 $class->ensure_class_loaded($rs_class);
448 $result_class->resultset_class($rs_class);
451 push(@to_register, [ $result_class->source_name, $result_class ]);
455 foreach (sort keys %resultsets) {
456 warn "load_namespaces found ResultSet class $_ with no "
457 . 'corresponding Result class';
460 Class::C3->reinitialize;
461 $class->register_class(@$_) for (@to_register);
466 =head2 compose_connection (DEPRECATED)
470 =item Arguments: $target_namespace, @db_info
472 =item Return Value: $new_schema
476 DEPRECATED. You probably wanted compose_namespace.
478 Actually, you probably just wanted to call connect.
480 =for hidden due to deprecation
482 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
483 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
484 then injects the L<DBix::Class::ResultSetProxy> component and a
485 resultset_instance classdata entry on all the new classes, in order to support
486 $target_namespaces::$class->search(...) method calls.
488 This is primarily useful when you have a specific need for class method access
489 to a connection. In normal usage it is preferred to call
490 L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
491 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
499 sub compose_connection {
500 my ($self, $target, @info) = @_;
502 warn "compose_connection deprecated as of 0.08000" unless $warn++;
504 my $base = 'DBIx::Class::ResultSetProxy';
505 eval "require ${base};";
506 $self->throw_exception
507 ("No arguments to load_classes and couldn't load ${base} ($@)")
510 if ($self eq $target) {
511 # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
512 foreach my $moniker ($self->sources) {
513 my $source = $self->source($moniker);
514 my $class = $source->result_class;
515 $self->inject_base($class, $base);
516 $class->mk_classdata(resultset_instance => $source->resultset);
517 $class->mk_classdata(class_resolver => $self);
519 $self->connection(@info);
523 my $schema = $self->compose_namespace($target, $base);
526 *{"${target}::schema"} = sub { $schema };
529 $schema->connection(@info);
530 foreach my $moniker ($schema->sources) {
531 my $source = $schema->source($moniker);
532 my $class = $source->result_class;
533 #warn "$moniker $class $source ".$source->storage;
534 $class->mk_classdata(result_source_instance => $source);
535 $class->mk_classdata(resultset_instance => $source->resultset);
536 $class->mk_classdata(class_resolver => $schema);
542 =head2 compose_namespace
546 =item Arguments: $target_namespace, $additional_base_class?
548 =item Return Value: $new_schema
552 For each L<DBIx::Class::ResultSource> in the schema, this method creates a
553 class in the target namespace (e.g. $target_namespace::CD,
554 $target_namespace::Artist) that inherits from the corresponding classes
555 attached to the current schema.
557 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
558 new $schema object. If C<$additional_base_class> is given, the new composed
559 classes will inherit from first the corresponding classe from the current
560 schema then the base class.
562 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
564 $schema->compose_namespace('My::DB', 'Base::Class');
565 print join (', ', @My::DB::CD::ISA) . "\n";
566 print join (', ', @My::DB::Artist::ISA) ."\n";
568 will produce the output
570 My::Schema::CD, Base::Class
571 My::Schema::Artist, Base::Class
575 sub compose_namespace {
576 my ($self, $target, $base) = @_;
577 my $schema = $self->clone;
579 no warnings qw/redefine/;
580 local *Class::C3::reinitialize = sub { };
581 foreach my $moniker ($schema->sources) {
582 my $source = $schema->source($moniker);
583 my $target_class = "${target}::${moniker}";
585 $target_class => $source->result_class, ($base ? $base : ())
587 $source->result_class($target_class);
588 $target_class->result_source_instance($source)
589 if $target_class->can('result_source_instance');
592 Class::C3->reinitialize();
595 foreach my $meth (qw/class source resultset/) {
596 *{"${target}::${meth}"} =
597 sub { shift->schema->$meth(@_) };
603 =head2 setup_connection_class
607 =item Arguments: $target, @info
611 Sets up a database connection class to inject between the schema and the
612 subclasses that the schema creates.
616 sub setup_connection_class {
617 my ($class, $target, @info) = @_;
618 $class->inject_base($target => 'DBIx::Class::DB');
619 #$target->load_components('DB');
620 $target->connection(@info);
627 =item Arguments: $storage_type
629 =item Return Value: $storage_type
633 Set the storage class that will be instantiated when L</connect> is called.
634 If the classname starts with C<::>, the prefix C<DBIx::Class::Storage> is
635 assumed by L</connect>. Defaults to C<::DBI>,
636 which is L<DBIx::Class::Storage::DBI>.
638 You want to use this to hardcoded subclasses of L<DBIx::Class::Storage::DBI>
639 in cases where the appropriate subclass is not autodetected, such as when
640 dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
641 C<::DBI::Sybase::MSSQL>.
647 =item Arguments: @args
649 =item Return Value: $new_schema
653 Instantiates a new Storage object of type
654 L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
655 $storage->connect_info. Sets the connection in-place on the schema.
657 See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
658 or L<DBIx::Class::Storage> in general.
663 my ($self, @info) = @_;
664 return $self if !@info && $self->storage;
665 my $storage_class = $self->storage_type;
666 $storage_class = 'DBIx::Class::Storage'.$storage_class
667 if $storage_class =~ m/^::/;
668 eval "require ${storage_class};";
669 $self->throw_exception(
670 "No arguments to load_classes and couldn't load ${storage_class} ($@)"
672 my $storage = $storage_class->new($self);
673 $storage->connect_info(\@info);
674 $self->storage($storage);
675 $self->on_connect() if($self->can('on_connect'));
683 =item Arguments: @info
685 =item Return Value: $new_schema
689 This is a convenience method. It is equivalent to calling
690 $schema->clone->connection(@info). See L</connection> and L</clone> for more
695 sub connect { shift->clone->connection(@_) }
701 =item Arguments: C<$coderef>, @coderef_args?
703 =item Return Value: The return value of $coderef
707 Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
708 returning its result (if any). Equivalent to calling $schema->storage->txn_do.
709 See L<DBIx::Class::Storage/"txn_do"> for more information.
711 This interface is preferred over using the individual methods L</txn_begin>,
712 L</txn_commit>, and L</txn_rollback> below.
719 $self->storage or $self->throw_exception
720 ('txn_do called on $schema without storage');
722 $self->storage->txn_do(@_);
727 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
728 calling $schema->storage->txn_begin. See
729 L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
736 $self->storage or $self->throw_exception
737 ('txn_begin called on $schema without storage');
739 $self->storage->txn_begin;
744 Commits the current transaction. Equivalent to calling
745 $schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
746 for more information.
753 $self->storage or $self->throw_exception
754 ('txn_commit called on $schema without storage');
756 $self->storage->txn_commit;
761 Rolls back the current transaction. Equivalent to calling
762 $schema->storage->txn_rollback. See
763 L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
770 $self->storage or $self->throw_exception
771 ('txn_rollback called on $schema without storage');
773 $self->storage->txn_rollback;
780 =item Return Value: $new_schema
784 Clones the schema and its associated result_source objects and returns the
791 my $clone = { (ref $self ? %$self : ()) };
792 bless $clone, (ref $self || $self);
794 foreach my $moniker ($self->sources) {
795 my $source = $self->source($moniker);
796 my $new = $source->new($source);
797 $clone->register_source($moniker => $new);
799 $clone->storage->set_schema($clone) if $clone->storage;
807 =item Arguments: $source_name, \@data;
811 Pass this method a resultsource name, and an arrayref of
812 arrayrefs. The arrayrefs should contain a list of column names,
813 followed by one or many sets of matching data for the given columns.
815 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
816 to insert the data, as this is a fast method. However, insert_bulk currently
817 assumes that your datasets all contain the same type of values, using scalar
818 references in a column in one row, and not in another will probably not work.
820 Otherwise, each set of data is inserted into the database using
821 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
826 $schema->populate('Artist', [
827 [ qw/artistid name/ ],
828 [ 1, 'Popular Band' ],
836 my ($self, $name, $data) = @_;
837 my $rs = $self->resultset($name);
838 my @names = @{shift(@$data)};
839 if(defined wantarray) {
841 foreach my $item (@$data) {
843 @create{@names} = @$item;
844 push(@created, $rs->create(\%create));
848 $self->storage->insert_bulk($self->source($name), \@names, $data);
851 =head2 exception_action
855 =item Arguments: $code_reference
859 If C<exception_action> is set for this class/object, L</throw_exception>
860 will prefer to call this code reference with the exception as an argument,
861 rather than its normal <croak> action.
863 Your subroutine should probably just wrap the error in the exception
864 object/class of your choosing and rethrow. If, against all sage advice,
865 you'd like your C<exception_action> to suppress a particular exception
866 completely, simply have it return true.
871 use base qw/DBIx::Class::Schema/;
872 use My::ExceptionClass;
873 __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) });
874 __PACKAGE__->load_classes;
877 my $schema_obj = My::Schema->connect( .... );
878 $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) });
880 # suppress all exceptions, like a moron:
881 $schema_obj->exception_action(sub { 1 });
883 =head2 throw_exception
887 =item Arguments: $message
891 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
892 user's perspective. See L</exception_action> for details on overriding
893 this method's behavior.
897 sub throw_exception {
899 croak @_ if !$self->exception_action || !$self->exception_action->(@_);
902 =head2 deploy (EXPERIMENTAL)
906 =item Arguments: $sqlt_args, $dir
910 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
912 Note that this feature is currently EXPERIMENTAL and may not work correctly
913 across all databases, or fully handle complex relationships. Saying that, it
914 has been used successfully by many people, including the core dev team.
916 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
917 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
918 produced include a DROP TABLE statement for each table created.
920 Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
921 ref or an array ref, containing a list of source to deploy. If present, then
922 only the sources listed will get deployed.
927 my ($self, $sqltargs, $dir) = @_;
928 $self->throw_exception("Can't deploy without storage") unless $self->storage;
929 $self->storage->deploy($self, undef, $sqltargs, $dir);
932 =head2 create_ddl_dir (EXPERIMENTAL)
936 =item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
940 Creates an SQL file based on the Schema, for each of the specified
941 database types, in the given directory. Given a previous version number,
942 this will also create a file containing the ALTER TABLE statements to
943 transform the previous schema into the current one. Note that these
944 statements may contain DROP TABLE or DROP COLUMN statements that can
945 potentially destroy data.
947 The file names are created using the C<ddl_filename> method below, please
948 override this method in your schema if you would like a different file
949 name format. For the ALTER file, the same format is used, replacing
950 $version in the name with "$preversion-$version".
952 If no arguments are passed, then the following default values are used:
956 =item databases - ['MySQL', 'SQLite', 'PostgreSQL']
958 =item version - $schema->VERSION
960 =item directory - './'
962 =item preversion - <none>
966 Note that this feature is currently EXPERIMENTAL and may not work correctly
967 across all databases, or fully handle complex relationships.
969 WARNING: Please check all SQL files created, before applying them.
976 $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
977 $self->storage->create_ddl_dir($self, @_);
980 =head2 ddl_filename (EXPERIMENTAL)
984 =item Arguments: $directory, $database-type, $version, $preversion
988 my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
990 This method is called by C<create_ddl_dir> to compose a file name out of
991 the supplied directory, database type and version number. The default file
992 name format is: C<$dir$schema-$version-$type.sql>.
994 You may override this method in your schema if you wish to use a different
1000 my ($self, $type, $dir, $version, $pversion) = @_;
1002 my $filename = ref($self);
1003 $filename =~ s/::/-/g;
1004 $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
1005 $filename =~ s/$version/$pversion-$version/ if($pversion);
1014 Matt S. Trout <mst@shadowcatsystems.co.uk>
1018 You may distribute this code under the same terms as Perl itself.