X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=7f7fb37c68e8486dbf03491f82fde7d9f178438b;hb=2a4d9487f09d04cde419d6840e06b9be5a880a23;hp=a51ab964ccf82440a506c2f44c2553ff5150f439;hpb=161fb22350bdfb511af2cc96d2a556a4296c20e8;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index a51ab96..7f7fb37 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -7,6 +7,7 @@ use DBIx::Class::Exception; use Carp::Clan qw/^DBIx::Class/; use Scalar::Util qw/weaken/; use File::Spec; +use Sub::Name (); require Module::Find; use base qw/DBIx::Class/; @@ -96,7 +97,32 @@ moniker. =cut sub register_source { - my ($self, $moniker, $source) = @_; + my $self = shift; + + $self->_register_source(@_); +} + +=head2 register_extra_source + +=over 4 + +=item Arguments: $moniker, $result_source + +=back + +As L but should be used if the result class already +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_source { + my ($self, $moniker, $source, $params) = @_; %$source = %{ $source->new( { %$source, source_name => $moniker }) }; @@ -106,9 +132,14 @@ sub register_source { $source->schema($self); + return if ($params->{extra}); + weaken($source->{schema}) if ref($self); if ($source->result_class) { my %map = %{$self->class_mappings}; + if (exists $map{$source->result_class}) { + warn $source->result_class . ' already has a source, use register_extra_source for additional sources'; + } $map{$source->result_class} = $moniker; $self->class_mappings(\%map); } @@ -535,7 +566,8 @@ more information. my $schema = $self->compose_namespace($target, $base); { no strict 'refs'; - *{"${target}::schema"} = sub { $schema }; + my $name = join '::', $target, 'schema'; + *$name = Sub::Name::subname $name, sub { $schema }; } $schema->connection(@info); @@ -606,26 +638,13 @@ sub compose_namespace { no strict 'refs'; no warnings 'redefine'; foreach my $meth (qw/class source resultset/) { - *{"${target}::${meth}"} = - sub { shift->schema->$meth(@_) }; + my $name = join '::', $target, $meth; + *$name = Sub::Name::subname $name, sub { shift->schema->$meth(@_) }; } } return $schema; } -=head2 setup_connection_class - -=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. - -=cut - sub setup_connection_class { my ($class, $target, @info) = @_; $class->inject_base($target => 'DBIx::Class::DB'); @@ -699,14 +718,14 @@ sub connection { } sub _normalize_storage_type { - my ($self, $storage_type) = @_; - if(ref $storage_type eq 'ARRAY') { - return @$storage_type; - } elsif(ref $storage_type eq 'HASH') { - return %$storage_type; - } else { - $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type); - } + my ($self, $storage_type) = @_; + if(ref $storage_type eq 'ARRAY') { + return @$storage_type; + } elsif(ref $storage_type eq 'HASH') { + return %$storage_type; + } else { + $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type); + } } =head2 connect @@ -755,9 +774,10 @@ sub txn_do { $self->storage->txn_do(@_); } -=head2 txn_scope_guard +=head2 txn_scope_guard (EXPERIMENTAL) -Runs C on the schema's storage. +Runs C on the schema's storage. See +L. =cut @@ -893,6 +913,7 @@ sub clone { foreach my $moniker ($self->sources) { my $source = $self->source($moniker); my $new = $source->new($source); + $clone->_unregister_source($moniker); $clone->register_source($moniker => $new); } $clone->storage->set_schema($clone) if $clone->storage; @@ -1049,7 +1070,9 @@ 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. +only the sources listed will get deployed. Furthermore, you can use the +C parser parameter to prevent the parser from creating an index for each +FK. =cut @@ -1103,6 +1126,8 @@ override this method in your schema if you would like a different file name format. For the ALTER file, the same format is used, replacing $version in the name with "$preversion-$version". +See L for details of $sqlt_args. + If no arguments are passed, then the following default values are used: =over 4 @@ -1131,15 +1156,15 @@ sub create_ddl_dir { $self->storage->create_ddl_dir($self, @_); } -=head2 ddl_filename (EXPERIMENTAL) +=head2 ddl_filename =over 4 -=item Arguments: $directory, $database-type, $version, $preversion +=item Arguments: $database-type, $version, $directory, $preversion =back - my $filename = $table->ddl_filename($type, $dir, $version, $preversion) + my $filename = $table->ddl_filename($type, $version, $dir, $preversion) This method is called by C to compose a file name out of the supplied directory, database type and version number. The default file @@ -1151,14 +1176,14 @@ format. =cut sub ddl_filename { - my ($self, $type, $dir, $version, $pversion) = @_; + my ($self, $type, $version, $dir, $preversion) = @_; - my $filename = ref($self); - $filename =~ s/::/-/g; - $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); - $filename =~ s/$version/$pversion-$version/ if($pversion); - - return $filename; + my $filename = ref($self); + $filename =~ s/::/-/g; + $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql"); + $filename =~ s/$version/$preversion-$version/ if($preversion); + + return $filename; } =head2 sqlt_deploy_hook($sqlt_schema) @@ -1208,6 +1233,29 @@ sub dclone { return Storable::dclone($obj); } +=head2 schema_version + +Returns the current schema class' $VERSION + +=cut + +sub schema_version { + my ($self) = @_; + my $class = ref($self)||$self; + + # does -not- use $schema->VERSION + # since that varies in results depending on if version.pm is installed, and if + # so the perl or XS versions. If you want this to change, bug the version.pm + # author to make vpp and vxs behave the same. + + my $version; + { + no strict 'refs'; + $version = ${"${class}::VERSION"}; + } + return $version; +} + 1; =head1 AUTHORS