X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=5d5070cf4335bfaf673ca1f4c4901956c761d7f9;hb=4d3a827d3c6009bbea3e08175dde81a0e4d96474;hp=3d7e681ee31ff1c4b8f24daa0ed7f678338025cd;hpb=27f01d1f4fc106e0d27a13c6f6c9d5fa131e9447;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 3d7e681..5d5070c 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,7 +51,7 @@ 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 @@ -59,12 +60,12 @@ particular which module inherits off which. =over 4 -=item Arguments: ($moniker, $component_class) +=item Arguments: $moniker, $component_class =back -Registers a class which isa L. Equivalent to -calling +Registers a class which isa DBIx::Class::ResultSourceProxy. Equivalent to +calling: $schema->register_source($moniker, $component_class->result_source_instance); @@ -79,7 +80,7 @@ sub register_class { =over 4 -=item Arguments: ($moniker, $result_source) +=item Arguments: $moniker, $result_source =back @@ -94,26 +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 =over 4 -=item Arguments: ($moniker) +=item Arguments: $moniker -=item Returns: $classname +=item Return Value: $classname =back -Retrieves the result class name for the given moniker. - -e.g., +Retrieves the result class name for the given moniker. For example: my $class = $schema->class('CD'); @@ -128,9 +128,9 @@ sub class { =over 4 -=item Arguments: ($moniker) +=item Arguments: $moniker -=item Returns: $result_source +=item Return Value: $result_source =back @@ -156,13 +156,12 @@ sub source { =over 4 -=item Returns: @source_monikers +=item Return Value: @source_monikers =back Returns the source monikers of all source registrations on this schema. - -e.g., +For example: my @source_monikers = $schema->sources; @@ -174,9 +173,9 @@ sub sources { return keys %{shift->source_registrations}; } =over 4 -=item Arguments: ($moniker) +=item Arguments: $moniker -=item Returns: $result_set +=item Return Value: $result_set =back @@ -203,14 +202,14 @@ 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 @@ -222,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') { @@ -264,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 ]); } } } @@ -286,16 +282,16 @@ sub load_classes { =over 4 -=item Arguments: ($target_namespace, @db_info) +=item Arguments: $target_namespace, @db_info -=item Returns: $new_schema +=item Return Value: $new_schema =back -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 +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 @@ -351,7 +347,7 @@ sub compose_connection { =item Arguments: $target_namespace, $additional_base_class? -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -365,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 @@ -394,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(); @@ -411,7 +409,7 @@ sub compose_namespace { =over 4 -=item Arguments: ($target, @info) +=item Arguments: $target, @info =back @@ -431,9 +429,9 @@ sub setup_connection_class { =over 4 -=item Arguments: (@args) +=item Arguments: @args -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -464,9 +462,9 @@ sub connection { =over 4 -=item Arguments: (@info) +=item Arguments: @info -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -512,9 +510,9 @@ sub txn_rollback { shift->storage->txn_rollback } =over 4 -=item Arguments: (C<$coderef>, @coderef_args?) +=item Arguments: C<$coderef>, @coderef_args? -=item Returns: The return value of $coderef +=item Return Value: The return value of $coderef =back @@ -526,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); @@ -540,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 @@ -562,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'); @@ -572,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 @@ -602,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}" @@ -619,7 +614,7 @@ sub txn_do { =over 4 -=item Returns: $new_schema +=item Return Value: $new_schema =back @@ -630,7 +625,9 @@ copy. sub clone { my ($self) = @_; - my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self); + my $clone = { (ref $self ? %$self : ()) }; + bless $clone, (ref $self || $self); + foreach my $moniker ($self->sources) { my $source = $self->source($moniker); my $new = $source->new($source); @@ -643,7 +640,7 @@ sub clone { =over 4 -=item Arguments: ($moniker, \@data); +=item Arguments: $moniker, \@data; =back @@ -677,9 +674,9 @@ sub populate { =head2 throw_exception -=over 4 +=over 4 -=item Arguments: ($message) +=item Arguments: $message =back @@ -697,7 +694,7 @@ sub throw_exception { =over 4 -=item Arguments: ($sqlt_args) +=item Arguments: $sqlt_args, $dir =back @@ -706,12 +703,58 @@ 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 { - my ($self, $sqltargs) = @_; + my ($self, $sqltargs, $dir) = @_; $self->throw_exception("Can't deploy without storage") unless $self->storage; - $self->storage->deploy($self, undef, $sqltargs); + $self->storage->deploy($self, undef, $sqltargs, $dir); +} + +=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; @@ -725,4 +768,3 @@ Matt S. Trout You may distribute this code under the same terms as Perl itself. =cut -