1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
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)");
}
}
|
