diff options
Diffstat (limited to 't/13_create_collation.t')
| -rw-r--r-- | t/13_create_collation.t | 146 |
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)"); + } +} + + + + |