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
147
148
149
150
151
152
153
154
155
156
157
|
#!/usr/bin/perl -w -I./t
# based on *Id: 20SqlServer.t 568 2004-11-08 15:12:37Z jurl *
use strict;
use warnings;
use UChelp;
use Test::More;
use DBI qw(:sql_types);
my $has_test_nowarnings;
$|=1;
my $WAIT=0;
my @data;
my $tests;
my $data_tests;
my $other_tests;
BEGIN {
if ($] < 5.008001) {
plan skip_all => "Old Perl lacking unicode support";
} elsif (!defined $ENV{DBI_DSN}) {
plan skip_all => "DBI_DSN is undefined";
}
@data=(
"hello ASCII: the quick brown fox jumps over the yellow dog",
"Hello Unicode: german umlauts (\x{00C4}\x{00D6}\x{00DC}\x{00E4}\x{00F6}\x{00FC}\x{00DF}) smile (\x{263A}) hebrew shalom (\x{05E9}\x{05DC}\x{05D5}\x{05DD})",
);
push @data,map { "again $_" } @data;
utf8::is_utf8($data[0]) and die "Perl set UTF8 flag on non-unicode string constant";
utf8::is_utf8($data[1]) or die "Perl did not set UTF8 flag on unicode string constant";
utf8::is_utf8($data[2]) and die "Perl set UTF8 flag on non-unicode string constant";
utf8::is_utf8($data[3]) or die "Perl did not set UTF8 flag on unicode string constant";
$data_tests=12*@data;
$other_tests = 7;
$tests = $other_tests + $data_tests;
eval "require Test::NoWarnings";
if (!$@) {
$has_test_nowarnings = 1;
}
$tests += 1 if $has_test_nowarnings;
plan tests => $tests,
}
END {
Test::NoWarnings::had_no_warnings()
if ($has_test_nowarnings);
}
my $dbh=DBI->connect();
ok(defined($dbh),"DBI connect");
SKIP: {
if (!$dbh->{odbc_has_unicode}) {
skip "Unicode-specific tests disabled - not a unicode build",
$data_tests + $other_tests - 1;
}
my $dbname = $dbh->get_info(17); # DBI::SQL_DBMS_NAME
SKIP: {
my ($sth,$NVARCHAR);
if ($dbname=~/Microsoft SQL Server/i) {
($NVARCHAR)=('NVARCHAR(1000)');
} elsif ($dbname=~/Oracle/i) {
($NVARCHAR)=('NVARCHAR2(1000)');
} elsif ($dbname=~/PostgreSQL/i) {
($NVARCHAR)=('VARCHAR(1000)');
} elsif ($dbname=~/ACCESS/i) {
($NVARCHAR)=('MEMO');
} else {
skip "Tests not supported using $dbname",
$data_tests + $other_tests - 1;
}
$dbh->{RaiseError} = 1;
$dbh->{'LongTruncOk'}=1;
$dbh->{'LongReadLen'}=32000;
eval {
local $dbh->{PrintError}=0;
$dbh->do("DROP TABLE PERL_DBD_TABLE1");
};
pass("Drop old test table");
$dbh->{RaiseError} = 1;
$dbh->do(<<__SQL__);
CREATE TABLE
PERL_DBD_TABLE1
(
i INTEGER PRIMARY KEY,
nva $NVARCHAR,
nvb $NVARCHAR,
nvc $NVARCHAR
)
__SQL__
pass("Create test table");
# Insert records into the database:
$sth=$dbh->prepare("INSERT INTO PERL_DBD_TABLE1 (i,nva,nvb,nvc) values (?,?,?,?)");
ok(defined($sth),"prepare insert statement");
for (my $i=0; $i<@data; $i++) {
my ($nva,$nvb,$nvc)=($data[$i]) x 3;
$sth->bind_param (1, $i, SQL_INTEGER);
pass("Bind parameter SQL_INTEGER");
$sth->bind_param (2, $nva);
pass("Bind parameter default");
$sth->bind_param (3, $nvb, SQL_WVARCHAR);
pass("Bind parameter SQL_WVARCHAR");
$sth->bind_param (4, $nvc, SQL_WVARCHAR);
pass("Bind parameter SQL_WVARCHAR");
$sth->execute();
pass("execute()");
}
$sth->finish();
# Retrieve records from the database, and see if they match original data:
$sth=$dbh->prepare("SELECT i,nva,nvb,nvc FROM PERL_DBD_TABLE1");
ok(defined($sth),'prepare select statement');
$sth->execute();
pass('execute select statement');
while (my ($i,$nva,$nvb,$nvc)=$sth->fetchrow_array()) {
my $info=sprintf("(index=%i, Unicode=%s)",$i,utf8::is_utf8($data[$i]) ? 'on' : 'off');
pass("fetch select statement $info");
cmp_ok(utf8::is_utf8($nva),'>=',utf8::is_utf8($data[$i]),"utf8 flag $info col1");
utf_eq_ok($nva,$data[$i],"value matches $info col1");
cmp_ok(utf8::is_utf8($nvb),'>=',utf8::is_utf8($data[$i]),"utf8 flag $info col2");
utf_eq_ok($nva,$data[$i],"value matches $info col2");
cmp_ok(utf8::is_utf8($nvc),'>=',utf8::is_utf8($data[$i]),"utf8 flag $info col3");
utf_eq_ok($nva,$data[$i],"value matches $info col3");
}
$WAIT && eval {
print "you may want to look at the table now, the unicode data is damaged!\nHit Enter to continue\n";
$_=<STDIN>;
};
# eval {
# local $dbh->{RaiseError} = 0;
# $dbh->do("DROP TABLE PERL_DBD_TABLE1");
# };
$dbh->disconnect;
pass("all done");
}
};
exit 0;
|
