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/;
=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</register_source> 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 }) };
$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);
}
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);
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');
}
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
$self->storage->txn_do(@_);
}
-=head2 txn_scope_guard
+=head2 txn_scope_guard (EXPERIMENTAL)
-Runs C<txn_scope_guard> on the schema's storage.
+Runs C<txn_scope_guard> on the schema's storage. See
+L<DBIx::Class::Storage/txn_scope_guard>.
=cut
my $clone = { (ref $self ? %$self : ()) };
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);
my $new = $source->new($source);
- $clone->register_source($moniker => $new);
+ # 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);
}
$clone->storage->set_schema($clone) if $clone->storage;
return $clone;
$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<create_ddl_dir> to compose a file name out of
the supplied directory, database type and version number. The default file
=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)
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