|
3 | 3 | * plperl.h |
4 | 4 | * Common include file for PL/Perl files |
5 | 5 | * |
6 | | - * This should be included _AFTER_ postgres.h and system include files |
| 6 | + * This should be included _AFTER_ postgres.h and system include files, as |
| 7 | + * well as headers that could in turn include system headers. |
7 | 8 | * |
8 | 9 | * Portions Copyright (c) 1996-2022, PostgreSQL Global Development Group |
9 | 10 | * Portions Copyright (c) 1995, Regents of the University of California |
|
14 | 15 | #ifndef PL_PERL_H |
15 | 16 | #define PL_PERL_H |
16 | 17 |
|
| 18 | +/* defines free() by way of system headers, so must be included before perl.h */ |
| 19 | +#include "mb/pg_wchar.h" |
| 20 | + |
17 | 21 | /* stop perl headers from hijacking stdio and other stuff on Windows */ |
18 | 22 | #ifdef WIN32 |
19 | 23 | #define WIN32IO_IS_STDIO |
@@ -213,4 +217,168 @@ void plperl_spi_rollback(void); |
213 | 217 | char *plperl_sv_to_literal(SV *, char *); |
214 | 218 | void plperl_util_elog(int level, SV *msg); |
215 | 219 |
|
| 220 | + |
| 221 | +/* helper functions */ |
| 222 | + |
| 223 | +/* |
| 224 | + * convert from utf8 to database encoding |
| 225 | + * |
| 226 | + * Returns a palloc'ed copy of the original string |
| 227 | + */ |
| 228 | +static inline char * |
| 229 | +utf_u2e(char *utf8_str, size_t len) |
| 230 | +{ |
| 231 | + char *ret; |
| 232 | + |
| 233 | + ret = pg_any_to_server(utf8_str, len, PG_UTF8); |
| 234 | + |
| 235 | + /* ensure we have a copy even if no conversion happened */ |
| 236 | + if (ret == utf8_str) |
| 237 | + ret = pstrdup(ret); |
| 238 | + |
| 239 | + return ret; |
| 240 | +} |
| 241 | + |
| 242 | +/* |
| 243 | + * convert from database encoding to utf8 |
| 244 | + * |
| 245 | + * Returns a palloc'ed copy of the original string |
| 246 | + */ |
| 247 | +static inline char * |
| 248 | +utf_e2u(const char *str) |
| 249 | +{ |
| 250 | + char *ret; |
| 251 | + |
| 252 | + ret = pg_server_to_any(str, strlen(str), PG_UTF8); |
| 253 | + |
| 254 | + /* ensure we have a copy even if no conversion happened */ |
| 255 | + if (ret == str) |
| 256 | + ret = pstrdup(ret); |
| 257 | + |
| 258 | + return ret; |
| 259 | +} |
| 260 | + |
| 261 | +/* |
| 262 | + * Convert an SV to a char * in the current database encoding |
| 263 | + * |
| 264 | + * Returns a palloc'ed copy of the original string |
| 265 | + */ |
| 266 | +static inline char * |
| 267 | +sv2cstr(SV *sv) |
| 268 | +{ |
| 269 | + dTHX; |
| 270 | + char *val, |
| 271 | + *res; |
| 272 | + STRLEN len; |
| 273 | + |
| 274 | + /* |
| 275 | + * get a utf8 encoded char * out of perl. *note* it may not be valid utf8! |
| 276 | + */ |
| 277 | + |
| 278 | + /* |
| 279 | + * SvPVutf8() croaks nastily on certain things, like typeglobs and |
| 280 | + * readonly objects such as $^V. That's a perl bug - it's not supposed to |
| 281 | + * happen. To avoid crashing the backend, we make a copy of the sv before |
| 282 | + * passing it to SvPVutf8(). The copy is garbage collected when we're done |
| 283 | + * with it. |
| 284 | + */ |
| 285 | + if (SvREADONLY(sv) || |
| 286 | + isGV_with_GP(sv) || |
| 287 | + (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)) |
| 288 | + sv = newSVsv(sv); |
| 289 | + else |
| 290 | + { |
| 291 | + /* |
| 292 | + * increase the reference count so we can just SvREFCNT_dec() it when |
| 293 | + * we are done |
| 294 | + */ |
| 295 | + SvREFCNT_inc_simple_void(sv); |
| 296 | + } |
| 297 | + |
| 298 | + /* |
| 299 | + * Request the string from Perl, in UTF-8 encoding; but if we're in a |
| 300 | + * SQL_ASCII database, just request the byte soup without trying to make |
| 301 | + * it UTF8, because that might fail. |
| 302 | + */ |
| 303 | + if (GetDatabaseEncoding() == PG_SQL_ASCII) |
| 304 | + val = SvPV(sv, len); |
| 305 | + else |
| 306 | + val = SvPVutf8(sv, len); |
| 307 | + |
| 308 | + /* |
| 309 | + * Now convert to database encoding. We use perl's length in the event we |
| 310 | + * had an embedded null byte to ensure we error out properly. |
| 311 | + */ |
| 312 | + res = utf_u2e(val, len); |
| 313 | + |
| 314 | + /* safe now to garbage collect the new SV */ |
| 315 | + SvREFCNT_dec(sv); |
| 316 | + |
| 317 | + return res; |
| 318 | +} |
| 319 | + |
| 320 | +/* |
| 321 | + * Create a new SV from a string assumed to be in the current database's |
| 322 | + * encoding. |
| 323 | + */ |
| 324 | +static inline SV * |
| 325 | +cstr2sv(const char *str) |
| 326 | +{ |
| 327 | + dTHX; |
| 328 | + SV *sv; |
| 329 | + char *utf8_str; |
| 330 | + |
| 331 | + /* no conversion when SQL_ASCII */ |
| 332 | + if (GetDatabaseEncoding() == PG_SQL_ASCII) |
| 333 | + return newSVpv(str, 0); |
| 334 | + |
| 335 | + utf8_str = utf_e2u(str); |
| 336 | + |
| 337 | + sv = newSVpv(utf8_str, 0); |
| 338 | + SvUTF8_on(sv); |
| 339 | + pfree(utf8_str); |
| 340 | + |
| 341 | + return sv; |
| 342 | +} |
| 343 | + |
| 344 | +/* |
| 345 | + * croak() with specified message, which is given in the database encoding. |
| 346 | + * |
| 347 | + * Ideally we'd just write croak("%s", str), but plain croak() does not play |
| 348 | + * nice with non-ASCII data. In modern Perl versions we can call cstr2sv() |
| 349 | + * and pass the result to croak_sv(); in versions that don't have croak_sv(), |
| 350 | + * we have to work harder. |
| 351 | + */ |
| 352 | +static inline void |
| 353 | +croak_cstr(const char *str) |
| 354 | +{ |
| 355 | + dTHX; |
| 356 | + |
| 357 | +#ifdef croak_sv |
| 358 | + /* Use sv_2mortal() to be sure the transient SV gets freed */ |
| 359 | + croak_sv(sv_2mortal(cstr2sv(str))); |
| 360 | +#else |
| 361 | + |
| 362 | + /* |
| 363 | + * The older way to do this is to assign a UTF8-marked value to ERRSV and |
| 364 | + * then call croak(NULL). But if we leave it to croak() to append the |
| 365 | + * error location, it does so too late (only after popping the stack) in |
| 366 | + * some Perl versions. Hence, use mess() to create an SV with the error |
| 367 | + * location info already appended. |
| 368 | + */ |
| 369 | + SV *errsv = get_sv("@", GV_ADD); |
| 370 | + char *utf8_str = utf_e2u(str); |
| 371 | + SV *ssv; |
| 372 | + |
| 373 | + ssv = mess("%s", utf8_str); |
| 374 | + SvUTF8_on(ssv); |
| 375 | + |
| 376 | + pfree(utf8_str); |
| 377 | + |
| 378 | + sv_setsv(errsv, ssv); |
| 379 | + |
| 380 | + croak(NULL); |
| 381 | +#endif /* croak_sv */ |
| 382 | +} |
| 383 | + |
216 | 384 | #endif /* PL_PERL_H */ |
0 commit comments