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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
#ifndef PL_PERL_HELPERS_H
#define PL_PERL_HELPERS_H
#include "mb/pg_wchar.h"
#include "plperl.h"
/*
* convert from utf8 to database encoding
*
* Returns a palloc'ed copy of the original string
*/
static inline char *
utf_u2e(char *utf8_str, size_t len)
{
char *ret;
ret = pg_any_to_server(utf8_str, len, PG_UTF8);
/* ensure we have a copy even if no conversion happened */
if (ret == utf8_str)
ret = pstrdup(ret);
return ret;
}
/*
* convert from database encoding to utf8
*
* Returns a palloc'ed copy of the original string
*/
static inline char *
utf_e2u(const char *str)
{
char *ret;
ret = pg_server_to_any(str, strlen(str), PG_UTF8);
/* ensure we have a copy even if no conversion happened */
if (ret == str)
ret = pstrdup(ret);
return ret;
}
/*
* Convert an SV to a char * in the current database encoding
*
* Returns a palloc'ed copy of the original string
*/
static inline char *
sv2cstr(SV *sv)
{
dTHX;
char *val,
*res;
STRLEN len;
/*
* get a utf8 encoded char * out of perl. *note* it may not be valid utf8!
*/
/*
* SvPVutf8() croaks nastily on certain things, like typeglobs and
* readonly objects such as $^V. That's a perl bug - it's not supposed to
* happen. To avoid crashing the backend, we make a copy of the sv before
* passing it to SvPVutf8(). The copy is garbage collected when we're done
* with it.
*/
if (SvREADONLY(sv) ||
isGV_with_GP(sv) ||
(SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
sv = newSVsv(sv);
else
{
/*
* increase the reference count so we can just SvREFCNT_dec() it when
* we are done
*/
SvREFCNT_inc_simple_void(sv);
}
/*
* Request the string from Perl, in UTF-8 encoding; but if we're in a
* SQL_ASCII database, just request the byte soup without trying to make
* it UTF8, because that might fail.
*/
if (GetDatabaseEncoding() == PG_SQL_ASCII)
val = SvPV(sv, len);
else
val = SvPVutf8(sv, len);
/*
* Now convert to database encoding. We use perl's length in the event we
* had an embedded null byte to ensure we error out properly.
*/
res = utf_u2e(val, len);
/* safe now to garbage collect the new SV */
SvREFCNT_dec(sv);
return res;
}
/*
* Create a new SV from a string assumed to be in the current database's
* encoding.
*/
static inline SV *
cstr2sv(const char *str)
{
dTHX;
SV *sv;
char *utf8_str;
/* no conversion when SQL_ASCII */
if (GetDatabaseEncoding() == PG_SQL_ASCII)
return newSVpv(str, 0);
utf8_str = utf_e2u(str);
sv = newSVpv(utf8_str, 0);
SvUTF8_on(sv);
pfree(utf8_str);
return sv;
}
/*
* croak() with specified message, which is given in the database encoding.
*
* Ideally we'd just write croak("%s", str), but plain croak() does not play
* nice with non-ASCII data. In modern Perl versions we can call cstr2sv()
* and pass the result to croak_sv(); in versions that don't have croak_sv(),
* we have to work harder.
*/
static inline void
croak_cstr(const char *str)
{
dTHX;
#ifdef croak_sv
/* Use sv_2mortal() to be sure the transient SV gets freed */
croak_sv(sv_2mortal(cstr2sv(str)));
#else
/*
* The older way to do this is to assign a UTF8-marked value to ERRSV and
* then call croak(NULL). But if we leave it to croak() to append the
* error location, it does so too late (only after popping the stack) in
* some Perl versions. Hence, use mess() to create an SV with the error
* location info already appended.
*/
SV *errsv = get_sv("@", GV_ADD);
char *utf8_str = utf_e2u(str);
SV *ssv;
ssv = mess("%s", utf8_str);
SvUTF8_on(ssv);
pfree(utf8_str);
sv_setsv(errsv, ssv);
croak(NULL);
#endif /* croak_sv */
}
#endif /* PL_PERL_HELPERS_H */
|
