Branch data 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 *
51 : 1209 : utf_u2e(char *utf8_str, size_t len)
52 : : {
53 : : char *ret;
54 : :
55 : 1209 : ret = pg_any_to_server(utf8_str, len, PG_UTF8);
56 : :
57 : : /* ensure we have a copy even if no conversion happened */
58 [ + - ]: 1208 : if (ret == utf8_str)
59 : 1208 : ret = pstrdup(ret);
60 : :
61 : 1208 : 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 : 1374 : utf_e2u(const char *str)
71 : : {
72 : : char *ret;
73 : :
74 : 1374 : ret = pg_server_to_any(str, strlen(str), PG_UTF8);
75 : :
76 : : /* ensure we have a copy even if no conversion happened */
77 [ + - ]: 1374 : if (ret == str)
78 : 1374 : ret = pstrdup(ret);
79 : :
80 : 1374 : 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 : 1209 : sv2cstr(SV *sv)
90 : : {
91 : 1209 : 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 [ + + ]: 1209 : if (SvREADONLY(sv) ||
108 [ - + - - : 1129 : isGV_with_GP(sv) ||
- - ]
109 [ - + - - ]: 1129 : (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
110 : 80 : 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 [ + - ]: 1129 : 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 [ - + ]: 1209 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
126 : 0 : val = SvPV(sv, len);
127 : : else
128 : 1209 : 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 : 1209 : res = utf_u2e(val, len);
135 : :
136 : : /* safe now to garbage collect the new SV */
137 : 1208 : SvREFCNT_dec(sv);
138 : :
139 : 1208 : 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 : 1374 : cstr2sv(const char *str)
148 : : {
149 : 1374 : dTHX;
150 : : SV *sv;
151 : : char *utf8_str;
152 : :
153 : : /* no conversion when SQL_ASCII */
154 [ - + ]: 1374 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
155 : 0 : return newSVpv(str, 0);
156 : :
157 : 1374 : utf8_str = utf_e2u(str);
158 : :
159 : 1374 : sv = newSVpv(utf8_str, 0);
160 : 1374 : SvUTF8_on(sv);
161 : 1374 : pfree(utf8_str);
162 : :
163 : 1374 : 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 *
181 : 274 : hek2cstr(HE *he)
182 : : {
183 : 274 : 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 : 274 : ENTER;
192 : 274 : 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 [ + - + + ]: 274 : sv = HeSVKEY_force(he);
220 [ + + - + ]: 274 : if (HeUTF8(he))
221 : 0 : SvUTF8_on(sv);
222 : 274 : ret = sv2cstr(sv);
223 : :
224 : : /* free sv */
225 [ + + ]: 274 : FREETMPS;
226 : 274 : LEAVE;
227 : :
228 : 274 : return ret;
229 : : }
230 : :
231 : : /*
232 : : * Test whether ERRSV indicates that Perl threw an error.
233 : : *
234 : : * The traditional way to write this is SvTRUE(ERRSV), but that is unsafe.
235 : : * If the error is an object whose class overloads "bool", SvTRUE invokes
236 : : * that user-defined Perl code, which is free to throw an error of its own.
237 : : * Since we typically ask this question while unwinding from an error, such
238 : : * a nested throw tends to land right back where we started, giving an
239 : : * infinite loop. Avoid the problem by not asking Perl at all in the case
240 : : * that matters: any reference is true, whatever its class may claim. Only
241 : : * non-references need the full test, and overloading cannot apply to those.
242 : : */
243 : : static inline bool
244 : 580 : errsv_is_true(SV *errsv)
245 : : {
246 : 580 : dTHX;
247 : :
248 [ - + ]: 580 : if (!errsv)
249 : 0 : return false;
250 [ - + ]: 580 : if (SvROK(errsv))
251 : 0 : return true;
252 : 580 : return SvTRUE(errsv);
253 : : }
254 : :
255 : : /*
256 : : * croak() with specified message, which is given in the database encoding.
257 : : *
258 : : * Ideally we'd just write croak("%s", str), but plain croak() does not play
259 : : * nice with non-ASCII data. In modern Perl versions we can call cstr2sv()
260 : : * and pass the result to croak_sv(); in versions that don't have croak_sv(),
261 : : * we have to work harder.
262 : : */
263 : : static inline void
264 : 19 : croak_cstr(const char *str)
265 : : {
266 : 19 : dTHX;
267 : :
268 : : #ifdef croak_sv
269 : : /* Use sv_2mortal() to be sure the transient SV gets freed */
270 : 19 : croak_sv(sv_2mortal(cstr2sv(str)));
271 : : #else
272 : :
273 : : /*
274 : : * The older way to do this is to assign a UTF8-marked value to ERRSV and
275 : : * then call croak(NULL). But if we leave it to croak() to append the
276 : : * error location, it does so too late (only after popping the stack) in
277 : : * some Perl versions. Hence, use mess() to create an SV with the error
278 : : * location info already appended.
279 : : */
280 : : SV *errsv = get_sv("@", GV_ADD);
281 : : char *utf8_str = utf_e2u(str);
282 : : SV *ssv;
283 : :
284 : : ssv = mess("%s", utf8_str);
285 : : SvUTF8_on(ssv);
286 : :
287 : : pfree(utf8_str);
288 : :
289 : : sv_setsv(errsv, ssv);
290 : :
291 : : croak(NULL);
292 : : #endif /* croak_sv */
293 : : }
294 : :
295 : : /*
296 : : * These macros provide a version of the PG_TRY facility that can catch
297 : : * Perl's longjmps as well as our own. Use these, not plain PG_TRY, in any
298 : : * code that can invoke Perl functions, to ensure that the two jmp_buf stacks
299 : : * remain consistent. Without this, any Perl function that is called directly
300 : : * (rather than via a runops loop such as call_sv's) will wreak havoc if it
301 : : * throws an error.
302 : : *
303 : : * These must be invoked within the scope of a dTHX declaration. That
304 : : * declaration controls which interpreter we manipulate the jmp_buf stack of.
305 : : *
306 : : * Like PG_TRY, we accept a __VA_ARGS__ string to append to local variable
307 : : * names, but that's of limited use since we can't modify the "cur_env" name
308 : : * declared by dJMPENV; so you can't nest these without drawing compiler
309 : : * warnings about shadowed variables. However, it is helpful in some places
310 : : * to nest PG_PERL_TRY within PG_TRY, so we make sure not to conflict with
311 : : * the names that PG_TRY declares. (Beware of nesting them too closely,
312 : : * for fear of breaking clang. It does seem to work so long as there's a
313 : : * nontrivial amount of code in between.)
314 : : *
315 : : * Since nothing in life is easy, we need two implementations of this idea.
316 : : * They are equivalent from the outside.
317 : : */
318 : :
319 : : #if !(defined(WIN32) && defined(__MINGW64__))
320 : :
321 : : /*
322 : : * This is our preferred implementation, which we use everywhere but MinGW-64.
323 : : * It depends on the assumption that Perl is built with the same sigsetjmp()
324 : : * infrastructure that we are.
325 : : *
326 : : * A key design choice here is to use just one sigsetjmp() call and link
327 : : * that jmp_buf structure into both jmp_buf stacks. That requires being more
328 : : * intimate with both error mechanisms than one could wish, but using two
329 : : * sigsetjmp() calls is expensive, and more importantly it completely breaks
330 : : * clang's optimizer, so much so that clang generates buggy code even at -O0.
331 : : * To provide at least a fig-leaf of separation from Perl innards, we use
332 : : * JMPENV_PUSH/JMPENV_POP to manipulate their jmp_buf stack and modify our
333 : : * own stack by hand. (Thus, these macros look a good deal like elog.h's.)
334 : : * The main trick to using a single jmp_buf is how to tell whether a caught
335 : : * longjmp was raised by our code or Perl's. We handle that by detecting
336 : : * whether elog.c has a complete error report that's not been popped.
337 : : * If so, we assume the already-stacked Postgres error is what to report.
338 : : * If not, the error is Perl's, so we convert their error to a Postgres one.
339 : : */
340 : : #define PG_PERL_TRY(...) \
341 : : do { \
342 : : dJMPENV; \
343 : : OP *_pp_save_op = PL_op; \
344 : : volatile bool _pp_leavetry_needed = true; \
345 : : volatile bool _pp_reporting = false; \
346 : : int _pp_ret_; \
347 : : sigjmp_buf *_save_exception_stack##__VA_ARGS__ = PG_exception_stack; \
348 : : ErrorContextCallback *_save_context_stack##__VA_ARGS__ = error_context_stack; \
349 : : bool _do_rethrow##__VA_ARGS__ = false; \
350 : : bool _cleanup_needed##__VA_ARGS__ = true; \
351 : : JMPENV_PUSH(_pp_ret_); \
352 : : if (_pp_ret_ == 0) \
353 : : { \
354 : : PG_exception_stack = &cur_env.je_buf; \
355 : : plperl_do_entertry(aTHX)
356 : :
357 : : #define PG_PERL_CATCH(...) \
358 : : } \
359 : : else \
360 : : { \
361 : : /* Is the thrown error ours, or Perl's? */ \
362 : : if (!HaveCompleteError()) \
363 : : { \
364 : : /* Perl's, so assume we don't need LEAVETRY any more */ \
365 : : _pp_leavetry_needed = false; \
366 : : /* Reset our error stacks to ensure they're not dangling */ \
367 : : PG_exception_stack = &cur_env.je_buf; \
368 : : error_context_stack = _save_context_stack##__VA_ARGS__; \
369 : : /* This'll longjmp back here, but now with an error stacked */ \
370 : : PG_PERL_REPORT_LONGJMP(_pp_ret_); \
371 : : } \
372 : : PG_PERL_POP_STACKS(__VA_ARGS__)
373 : :
374 : : #define PG_PERL_FINALLY(...) \
375 : : } \
376 : : else \
377 : : { \
378 : : /* Is the thrown error ours, or Perl's? */ \
379 : : if (!HaveCompleteError()) \
380 : : { \
381 : : /* Perl's, so assume we don't need LEAVETRY any more */ \
382 : : _pp_leavetry_needed = false; \
383 : : /* Reset our error stacks to ensure they're not dangling */ \
384 : : PG_exception_stack = &cur_env.je_buf; \
385 : : error_context_stack = _save_context_stack##__VA_ARGS__; \
386 : : /* This'll longjmp back here, but now with an error stacked */ \
387 : : PG_PERL_REPORT_LONGJMP(_pp_ret_); \
388 : : } \
389 : : _do_rethrow##__VA_ARGS__ = true; \
390 : : } \
391 : : { \
392 : : PG_PERL_POP_STACKS(__VA_ARGS__)
393 : :
394 : : #define PG_PERL_END_TRY(...) \
395 : : } \
396 : : if (_do_rethrow##__VA_ARGS__) \
397 : : PG_RE_THROW(); \
398 : : if (_cleanup_needed##__VA_ARGS__) \
399 : : { \
400 : : PG_PERL_POP_STACKS(__VA_ARGS__); \
401 : : } \
402 : : } while (0)
403 : :
404 : : /*
405 : : * This helper macro is split out just to reduce code duplication.
406 : : * It pops both jmp_buf stacks and does some other end-of-block cleanup.
407 : : *
408 : : * Unlike the case in PG_TRY and friends, we must do this only once,
409 : : * so we need an explicit _cleanup_needed flag to avoid doing it twice
410 : : * during successful exit from a FINALLY block.
411 : : */
412 : : #define PG_PERL_POP_STACKS(...) \
413 : : _cleanup_needed##__VA_ARGS__ = false; \
414 : : JMPENV_POP; \
415 : : PG_exception_stack = _save_exception_stack##__VA_ARGS__; \
416 : : error_context_stack = _save_context_stack##__VA_ARGS__; \
417 : : if (_pp_leavetry_needed) \
418 : : plperl_do_leavetry(aTHX); \
419 : : PL_op = _pp_save_op
420 : :
421 : : #else /* defined(WIN32) && defined(__MINGW64__) */
422 : :
423 : : /*
424 : : * We use this implementation on MinGW-64, where we use __builtin_setjmp()
425 : : * (see c.h), but Perl is content with MinGW's setjmp(). Of necessity, we
426 : : * maintain the two jmp_buf stacks separately and pay the price of two setjmp
427 : : * calls per level.
428 : : *
429 : : * Here, the forced updates of PL_top_env are needed to prevent an assertion
430 : : * failure in JMPENV_POP when what we are catching is a Postgres longjmp that
431 : : * has exited past the stack level of some Perl JMPENV_PUSH.
432 : : */
433 : : #define PG_PERL_TRY(...) \
434 : : do { \
435 : : dJMPENV; \
436 : : OP *_pp_save_op = PL_op; \
437 : : volatile bool _pp_leavetry_needed = true; \
438 : : volatile bool _pp_reporting = false; \
439 : : PG_TRY(__VA_ARGS__); \
440 : : { \
441 : : int _pp_ret_; \
442 : : JMPENV_PUSH(_pp_ret_); \
443 : : if (_pp_ret_ == 0) \
444 : : { \
445 : : plperl_do_entertry(aTHX);
446 : :
447 : : #define PG_PERL_CATCH(...) \
448 : : } \
449 : : else \
450 : : { \
451 : : _pp_leavetry_needed = false; \
452 : : PG_PERL_REPORT_LONGJMP(_pp_ret_); \
453 : : } \
454 : : PL_top_env = &cur_env; \
455 : : JMPENV_POP; \
456 : : if (_pp_leavetry_needed) \
457 : : plperl_do_leavetry(aTHX); \
458 : : PL_op = _pp_save_op; \
459 : : } \
460 : : PG_CATCH(__VA_ARGS__); \
461 : : { \
462 : : PL_top_env = &cur_env; \
463 : : JMPENV_POP; \
464 : : if (_pp_leavetry_needed) \
465 : : plperl_do_leavetry(aTHX); \
466 : : PL_op = _pp_save_op; \
467 : : {
468 : :
469 : : #define PG_PERL_FINALLY(...) \
470 : : } \
471 : : else \
472 : : { \
473 : : _pp_leavetry_needed = false; \
474 : : PG_PERL_REPORT_LONGJMP(_pp_ret_); \
475 : : } \
476 : : } \
477 : : PG_FINALLY(__VA_ARGS__); \
478 : : { \
479 : : PL_top_env = &cur_env; \
480 : : JMPENV_POP; \
481 : : if (_pp_leavetry_needed) \
482 : : plperl_do_leavetry(aTHX); \
483 : : PL_op = _pp_save_op; \
484 : : {
485 : :
486 : : #define PG_PERL_END_TRY(...) \
487 : : } \
488 : : } \
489 : : PG_END_TRY(__VA_ARGS__); \
490 : : } while (0)
491 : :
492 : : #endif /* !(defined(WIN32) && defined(__MINGW64__)) */
493 : :
494 : : /*
495 : : * This helper macro is split out just to reduce code duplication.
496 : : * It converts an error thrown by Perl into a Postgres ereport.
497 : : */
498 : : #define PG_PERL_REPORT_LONGJMP(_pp_ret_) \
499 : : do { \
500 : : SV *errsv; \
501 : : const char *errmessage; \
502 : : /* \
503 : : * Since we're still within the scope of PG_PERL_TRY's JMPENV_PUSH, \
504 : : * any error thrown by the Perl functions used herein will jump right \
505 : : * back here, risking an infinite loop. While we try to prevent \
506 : : * that, provide a way to break out of such a loop, just in case. \
507 : : */ \
508 : : CHECK_FOR_INTERRUPTS(); \
509 : : /* \
510 : : * If we already failed while converting Perl's error to a string, \
511 : : * don't try again. The conversion runs user-supplied Perl code \
512 : : * if the error is an object with an overloaded "" operator, and if \
513 : : * that throws we'll come right back here. \
514 : : */ \
515 : : if (_pp_reporting) \
516 : : ereport(ERROR, \
517 : : (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), \
518 : : errmsg("Perl error could not be converted to a string"))); \
519 : : _pp_reporting = true; \
520 : : /* \
521 : : * Convert the error to a string before starting the ereport, not \
522 : : * within it. A throw from an overloaded "" operator would otherwise \
523 : : * leave an incomplete error stacked, leaking an errordata slot. \
524 : : */ \
525 : : errsv = ERRSV; \
526 : : if (!errsv_is_true(errsv)) \
527 : : elog(ERROR, "unexpected Perl longjmp, code %d", _pp_ret_); \
528 : : errmessage = strip_trailing_ws(sv2cstr(errsv)); \
529 : : _pp_reporting = false; \
530 : : /* This'll longjmp back here, but now with a Postgres error ready */ \
531 : : ereport(ERROR, \
532 : : (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), \
533 : : errmsg_internal("%s", errmessage))); \
534 : : } while (0)
535 : :
536 : : /*
537 : : * Helper function: invoke OP_ENTERTRY to push a CXt_EVAL context
538 : : *
539 : : * This hackery with ENTERTRY/LEAVETRY ensures that Perl will longjmp rather
540 : : * than exiting, even if we're not presently inside an eval{}. We explicitly
541 : : * save/restore PL_op rather than trying to get ENTERTRY/LEAVETRY to do that.
542 : : *
543 : : * A side-effect of OP_ENTERTRY that we do *not* want is CLEAR_ERRSV.
544 : : * Hack around that by hiding the entry-time ERRSV in a local.
545 : : */
546 : : static inline void
547 : 933 : plperl_do_entertry(pTHX)
548 : : {
549 : 933 : SV *old_errsv = GvSV(PL_errgv);
550 : : LOGOP et_op;
551 : : OP child_op;
552 : :
553 : : /* Replace ERRSV with a dummy SV, which ENTERTRY will clear */
554 : 933 : GvSV(PL_errgv) = newSV(0);
555 : :
556 : : /* We had better have disabled CATCH_GET, else this does the wrong thing */
557 : : Assert(!CATCH_GET);
558 : 933 : memset(&et_op, 0, sizeof(et_op));
559 : 933 : et_op.op_flags = OPf_WANT_VOID;
560 : : /* We need a child OP, just to avoid a null-pointer dereference */
561 : 933 : memset(&child_op, 0, sizeof(child_op));
562 : 933 : et_op.op_other = &child_op;
563 : 933 : PL_op = (OP *) &et_op;
564 : 933 : (void) (PL_ppaddr[OP_ENTERTRY]) (aTHX);
565 : :
566 : : /* Release the dummy SV's one and only refcnt */
567 : 933 : SvREFCNT_dec(GvSV(PL_errgv));
568 : : /* ... and put back the old ERRSV value */
569 : 933 : GvSV(PL_errgv) = old_errsv;
570 : 933 : }
571 : :
572 : : /*
573 : : * Helper function: invoke OP_LEAVETRY to pop that context again
574 : : *
575 : : * Just to make things difficult, we must skip this if Perl threw a
576 : : * longjmp, because die_unwind() would have popped the context.
577 : : *
578 : : * As above, don't let it change ERRSV.
579 : : */
580 : : static inline void
581 : 930 : plperl_do_leavetry(pTHX)
582 : : {
583 : 930 : SV *old_errsv = GvSV(PL_errgv);
584 : : OP lt_op;
585 : :
586 : : /* Replace ERRSV with a dummy SV, which LEAVETRY will clear */
587 : 930 : GvSV(PL_errgv) = newSV(0);
588 : :
589 : 930 : memset(<_op, 0, sizeof(lt_op));
590 : 930 : PL_op = <_op;
591 : 930 : (void) (PL_ppaddr[OP_LEAVETRY]) (aTHX);
592 : :
593 : : /* Release the dummy SV's one and only refcnt */
594 : 930 : SvREFCNT_dec(GvSV(PL_errgv));
595 : : /* ... and put back the old ERRSV value */
596 : 930 : GvSV(PL_errgv) = old_errsv;
597 : 930 : }
598 : :
599 : : #endif /* PL_PERL_H */
|
