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

[email protected] Sat, 14 Aug 2010 07:57:38 -0700 (PDT)
Newsgroups perl.dbi.changes
Message-ID <[email protected]>
Author: REHSACK
Date: Sat Aug 14 07:57:38 2010
New Revision: 14328

Modified:
   dbi/trunk/lib/DBD/File.pm

Log:
- fix issue when absolute filename is used as table name
- minor speed improvements


Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm	(original)
+++ dbi/trunk/lib/DBD/File.pm	Sat Aug 14 07:57:38 2010
@@ -705,6 +705,8 @@
 
 # ====== FLYWEIGHT SUPPORT =====================================================
 
+my $fn_any_ext_regex = qr/\.[^.]*/;
+
 # Flyweight support for table_info
 # The functions file2table, init_table_meta, default_table_meta and
 # get_table_meta are using $self arguments for polymorphism only. The
@@ -735,16 +737,17 @@
 	$user_spec_file = 0;
 	}
 
-    -d File::Spec->catdir ($meta->{f_dir}, $dir) or
-	croak (File::Spec->catdir ($meta->{f_dir}, $dir) . ": $!");
-
     !$respect_case and $meta->{sql_identifier_case} == 1 and # XXX SQL_IC_UPPER
         $tbl = uc $tbl;
     !$respect_case and $meta->{sql_identifier_case} == 2 and # XXX SQL_IC_LOWER
         $tbl = lc $tbl;
+
     my $searchdir = File::Spec->file_name_is_absolute ($dir)
-	? $dir
+	? ($dir =~ s|/$||, $dir)
 	: Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
+    -d $searchdir or
+	croak "-d $searchdir: $!";
+
     $searchdir eq $meta->{f_dir} and
 	$dir = "";
 
@@ -755,7 +758,7 @@
 	my $cmpsub;
 	if ($respect_case) {
 	    $cmpsub = sub {
-		my ($fn, undef, $sfx) = File::Basename::fileparse ($_, qr/\.[^.]*/);
+		my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
 		$fn eq $tbl and
 		    return (lc $sfx eq lc $ext or !$req && !$sfx);
 		return 0;
@@ -763,7 +766,7 @@
 	    }
 	else {
 	    $cmpsub = sub {
-		my ($fn, undef, $sfx) = File::Basename::fileparse ($_, qr/\.[^.]*/);
+		my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex);
 		lc $fn eq lc $tbl and
 		    return (lc $sfx eq lc $ext or !$req && !$sfx);
 		return 0;