X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=427faeb1a5a25940efc57f5a33c50db8e0650fdb;hb=d09c569a37b1bd7b79bcffd4c638d6816ac6c62a;hp=17c16020e98cf0ba1a638462e3de3ffc503f8e1d;hpb=82b01c38eb0b505543a829a5a171a26cca030c91;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 17c1602..427faeb 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -4,6 +4,7 @@ use strict; use warnings; use Carp::Clan qw/^DBIx::Class/; +use Scalar::Util qw/weaken/; use base qw/DBIx::Class/; @@ -20,7 +21,7 @@ DBIx::Class::Schema - composable schemas package Library::Schema; use base qw/DBIx::Class::Schema/; - + # load Library::Schema::CD, Library::Schema::Book, Library::Schema::DVD __PACKAGE__->load_classes(qw/CD Book DVD/); @@ -36,7 +37,7 @@ DBIx::Class::Schema - composable schemas $password, { AutoCommit => 0 }, ); - + my $schema2 = Library::Schema->connect($coderef_returning_dbh); # fetch objects using Library::Schema::DVD @@ -50,17 +51,21 @@ use L and allows you to use more than one concurrent connection with your classes. NB: If you're used to L it's worth reading the L -carefully as DBIx::Class does things a little differently. Note in +carefully, as DBIx::Class does things a little differently. Note in particular which module inherits off which. =head1 METHODS =head2 register_class -=head3 Arguments: ($moniker, $component_class) +=over 4 -Registers a class which isa L. Equivalent to -calling +=item Arguments: $moniker, $component_class + +=back + +Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to +calling: $schema->register_source($moniker, $component_class->result_source_instance); @@ -73,7 +78,11 @@ sub register_class { =head2 register_source -=head3 Arguments: ($moniker, $result_source) +=over 4 + +=item Arguments: $moniker, $result_source + +=back Registers the L in the schema with the given moniker. @@ -86,22 +95,25 @@ sub register_source { $reg{$moniker} = $source; $self->source_registrations(\%reg); $source->schema($self); + weaken($source->{schema}) if ref($self); if ($source->result_class) { my %map = %{$self->class_mappings}; $map{$source->result_class} = $moniker; $self->class_mappings(\%map); } -} +} =head2 class -=head3 Arguments: ($moniker) +=over 4 -=head3 Returns: $classname +=item Arguments: $moniker -Retrieves the result class name for the given moniker. +=item Return Value: $classname -e.g., +=back + +Retrieves the result class name for the given moniker. For example: my $class = $schema->class('CD'); @@ -114,9 +126,13 @@ sub class { =head2 source -=head3 Arguments: ($moniker) +=over 4 + +=item Arguments: $moniker -=head3 Returns: $result_source +=item Return Value: $result_source + +=back my $source = $schema->source('Book'); @@ -138,11 +154,14 @@ sub source { =head2 sources -=head3 Returns: @source_monikers +=over 4 + +=item Return Value: @source_monikers -Returns the source monikers of all source registrations on this schema. +=back -e.g., +Returns the source monikers of all source registrations on this schema. +For example: my @source_monikers = $schema->sources; @@ -152,9 +171,13 @@ sub sources { return keys %{shift->source_registrations}; } =head2 resultset -=head3 Arguments: ($moniker) +=over 4 + +=item Arguments: $moniker -=head3 Returns: $result_set +=item Return Value: $result_set + +=back my $rs = $schema->resultset('DVD'); @@ -169,20 +192,24 @@ sub resultset { =head2 load_classes -=head3 Arguments: @classes?, { $namespace => [ @classes ] }+ +=over 4 + +=item Arguments: @classes?, { $namespace => [ @classes ] }+ + +=back With no arguments, this method uses L to find all classes under the schema's namespace. Otherwise, this method loads the classes you specify (using L), and registers them (using L). -It is possible to comment out classes with a leading '#', but note that perl -will think it's a mistake (trying to use a comment in a qw list) so you'll -need to add "no warnings 'qw';" before your load_classes call. +It is possible to comment out classes with a leading C<#>, but note that perl +will think it's a mistake (trying to use a comment in a qw list), so you'll +need to add C before your load_classes call. -e.g., +Example: My::Schema->load_classes(); # loads My::Schema::CD, My::Schema::Artist, - # etc. (anything under the My::Schema namespace) + # etc. (anything under the My::Schema namespace) # loads My::Schema::CD, My::Schema::Artist, Other::Namespace::Producer but # not Other::Namespace::LinerNotes nor My::Schema::Track @@ -194,15 +221,15 @@ e.g., sub load_classes { my ($class, @params) = @_; - + my %comps_for; - + if (@params) { foreach my $param (@params) { if (ref $param eq 'ARRAY') { # filter out commented entries my @modules = grep { $_ !~ /^#/ } @$param; - + push (@{$comps_for{$class}}, @modules); } elsif (ref $param eq 'HASH') { @@ -236,13 +263,10 @@ sub load_classes { foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; - eval "use $comp_class"; # If it fails, assume the user fixed it - if ($@) { - $comp_class =~ s/::/\//g; - die $@ unless $@ =~ /Can't locate.+$comp_class\.pm\sin\s\@INC/; - warn $@ if $@; - } - push(@to_register, [ $comp, $comp_class ]); + $class->ensure_class_loaded($comp_class); + $comp_class->source_name($comp) unless $comp_class->source_name; + + push(@to_register, [ $comp_class->source_name, $comp_class ]); } } } @@ -256,14 +280,18 @@ sub load_classes { =head2 compose_connection -=head3 Arguments: ($target_namespace, @db_info) +=over 4 + +=item Arguments: $target_namespace, @db_info -=head3 Returns: $new_schema +=item Return Value: $new_schema -Calls L to the target namespace, -calls L(@db_info) on the new schema, then -injects the L component and a resultset_instance -classdata entry on all the new classes in order to support +=back + +Calls L to the target namespace, +calls L with @db_info on the new schema, +then injects the L component and a +resultset_instance classdata entry on all the new classes, in order to support $target_namespaces::$class->search(...) method calls. This is primarily useful when you have a specific need for class method access @@ -315,9 +343,13 @@ sub compose_connection { =head2 compose_namespace -=head3 Arguments: $target_namespace, $additional_base_class? +=over 4 + +=item Arguments: $target_namespace, $additional_base_class? + +=item Return Value: $new_schema -=head3 Returns: $new_schema +=back For each L in the schema, this method creates a class in the target namespace (e.g. $target_namespace::CD, @@ -329,13 +361,13 @@ new $schema object. If C<$additional_base_class> is given, the new composed classes will inherit from first the corresponding classe from the current schema then the base class. -e.g. (for a schema with My::Schema::CD and My::Schema::Artist classes), +For example, for a schema with My::Schema::CD and My::Schema::Artist classes, $schema->compose_namespace('My::DB', 'Base::Class'); print join (', ', @My::DB::CD::ISA) . "\n"; print join (', ', @My::DB::Artist::ISA) ."\n"; -Will produce the output +will produce the output My::Schema::CD, Base::Class My::Schema::Artist, Base::Class @@ -358,6 +390,8 @@ sub compose_namespace { $target_class => $source->result_class, ($base ? $base : ()) ); $source->result_class($target_class); + $target_class->result_source_instance($source) + if $target_class->can('result_source_instance'); } } Class::C3->reinitialize(); @@ -373,7 +407,11 @@ sub compose_namespace { =head2 setup_connection_class -=head3 Arguments: ($target, @info) +=over 4 + +=item Arguments: $target, @info + +=back Sets up a database connection class to inject between the schema and the subclasses that the schema creates. @@ -389,9 +427,13 @@ sub setup_connection_class { =head2 connection -=head3 Arguments: (@args) +=over 4 + +=item Arguments: @args -=head3 Returns: $new_schema +=item Return Value: $new_schema + +=back Instantiates a new Storage object of type L and passes the arguments to @@ -418,9 +460,13 @@ sub connection { =head2 connect -=head3 Arguments: (@info) +=over 4 + +=item Arguments: @info -=head3 Returns: $new_schema +=item Return Value: $new_schema + +=back This is a convenience method. It is equivalent to calling $schema->clone->connection(@info). See L and L for more @@ -462,10 +508,13 @@ sub txn_rollback { shift->storage->txn_rollback } =head2 txn_do -=head3 Arguments: (C<$coderef>, @coderef_args?) +=over 4 -=head3 Returns: (C<$return_value> | C<@return_values> | C) for scalar, -list and void contexts, respectively +=item Arguments: C<$coderef>, @coderef_args? + +=item Return Value: The return value of $coderef + +=back Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically, returning its result (if any). If an exception is caught, a rollback is issued @@ -475,12 +524,11 @@ exception) an exception is thrown that includes a "Rollback failed" message. For example, my $author_rs = $schema->resultset('Author')->find(1); + my @titles = qw/Night Day It/; my $coderef = sub { - my ($author, @titles) = @_; - # If any one of these fails, the entire transaction fails - $author->create_related('books', { + $author_rs->create_related('books', { title => $_ }) foreach (@titles); @@ -489,16 +537,14 @@ For example, my $rs; eval { - $rs = $schema->txn_do($coderef, $author_rs, qw/Night Day It/); + $rs = $schema->txn_do($coderef); }; - if ($@) { - my $error = $@; - if ($error =~ /Rollback failed/) { - die "something terrible has happened!"; - } else { - deal_with_failed_transaction(); - } + if ($@) { # Transaction failed + die "something terrible has happened!" # + if ($@ =~ /Rollback failed/); # Rollback failed + + deal_with_failed_transaction(); } In a nested transaction (calling txn_do() from within a txn_do() coderef) only @@ -511,8 +557,8 @@ context and it will behave as expected. sub txn_do { my ($self, $coderef, @args) = @_; - ref $self or $self->throw_exception - ('Cannot execute txn_do as a class method'); + $self->storage or $self->throw_exception + ('txn_do called on $schema without storage'); ref $coderef eq 'CODE' or $self->throw_exception ('$coderef must be a CODE reference'); @@ -521,8 +567,8 @@ sub txn_do { $self->txn_begin; # If this throws an exception, no rollback is needed my $wantarray = wantarray; # Need to save this since the context - # inside the eval{} block is independent - # of the context that called txn_do() + # inside the eval{} block is independent + # of the context that called txn_do() eval { # Need to differentiate between scalar/list context to allow for @@ -551,7 +597,7 @@ sub txn_do { my $rollback_error = $@; my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION"; $self->throw_exception($error) # propagate nested rollback - if $rollback_error =~ /$exception_class/; + if $rollback_error =~ /$exception_class/; $self->throw_exception( "Transaction aborted: $error. Rollback failed: ${rollback_error}" @@ -566,7 +612,11 @@ sub txn_do { =head2 clone -=head3 Returns: $new_schema +=over 4 + +=item Return Value: $new_schema + +=back Clones the schema and its associated result_source objects and returns the copy. @@ -586,7 +636,11 @@ sub clone { =head2 populate -=head3 Arguments: ($moniker, \@data); +=over 4 + +=item Arguments: $moniker, \@data; + +=back Populates the source registered with the given moniker with the supplied data. @data should be a list of listrefs -- the first containing column names, the @@ -618,9 +672,9 @@ sub populate { =head2 throw_exception -=over 4 +=over 4 -=item Arguments: ($message) +=item Arguments: $message =back @@ -638,7 +692,7 @@ sub throw_exception { =over 4 -=item Arguments: ($sqlt_args) +=item Arguments: $sqlt_args =back @@ -647,6 +701,10 @@ Attempts to deploy the schema to the current storage using L. Note that this feature is currently EXPERIMENTAL and may not work correctly across all databases, or fully handle complex relationships. +See L for a list of values for C<$sqlt_args>. The most +common value for this would be C<< { add_drop_table => 1, } >> to have the SQL +produced include a DROP TABLE statement for each table created. + =cut sub deploy { @@ -655,6 +713,50 @@ sub deploy { $self->storage->deploy($self, undef, $sqltargs); } +=head2 create_ddl_dir (EXPERIMENTAL) + +=over 4 + +=item Arguments: \@databases, $version, $directory, $sqlt_args + +=back + +Creates an SQL file based on the Schema, for each of the specified +database types, in the given directory. + +Note that this feature is currently EXPERIMENTAL and may not work correctly +across all databases, or fully handle complex relationships. + +=cut + +sub create_ddl_dir +{ + my $self = shift; + + $self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage; + $self->storage->create_ddl_dir($self, @_); +} + +=head2 ddl_filename (EXPERIMENTAL) + + my $filename = $table->ddl_filename($type, $dir, $version) + +Creates a filename for a SQL file based on the table class name. Not +intended for direct end user use. + +=cut + +sub ddl_filename +{ + my ($self, $type, $dir, $version) = @_; + + my $filename = ref($self); + $filename =~ s/^.*:://; + $filename = "$dir$filename-$version-$type.sql"; + + return $filename; +} + 1; =head1 AUTHORS