Ah, I've just remembered the UTF8 patch kindly sent by Stefan Eissing!
I've appended his email and attached the attachments.
Please let me, and Stefan, know how it goes for you.
Tim.
------
Tim,
attached is the current diff against 1.03 of my utf8 port.
With Perl 5.6.0 patchlevel 6090, all tests pass. I've
added select.t to test (VAR)CHAR(2) and utf8 behaviour.
One annoyance is that pre5.6.0 versions now give warning
about illegal hex chars in long.t/select.t (because of the
unicode constants).
This patch has the following improvements compared to the last:
a) it works with utf8 chars in CHAR/VARCHAR columns
b) it marks strings with UTF8 only when 8-bit chars are present.
this should give better performance as perl can skip the utf8
special handling more often (at least in the U.S. that is)
c) there is a readme about utfishiness
d) it was even more fun. Sarathy was very helpful and I supplied
my first patches to Perl itself. ;)
Stefan
------
>From Perl 5.6.0 onwards DBD::Oracle supports UTF8 as local
character set (using OCI8). Thus, when the environment
variable NLS_LANG ends with "utf8", DBD::Oracle marks Perl
strings as unicode (when multibyte characters are present).
This affects the handling of CHAR/VARCHARx columns and
LONGs/CLOBs.
Multibyte chars in Perl 5.6.0:
Perl 5.6.0 switches to character semantics (as compared to
byte) for multibyte strings. According to Perl documentation
this is done transparently to Perl scripts - all builtin
operators know about it. DBD::Oracle tries to preserve this
transparency as far as Oracle allows this (see below).
As a consequence, "LongReadLen" now counts characters and
not bytes when dealing with LONG/CLOB values. Selected LONGs
and CLOBs will return at most LongReadLen chars, but may
contain a multiple of that in actual bytes.
blob_read issued on CLOBs will also use character semantics.
You have to take extra precautions when using such strings
in a byte-size context, for example a fixed size field in
a protocol message. This is not specific to DBD::Oracle as
such, but be warned.
You need patches at least up to 6090 for Perl 5.6.0 for utf8
to work with DBD::Oracle. (For WinUsers: ActiveState build
beyond 613 will probably do).
Multibyte chars in Oracle 8(i)
CHAR/VARCHAR and friends count size in bytes, not characters.
If you have a Oracle database created with character set utf8
and insert a string with 10 characters into a VARCHAR2(10)
column, this will only work if the string is 10 bytes long.
If the string is longer, it will fail (and report and error).
This behaviour is inherent to Oracle/OCI and not influenced
by DBD::Oracle.
This is then the place where transparency of utf8 breaks. If
you want to check your parameter lengths before insert, you
have to switch Perl to bytes semantics (see "use bytes" in
Perl documentation).
2000-05-09, Stefan Eissing ([EMAIL PROTECTED])
*** //c/usr/local/src/DBD-Oracle-1.03//./dbdimp.c Mon Jul 12 05:21:10 1999
--- ./dbdimp.c Tue May 09 10:58:37 2000
***************
*** 23,28 ****
--- 23,32 ----
int ora_fetchtest;
+ #ifdef UTF8_SUPPORT
+ int cs_is_utf8;
+ #endif
+
static int ora_login_nomsg; /* don't fetch real login errmsg if true */
static int ora_sigchld_restart = 1;
#ifndef OCI_V8_SYNTAX
***************
*** 45,50 ****
--- 49,63 ----
ora_login_nomsg = atoi(getenv("DBD_ORACLE_LOGIN_NOMSG"));
if (getenv("DBD_ORACLE_SIGCHLD"))
ora_sigchld_restart = atoi(getenv("DBD_ORACLE_SIGCHLD"));
+ #ifdef UTF8_SUPPORT
+ {
+ char *nls = getenv("NLS_LANG");
+ STRLEN nlslen;
+ if (nls && (nlslen = strlen(nls)) >= 4) {
+ cs_is_utf8 = !stricmp(nls + nlslen - 4, "utf8");
+ }
+ }
+ #endif
}
***************
*** 1341,1347 ****
--- 1354,1364 ----
else
/* phs->alen has been updated by Oracle to hold the length of the result
*/
if (phs->indp == 0) { /* is okay */
+ #ifdef UTF8_SUPPORT
+ SvPOK_only_UTF8(sv);
+ #else
SvPOK_only(sv);
+ #endif
SvCUR(sv) = phs->alen;
*SvEND(sv) = '\0';
if (debug >= 2)
***************
*** 1351,1357 ****
--- 1368,1378 ----
}
else
if (phs->indp > 0 || phs->indp == -2) { /* truncated */
+ #ifdef UTF8_SUPPORT
+ SvPOK_only_UTF8(sv);
+ #else
SvPOK_only(sv);
+ #endif
SvCUR(sv) = phs->alen;
*SvEND(sv) = '\0';
if (debug >= 2)
***************
*** 1395,1400 ****
--- 1416,1432 ----
bufsv = SvRV(destrv);
sv_setpvn(bufsv,"",0); /* ensure it's writable string */
+
+ #ifdef OCI_V8_SYNTAX
+ #ifdef UTF8_SUPPORT
+ if (ftype == 112 && cs_is_utf8) {
+ return ora_blob_read_mb_piece(sth, imp_sth, fbh, bufsv,
+ offset, len, destoffset);
+ }
+
+ #endif /* UTF8_SUPPORT */
+ #endif /* ifdef OCI_V8_SYNTAX */
+
SvGROW(bufsv, destoffset+len+1); /* SvGROW doesn't do +1 */
#ifdef OCI_V8_SYNTAX
*** //c/usr/local/src/DBD-Oracle-1.03//./dbdimp.h Mon Jul 12 05:21:12 1999
--- ./dbdimp.h Thu May 04 12:55:12 2000
***************
*** 236,241 ****
--- 236,245 ----
extern int ora_fetchtest;
+ #ifdef UTF8_SUPPORT
+ extern int cs_is_utf8;
+ #endif
+
void dbd_init_oci _((dbistate_t *dbistate));
void dbd_preparse _((imp_sth_t *imp_sth, char *statement));
void dbd_fbh_dump _((imp_fbh_t *fbh, int i, int aidx));
*** //c/usr/local/src/DBD-Oracle-1.03//./Makefile.PL Mon Jul 12 05:21:14 1999
--- ./Makefile.PL Tue May 09 11:00:51 2000
***************
*** 162,168 ****
elsif (($os eq 'MSWin32') or ($os =~ /cygwin/i)) {
my $oci_compiler_dir = ($Config{cc} eq 'bcc32' ? "BORLAND" : "MSVC");
! my $OCIDIR = "";
find( sub {
print "Found $_ directory\n" if /^OCI\d+/i;
$OCIDIR = $_ if /^OCI\d\d+$/i && $OCIDIR lt $_;
--- 162,168 ----
elsif (($os eq 'MSWin32') or ($os =~ /cygwin/i)) {
my $oci_compiler_dir = ($Config{cc} eq 'bcc32' ? "BORLAND" : "MSVC");
! my $OCIDIR = "OCI";
find( sub {
print "Found $_ directory\n" if /^OCI\d+/i;
$OCIDIR = $_ if /^OCI\d\d+$/i && $OCIDIR lt $_;
***************
*** 372,377 ****
--- 372,379 ----
$opts{DEFINE} .= ' -Xa' if $Config{cc} eq 'clcc'; # CenterLine CC
$opts{DEFINE} .= ' -DNO_OCI8' if $::opt_8;
+
+ $opts{DEFINE} .= ' -DUTF8_SUPPORT' if ($] >= 5.006);
$opts{DEFINE} .= ' $(HP64DEFINES)' if ($os eq "hpux" and $Config{archname} =~
/-thread\b/i
and $Config{ccflags} =~ /\+DD64\b/);
*** //c/usr/local/src/DBD-Oracle-1.03//./oci8.c Mon Jul 12 05:21:02 1999
--- ./oci8.c Tue May 09 11:13:53 2000
***************
*** 12,17 ****
--- 12,20 ----
#include "Oracle.h"
+ #ifdef UTF8_SUPPORT
+ #include <utf8.h>
+ #endif
#ifdef OCI_V8_SYNTAX
***************
*** 307,312 ****
--- 310,347 ----
return OCI_CONTINUE;
}
+ #ifdef UTF8_SUPPORT
+ /* How many bytes are n utf8 chars in buffer */
+ static ub4
+ utf8_to_bytes (ub1 *buffer, ub4 chars_wanted, ub4 max_bytes)
+ {
+ ub4 i = 0;
+ while (i < max_bytes && (chars_wanted-- > 0)) {
+ i += UTF8SKIP(&buffer[i]);
+ }
+ return (i < max_bytes)? i : max_bytes;
+ }
+
+ /* Given the 5.6.0 implementation of utf8 handling in perl,
+ * avoid setting the UTF8 flag as much as possible. Almost
+ * every binary operator in Perl will do conversions when
+ * strings marked as UTF8 are involved.
+ * Maybe setting the flag should be default in Japan or
+ * Europe? Deduce that from NLS_LANG? Possibly...
+ */
+ #define DBD_SET_UTF8(sv) (cs_is_utf8? set_utf8(sv): 0)
+ static int
+ set_utf8(SV *sv) {
+ ub1 *c;
+ for (c = SvPVX(sv); c < SvEND(sv); c++) {
+ if (*c & 0x80) {
+ SvUTF8_on(sv);
+ return 1;
+ }
+ }
+ return 0;
+ }
+ #endif
static int
fetch_func_varfield(SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv)
***************
*** 315,321 ****
--- 350,391 ----
char *p = (char*)&fb_ary->abuf[0];
ub4 datalen = *(ub4*)p; /* XXX alignment ? */
p += 4;
+ #ifdef UTF8_SUPPORT
+ if (cs_is_utf8 && fbh->ftype == 94) {
+ if (datalen > imp_sth->long_readlen) {
+ ub4 bytelen = utf8_to_bytes(p, imp_sth->long_readlen, datalen);
+
+ if (bytelen < datalen) { /* will be truncated */
+ int oraperl = DBIc_COMPAT(imp_sth);
+ if (DBIc_has(imp_sth,DBIcf_LongTruncOk)
+ || (oraperl && SvIV(ora_trunc))) {
+ /* user says truncation is ok */
+ /* Oraperl recorded the truncation in ora_errno so we */
+ /* so also but only for Oraperl mode handles. */
+ if (oraperl) sv_setiv(DBIc_ERR(imp_sth), 1406);
+ } else {
+ char buf[300];
+ sprintf(buf,"fetching field %d of %d. LONG value truncated from %ld to
+%ld. %s",
+ fbh->field_num+1, DBIc_NUM_FIELDS(imp_sth), datalen, bytelen,
+ "DBI attribute LongReadLen too small and/or LongTruncOk not set");
+ oci_error(sth, NULL, OCI_ERROR, buf);
+ sv_setiv(DBIc_ERR(imp_sth), (IV)24345); /* appropriate ORA error number */
+ (void)SvOK_off(dest_sv);
+ return 0;
+ }
+
+ if (DBIS->debug >= 3)
+ fprintf(DBILOGFP, " fetching field %d of %d. LONG value truncated
+from %ld to %ld.\n",
+ fbh->field_num+1, DBIc_NUM_FIELDS(imp_sth), datalen, bytelen);
+ datalen = bytelen;
+ }
+ }
+ sv_setpvn(dest_sv, p, (STRLEN)datalen);
+ DBD_SET_UTF8(dest_sv);
+ } else
+ #endif
sv_setpvn(dest_sv, p, (STRLEN)datalen);
+
return 1;
}
***************
*** 425,430 ****
--- 495,591 ----
}
+ #ifdef UTF8_SUPPORT
+ ub4
+ ora_blob_read_mb_piece(SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh,
+ SV *dest_sv, long offset, long len, long destoffset)
+ {
+ ub4 loblen = 0;
+ ub4 buflen;
+ ub4 amtp = 0;
+ ub4 byte_destoffset = 0;
+ OCILobLocator *lobl = (OCILobLocator*)fbh->desc_h;
+ sword ftype = fbh->ftype;
+ sword status;
+
+ /*
+ * We assume our caller has already done the
+ * equivalent of the following:
+ * (void)SvUPGRADE(dest_sv, SVt_PV);
+ */
+
+ if (ftype != 112) {
+ oci_error(sth, imp_sth->errhp, OCI_ERROR,
+ "blob_read not currently supported for non-CLOB types with OCI 8 "
+ "(but with OCI 8 you can set $dbh->{LongReadLen} to the length you need,"
+ "so you don't need to call blob_read at all)");
+ (void)SvOK_off(dest_sv); /* signal error */
+ return 0;
+ }
+
+ OCILobGetLength_log_stat(imp_sth->svchp, imp_sth->errhp,
+ lobl, &loblen, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCILobGetLength");
+ (void)SvOK_off(dest_sv); /* signal error */
+ return 0;
+ }
+
+ loblen -= offset; /* only count from offset onwards */
+ amtp = (loblen > len) ? len : loblen;
+ buflen = 4 * amtp;
+
+ byte_destoffset = utf8_to_bytes((ub1 *)(SvPVX(dest_sv)),
+ destoffset, SvCUR(dest_sv));
+
+ if (loblen > 0) {
+ ub1 *dest_bufp;
+ ub1 *buffer;
+
+ New(42, buffer, buflen, ub1);
+
+ OCILobRead_log_stat(imp_sth->svchp, imp_sth->errhp, lobl,
+ &amtp, 1 + offset, buffer, buflen,
+ 0, 0, 0, SQLCS_IMPLICIT, status);
+ if (dbis->debug >= 3)
+ fprintf(DBILOGFP, " OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld,
+BufLen %ld, Got %ld\n",
+ fbh->field_num+1, oci_status_name(status), loblen,
+ imp_sth->long_readlen, buflen, amtp);
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCILobRead");
+ (void)SvOK_off(dest_sv); /* signal error */
+ return 0;
+ }
+
+ amtp = utf8_to_bytes(buffer, len, amtp);
+ SvGROW(dest_sv, byte_destoffset + amtp + 1);
+ dest_bufp = (ub1 *)(SvPVX(dest_sv));
+ dest_bufp += byte_destoffset;
+ memcpy(dest_bufp, buffer, amtp);
+ Safefree(buffer);
+ }
+ else {
+ assert(amtp == 0);
+ SvGROW(dest_sv, byte_destoffset + 1);
+ if (dbis->debug >= 3)
+ fprintf(DBILOGFP,
+ " OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld, BufLen
+%ld, Got %ld\n",
+ fbh->field_num+1, "SKIPPED", loblen, imp_sth->long_readlen, buflen,
+amtp);
+ }
+
+ if (dbis->debug >= 3)
+ fprintf(DBILOGFP, " blob_read field %d, ftype %d, offset %ld, len %ld,
+destoffset %ld, retlen %ld\n",
+ fbh->field_num+1, ftype, offset, len, destoffset, amtp);
+
+ SvCUR_set(dest_sv, byte_destoffset+amtp);
+ *SvEND(dest_sv) = '\0'; /* consistent with perl sv_setpvn etc */
+ SvPOK_on(dest_sv);
+ DBD_SET_UTF8(dest_sv);
+
+ return 1;
+ }
+ #endif /* ifdef UTF8_SUPPORT */
+
ub4
ora_blob_read_piece(SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV *dest_sv,
long offset, long len, long destoffset)
***************
*** 542,550 ****
}
(void)SvUPGRADE(dest_sv, SVt_PV);
- SvGROW(dest_sv, buflen+1);
if (loblen > 0) {
OCILobRead_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc,
&amtp, 1, SvPVX(dest_sv), buflen, 0, 0, 0, SQLCS_IMPLICIT, status);
if (DBIS->debug >= 3)
--- 703,744 ----
}
(void)SvUPGRADE(dest_sv, SVt_PV);
if (loblen > 0) {
+ #ifdef UTF8_SUPPORT
+ if (cs_is_utf8 && fbh->ftype == 112) {
+ ub4 alloclen = buflen << 2;
+ ub4 chars_to_read = amtp;
+ char *buffer;
+ New(42, buffer, alloclen, char);
+ OCILobRead_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc,
+ &amtp, 1, buffer, alloclen,
+ 0, 0, 0, SQLCS_IMPLICIT, status);
+
+ if (DBIS->debug >= 3) {
+ fprintf(DBILOGFP, " OCILobRead field %d %s: LOBlen %ld, LongReadLen
+%ld, BufLen %ld, Got %ld\n",
+ fbh->field_num+1, oci_status_name(status), loblen,
+ imp_sth->long_readlen, alloclen, amtp);
+ }
+ if (status != OCI_SUCCESS) {
+ oci_error(sth, imp_sth->errhp, status, "OCILobRead");
+ (void)SvOK_off(dest_sv);
+ return 0;
+ }
+
+ SvGROW(dest_sv, amtp+1);
+ memcpy(SvPVX(dest_sv), buffer, amtp);
+ Safefree(buffer);
+
+ /* tell perl what we've put in its dest_sv */
+ SvCUR(dest_sv) = amtp;
+ *SvEND(dest_sv) = '\0';
+ DBD_SET_UTF8(dest_sv);
+ }
+ else
+ #endif /* ifdef UTF8_SUPPORT */
+ {
+ SvGROW(dest_sv, buflen+1);
OCILobRead_log_stat(imp_sth->svchp, imp_sth->errhp, lobloc,
&amtp, 1, SvPVX(dest_sv), buflen, 0, 0, 0, SQLCS_IMPLICIT, status);
if (DBIS->debug >= 3)
***************
*** 556,573 ****
(void)SvOK_off(dest_sv);
return 0;
}
}
else {
assert(amtp == 0);
if (DBIS->debug >= 3)
fprintf(DBILOGFP,
" OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld, BufLen
%ld, Got %ld\n",
fbh->field_num+1, "SKIPPED", loblen, imp_sth->long_readlen, buflen,
amtp);
}
- /* tell perl what we've put in its dest_sv */
- SvCUR(dest_sv) = amtp;
- *SvEND(dest_sv) = '\0';
SvPOK_on(dest_sv);
return 1;
--- 750,774 ----
(void)SvOK_off(dest_sv);
return 0;
}
+
+ /* tell perl what we've put in its dest_sv */
+ SvCUR(dest_sv) = amtp;
+ *SvEND(dest_sv) = '\0';
+ }
+
}
else {
assert(amtp == 0);
+ /* tell perl what we've put in its dest_sv */
+ SvGROW(dest_sv, buflen+1);
+ SvCUR(dest_sv) = amtp;
+ *SvEND(dest_sv) = '\0';
if (DBIS->debug >= 3)
fprintf(DBILOGFP,
" OCILobRead field %d %s: LOBlen %ld, LongReadLen %ld, BufLen
%ld, Got %ld\n",
fbh->field_num+1, "SKIPPED", loblen, imp_sth->long_readlen, buflen,
amtp);
}
SvPOK_on(dest_sv);
return 1;
***************
*** 697,703 ****
--- 898,910 ----
break;
case 8: /* LONG */
+ #ifdef UTF8_SUPPORT
+ if (cs_is_utf8)
+ fbh->disize = long_readlen * 4;
+ else
+ #endif
fbh->disize = long_readlen;
+
fbh->dbsize = (fbh->disize>65535) ? 65535 : fbh->disize;
fbh->ftype = 94; /* VAR form */
fbh->fetch_func = fetch_func_varfield;
***************
*** 920,925 ****
--- 1127,1135 ----
--datalen;
}
sv_setpvn(sv, p, (STRLEN)datalen);
+ #ifdef UTF8_SUPPORT
+ DBD_SET_UTF8(sv);
+ #endif
}
} else if (rc == 1405) { /* field is null - return undef */
***************
*** 935,940 ****
--- 1145,1153 ----
/* but it'll only be accessible via prior bind_column() */
sv_setpvn(sv, (char*)&fb_ary->abuf[0],
fb_ary->arlen[0]);
+ #ifdef UTF8_SUPPORT
+ DBD_SET_UTF8(sv);
+ #endif
}
if (ora_dbtype_is_long(fbh->dbtype)) /* double check */
hint = ", LongReadLen too small and/or LongTruncOk not set";
***************
*** 1190,1195 ****
--- 1403,1411 ----
lob_cols_hv = newHV();
sv = newSViv(col_dbtype);
(void)sv_setpvn(sv, col_name, col_name_len);
+ #ifdef UTF8_SUPPORT
+ DBD_SET_UTF8(sv);
+ #endif
(void)SvIOK_on(sv); /* what a wonderful hack! */
hv_store(lob_cols_hv, col_name,col_name_len, sv,0);
}
*** //c/usr/local/src/DBD-Oracle-1.03//./Oracle.h Mon Jul 12 05:21:14 1999
--- ./Oracle.h Thu May 04 12:55:13 2000
***************
*** 55,59 ****
--- 55,60 ----
int dbd_describe _((SV *sth, imp_sth_t *imp_sth));
ub4 ora_blob_read_piece _((SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV
*dest_sv,
long offset, long len, long destoffset));
+ ub4 ora_blob_read_mb_piece _((SV *sth, imp_sth_t *imp_sth, imp_fbh_t *fbh, SV
+*dest_sv, long offset, long len, long destoffset));
/* end of Oracle.h */
*** //c/usr/local/src/DBD-Oracle-1.03//./t/long.t Mon Jul 12 05:21:50 1999
--- ./t/long.t Tue May 09 10:50:12 2000
***************
*** 14,19 ****
--- 14,21 ----
my %ocibug;
my $table = "dbd_ora__drop_me";
+ my $utf8_test = ($] >= 5.006) && ($ENV{NLS_LANG} =~ m/utf8$/i);
+
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect('dbi:Oracle:', $dbuser, '', {
AutoCommit => 1,
***************
*** 64,70 ****
my ($type_name, $type_num) = @_;
# relationships between these lengths are important # e.g.
! my $long_data0 = ("0\177x\0X" x 2048) x (1 ); # 10KB < 64KB
my $long_data1 = ("1234567890" x 1024) x ($sz ); # 80KB >> 64KB && > long_data2
my $long_data2 = ("2bcdefabcd" x 1024) x ($sz-1); # 70KB > 64KB && < long_data1
--- 66,89 ----
my ($type_name, $type_num) = @_;
# relationships between these lengths are important # e.g.
!
! my $long_data0;
! if ($utf8_test) {
! $long_data0 = ("0\x{263A}xyX" x 2048) x (1 ); # 10KB < 64KB
! if (length($long_data0) > 10240) {
! print "known bug in Perl5.6.0, applying workaround\n";
! $long_data0 = "0\x{263A}xyZ";
! foreach my $i (1..2047) {
! $long_data0 .= "0\x{263A}xyZ";
! }
! }
! if ($type_name =~ /BLOB/) {
! # convert string from utf-8 to byte encoding
! $long_data0 = pack "C*", (unpack "C*", $long_data0);
! }
! } else {
! $long_data0 = ("0\177x\0X" x 2048) x (1 ); # 10KB < 64KB
! }
my $long_data1 = ("1234567890" x 1024) x ($sz ); # 80KB >> 64KB && > long_data2
my $long_data2 = ("2bcdefabcd" x 1024) x ($sz-1); # 70KB > 64KB && < long_data1
