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
|
#!/usr/bin/perl -w -I./t
# $Id: rt_61370.t 14448 2010-09-24 10:07:23Z mjevans $
#
# rt 61370
#
# Check DBD::ODBC handles MS SQL Server XML column type as Unicode
# and that set magic is used internally to ensure length() returns the
# correct value.
#
use Test::More;
use strict;
#my $has_test_more_utf8 = 1;
#eval "require Test::More::UTF8";
#$has_test_more_utf8 = undef if $@;
binmode Test::More->builder->output, ":utf8";
binmode Test::More->builder->failure_output, ":utf8";
binmode STDOUT, ':utf8';
use DBI qw(:sql_types);
use_ok('ODBCTEST');
my $dbh;
BEGIN {
if (!defined $ENV{DBI_DSN}) {
plan skip_all => "DBI_DSN is undefined";
}
}
END {
if ($dbh) {
eval {
local $dbh->{PrintWarn} = 0;
local $dbh->{PrintError} = 0;
$dbh->do(q/drop table PERL_DBD_RT_61370/);
};
}
}
$dbh = DBI->connect();
unless($dbh) {
BAIL_OUT("Unable to connect to the database $DBI::errstr\nTests skipped.\n");
exit 0;
}
$dbh->{RaiseError} = 1;
$dbh->{ChopBlanks} = 1;
my ($txt_de, $txt_ru);
{
use utf8;
$txt_de = 'Käse';
$txt_ru = 'Москва';
}
my $dbms_name = $dbh->get_info(17);
ok($dbms_name, "got DBMS name: $dbms_name"); # 2
my $dbms_version = $dbh->get_info(18);
ok($dbms_version, "got DBMS version: $dbms_version"); # 3
my $driver_name = $dbh->get_info(6);
ok($driver_name, "got DRIVER name: $driver_name"); # 4
my $driver_version = $dbh->get_info(7);
ok($driver_version, "got DRIVER version $driver_version"); # 5
my ($ev, $sth);
# this needs to be MS SQL Server and not the OOB driver
if ($dbms_name !~ /Microsoft SQL Server/) {
note('Not Microsoft SQL Server');
done_testing();
exit 0;
}
if ($driver_name =~ /esoobclient/) {
note("Easysoft OOB");
done_testing();
exit 0;
}
if (!$dbh->{odbc_has_unicode}) {
note('DBD::ODBC not built with unicode support');
done_testing();
exit 0;
}
eval {
local $dbh->{PrintWarn} = 0;
local $dbh->{PrintError} = 0;
$dbh->do('drop table PERL_DBD_RT_61370');
};
# try and create a table with an XML column
# if we cannot, we'll have to assume your SQL Server is too old
# and skip the rest of the tests
eval {
$dbh->do('create table PERL_DBD_RT_61370 (a int primary key, b xml)');
};
$ev = $@;
if ($@) {
note("Failed to create test table with XML type - server too old and perhaps does not support XML column type ($ev)");
done_testing;
exit 0;
}
pass('created test table');
eval {
$sth = $dbh->prepare('INSERT into PERL_DBD_RT_61370 VALUES (?,?)');
};
$ev = $@;
diag($ev) if $ev;
ok(!$ev, 'prepare insert');
SKIP: {
skip "Failed to prepare xml insert - $@", 8 if $ev;
my @rowdata = ([1, "<d>$txt_de</d>"], [2, "<d>$txt_ru</d>"]);
$ev = undef;
foreach my $row(@rowdata) {
$sth->bind_param(1, $row->[0]);
$sth->bind_param(2, $row->[1]);
eval {$sth->execute};
if ($@) {
$ev = $@;
fail('execute for insert'); # 1,2
} else {
pass('execute for insert'); # 1,2
}
}
SKIP: {
skip "Could not insert test data - $@", 6 if $ev;
$sth = $dbh->prepare(q/select a,b from PERL_DBD_RT_61370 order by a/);
ok($sth, 'prepare for select'); # 1
ok($sth->execute, 'execute for select'); # 2
$sth->bind_col(1, \my $pkey);
$sth->bind_col(2, \my $xml, {TYPE => SQL_WCHAR});
foreach my $row(@rowdata) {
$sth->fetch;
#diag(sprintf("%3u %s", length($row->[1]), $row->[1]));
is($xml, $row->[1], 'inserted/selected strings match'); # 3,5
is(length($xml), length($row->[1]),
'inserted/selected string sizes match'); # 4,6
}
};
};
eval {
local $dbh->{PrintWarn} = 0;
local $dbh->{PrintError} = 0;
$dbh->do('drop table PERL_DBD_RT_61370');
};
done_testing();
|
