Age Owner 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-2023, 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 : /* stop perl headers from hijacking stdio and other stuff on Windows */
22 : #ifdef WIN32
23 : #define WIN32IO_IS_STDIO
24 : #endif /* WIN32 */
25 :
26 : /*
27 : * Supply a value of PERL_UNUSED_DECL that will satisfy gcc - the one
28 : * perl itself supplies doesn't seem to.
29 : */
30 : #define PERL_UNUSED_DECL pg_attribute_unused()
31 :
32 : /*
33 : * Sometimes perl carefully scribbles on our *printf macros.
34 : * So we undefine them here and redefine them after it's done its dirty deed.
35 : */
36 : #undef vsnprintf
37 : #undef snprintf
38 : #undef vsprintf
39 : #undef sprintf
40 : #undef vfprintf
41 : #undef fprintf
42 : #undef vprintf
43 : #undef printf
44 :
45 : /*
46 : * Perl scribbles on the "_" macro too.
47 : */
48 : #undef _
49 :
50 : /*
51 : * ActivePerl 5.18 and later are MinGW-built, and their headers use GCC's
52 : * __inline__. Translate to something MSVC recognizes. Also, perl.h sometimes
53 : * defines isnan, so undefine it here and put back the definition later if
54 : * perl.h doesn't.
55 : */
56 : #ifdef _MSC_VER
57 : #define __inline__ inline
58 : #ifdef isnan
59 : #undef isnan
60 : #endif
61 : /* Work around for using MSVC and Strawberry Perl >= 5.30. */
62 : #define __builtin_expect(expr, val) (expr)
63 : #endif
64 :
65 : /*
66 : * Regarding bool, both PostgreSQL and Perl might use stdbool.h or not,
67 : * depending on configuration. If both agree, things are relatively harmless.
68 : * If not, things get tricky. If PostgreSQL does but Perl does not, define
69 : * HAS_BOOL here so that Perl does not redefine bool; this avoids compiler
70 : * warnings. If PostgreSQL does not but Perl does, we need to undefine bool
71 : * after we include the Perl headers; see below.
72 : */
73 : #ifdef PG_USE_STDBOOL
74 : #define HAS_BOOL 1
75 : #endif
76 :
77 : /*
78 : * Newer versions of the perl headers trigger a lot of warnings with our
79 : * compiler flags (at least -Wdeclaration-after-statement,
80 : * -Wshadow=compatible-local are known to be problematic). The system_header
81 : * pragma hides warnings from within the rest of this file, if supported.
82 : */
83 : #ifdef HAVE_PRAGMA_GCC_SYSTEM_HEADER
84 : #pragma GCC system_header
85 : #endif
86 :
87 : /*
88 : * Get the basic Perl API. We use PERL_NO_GET_CONTEXT mode so that our code
89 : * can compile against MULTIPLICITY Perl builds without including XSUB.h.
90 : */
91 : #define PERL_NO_GET_CONTEXT
92 : #include "EXTERN.h"
93 : #include "perl.h"
94 :
95 : /*
96 : * We want to include XSUB.h only within .xs files, because on some platforms
97 : * it undesirably redefines a lot of libc functions. But it must appear
98 : * before ppport.h, so use a #define flag to control inclusion here.
99 : */
100 : #ifdef PG_NEED_PERL_XSUB_H
101 : /*
102 : * On Windows, win32_port.h defines macros for a lot of these same functions.
103 : * To avoid compiler warnings when XSUB.h redefines them, #undef our versions.
104 : */
105 : #ifdef WIN32
106 : #undef accept
107 : #undef bind
108 : #undef connect
109 : #undef fopen
110 : #undef fstat
111 : #undef kill
112 : #undef listen
113 : #undef lstat
114 : #undef mkdir
115 : #undef open
116 : #undef putenv
117 : #undef recv
118 : #undef rename
119 : #undef select
120 : #undef send
121 : #undef socket
122 : #undef stat
123 : #undef unlink
124 : #endif
125 :
126 : #include "XSUB.h"
127 : #endif
128 :
129 : /* put back our *printf macros ... this must match src/include/port.h */
130 : #ifdef vsnprintf
131 : #undef vsnprintf
132 : #endif
133 : #ifdef snprintf
134 : #undef snprintf
135 : #endif
136 : #ifdef vsprintf
137 : #undef vsprintf
138 : #endif
139 : #ifdef sprintf
140 : #undef sprintf
141 : #endif
142 : #ifdef vfprintf
143 : #undef vfprintf
144 : #endif
145 : #ifdef fprintf
146 : #undef fprintf
147 : #endif
148 : #ifdef vprintf
149 : #undef vprintf
150 : #endif
151 : #ifdef printf
152 : #undef printf
153 : #endif
154 :
155 : #define vsnprintf pg_vsnprintf
156 : #define snprintf pg_snprintf
157 : #define vsprintf pg_vsprintf
158 : #define sprintf pg_sprintf
159 : #define vfprintf pg_vfprintf
160 : #define fprintf pg_fprintf
161 : #define vprintf pg_vprintf
162 : #define printf(...) pg_printf(__VA_ARGS__)
163 :
164 : /*
165 : * Put back "_" too; but rather than making it just gettext() as the core
166 : * code does, make it dgettext() so that the right things will happen in
167 : * loadable modules (if they've set up TEXTDOMAIN correctly). Note that
168 : * we can't just set TEXTDOMAIN here, because this file is used by more
169 : * extensions than just PL/Perl itself.
170 : */
171 : #undef _
172 : #define _(x) dgettext(TEXTDOMAIN, x)
173 :
174 : /* put back the definition of isnan if needed */
175 : #ifdef _MSC_VER
176 : #ifndef isnan
177 : #define isnan(x) _isnan(x)
178 : #endif
179 : #endif
180 :
181 : /* perl version and platform portability */
182 : #include "ppport.h"
183 :
184 : /*
185 : * perl might have included stdbool.h. If we also did that earlier (see c.h),
186 : * then that's fine. If not, we probably rejected it for some reason. In
187 : * that case, undef bool and proceed with our own bool. (Note that stdbool.h
188 : * makes bool a macro, but our own replacement is a typedef, so the undef
189 : * makes ours visible again).
190 : */
191 : #ifndef PG_USE_STDBOOL
192 : #ifdef bool
193 : #undef bool
194 : #endif
195 : #endif
196 :
197 : /* supply HeUTF8 if it's missing - ppport.h doesn't supply it, unfortunately */
198 : #ifndef HeUTF8
199 : #define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
200 : SvUTF8(HeKEY_sv(he)) : \
201 : (U32)HeKUTF8(he))
202 : #endif
203 :
204 : /* supply GvCV_set if it's missing - ppport.h doesn't supply it, unfortunately */
205 : #ifndef GvCV_set
206 : #define GvCV_set(gv, cv) (GvCV(gv) = cv)
207 : #endif
208 :
209 : /* Perl 5.19.4 changed array indices from I32 to SSize_t */
210 : #if PERL_BCDVERSION >= 0x5019004
211 : #define AV_SIZE_MAX SSize_t_MAX
212 : #else
213 : #define AV_SIZE_MAX I32_MAX
214 : #endif
215 :
216 : /* declare routines from plperl.c for access by .xs files */
6300 andrew 217 GIC 56 : HV *plperl_spi_exec(char *, int);
218 87 : void plperl_return_next(SV *);
219 9 : SV *plperl_spi_query(char *);
220 36 : SV *plperl_spi_fetchrow(char *);
6031 bruce 221 CBC 8 : SV *plperl_spi_prepare(char *, int, SV **);
222 6 : HV *plperl_spi_exec_prepared(char *, HV *, int, SV **);
223 2 : SV *plperl_spi_query_prepared(char *, int, SV **);
224 5 : void plperl_spi_freeplan(char *);
225 1 : void plperl_spi_cursor_close(char *);
1903 peter_e 226 25 : void plperl_spi_commit(void);
227 17 : void plperl_spi_rollback(void);
4382 bruce 228 16 : char *plperl_sv_to_literal(SV *, char *);
2081 tgl 229 184 : void plperl_util_elog(int level, SV *msg);
6244 andrew 230 ECB :
231 :
232 : /* helper functions */
233 :
234 : /*
235 : * convert from utf8 to database encoding
236 : *
237 : * Returns a palloc'ed copy of the original string
238 : */
239 : static inline char *
225 john.naylor 240 GNC 1084 : utf_u2e(char *utf8_str, size_t len)
241 : {
242 : char *ret;
243 :
244 1084 : ret = pg_any_to_server(utf8_str, len, PG_UTF8);
245 :
246 : /* ensure we have a copy even if no conversion happened */
247 1083 : if (ret == utf8_str)
248 1083 : ret = pstrdup(ret);
249 :
250 1083 : return ret;
251 : }
252 :
253 : /*
254 : * convert from database encoding to utf8
255 : *
256 : * Returns a palloc'ed copy of the original string
257 : */
258 : static inline char *
259 1280 : utf_e2u(const char *str)
260 : {
261 : char *ret;
262 :
263 1280 : ret = pg_server_to_any(str, strlen(str), PG_UTF8);
264 :
265 : /* ensure we have a copy even if no conversion happened */
266 1280 : if (ret == str)
267 1280 : ret = pstrdup(ret);
268 :
269 1280 : return ret;
270 : }
271 :
272 : /*
273 : * Convert an SV to a char * in the current database encoding
274 : *
275 : * Returns a palloc'ed copy of the original string
276 : */
277 : static inline char *
278 1084 : sv2cstr(SV *sv)
279 : {
280 1084 : dTHX;
281 : char *val,
282 : *res;
283 : STRLEN len;
284 :
285 : /*
286 : * get a utf8 encoded char * out of perl. *note* it may not be valid utf8!
287 : */
288 :
289 : /*
290 : * SvPVutf8() croaks nastily on certain things, like typeglobs and
291 : * readonly objects such as $^V. That's a perl bug - it's not supposed to
292 : * happen. To avoid crashing the backend, we make a copy of the sv before
293 : * passing it to SvPVutf8(). The copy is garbage collected when we're done
294 : * with it.
295 : */
296 1084 : if (SvREADONLY(sv) ||
297 1011 : isGV_with_GP(sv) ||
298 1011 : (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
299 73 : sv = newSVsv(sv);
300 : else
301 : {
302 : /*
303 : * increase the reference count so we can just SvREFCNT_dec() it when
304 : * we are done
305 : */
306 1011 : SvREFCNT_inc_simple_void(sv);
307 : }
308 :
309 : /*
310 : * Request the string from Perl, in UTF-8 encoding; but if we're in a
311 : * SQL_ASCII database, just request the byte soup without trying to make
312 : * it UTF8, because that might fail.
313 : */
314 1084 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
225 john.naylor 315 UNC 0 : val = SvPV(sv, len);
316 : else
225 john.naylor 317 GNC 1084 : val = SvPVutf8(sv, len);
318 :
319 : /*
320 : * Now convert to database encoding. We use perl's length in the event we
321 : * had an embedded null byte to ensure we error out properly.
322 : */
323 1084 : res = utf_u2e(val, len);
324 :
325 : /* safe now to garbage collect the new SV */
326 1083 : SvREFCNT_dec(sv);
327 :
328 1083 : return res;
329 : }
330 :
331 : /*
332 : * Create a new SV from a string assumed to be in the current database's
333 : * encoding.
334 : */
335 : static inline SV *
336 1280 : cstr2sv(const char *str)
337 : {
338 1280 : dTHX;
339 : SV *sv;
340 : char *utf8_str;
341 :
342 : /* no conversion when SQL_ASCII */
343 1280 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
225 john.naylor 344 UNC 0 : return newSVpv(str, 0);
345 :
225 john.naylor 346 GNC 1280 : utf8_str = utf_e2u(str);
347 :
348 1280 : sv = newSVpv(utf8_str, 0);
349 1280 : SvUTF8_on(sv);
350 1280 : pfree(utf8_str);
351 :
352 1280 : return sv;
353 : }
354 :
355 : /*
356 : * croak() with specified message, which is given in the database encoding.
357 : *
358 : * Ideally we'd just write croak("%s", str), but plain croak() does not play
359 : * nice with non-ASCII data. In modern Perl versions we can call cstr2sv()
360 : * and pass the result to croak_sv(); in versions that don't have croak_sv(),
361 : * we have to work harder.
362 : */
363 : static inline void
364 13 : croak_cstr(const char *str)
365 : {
366 13 : dTHX;
367 :
368 : #ifdef croak_sv
369 : /* Use sv_2mortal() to be sure the transient SV gets freed */
370 13 : croak_sv(sv_2mortal(cstr2sv(str)));
371 : #else
372 :
373 : /*
374 : * The older way to do this is to assign a UTF8-marked value to ERRSV and
375 : * then call croak(NULL). But if we leave it to croak() to append the
376 : * error location, it does so too late (only after popping the stack) in
377 : * some Perl versions. Hence, use mess() to create an SV with the error
378 : * location info already appended.
379 : */
380 : SV *errsv = get_sv("@", GV_ADD);
381 : char *utf8_str = utf_e2u(str);
382 : SV *ssv;
383 :
384 : ssv = mess("%s", utf8_str);
385 : SvUTF8_on(ssv);
386 :
387 : pfree(utf8_str);
388 :
389 : sv_setsv(errsv, ssv);
390 :
391 : croak(NULL);
392 : #endif /* croak_sv */
393 : }
394 :
2118 tgl 395 ECB : #endif /* PL_PERL_H */
|
