X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=415fd79984ec2b4af0418b06d17498a1d7fd6801;hb=0c11ad0ee5c8407f6b87d6e15c62a1b445076dc0;hp=47fb8637400e673609d99f3f5b836e7eb7dd9ebb;hpb=6f731572aed6ab2bd71ec33ba2c35ec78b9909b1;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 47fb863..415fd79 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -4,11 +4,12 @@ use strict; use warnings; use DBIx::Class::Exception; -use Carp::Clan qw/^DBIx::Class|^Try::Tiny/; +use DBIx::Class::Carp; use Try::Tiny; -use Scalar::Util 'weaken'; +use Scalar::Util qw/weaken blessed/; use Sub::Name 'subname'; use B 'svref_2object'; +use Devel::GlobalDestruction; use namespace::clean; use base qw/DBIx::Class/; @@ -167,12 +168,9 @@ sub _findallmod { my $ns = shift || ref $proto || $proto; require Module::Find; - my @mods = Module::Find::findallmod($ns); - # try to untaint module names. mods where this fails - # are left alone so we don't have to change the old behavior - no locale; # localized \w doesn't untaint expression - return map { $_ =~ m/^( (?:\w+::)* \w+ )$/x ? $1 : $_ } @mods; + # untaint result + return map { $_ =~ /(.+)/ } Module::Find::findallmod($ns); } # returns a hash of $shortname => $fullname for every package @@ -196,17 +194,16 @@ sub _map_namespaces { # returns the result_source_instance for the passed class/object, # or dies with an informative message (used by load_namespaces) sub _ns_get_rsrc_instance { - my $class = shift; - my $rs = ref ($_[0]) || $_[0]; - - if ($rs->can ('result_source_instance') ) { - return $rs->result_source_instance; - } - else { - $class->throw_exception ( - "Attempt to load_namespaces() class $rs failed - are you sure this is a real Result Class?" + my $me = shift; + my $rs_class = ref ($_[0]) || $_[0]; + + return try { + $rs_class->result_source_instance + } catch { + $me->throw_exception ( + "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_" ); - } + }; } sub load_namespaces { @@ -400,7 +397,6 @@ sub load_classes { foreach my $to (@to_register) { $class->register_class(@$to); - # if $class->can('result_source_instance'); } } @@ -831,7 +827,7 @@ sub connection { } catch { $self->throw_exception( - "No arguments to load_classes and couldn't load ${storage_class} ($_)" + "Unable to load storage class ${storage_class}: $_" ); }; my $storage = $storage_class->new($self=>$args); @@ -905,40 +901,51 @@ will produce the output sub compose_namespace { my ($self, $target, $base) = @_; + my $schema = $self->clone; + + $schema->source_registrations({}); + + # the original class-mappings must remain - otherwise + # reverse_relationship_info will not work + #$schema->class_mappings({}); + { no warnings qw/redefine/; local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; no strict qw/refs/; - foreach my $moniker ($schema->sources) { - my $source = $schema->source($moniker); + foreach my $moniker ($self->sources) { + my $orig_source = $self->source($moniker); + my $target_class = "${target}::${moniker}"; - $self->inject_base( - $target_class => $source->result_class, ($base ? $base : ()) + $self->inject_base($target_class, $orig_source->result_class, ($base || ()) ); + + # register_source examines result_class, and then returns us a clone + my $new_source = $schema->register_source($moniker, bless + { %$orig_source, result_class => $target_class }, + ref $orig_source, ); - $source->result_class($target_class); - if ($target_class->can('result_source_instance')) { - # since the newly created classes are registered only with - # the instance of $schema, it should be safe to weaken - # the ref (it will GC when $schema is destroyed) - $target_class->result_source_instance($source); - weaken ${"${target_class}::__cag_result_source_instance"}; + if ($target_class->can('result_source_instance')) { + # give the class a schema-less source copy + $target_class->result_source_instance( bless + { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} }, + ref $new_source, + ); } - $schema->register_source($moniker, $source); } - } - Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; - { - no strict 'refs'; - no warnings 'redefine'; + foreach my $meth (qw/class source resultset/) { + no warnings 'redefine'; *{"${target}::${meth}"} = subname "${target}::${meth}" => sub { shift->schema->$meth(@_) }; } } + + Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + return $schema; } @@ -1004,31 +1011,54 @@ sub svp_rollback { =over 4 +=item Arguments: %attrs? + =item Return Value: $new_schema =back Clones the schema and its associated result_source objects and returns the -copy. +copy. The resulting copy will have the same attributes as the source schema, +except for those attributes explicitly overriden by the provided C<%attrs>. =cut sub clone { - my ($self) = @_; - my $clone = { (ref $self ? %$self : ()) }; + my $self = shift; + + my $clone = { + (ref $self ? %$self : ()), + (@_ == 1 && ref $_[0] eq 'HASH' ? %{ $_[0] } : @_), + }; bless $clone, (ref $self || $self); - $clone->class_mappings({ %{$clone->class_mappings} }); - $clone->source_registrations({ %{$clone->source_registrations} }); - foreach my $moniker ($self->sources) { - my $source = $self->source($moniker); + $clone->$_(undef) for qw/class_mappings source_registrations storage/; + + $clone->_copy_state_from($self); + + return $clone; +} + +# Needed in Schema::Loader - if you refactor, please make a compatibility shim +# -- Caelum +sub _copy_state_from { + my ($self, $from) = @_; + + $self->class_mappings({ %{$from->class_mappings} }); + $self->source_registrations({ %{$from->source_registrations} }); + + foreach my $moniker ($from->sources) { + my $source = $from->source($moniker); my $new = $source->new($source); # we use extra here as we want to leave the class_mappings as they are # but overwrite the source_registrations entry with the new source - $clone->register_extra_source($moniker => $new); + $self->register_extra_source($moniker => $new); + } + + if ($from->storage) { + $self->storage($from->storage); + $self->storage->set_schema($self); } - $clone->storage->set_schema($clone) if $clone->storage; - return $clone; } =head2 throw_exception @@ -1039,8 +1069,8 @@ sub clone { =back -Throws an exception. Defaults to using L to report errors from -user's perspective. See L for details on overriding +Throws an exception. Obeys the exemption rules of L to report +errors from outer-user's perspective. See L for details on overriding this method's behavior. If L is turned on, C's default behavior will provide a detailed stack trace. @@ -1189,12 +1219,12 @@ sub ddl_filename { require File::Spec; - my $filename = ref($self); - $filename =~ s/::/-/g; - $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); - $filename =~ s/$version/$preversion-$version/ if($preversion); + $version = "$preversion-$version" if $preversion; - return $filename; + my $class = blessed($self) || $self; + $class =~ s/::/-/g; + + return File::Spec->catfile($dir, "$class-$version-$type.sql"); } =head2 thaw @@ -1312,11 +1342,7 @@ moniker. =cut -sub register_source { - my $self = shift; - - $self->_register_source(@_); -} +sub register_source { shift->_register_source(@_) } =head2 unregister_source @@ -1330,11 +1356,7 @@ Removes the L from the schema for the given moniker. =cut -sub unregister_source { - my $self = shift; - - $self->_unregister_source(@_); -} +sub unregister_source { shift->_unregister_source(@_) } =head2 register_extra_source @@ -1349,77 +1371,72 @@ has a source and you want to register an extra one. =cut -sub register_extra_source { - my $self = shift; - - $self->_register_source(@_, { extra => 1 }); -} +sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { my ($self, $moniker, $source, $params) = @_; - my $orig_source = $source; - $source = $source->new({ %$source, source_name => $moniker }); + $source->schema($self); weaken $source->{schema} if ref($self); - my $rs_class = $source->result_class; - my %reg = %{$self->source_registrations}; $reg{$moniker} = $source; $self->source_registrations(\%reg); - return if ($params->{extra}); - return unless defined($rs_class) && $rs_class->can('result_source_instance'); - - my %map = %{$self->class_mappings}; - if ( - exists $map{$rs_class} - and - $map{$rs_class} ne $moniker - and - $rs_class->result_source_instance ne $orig_source - ) { - carp "$rs_class already has a source, use register_extra_source for additional sources"; + return $source if $params->{extra}; + + my $rs_class = $source->result_class; + if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) { + my %map = %{$self->class_mappings}; + if ( + exists $map{$rs_class} + and + $map{$rs_class} ne $moniker + and + $rsrc ne $_[2] # orig_source + ) { + carp + "$rs_class already had a registered source which was replaced by this call. " + . 'Perhaps you wanted register_extra_source(), though it is more likely you did ' + . 'something wrong.' + ; + } + + $map{$rs_class} = $moniker; + $self->class_mappings(\%map); } - $map{$rs_class} = $moniker; - $self->class_mappings(\%map); + + return $source; } -{ - my $global_phase_destroy; - - # SpeedyCGI runs END blocks every cycle but keeps object instances - # hence we have to disable the globaldestroy hatch, and rely on the - # eval trap below (which appears to work, but is risky done so late) - END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy } - - sub DESTROY { - return if $global_phase_destroy; - - my $self = shift; - my $srcs = $self->source_registrations; - - for my $moniker (keys %$srcs) { - # find first source that is not about to be GCed (someone other than $self - # holds a reference to it) and reattach to it, weakening our own link - # - # during global destruction (if we have not yet bailed out) this will throw - # which will serve as a signal to not try doing anything else - if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) { - local $@; - eval { - $srcs->{$moniker}->schema($self); - 1; - } or do { - $global_phase_destroy = 1; - last; - }; +my $global_phase_destroy; +sub DESTROY { + return if $global_phase_destroy ||= in_global_destruction; + my $self = shift; + my $srcs = $self->source_registrations; + + for my $moniker (keys %$srcs) { + # find first source that is not about to be GCed (someone other than $self + # holds a reference to it) and reattach to it, weakening our own link + # + # during global destruction (if we have not yet bailed out) this should throw + # which will serve as a signal to not try doing anything else + # however beware - on older perls the exception seems randomly untrappable + # due to some weird race condition during thread joining :((( + if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) { + local $@; + eval { + $srcs->{$moniker}->schema($self); weaken $srcs->{$moniker}; - last; - } + 1; + } or do { + $global_phase_destroy = 1; + }; + + last; } } } @@ -1472,62 +1489,58 @@ more information. =cut -{ - my $warn; - - sub compose_connection { - my ($self, $target, @info) = @_; +sub compose_connection { + my ($self, $target, @info) = @_; - carp "compose_connection deprecated as of 0.08000" - unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++); + carp_once "compose_connection deprecated as of 0.08000" + unless $INC{"DBIx/Class/CDBICompat.pm"}; - my $base = 'DBIx::Class::ResultSetProxy'; - try { - eval "require ${base};" - } - catch { - $self->throw_exception - ("No arguments to load_classes and couldn't load ${base} ($_)") - }; - - if ($self eq $target) { - # Pathological case, largely caused by the docs on early C::M::DBIC::Plain - foreach my $moniker ($self->sources) { - my $source = $self->source($moniker); - my $class = $source->result_class; - $self->inject_base($class, $base); - $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $self); - } - $self->connection(@info); - return $self; - } - - my $schema = $self->compose_namespace($target, $base); - { - no strict 'refs'; - my $name = join '::', $target, 'schema'; - *$name = subname $name, sub { $schema }; - } + my $base = 'DBIx::Class::ResultSetProxy'; + try { + eval "require ${base};" + } + catch { + $self->throw_exception + ("No arguments to load_classes and couldn't load ${base} ($_)") + }; - $schema->connection(@info); - foreach my $moniker ($schema->sources) { - my $source = $schema->source($moniker); + if ($self eq $target) { + # Pathological case, largely caused by the docs on early C::M::DBIC::Plain + foreach my $moniker ($self->sources) { + my $source = $self->source($moniker); my $class = $source->result_class; - #warn "$moniker $class $source ".$source->storage; - $class->mk_classdata(result_source_instance => $source); + $self->inject_base($class, $base); $class->mk_classdata(resultset_instance => $source->resultset); - $class->mk_classdata(class_resolver => $schema); + $class->mk_classdata(class_resolver => $self); } - return $schema; + $self->connection(@info); + return $self; } + + my $schema = $self->compose_namespace($target, $base); + { + no strict 'refs'; + my $name = join '::', $target, 'schema'; + *$name = subname $name, sub { $schema }; + } + + $schema->connection(@info); + foreach my $moniker ($schema->sources) { + my $source = $schema->source($moniker); + my $class = $source->result_class; + #warn "$moniker $class $source ".$source->storage; + $class->mk_classdata(result_source_instance => $source); + $class->mk_classdata(resultset_instance => $source->resultset); + $class->mk_classdata(class_resolver => $schema); + } + return $schema; } 1; -=head1 AUTHORS +=head1 AUTHOR AND CONTRIBUTORS -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE