PostgreSQL Source Code  git master
plperl.h
Go to the documentation of this file.
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 */
217 HV *plperl_spi_exec(char *, int);
218 void plperl_return_next(SV *);
219 SV *plperl_spi_query(char *);
220 SV *plperl_spi_fetchrow(char *);
221 SV *plperl_spi_prepare(char *, int, SV **);
222 HV *plperl_spi_exec_prepared(char *, HV *, int, SV **);
223 SV *plperl_spi_query_prepared(char *, int, SV **);
224 void plperl_spi_freeplan(char *);
225 void plperl_spi_cursor_close(char *);
226 void plperl_spi_commit(void);
227 void plperl_spi_rollback(void);
228 char *plperl_sv_to_literal(SV *, char *);
229 void plperl_util_elog(int level, SV *msg);
230 
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 *
240 utf_u2e(char *utf8_str, size_t len)
241 {
242  char *ret;
243 
244  ret = pg_any_to_server(utf8_str, len, PG_UTF8);
245 
246  /* ensure we have a copy even if no conversion happened */
247  if (ret == utf8_str)
248  ret = pstrdup(ret);
249 
250  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 utf_e2u(const char *str)
260 {
261  char *ret;
262 
263  ret = pg_server_to_any(str, strlen(str), PG_UTF8);
264 
265  /* ensure we have a copy even if no conversion happened */
266  if (ret == str)
267  ret = pstrdup(ret);
268 
269  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 sv2cstr(SV *sv)
279 {
280  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  if (SvREADONLY(sv) ||
297  isGV_with_GP(sv) ||
298  (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
299  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  */
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  */
315  val = SvPV(sv, len);
316  else
317  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  res = utf_u2e(val, len);
324 
325  /* safe now to garbage collect the new SV */
326  SvREFCNT_dec(sv);
327 
328  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 cstr2sv(const char *str)
337 {
338  dTHX;
339  SV *sv;
340  char *utf8_str;
341 
342  /* no conversion when SQL_ASCII */
344  return newSVpv(str, 0);
345 
346  utf8_str = utf_e2u(str);
347 
348  sv = newSVpv(utf8_str, 0);
349  SvUTF8_on(sv);
350  pfree(utf8_str);
351 
352  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 croak_cstr(const char *str)
365 {
366  dTHX;
367 
368 #ifdef croak_sv
369  /* Use sv_2mortal() to be sure the transient SV gets freed */
370  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 
395 #endif /* PL_PERL_H */
long val
Definition: informix.c:664
char * pg_any_to_server(const char *s, int len, int encoding)
Definition: mbutils.c:677
int GetDatabaseEncoding(void)
Definition: mbutils.c:1268
char * pg_server_to_any(const char *s, int len, int encoding)
Definition: mbutils.c:750
char * pstrdup(const char *in)
Definition: mcxt.c:1624
void pfree(void *pointer)
Definition: mcxt.c:1436
const void size_t len
@ PG_SQL_ASCII
Definition: pg_wchar.h:226
@ PG_UTF8
Definition: pg_wchar.h:232
void plperl_return_next(SV *)
Definition: plperl.c:3231
HV * plperl_spi_exec(char *, int)
Definition: plperl.c:3119
void plperl_spi_cursor_close(char *)
Definition: plperl.c:3537
char * plperl_sv_to_literal(SV *, char *)
Definition: plperl.c:1428
void plperl_spi_rollback(void)
Definition: plperl.c:4003
SV * plperl_spi_query(char *)
Definition: plperl.c:3390
SV * plperl_spi_prepare(char *, int, SV **)
Definition: plperl.c:3553
SV * plperl_spi_query_prepared(char *, int, SV **)
Definition: plperl.c:3828
static SV * cstr2sv(const char *str)
Definition: plperl.h:336
HV * plperl_spi_exec_prepared(char *, HV *, int, SV **)
Definition: plperl.c:3701
static void croak_cstr(const char *str)
Definition: plperl.h:364
static char * utf_e2u(const char *str)
Definition: plperl.h:259
SV * plperl_spi_fetchrow(char *)
Definition: plperl.c:3462
static char * utf_u2e(char *utf8_str, size_t len)
Definition: plperl.h:240
static char * sv2cstr(SV *sv)
Definition: plperl.h:278
void plperl_util_elog(int level, SV *msg)
Definition: plperl.c:4040
void plperl_spi_commit(void)
Definition: plperl.c:3977
void plperl_spi_freeplan(char *)
Definition: plperl.c:3946
#define get_sv
Definition: ppport.h:12463
#define dTHX
Definition: ppport.h:11306
#define SvREFCNT_inc_simple_void(sv)
Definition: ppport.h:15412
#define isGV_with_GP(gv)
Definition: ppport.h:15703
#define croak_sv(sv)
Definition: ppport.h:14714