From 1a5d2ed879f4a17e56a9d3c34ccad28f269a23a6 Mon Sep 17 00:00:00 2001
From: Adam Kennedy <adamk@cpan.org>
Date: Wed, 15 Apr 2009 14:49:23 +0000
Subject: [PATCH] Encoding tweaks

---
 Changes               |  2 +-
 lib/DBD/SQLite.pm     | 22 ++++++++++++++++-
 t/33_non_latin_path.t | 56 +++++++++++++++++++++++++++++++++----------
 3 files changed, 65 insertions(+), 15 deletions(-)

diff --git a/Changes b/Changes
index 5479547..8830873 100644
--- a/Changes
+++ b/Changes
@@ -2,7 +2,7 @@ Changes for Perl extension DBD-SQLite.
 
 1.22_06 Wed 15 Apr 2009
     - Simplifying various miscellaneous code (ADAMK)
-    - Adding a test for non-latin filename support ()
+    - Adding support for non-latin unicode filenames on Windows (ADAMK)
 
 1.22_05 Wed 15 Apr 2009
     - Hopefully the last dev release before the next production release.
diff --git a/lib/DBD/SQLite.pm b/lib/DBD/SQLite.pm
index eac479c..f2a8db0 100644
--- a/lib/DBD/SQLite.pm
+++ b/lib/DBD/SQLite.pm
@@ -53,7 +53,7 @@ sub connect {
 
     my $real = $dbname;
     if ( $dbname =~ /=/ ) {
-        foreach my $attrib ( split(/;/, $dbname ) ) {
+        foreach my $attrib ( split(/;/, $dbname) ) {
             my ($key, $value) = split(/=/, $attrib, 2);
             if ( $key eq 'dbname' ) {
                 $real = $value;
@@ -63,6 +63,26 @@ sub connect {
         }
     }
 
+    # To avoid unicode and long file name problems on Windows,
+    # convert to the shortname if the file (or parent directory) exists.
+    if ( $^O eq 'MSWin32' ) {
+        require Win32;
+        require File::Basename;
+        my ($file, $dir, $suffix) = File::Basename::fileparse($real);
+        if ( -f $real ) {
+            # Existing files will work directly.
+            $real = Win32::GetShortPathName($real);
+        } elsif ( -d $dir ) {
+            # We are creating a new file.
+            # Does the directory it's in at least exist?
+            $real = Win32::GetShortPathName($dir) . $file . $suffix;
+        } else {
+            # SQLite can't do mkpath anyway.
+            # So let it go through as it and fail.
+        }
+    }
+
+    # Hand off to the actual login function
     DBD::SQLite::db::_login($dbh, $real, $user, $auth) or return undef;
 
     # Install perl collations
diff --git a/t/33_non_latin_path.t b/t/33_non_latin_path.t
index 4944504..1e4d8fe 100644
--- a/t/33_non_latin_path.t
+++ b/t/33_non_latin_path.t
@@ -8,26 +8,59 @@ BEGIN {
 	$|  = 1;
 	$^W = 1;
 }
-use utf8;
 
 use t::lib::Test;
 use Test::More;
+BEGIN {
+	if ( $] >= 5.008005 ) {
+		plan( tests => 13 );
+	} else {
+		plan( skip_all => 'Unicode is not supported before 5.8.5' );
+	}
+}
 use Test::NoWarnings;
-use File::Temp            qw(tempdir);
-use File::Spec::Functions qw(catdir catfile);
+use File::Temp ();
+use File::Spec::Functions ':ALL';
 
-my @words = ('database', 'adatbázis');
-plan tests => 1 + @words * 3;
+# Don't use this, it annoys the MinimumVersion scanner
+# use utf8;
 
-my $dir = tempdir( CLEANUP => 1 );
+eval "require utf8";
+die $@ if $@;
 
-foreach my $subdir (@words) {
-	ok(mkdir(catdir($dir, $subdir)), "subdir $subdir created");
+my $dir = File::Temp::tempdir( CLEANUP => 1 );
+foreach my $subdir ( 'longascii', 'adatbázis' ) {
+	utf8::upgrade($subdir);
+	ok(
+		mkdir(catdir($dir, $subdir)),
+		"$subdir created",
+	);
+
+	# Open the database
 	my $dbfile = catfile($dir, $subdir, 'db.db');
 	eval {
-		DBI->connect("dbi:SQLite:dbname=$dbfile", "", "", {RaiseError => 1, PrintError => 0});
+		my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", undef, undef, {
+			RaiseError => 1,
+			PrintError => 0,
+		} );
+		isa_ok( $dbh, 'DBI::db' );
 	};
-	ok(!$@, "Could connect to database in $subdir") or diag $@;
+	is( $@, '', "Could connect to database in $subdir" );
+	diag( $@ ) if $@;
+	unlink($dbfile)  if -e $dbfile;
+
+	# Repeat with the unicode flag on
+	my $ufile = $dbfile;
+	eval {
+		my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", undef, undef, {
+			RaiseError => 1,
+			PrintError => 0,
+			unicode    => 1,
+		} );
+		isa_ok( $dbh, 'DBI::db' );
+	};
+	is( $@, '', "Could connect to database in $subdir" );
+	diag( $@ ) if $@;
 	
 	# when the name of the database file has non-latin characters
 	my $dbfilex = catfile($dir, "$subdir.db");
@@ -36,6 +69,3 @@ foreach my $subdir (@words) {
 	};
 	ok(!$@, "Could connect to database in $dbfilex") or diag $@;
 }
-
-
-