[svn:dbi] r14150 - dbi/trunk/lib/DBD

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