Author: REHSACK
Date: Tue Jun 15 02:54:14 2010
New Revision: 14150
Modified:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
Log:
- Improve DBD::File::db::get_versions and retrieve additional info from
derived ImplementorClass
- Remove depreciated DBD::DBM::dbm_versions stub
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Tue Jun 15 02:54:14 2010
@@ -47,7 +47,6 @@
#
unless ( $methods_already_installed++ )
{
- DBD::DBM::db->install_method('dbm_versions');
DBD::DBM::st->install_method('dbm_schema');
}
@@ -229,38 +228,36 @@
return $dbh;
}
-# this is an example of a private method
-# these used to be done with $dbh->func(...)
-# see above in the driver() sub for how to install the method
-#
-sub dbm_versions
-{
- my $class = $_[0]->FETCH ("ImplementorClass");
- my $get_versions = $class->can( 'get_versions' );
- goto &$get_versions;
-}
-
-sub get_versions
+sub get_dbm_versions
{
my ($dbh, $table) = @_;
$table ||= '';
- my @versions = $dbh->SUPER::get_versions( $table );
-
- # update first line (optical)
- my $dbdfv = shift @versions;
- my ($pkg, $info) = split( /\s+/, $dbdfv, 2 );
- unshift (@versions, sprintf ("%-16s %s", ' ' . $pkg, $info ));
my $class = $dbh->FETCH ("ImplementorClass");
$class =~ s/::db$/::Table/;
my (undef, $meta) = $class->get_table_meta( $dbh, $table, 1 );
$meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta,
$table ) );
+ my $dver;
+ my $eval_str;
+ $eval_str = sprintf( '$dver = $%s::VERSION', $meta->{dbm_type} );
+ eval $eval_str;
my $dtype = $meta->{dbm_type};
- $dtype .= ' + MLDBM + ' . $meta->{dbm_mldbm} if( $meta->{dbm_mldbm} );
- unshift( @versions, sprintf( "%-16s %s using %s", 'DBD::DBM',
$dbh->{dbm_version}, $dtype ) );
-
- return wantarray ? @versions : join ("\n", @versions);
+ $dtype .= ' (' . $dver . ')' if $dver;
+ if( $meta->{dbm_mldbm} )
+ {
+ $dtype .= ' + MLDBM';
+ $eval_str = '$dver = $MLDBM::VERSION';
+ eval $eval_str;
+ $dtype .= ' (' . $dver . ')' if $dver;
+ $dtype .= ' + ' . $meta->{dbm_mldbm};
+ $eval_str = sprintf( 'require MLDBM::Serializer::%s;' .
+ '$dver = $MLDBM::Serializer::%s::VERSION',
+ $meta->{dbm_mldbm}, $meta->{dbm_mldbm} );
+ eval $eval_str;
+ $dtype .= ' (' . $dver . ')' if $dver;
+ }
+ return sprintf( "%s using %s", $dbh->{dbm_version}, $dtype );
}
# you may need to over-ride some DBD::File::db methods here
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Tue Jun 15 02:54:14 2010
@@ -501,21 +501,41 @@
sub get_versions
{
- my $dbh = $_[0];
+ my ($dbh, $table) = @_;
my %vsn = (
OS => "$^O ($Config::Config{osvers})",
Perl => "$] ($Config::Config{archname})",
DBI => $DBI::VERSION,
-
- "DBD::File" => join " ",
- $dbh->{f_version}, "using", $dbh->{sql_handler},
- $dbh->{sql_handler} eq "SQL::Statement"
- ? $dbh->{sql_statement_version}
- : $dbh->{sql_nano_version},
);
+ my %vmp;
+
+ my $dbd_file_verinfo = join " ",
+ $dbh->{f_version}, "using", $dbh->{sql_handler},
+ $dbh->{sql_handler} eq "SQL::Statement"
+ ? $dbh->{sql_statement_version}
+ : $dbh->{sql_nano_version};
+
+ (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
+ my $drv_prefix = DBI->driver_prefix ($drv_class);
+ my $ddgv = $dbh->{ImplementorClass}->can( "get_" . $drv_prefix .
"versions" );
+ if ($ddgv) {
+ $vsn{"DBD::File"} = $dbd_file_verinfo;
+ $vmp{"DBD::File"} = " DBD::File";
+ $vsn{$drv_class} = &$ddgv ($dbh, $table);
+ }
+ else {
+ $vsn{"DBD::File"} = $dbd_file_verinfo;
+ }
+
$DBI::PurePerl and $vsn{"DBI::PurePerl"} = $DBI::PurePerl::VERSION;
- my @versions = map { sprintf "%-16s %s", $_, $vsn{$_} } sort keys %vsn;
+ my @versions = map { sprintf "%-16s %s", $vmp{$_} || $_, $vsn{$_} }
+ sort
+ {
+ $a->isa ($b) and return -1;
+ $b->isa ($a) and return 1;
+ return $a cmp $b;
+ } keys %vsn;
return wantarray ? @versions : join "\n", @versions;
} # get_versions
