Age Owner Branch data TLA Line data Source code
1 : : /*-------------------------------------------------------------------------
2 : : *
3 : : * plperl.h
4 : : * Common include file for PL/Perl files
5 : : *
6 : : * This should be included _AFTER_ postgres.h and system include files, as
7 : : * well as headers that could in turn include system headers.
8 : : *
9 : : * Portions Copyright (c) 1996-2026, PostgreSQL Global Development Group
10 : : * Portions Copyright (c) 1995, Regents of the University of California
11 : : *
12 : : * src/pl/plperl/plperl.h
13 : : */
14 : :
15 : : #ifndef PL_PERL_H
16 : : #define PL_PERL_H
17 : :
18 : : /* defines free() by way of system headers, so must be included before perl.h */
19 : : #include "mb/pg_wchar.h"
20 : :
21 : : /*
22 : : * Pull in Perl headers via a wrapper header, to control the scope of
23 : : * the system_header pragma therein.
24 : : */
25 : : #include "plperl_system.h"
26 : :
27 : : /* declare routines from plperl.c for access by .xs files */
28 : : HV *plperl_spi_exec(char *, int);
29 : : void plperl_return_next(SV *);
30 : : SV *plperl_spi_query(char *);
31 : : SV *plperl_spi_fetchrow(char *);
32 : : SV *plperl_spi_prepare(char *, int, SV **);
33 : : HV *plperl_spi_exec_prepared(char *, HV *, int, SV **);
34 : : SV *plperl_spi_query_prepared(char *, int, SV **);
35 : : void plperl_spi_freeplan(char *);
36 : : void plperl_spi_cursor_close(char *);
37 : : void plperl_spi_commit(void);
38 : : void plperl_spi_rollback(void);
39 : : char *plperl_sv_to_literal(SV *, char *);
40 : : void plperl_util_elog(int level, SV *msg);
41 : :
42 : :
43 : : /* helper functions */
44 : :
45 : : /*
46 : : * convert from utf8 to database encoding
47 : : *
48 : : * Returns a palloc'ed copy of the original string
49 : : */
50 : : static inline char *
1461 john.naylor@postgres 51 :CBC 1144 : utf_u2e(char *utf8_str, size_t len)
52 : : {
53 : : char *ret;
54 : :
55 : 1144 : ret = pg_any_to_server(utf8_str, len, PG_UTF8);
56 : :
57 : : /* ensure we have a copy even if no conversion happened */
58 [ + - ]: 1143 : if (ret == utf8_str)
59 : 1143 : ret = pstrdup(ret);
60 : :
61 : 1143 : return ret;
62 : : }
63 : :
64 : : /*
65 : : * convert from database encoding to utf8
66 : : *
67 : : * Returns a palloc'ed copy of the original string
68 : : */
69 : : static inline char *
70 : 1321 : utf_e2u(const char *str)
71 : : {
72 : : char *ret;
73 : :
74 : 1321 : ret = pg_server_to_any(str, strlen(str), PG_UTF8);
75 : :
76 : : /* ensure we have a copy even if no conversion happened */
77 [ + - ]: 1321 : if (ret == str)
78 : 1321 : ret = pstrdup(ret);
79 : :
80 : 1321 : return ret;
81 : : }
82 : :
83 : : /*
84 : : * Convert an SV to a char * in the current database encoding
85 : : *
86 : : * Returns a palloc'ed copy of the original string
87 : : */
88 : : static inline char *
89 : 1144 : sv2cstr(SV *sv)
90 : : {
91 : 1144 : dTHX;
92 : : char *val,
93 : : *res;
94 : : STRLEN len;
95 : :
96 : : /*
97 : : * get a utf8 encoded char * out of perl. *note* it may not be valid utf8!
98 : : */
99 : :
100 : : /*
101 : : * SvPVutf8() croaks nastily on certain things, like typeglobs and
102 : : * readonly objects such as $^V. That's a perl bug - it's not supposed to
103 : : * happen. To avoid crashing the backend, we make a copy of the sv before
104 : : * passing it to SvPVutf8(). The copy is garbage collected when we're done
105 : : * with it.
106 : : */
107 [ + + ]: 1144 : if (SvREADONLY(sv) ||
108 [ - + - - : 1072 : isGV_with_GP(sv) ||
- - ]
109 [ - + - - ]: 1072 : (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
110 : 72 : sv = newSVsv(sv);
111 : : else
112 : : {
113 : : /*
114 : : * increase the reference count so we can just SvREFCNT_dec() it when
115 : : * we are done
116 : : */
117 [ + - ]: 1072 : SvREFCNT_inc_simple_void(sv);
118 : : }
119 : :
120 : : /*
121 : : * Request the string from Perl, in UTF-8 encoding; but if we're in a
122 : : * SQL_ASCII database, just request the byte soup without trying to make
123 : : * it UTF8, because that might fail.
124 : : */
125 [ - + ]: 1144 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
1461 john.naylor@postgres 126 :UBC 0 : val = SvPV(sv, len);
127 : : else
1461 john.naylor@postgres 128 :CBC 1144 : val = SvPVutf8(sv, len);
129 : :
130 : : /*
131 : : * Now convert to database encoding. We use perl's length in the event we
132 : : * had an embedded null byte to ensure we error out properly.
133 : : */
134 : 1144 : res = utf_u2e(val, len);
135 : :
136 : : /* safe now to garbage collect the new SV */
137 : 1143 : SvREFCNT_dec(sv);
138 : :
139 : 1143 : return res;
140 : : }
141 : :
142 : : /*
143 : : * Create a new SV from a string assumed to be in the current database's
144 : : * encoding.
145 : : */
146 : : static inline SV *
147 : 1321 : cstr2sv(const char *str)
148 : : {
149 : 1321 : dTHX;
150 : : SV *sv;
151 : : char *utf8_str;
152 : :
153 : : /* no conversion when SQL_ASCII */
154 [ - + ]: 1321 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
1461 john.naylor@postgres 155 :UBC 0 : return newSVpv(str, 0);
156 : :
1461 john.naylor@postgres 157 :CBC 1321 : utf8_str = utf_e2u(str);
158 : :
159 : 1321 : sv = newSVpv(utf8_str, 0);
160 : 1321 : SvUTF8_on(sv);
161 : 1321 : pfree(utf8_str);
162 : :
163 : 1321 : return sv;
164 : : }
165 : :
166 : : /*
167 : : * If the SV has get magic, run FETCH to convert it to the intended value.
168 : : *
169 : : * While Perl functions such as SvPV() will handle get magic automatically,
170 : : * we must run this before primitive checks such as SvOK() or SvROK().
171 : : * This must be invoked within the scope of a dTHX declaration.
172 : : */
173 : : #define plperl_materialize_sv(sv) \
174 : : do { if (sv) SvGETMAGIC(sv); } while(0)
175 : :
176 : : /*
177 : : * Convert a HE (hash entry) key to a cstr in the current database encoding.
178 : : * The result is palloc'd.
179 : : */
180 : : static inline char *
9 tgl@sss.pgh.pa.us 181 :GNC 263 : hek2cstr(HE *he)
182 : : {
183 : 263 : dTHX;
184 : : char *ret;
185 : : SV *sv;
186 : :
187 : : /*
188 : : * HeSVKEY_force will return a temporary mortal SV*, so we need to make
189 : : * sure to free it with ENTER/SAVE/FREE/LEAVE
190 : : */
191 : 263 : ENTER;
192 : 263 : SAVETMPS;
193 : :
194 : : /*-------------------------
195 : : * Unfortunately, while HeUTF8 is true for most things > 256, for values
196 : : * 128..255 it's not, but perl will treat them as unicode code points if
197 : : * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
198 : : * for more)
199 : : *
200 : : * So if we did the expected:
201 : : * if (HeUTF8(he))
202 : : * utf_u2e(key...);
203 : : * else // must be ascii
204 : : * return HePV(he);
205 : : * we won't match columns with codepoints from 128..255
206 : : *
207 : : * For a more concrete example given a column with the name of the unicode
208 : : * codepoint U+00ae (registered sign) and a UTF8 database and the perl
209 : : * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
210 : : * 0 and HePV() would give us a char * with 1 byte contains the decimal
211 : : * value 174
212 : : *
213 : : * Perl has the brains to know when it should utf8 encode 174 properly, so
214 : : * here we force it into an SV so that perl will figure it out and do the
215 : : * right thing
216 : : *-------------------------
217 : : */
218 : :
219 [ + - + + ]: 263 : sv = HeSVKEY_force(he);
220 [ + + - + ]: 263 : if (HeUTF8(he))
9 tgl@sss.pgh.pa.us 221 :UNC 0 : SvUTF8_on(sv);
9 tgl@sss.pgh.pa.us 222 :GNC 263 : ret = sv2cstr(sv);
223 : :
224 : : /* free sv */
225 [ + + ]: 263 : FREETMPS;
226 : 263 : LEAVE;
227 : :
228 : 263 : return ret;
229 : : }
230 : :
231 : : /*
232 : : * croak() with specified message, which is given in the database encoding.
233 : : *
234 : : * Ideally we'd just write croak("%s", str), but plain croak() does not play
235 : : * nice with non-ASCII data. In modern Perl versions we can call cstr2sv()
236 : : * and pass the result to croak_sv(); in versions that don't have croak_sv(),
237 : : * we have to work harder.
238 : : */
239 : : static inline void
1461 john.naylor@postgres 240 :CBC 10 : croak_cstr(const char *str)
241 : : {
242 : 10 : dTHX;
243 : :
244 : : #ifdef croak_sv
245 : : /* Use sv_2mortal() to be sure the transient SV gets freed */
246 : 10 : croak_sv(sv_2mortal(cstr2sv(str)));
247 : : #else
248 : :
249 : : /*
250 : : * The older way to do this is to assign a UTF8-marked value to ERRSV and
251 : : * then call croak(NULL). But if we leave it to croak() to append the
252 : : * error location, it does so too late (only after popping the stack) in
253 : : * some Perl versions. Hence, use mess() to create an SV with the error
254 : : * location info already appended.
255 : : */
256 : : SV *errsv = get_sv("@", GV_ADD);
257 : : char *utf8_str = utf_e2u(str);
258 : : SV *ssv;
259 : :
260 : : ssv = mess("%s", utf8_str);
261 : : SvUTF8_on(ssv);
262 : :
263 : : pfree(utf8_str);
264 : :
265 : : sv_setsv(errsv, ssv);
266 : :
267 : : croak(NULL);
268 : : #endif /* croak_sv */
269 : : }
270 : :
271 : : #endif /* PL_PERL_H */
|
