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
|
# This is a test for correct handling of the "unicode" database
# handle parameter.
use strict;
use warnings;
use lib "t/lib";
use SQLiteTest;
use Test::More;
use if -d ".git", "Test::FailWarnings";
use DBD::SQLite::Constants ':dbd_sqlite_string_mode';
my $unicode_opt = DBD_SQLITE_STRING_MODE_UNICODE_STRICT;
BEGIN { requires_unicode_support() }
#
# Include std stuff
#
use Carp;
use DBI qw(:sql_types);
# Unintuitively, still has the effect of loading bytes.pm :-)
no bytes;
# Portable albeit kludgy: detects UTF-8 promotion of $hibyte from
# the abnormal length increase of $string concatenated to it.
sub is_utf8 {
no bytes;
my ($string) = @_;
my $hibyte = pack("C", 0xe9);
my @lengths = map { bytes::length($_) } ($string, $string . $hibyte);
return ($lengths[0] + 1 < $lengths[1]);
}
# First, some UTF-8 framework self-test:
my @isochars = (ord("K"), 0xf6, ord("n"), ord("i"), ord("g"));
my $bytestring = pack("C*", @isochars);
my $utfstring = pack("U*", @isochars);
ok(length($bytestring) == @isochars, 'Correct length for $bytestring');
ok(length($utfstring) == @isochars, 'Correct length for $utfstring');
ok(
is_utf8($utfstring),
'$utfstring should be marked as UTF-8 by Perl',
);
ok(
! is_utf8($bytestring),
'$bytestring should *NOT* be marked as UTF-8 by Perl',
);
# Sends $ain and $bin into TEXT resp. BLOB columns the database, then
# reads them again and returns the result as a list ($aout, $bout).
### Real DBD::SQLite testing starts here
my ($textback, $bytesback);
SCOPE: {
my $dbh = connect_ok( dbfile => 'foo', RaiseError => 1 );
is( $dbh->{sqlite_string_mode}, DBD::SQLite::Constants::DBD_SQLITE_STRING_MODE_PV, 'default string mode is pv' );
ok(
$dbh->do("CREATE TABLE table1 (a TEXT, b BLOB)"),
'CREATE TABLE',
);
($textback, $bytesback) = database_roundtrip($dbh, $bytestring, $bytestring);
ok(
! is_utf8($bytesback),
"Reading blob gives binary",
);
ok(
! is_utf8($textback),
"Reading text gives binary too (for now)",
);
is($bytesback, $bytestring, "No blob corruption");
is($textback, $bytestring, "Same text, different encoding");
}
# Start over but now activate Unicode support.
SCOPE: {
my $dbh = connect_ok( dbfile => 'foo', sqlite_string_mode => $unicode_opt );
is( $dbh->{sqlite_string_mode}, $unicode_opt, 'Unicode is on' );
($textback, $bytesback) = database_roundtrip($dbh, $utfstring, $bytestring);
ok(! is_utf8($bytesback), "Reading blob still gives binary");
ok(is_utf8($textback), "Reading text returns UTF-8");
ok($bytesback eq $bytestring, "Still no blob corruption");
ok($textback eq $utfstring, "Same text");
my $lengths = $dbh->selectall_arrayref(
"SELECT length(a), length(b) FROM table1"
);
ok(
$lengths->[0]->[0] == $lengths->[0]->[1],
"Database actually understands char set"
)
or
warn "($lengths->[0]->[0] != $lengths->[0]->[1])";
}
# Test that passing a string with the utf-8 flag on is handled properly in a BLOB field
SCOPE: {
my $dbh = connect_ok( dbfile => 'foo' );
ok( utf8::upgrade($bytestring), 'bytestring upgraded to utf-8' );
ok( utf8::is_utf8($bytestring), 'bytestring has utf-8 flag' );
($textback, $bytesback) = database_roundtrip($dbh, $utfstring, $bytestring);
ok( $bytesback eq $bytestring, 'No blob corruption with utf-8 flag on' );
ok( utf8::downgrade($bytestring), 'bytestring downgraded to bytes' );
ok( !utf8::is_utf8($bytestring), 'bytestring does not have utf-8 flag' );
($textback, $bytesback) = database_roundtrip($dbh, $utfstring, $bytestring);
ok( $bytesback eq $bytestring, 'No blob corruption with utf-8 flag off' );
}
sub database_roundtrip {
my ($dbh, $ain, $bin) = @_;
$dbh->do("DELETE FROM table1");
my $sth = $dbh->prepare("INSERT INTO table1 (a, b) VALUES (?, ?)");
$sth->bind_param(1, $ain, SQL_VARCHAR);
$sth->bind_param(2, $bin, SQL_BLOB );
$sth->execute();
$sth = $dbh->prepare("SELECT a, b FROM table1");
$sth->execute();
my @row = $sth->fetchrow_array;
undef $sth;
croak "Bad row length ".@row unless (@row == 2);
@row;
}
done_testing;
|
