X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=223dbd3fdf8be10f502687f5a2744cd8a1b407b9;hb=e287d9b08f5652a490eb7943ac07d5e38377852e;hp=dbb14bc986e2e9e37b8b8ec39d7326dfb8e4b721;hpb=c9d2e0a20b79cf2c65ff86e8b400ff683b18627d;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index dbb14bc..223dbd3 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -94,10 +94,15 @@ moniker. sub register_source { my ($self, $moniker, $source) = @_; + + %$source = %{ $source->new( { %$source, source_name => $moniker }) }; + my %reg = %{$self->source_registrations}; $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}; @@ -106,6 +111,19 @@ sub register_source { } } +sub _unregister_source { + my ($self, $moniker) = @_; + my %reg = %{$self->source_registrations}; + + my $source = delete $reg{$moniker}; + $self->source_registrations(\%reg); + if ($source->result_class) { + my %map = %{$self->class_mappings}; + delete $map{$source->result_class}; + $self->class_mappings(\%map); + } +} + =head2 class =over 4 @@ -268,10 +286,18 @@ sub load_classes { foreach my $prefix (keys %comps_for) { foreach my $comp (@{$comps_for{$prefix}||[]}) { my $comp_class = "${prefix}::${comp}"; + { # try to untaint module name. 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 + if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) { + $comp_class = $1; + } + } $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 ]); + $comp = $comp_class->source_name || $comp; +# $DB::single = 1; + push(@to_register, [ $comp, $comp_class ]); } } } @@ -441,7 +467,7 @@ sub load_namespaces { return; } -=head2 compose_connection +=head2 compose_connection (DEPRECATED) =over 4 @@ -451,6 +477,12 @@ sub load_namespaces { =back +DEPRECATED. You probably wanted compose_namespace. + +Actually, you probably just wanted to call connect. + +=for hidden due to deprecation + Calls L to the target namespace, calls L with @db_info on the new schema, then injects the L component and a @@ -465,43 +497,50 @@ more information. =cut -sub compose_connection { - my ($self, $target, @info) = @_; - my $base = 'DBIx::Class::ResultSetProxy'; - eval "require ${base};"; - $self->throw_exception - ("No arguments to load_classes and couldn't load ${base} ($@)") - if $@; - - 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 $warn; + + sub compose_connection { + my ($self, $target, @info) = @_; + + warn "compose_connection deprecated as of 0.08000" unless $warn++; + + my $base = 'DBIx::Class::ResultSetProxy'; + eval "require ${base};"; + $self->throw_exception + ("No arguments to load_classes and couldn't load ${base} ($@)") + if $@; + + 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'; + *{"${target}::schema"} = sub { $schema }; + } + + $schema->connection(@info); + foreach my $moniker ($schema->sources) { + my $source = $schema->source($moniker); my $class = $source->result_class; - $self->inject_base($class, $base); + #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 => $self); + $class->mk_classdata(class_resolver => $schema); } - $self->connection(@info); - return $self; + return $schema; } - - my $schema = $self->compose_namespace($target, $base); - { - no strict 'refs'; - *{"${target}::schema"} = 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; } =head2 compose_namespace @@ -539,9 +578,6 @@ will produce the output sub compose_namespace { my ($self, $target, $base) = @_; - my %reg = %{ $self->source_registrations }; - my %target; - my %map; my $schema = $self->clone; { no warnings qw/redefine/; @@ -813,7 +849,7 @@ sub populate { } return @created; } - $self->storage->insert_bulk($self->source($name)->from, \@names, $data); + $self->storage->insert_bulk($self->source($name), \@names, $data); } =head2 exception_action @@ -878,12 +914,17 @@ sub throw_exception { 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. +across all databases, or fully handle complex relationships. Saying that, it +has been used successfully by many people, including the core dev team. 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. +Additionally, the DBIx::Class parser accepts a C parameter as a hash +ref or an array ref, containing a list of source to deploy. If present, then +only the sources listed will get deployed. + =cut sub deploy { @@ -963,7 +1004,7 @@ sub ddl_filename { my ($self, $type, $dir, $version, $pversion) = @_; my $filename = ref($self); - $filename =~ s/::/-/; + $filename =~ s/::/-/g; $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); $filename =~ s/$version/$pversion-$version/ if($pversion);