Imported from /srv/lorry/lorry-area/perl-dbd-sqlite-tarball/DBD-SQLite-1.38_01.tar.gz.HEADDBD-SQLite-1.38_01masterbaserock/morph

1 files changed, 146 insertions, 0 deletions

diff --git a/t/13_create_collation.t b/t/13_create_collation.t
new file mode 100644
index 0000000..8849249
--- /dev/null
+++ b/t/13_create_collation.t
@@ -0,0 +1,146 @@
+#!/usr/bin/perl
+
+use strict;
+BEGIN {
+	$|  = 1;
+	$^W = 1;
+}
+
+use t::lib::Test     qw/connect_ok dies @CALL_FUNCS/;
+use Test::More;
+BEGIN {
+        my $COLLATION_TESTS = 10;
+        my $WRITE_ONCE_TESTS = 4;
+
+	if ( $] >= 5.008005 ) {
+		plan( tests => $COLLATION_TESTS * @CALL_FUNCS + 
+                               $WRITE_ONCE_TESTS + 1);
+	} else {
+		plan( skip_all => 'Unicode is not supported before 5.8.5' );
+	}
+}
+use Test::NoWarnings;
+use Encode qw/decode/;
+use DBD::SQLite;
+
+BEGIN {
+	# Sadly perl for windows (and probably sqlite, too) may hang
+	# if the system locale doesn't support european languages.
+	# en-us should be a safe default. if it doesn't work, use 'C'.
+	if ( $^O eq 'MSWin32') {
+		use POSIX 'locale_h';
+		setlocale(LC_COLLATE, 'en-us');
+	}
+}
+
+# ad hoc collation functions
+sub no_accents ($$) {
+	my ( $a, $b ) = map lc, @_;
+	tr[àâáäåãçðèêéëìîíïñòôóöõøùûúüý]
+	  [aaaaaacdeeeeiiiinoooooouuuuy] for $a, $b;
+	$a cmp $b;
+}
+
+sub by_length ($$) {
+	length($_[0]) <=> length($_[1])
+}
+
+sub by_num ($$) {
+	$_[0] <=> $_[1];
+}
+sub by_num_desc ($$) {
+	$_[1] <=> $_[0];
+}
+
+
+# collation 'no_accents' will be automatically loaded on demand
+$DBD::SQLite::COLLATION{no_accents} = \&no_accents;
+
+
+$" = ", "; # to embed arrays into message strings
+
+my $sql = "SELECT txt from collate_test ORDER BY txt";
+
+
+
+# test interaction with the global COLLATION hash ("WriteOnce")
+
+dies (sub {$DBD::SQLite::COLLATION{perl} = sub {}},
+      qr/already registered/,
+      "can't override builtin perl collation");
+
+dies (sub {delete $DBD::SQLite::COLLATION{perl}},
+      qr/deletion .* is forbidden/,
+      "can't delete builtin perl collation");
+
+# once a collation is registered, we can't override it ... unless by
+# digging into the tied object
+$DBD::SQLite::COLLATION{foo} = \&by_num;
+dies (sub {$DBD::SQLite::COLLATION{foo} = \&by_num_desc},
+      qr/already registered/,
+      "can't override registered collation");
+my $tied = tied %DBD::SQLite::COLLATION;
+delete $tied->{foo};
+$DBD::SQLite::COLLATION{foo} = \&by_num_desc; # override, no longer dies
+is($DBD::SQLite::COLLATION{foo}, \&by_num_desc, "overridden collation");
+
+
+
+# now really test the collation functions
+
+foreach my $call_func (@CALL_FUNCS) {
+
+  for my $use_unicode (0, 1) {
+
+    # connect
+    my $dbh = connect_ok( RaiseError => 1, sqlite_unicode => $use_unicode );
+
+    # populate test data
+    my @words = qw{
+	berger Bergèòe bergèòe Bergere
+	HOT hôôe 
+	héôéòoclite héôaïòe hêôre héòaut
+	HAT hâôer 
+	féôu fêôe fèöe ferme
+     };
+    if ($use_unicode) {
+      utf8::upgrade($_) foreach @words;
+    }
+
+    $dbh->do( 'CREATE TEMP TABLE collate_test ( txt )' );
+    $dbh->do( "INSERT INTO collate_test VALUES ( '$_' )" ) foreach @words;
+
+    # test builtin collation "perl"
+    my @sorted    = sort @words;
+    my $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE perl");
+    is_deeply(\@sorted, $db_sorted, "collate perl (@sorted // @$db_sorted)");
+
+  SCOPE: {
+      use locale;
+      @sorted = sort @words;
+    }
+
+    # test builtin collation "perllocale"
+    $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE perllocale");
+    is_deeply(\@sorted, $db_sorted, 
+              "collate perllocale (@sorted // @$db_sorted)");
+
+    # test additional collation "no_accents"
+    @sorted    = sort no_accents @words;
+    $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE no_accents");
+    is_deeply(\@sorted, $db_sorted, 
+              "collate no_accents (@sorted // @$db_sorted)");
+
+
+    # manual addition of a collation for this dbh
+    $dbh->$call_func(by_length => \&by_length, "create_collation");
+    @sorted    = sort by_length @words;
+    $db_sorted = $dbh->selectcol_arrayref("$sql COLLATE by_length");
+    is_deeply(\@sorted, $db_sorted, 
+              "collate by_length (@sorted // @$db_sorted)");
+  }
+}
+
+
+
+