This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
combopatch
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
cbdf9ef8 4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e
LW
9 */
10
11/*
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
79072805
LW
14 */
15
ccfc67b7
JH
16/*
17=head1 Magical Functions
166f8a29
DM
18
19"Magic" is special data attached to SV structures in order to give them
20"magical" properties. When any Perl code tries to read from, or assign to,
21an SV marked as magical, it calls the 'get' or 'set' function associated
22with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 23give it a chance to update its internal value (get on $. writes the line
166f8a29
DM
24number of the last read filehandle into to the SV's IV slot), while
25set is called after an SV has been written to, in order to allow it to make
ddfa107c 26use of its changed value (set on $/ copies the SV's new value to the
166f8a29
DM
27PL_rs global variable).
28
29Magic is implemented as a linked list of MAGIC structures attached to the
30SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31of functions that implement the get(), set(), length() etc functions,
32plus space for some flags and pointers. For example, a tied variable has
33a MAGIC structure that contains a pointer to the object associated with the
34tie.
35
ccfc67b7
JH
36*/
37
79072805 38#include "EXTERN.h"
864dbfa3 39#define PERL_IN_MG_C
79072805
LW
40#include "perl.h"
41
5cd24f17 42#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
188ea221
CS
43# ifndef NGROUPS
44# define NGROUPS 32
45# endif
b7953727
JH
46# ifdef I_GRP
47# include <grp.h>
48# endif
188ea221
CS
49#endif
50
17aa7f3d
JH
51#ifdef __hpux
52# include <sys/pstat.h>
53#endif
54
e69880a5
CB
55Signal_t Perl_csighandler(int sig);
56
35a4481c
AL
57static void restore_magic(pTHX_ const void *p);
58static void unwind_handler_stack(pTHX_ const void *p);
51371543 59
9cffb111
OS
60#ifdef __Lynx__
61/* Missing protos on LynxOS */
62void setruid(uid_t id);
63void seteuid(uid_t id);
64void setrgid(uid_t id);
65void setegid(uid_t id);
66#endif
67
c07a80fd
PP
68/*
69 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
70 */
71
72struct magic_state {
73 SV* mgs_sv;
74 U32 mgs_flags;
455ece5e 75 I32 mgs_ss_ix;
c07a80fd 76};
455ece5e 77/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS
78
79STATIC void
8fb26106 80S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 81{
455ece5e 82 MGS* mgs;
c07a80fd 83 assert(SvMAGICAL(sv));
765f542d
NC
84#ifdef PERL_COPY_ON_WRITE
85 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
86 if (SvIsCOW(sv))
87 sv_force_normal(sv);
88#endif
c07a80fd 89
685f876f 90 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD
91
92 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd
PP
93 mgs->mgs_sv = sv;
94 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 95 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
c07a80fd
PP
96
97 SvMAGICAL_off(sv);
98 SvREADONLY_off(sv);
06759ea0 99 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
c07a80fd
PP
100}
101
954c1994
GS
102/*
103=for apidoc mg_magical
104
105Turns on the magical status of an SV. See C<sv_magic>.
106
107=cut
108*/
109
8990e307 110void
864dbfa3 111Perl_mg_magical(pTHX_ SV *sv)
8990e307 112{
e1ec3a88 113 const MAGIC* mg;
8990e307 114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 115 const MGVTBL* const vtbl = mg->mg_virtual;
8990e307 116 if (vtbl) {
2b260de0 117 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
8990e307
LW
118 SvGMAGICAL_on(sv);
119 if (vtbl->svt_set)
120 SvSMAGICAL_on(sv);
2b260de0 121 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
8990e307
LW
122 SvRMAGICAL_on(sv);
123 }
124 }
125}
126
954c1994
GS
127/*
128=for apidoc mg_get
129
130Do magic after a value is retrieved from the SV. See C<sv_magic>.
131
132=cut
133*/
134
79072805 135int
864dbfa3 136Perl_mg_get(pTHX_ SV *sv)
79072805 137{
35a4481c 138 const I32 mgs_ix = SSNEW(sizeof(MGS));
fe2774ed 139 const bool was_temp = (bool)SvTEMP(sv);
0723351e 140 int have_new = 0;
ff76feab 141 MAGIC *newmg, *head, *cur, *mg;
20135930 142 /* guard against sv having being freed midway by holding a private
6683b158
NC
143 reference. */
144
145 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
146 cause the SV's buffer to get stolen (and maybe other stuff).
147 So restore it.
148 */
149 sv_2mortal(SvREFCNT_inc(sv));
150 if (!was_temp) {
151 SvTEMP_off(sv);
152 }
153
455ece5e 154 save_magic(mgs_ix, sv);
463ee0b2 155
ff76feab
AMS
156 /* We must call svt_get(sv, mg) for each valid entry in the linked
157 list of magic. svt_get() may delete the current entry, add new
158 magic to the head of the list, or upgrade the SV. AMS 20010810 */
159
160 newmg = cur = head = mg = SvMAGIC(sv);
161 while (mg) {
35a4481c 162 const MGVTBL * const vtbl = mg->mg_virtual;
ff76feab 163
2b260de0 164 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
316ad4fe 165 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
b77f7d40 166
58f82c5c
DM
167 /* guard against magic having been deleted - eg FETCH calling
168 * untie */
169 if (!SvMAGIC(sv))
170 break;
b77f7d40 171
ff76feab
AMS
172 /* Don't restore the flags for this entry if it was deleted. */
173 if (mg->mg_flags & MGf_GSKIP)
174 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
a0d0e21e 175 }
ff76feab
AMS
176
177 mg = mg->mg_moremagic;
178
0723351e 179 if (have_new) {
ff76feab
AMS
180 /* Have we finished with the new entries we saw? Start again
181 where we left off (unless there are more new entries). */
182 if (mg == head) {
0723351e 183 have_new = 0;
ff76feab
AMS
184 mg = cur;
185 head = newmg;
186 }
187 }
188
189 /* Were any new entries added? */
0723351e
NC
190 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
191 have_new = 1;
ff76feab
AMS
192 cur = mg;
193 mg = newmg;
760ac839 194 }
79072805 195 }
463ee0b2 196
acfe0abc 197 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
6683b158
NC
198
199 if (SvREFCNT(sv) == 1) {
200 /* We hold the last reference to this SV, which implies that the
201 SV was deleted as a side effect of the routines we called. */
0c34ef67 202 SvOK_off(sv);
6683b158 203 }
79072805
LW
204 return 0;
205}
206
954c1994
GS
207/*
208=for apidoc mg_set
209
210Do magic after a value is assigned to the SV. See C<sv_magic>.
211
212=cut
213*/
214
79072805 215int
864dbfa3 216Perl_mg_set(pTHX_ SV *sv)
79072805 217{
35a4481c 218 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 219 MAGIC* mg;
463ee0b2
LW
220 MAGIC* nextmg;
221
455ece5e 222 save_magic(mgs_ix, sv);
463ee0b2
LW
223
224 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 225 const MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 226 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
227 if (mg->mg_flags & MGf_GSKIP) {
228 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
455ece5e 229 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
a0d0e21e 230 }
2b260de0 231 if (vtbl && vtbl->svt_set)
fc0dc3b3 232 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
79072805 233 }
463ee0b2 234
acfe0abc 235 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
79072805
LW
236 return 0;
237}
238
954c1994
GS
239/*
240=for apidoc mg_length
241
242Report on the SV's length. See C<sv_magic>.
243
244=cut
245*/
246
79072805 247U32
864dbfa3 248Perl_mg_length(pTHX_ SV *sv)
79072805
LW
249{
250 MAGIC* mg;
463ee0b2 251 STRLEN len;
463ee0b2 252
79072805 253 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 254 const MGVTBL * const vtbl = mg->mg_virtual;
2b260de0 255 if (vtbl && vtbl->svt_len) {
35a4481c 256 const I32 mgs_ix = SSNEW(sizeof(MGS));
455ece5e 257 save_magic(mgs_ix, sv);
a0d0e21e 258 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 259 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
acfe0abc 260 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW
261 return len;
262 }
263 }
264
35a4481c 265 if (DO_UTF8(sv)) {
5636d518
DB
266 U8 *s = (U8*)SvPV(sv, len);
267 len = Perl_utf8_length(aTHX_ s, s + len);
268 }
269 else
270 (void)SvPV(sv, len);
463ee0b2 271 return len;
79072805
LW
272}
273
8fb26106 274I32
864dbfa3 275Perl_mg_size(pTHX_ SV *sv)
93965878
NIS
276{
277 MAGIC* mg;
ac27b0f5 278
93965878 279 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 280 const MGVTBL* const vtbl = mg->mg_virtual;
2b260de0 281 if (vtbl && vtbl->svt_len) {
35a4481c
AL
282 const I32 mgs_ix = SSNEW(sizeof(MGS));
283 I32 len;
455ece5e 284 save_magic(mgs_ix, sv);
93965878 285 /* omit MGf_GSKIP -- not changed here */
fc0dc3b3 286 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
acfe0abc 287 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
93965878
NIS
288 return len;
289 }
290 }
291
292 switch(SvTYPE(sv)) {
293 case SVt_PVAV:
35a4481c 294 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
93965878
NIS
295 case SVt_PVHV:
296 /* FIXME */
297 default:
cea2e8a9 298 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS
299 break;
300 }
301 return 0;
302}
303
954c1994
GS
304/*
305=for apidoc mg_clear
306
307Clear something magical that the SV represents. See C<sv_magic>.
308
309=cut
310*/
311
79072805 312int
864dbfa3 313Perl_mg_clear(pTHX_ SV *sv)
79072805 314{
35a4481c 315 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 316 MAGIC* mg;
463ee0b2 317
455ece5e 318 save_magic(mgs_ix, sv);
463ee0b2 319
79072805 320 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 321 const MGVTBL* const vtbl = mg->mg_virtual;
a0d0e21e 322 /* omit GSKIP -- never set here */
727405f8 323
2b260de0 324 if (vtbl && vtbl->svt_clear)
fc0dc3b3 325 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
79072805 326 }
463ee0b2 327
acfe0abc 328 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
79072805
LW
329 return 0;
330}
331
954c1994
GS
332/*
333=for apidoc mg_find
334
335Finds the magic pointer for type matching the SV. See C<sv_magic>.
336
337=cut
338*/
339
93a17b20 340MAGIC*
35a4481c 341Perl_mg_find(pTHX_ const SV *sv, int type)
93a17b20 342{
35a4481c
AL
343 if (sv) {
344 MAGIC *mg;
345 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
346 if (mg->mg_type == type)
347 return mg;
348 }
93a17b20
LW
349 }
350 return 0;
351}
352
954c1994
GS
353/*
354=for apidoc mg_copy
355
356Copies the magic from one SV to another. See C<sv_magic>.
357
358=cut
359*/
360
79072805 361int
864dbfa3 362Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 363{
463ee0b2 364 int count = 0;
79072805 365 MAGIC* mg;
463ee0b2 366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 367 const MGVTBL* const vtbl = mg->mg_virtual;
68795e93
NIS
368 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
369 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
370 }
371 else if (isUPPER(mg->mg_type)) {
33c27489 372 sv_magic(nsv,
14befaf4
DM
373 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
374 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
375 ? sv : mg->mg_obj,
33c27489 376 toLOWER(mg->mg_type), key, klen);
463ee0b2 377 count++;
79072805 378 }
79072805 379 }
463ee0b2 380 return count;
79072805
LW
381}
382
954c1994
GS
383/*
384=for apidoc mg_free
385
386Free any magic storage used by the SV. See C<sv_magic>.
387
388=cut
389*/
390
79072805 391int
864dbfa3 392Perl_mg_free(pTHX_ SV *sv)
79072805
LW
393{
394 MAGIC* mg;
395 MAGIC* moremagic;
396 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
35a4481c 397 const MGVTBL* const vtbl = mg->mg_virtual;
79072805 398 moremagic = mg->mg_moremagic;
2b260de0 399 if (vtbl && vtbl->svt_free)
fc0dc3b3 400 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
14befaf4 401 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
979acdb5 402 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
88e89b8a 403 Safefree(mg->mg_ptr);
565764a8 404 else if (mg->mg_len == HEf_SVKEY)
88e89b8a 405 SvREFCNT_dec((SV*)mg->mg_ptr);
d460ef45 406 }
b881518d
JH
407 if (mg->mg_flags & MGf_REFCOUNTED)
408 SvREFCNT_dec(mg->mg_obj);
79072805
LW
409 Safefree(mg);
410 }
b162af07 411 SvMAGIC_set(sv, NULL);
79072805
LW
412 return 0;
413}
414
79072805 415#include <signal.h>
79072805 416
942e002e 417U32
864dbfa3 418Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 419{
35a4481c 420 register const REGEXP *rx;
dd374669 421 (void)sv;
6cef1e77 422
aaa362c4 423 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
8f580fb8
IZ
424 if (mg->mg_obj) /* @+ */
425 return rx->nparens;
426 else /* @- */
427 return rx->lastparen;
428 }
ac27b0f5 429
942e002e 430 return (U32)-1;
6cef1e77
IZ
431}
432
433int
864dbfa3 434Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 435{
6cef1e77 436 register REGEXP *rx;
6cef1e77 437
aaa362c4 438 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
35a4481c
AL
439 register const I32 paren = mg->mg_len;
440 register I32 s;
441 register I32 t;
6cef1e77
IZ
442 if (paren < 0)
443 return 0;
eb160463 444 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
445 (s = rx->startp[paren]) != -1 &&
446 (t = rx->endp[paren]) != -1)
6cef1e77 447 {
35a4481c 448 register I32 i;
6cef1e77 449 if (mg->mg_obj) /* @+ */
cf93c79d 450 i = t;
6cef1e77 451 else /* @- */
cf93c79d 452 i = s;
727405f8 453
a30b2f1f 454 if (i > 0 && RX_MATCH_UTF8(rx)) {
1aa99e6b 455 char *b = rx->subbeg;
0064a8a9
JH
456 if (b)
457 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
1aa99e6b 458 }
0064a8a9
JH
459
460 sv_setiv(sv, i);
6cef1e77
IZ
461 }
462 }
463 return 0;
464}
465
e4b89193 466int
a29d06ed
MG
467Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
468{
dd374669 469 (void)sv; (void)mg;
a29d06ed 470 Perl_croak(aTHX_ PL_no_modify);
e4b89193 471 /* NOT REACHED */
3c8a6f86
NC
472#ifndef HASATTRIBUTE
473 /* No __attribute__, so the compiler doesn't know that croak never returns
474 */
475 return 0;
476#endif
a29d06ed
MG
477}
478
93a17b20 479U32
864dbfa3 480Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20
LW
481{
482 register I32 paren;
93a17b20 483 register I32 i;
dd374669 484 register const REGEXP *rx;
a197cbdd 485 I32 s1, t1;
93a17b20
LW
486
487 switch (*mg->mg_ptr) {
488 case '1': case '2': case '3': case '4':
489 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 490 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 491
ffc61ed2 492 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93a17b20 493 getparen:
eb160463 494 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
495 (s1 = rx->startp[paren]) != -1 &&
496 (t1 = rx->endp[paren]) != -1)
bbce6d69 497 {
cf93c79d 498 i = t1 - s1;
a197cbdd 499 getlen:
a30b2f1f 500 if (i > 0 && RX_MATCH_UTF8(rx)) {
ffc61ed2 501 char *s = rx->subbeg + s1;
a197cbdd 502 char *send = rx->subbeg + t1;
ffc61ed2 503
6d5fa195 504 i = t1 - s1;
60425c38
JH
505 if (is_utf8_string((U8*)s, i))
506 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
a197cbdd 507 }
ffc61ed2 508 if (i < 0)
0844c848 509 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 510 return i;
93a17b20 511 }
235bddc8
NIS
512 else {
513 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 514 report_uninit(sv);
235bddc8
NIS
515 }
516 }
517 else {
518 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 519 report_uninit(sv);
93a17b20 520 }
748a9306 521 return 0;
93a17b20 522 case '+':
aaa362c4 523 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 524 paren = rx->lastparen;
13f57bf8
CS
525 if (paren)
526 goto getparen;
93a17b20 527 }
748a9306 528 return 0;
a01268b5
JH
529 case '\016': /* ^N */
530 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
531 paren = rx->lastcloseparen;
532 if (paren)
533 goto getparen;
534 }
535 return 0;
93a17b20 536 case '`':
aaa362c4 537 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
538 if (rx->startp[0] != -1) {
539 i = rx->startp[0];
a197cbdd
GS
540 if (i > 0) {
541 s1 = 0;
542 t1 = i;
543 goto getlen;
544 }
93a17b20 545 }
93a17b20 546 }
748a9306 547 return 0;
93a17b20 548 case '\'':
aaa362c4 549 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
550 if (rx->endp[0] != -1) {
551 i = rx->sublen - rx->endp[0];
a197cbdd
GS
552 if (i > 0) {
553 s1 = rx->endp[0];
554 t1 = rx->sublen;
555 goto getlen;
556 }
93a17b20 557 }
93a17b20 558 }
748a9306 559 return 0;
93a17b20
LW
560 }
561 magic_get(sv,mg);
2d8e6c8d
GS
562 if (!SvPOK(sv) && SvNIOK(sv)) {
563 STRLEN n_a;
564 sv_2pv(sv, &n_a);
565 }
93a17b20
LW
566 if (SvPOK(sv))
567 return SvCUR(sv);
568 return 0;
569}
570
79072805 571int
864dbfa3 572Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 573{
27da23d5 574 dVAR;
79072805 575 register I32 paren;
35272f84 576 register char *s = NULL;
79072805 577 register I32 i;
d9f97599 578 register REGEXP *rx;
79072805
LW
579
580 switch (*mg->mg_ptr) {
748a9306 581 case '\001': /* ^A */
3280af22 582 sv_setsv(sv, PL_bodytarget);
748a9306 583 break;
49460fe6
NIS
584 case '\003': /* ^C */
585 sv_setiv(sv, (IV)PL_minus_c);
586 break;
587
79072805 588 case '\004': /* ^D */
aea4f609 589 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
79072805 590 break;
28f23441 591 case '\005': /* ^E */
0a378802 592 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 593#ifdef MACOS_TRADITIONAL
0a378802
JH
594 {
595 char msg[256];
727405f8 596
0a378802 597 sv_setnv(sv,(double)gMacPerl_OSErr);
727405f8 598 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
0a378802 599 }
727405f8 600#else
28f23441 601#ifdef VMS
0a378802
JH
602 {
603# include <descrip.h>
604# include <starlet.h>
605 char msg[255];
606 $DESCRIPTOR(msgdsc,msg);
607 sv_setnv(sv,(NV) vaxc$errno);
608 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
609 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
610 else
611 sv_setpv(sv,"");
612 }
28f23441 613#else
88e89b8a 614#ifdef OS2
0a378802
JH
615 if (!(_emx_env & 0x200)) { /* Under DOS */
616 sv_setnv(sv, (NV)errno);
617 sv_setpv(sv, errno ? Strerror(errno) : "");
618 } else {
619 if (errno != errno_isOS2) {
620 int tmp = _syserrno();
621 if (tmp) /* 2nd call to _syserrno() makes it 0 */
622 Perl_rc = tmp;
623 }
624 sv_setnv(sv, (NV)Perl_rc);
625 sv_setpv(sv, os2error(Perl_rc));
626 }
88e89b8a 627#else
22fae026 628#ifdef WIN32
0a378802
JH
629 {
630 DWORD dwErr = GetLastError();
631 sv_setnv(sv, (NV)dwErr);
632 if (dwErr)
633 {
634 PerlProc_GetOSError(sv, dwErr);
635 }
636 else
637 sv_setpv(sv, "");
638 SetLastError(dwErr);
639 }
22fae026 640#else
f6c8f21d
RGS
641 {
642 int saveerrno = errno;
643 sv_setnv(sv, (NV)errno);
644 sv_setpv(sv, errno ? Strerror(errno) : "");
645 errno = saveerrno;
646 }
28f23441 647#endif
88e89b8a 648#endif
22fae026 649#endif
cd39f2b6 650#endif
0a378802
JH
651 SvNOK_on(sv); /* what a wonderful hack! */
652 }
653 else if (strEQ(mg->mg_ptr+1, "NCODING"))
654 sv_setsv(sv, PL_encoding);
655 break;
79072805 656 case '\006': /* ^F */
3280af22 657 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 658 break;
a0d0e21e 659 case '\010': /* ^H */
3280af22 660 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 661 break;
9d116dd7 662 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
663 if (PL_inplace)
664 sv_setpv(sv, PL_inplace);
79072805 665 else
3280af22 666 sv_setsv(sv, &PL_sv_undef);
79072805 667 break;
ac27b0f5 668 case '\017': /* ^O & ^OPEN */
3511154c 669 if (*(mg->mg_ptr+1) == '\0') {
ac27b0f5 670 sv_setpv(sv, PL_osname);
3511154c
DM
671 SvTAINTED_off(sv);
672 }
ac27b0f5
NIS
673 else if (strEQ(mg->mg_ptr, "\017PEN")) {
674 if (!PL_compiling.cop_io)
675 sv_setsv(sv, &PL_sv_undef);
676 else {
677 sv_setsv(sv, PL_compiling.cop_io);
678 }
679 }
28f23441 680 break;
79072805 681 case '\020': /* ^P */
3280af22 682 sv_setiv(sv, (IV)PL_perldb);
79072805 683 break;
fb73857a 684 case '\023': /* ^S */
4ffa73a3 685 if (*(mg->mg_ptr+1) == '\0') {
3280af22 686 if (PL_lex_state != LEX_NOTPARSING)
0c34ef67 687 SvOK_off(sv);
3280af22 688 else if (PL_in_eval)
6dc8a9e4 689 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS
690 else
691 sv_setiv(sv, 0);
d58bf5aa 692 }
fb73857a 693 break;
79072805 694 case '\024': /* ^T */
7c36658b 695 if (*(mg->mg_ptr+1) == '\0') {
88e89b8a 696#ifdef BIG_TIME
7c36658b 697 sv_setnv(sv, PL_basetime);
88e89b8a 698#else
7c36658b 699 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 700#endif
7c36658b
MS
701 }
702 else if (strEQ(mg->mg_ptr, "\024AINT"))
9aa05f58
RGS
703 sv_setiv(sv, PL_tainting
704 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
705 : 0);
7c36658b 706 break;
7cebcbc0 707 case '\025': /* $^UNICODE, $^UTF8LOCALE */
a05d7ebb
JH
708 if (strEQ(mg->mg_ptr, "\025NICODE"))
709 sv_setuv(sv, (UV) PL_unicode);
7cebcbc0
NC
710 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
711 sv_setuv(sv, (UV) PL_utf8locale);
fde18df1
JH
712 break;
713 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
714 if (*(mg->mg_ptr+1) == '\0')
715 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
0a378802 716 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
d3a7d8c7
GS
717 if (PL_compiling.cop_warnings == pWARN_NONE ||
718 PL_compiling.cop_warnings == pWARN_STD)
4438c4b7
JH
719 {
720 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
721 }
d3a7d8c7 722 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS
723 /* Get the bit mask for $warnings::Bits{all}, because
724 * it could have been extended by warnings::register */
725 SV **bits_all;
726 HV *bits=get_hv("warnings::Bits", FALSE);
727 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
728 sv_setsv(sv, *bits_all);
729 }
730 else {
731 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
732 }
ac27b0f5 733 }
4438c4b7
JH
734 else {
735 sv_setsv(sv, PL_compiling.cop_warnings);
ac27b0f5 736 }
d3a7d8c7 737 SvPOK_only(sv);
4438c4b7 738 }
79072805
LW
739 break;
740 case '1': case '2': case '3': case '4':
741 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 742 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
743 I32 s1, t1;
744
a863c7d1
MB
745 /*
746 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
747 * XXX Does the new way break anything?
748 */
ffc61ed2 749 paren = atoi(mg->mg_ptr); /* $& is in [0] */
79072805 750 getparen:
eb160463 751 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
752 (s1 = rx->startp[paren]) != -1 &&
753 (t1 = rx->endp[paren]) != -1)
bbce6d69 754 {
cf93c79d
IZ
755 i = t1 - s1;
756 s = rx->subbeg + s1;
01ec43d0 757 if (!rx->subbeg)
c2e66d9e
GS
758 break;
759
13f57bf8 760 getrx:
748a9306 761 if (i >= 0) {
cf93c79d 762 sv_setpvn(sv, s, i);
a30b2f1f 763 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
7e2040f0
GS
764 SvUTF8_on(sv);
765 else
766 SvUTF8_off(sv);
e9814ee1
HS
767 if (PL_tainting) {
768 if (RX_MATCH_TAINTED(rx)) {
769 MAGIC* mg = SvMAGIC(sv);
770 MAGIC* mgt;
771 PL_tainted = 1;
b162af07 772 SvMAGIC_set(sv, mg->mg_moremagic);
e9814ee1
HS
773 SvTAINT(sv);
774 if ((mgt = SvMAGIC(sv))) {
775 mg->mg_moremagic = mgt;
b162af07 776 SvMAGIC_set(sv, mg);
e9814ee1
HS
777 }
778 } else
779 SvTAINTED_off(sv);
780 }
748a9306
LW
781 break;
782 }
79072805 783 }
79072805 784 }
3280af22 785 sv_setsv(sv,&PL_sv_undef);
79072805
LW
786 break;
787 case '+':
aaa362c4 788 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 789 paren = rx->lastparen;
a0d0e21e
LW
790 if (paren)
791 goto getparen;
79072805 792 }
3280af22 793 sv_setsv(sv,&PL_sv_undef);
79072805 794 break;
a01268b5
JH
795 case '\016': /* ^N */
796 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
797 paren = rx->lastcloseparen;
798 if (paren)
799 goto getparen;
800 }
801 sv_setsv(sv,&PL_sv_undef);
802 break;
79072805 803 case '`':
aaa362c4 804 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
805 if ((s = rx->subbeg) && rx->startp[0] != -1) {
806 i = rx->startp[0];
13f57bf8 807 goto getrx;
79072805 808 }
79072805 809 }
3280af22 810 sv_setsv(sv,&PL_sv_undef);
79072805
LW
811 break;
812 case '\'':
aaa362c4 813 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
814 if (rx->subbeg && rx->endp[0] != -1) {
815 s = rx->subbeg + rx->endp[0];
816 i = rx->sublen - rx->endp[0];
13f57bf8 817 goto getrx;
79072805 818 }
79072805 819 }
3280af22 820 sv_setsv(sv,&PL_sv_undef);
79072805
LW
821 break;
822 case '.':
823#ifndef lint
3280af22 824 if (GvIO(PL_last_in_gv)) {
357c8808 825 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805
LW
826 }
827#endif
828 break;
829 case '?':
809a5acc 830 {
809a5acc 831 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 832#ifdef COMPLEX_STATUS
6b88bc9c
GS
833 LvTARGOFF(sv) = PL_statusvalue;
834 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 835#endif
809a5acc 836 }
79072805
LW
837 break;
838 case '^':
0daa599b
RGS
839 if (GvIOp(PL_defoutgv))
840 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
841 if (s)
842 sv_setpv(sv,s);
843 else {
3280af22 844 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
845 sv_catpv(sv,"_TOP");
846 }
847 break;
848 case '~':
0daa599b
RGS
849 if (GvIOp(PL_defoutgv))
850 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 851 if (!s)
3280af22 852 s = GvENAME(PL_defoutgv);
79072805
LW
853 sv_setpv(sv,s);
854 break;
855#ifndef lint
856 case '=':
0daa599b
RGS
857 if (GvIOp(PL_defoutgv))
858 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
859 break;
860 case '-':
0daa599b
RGS
861 if (GvIOp(PL_defoutgv))
862 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
863 break;
864 case '%':
0daa599b
RGS
865 if (GvIOp(PL_defoutgv))
866 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805
LW
867 break;
868#endif
869 case ':':
870 break;
871 case '/':
872 break;
873 case '[':
3280af22 874 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805
LW
875 break;
876 case '|':
0daa599b
RGS
877 if (GvIOp(PL_defoutgv))
878 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
879 break;
880 case ',':
79072805
LW
881 break;
882 case '\\':
b2ce0fda 883 if (PL_ors_sv)
f28098ff 884 sv_copypv(sv, PL_ors_sv);
79072805
LW
885 break;
886 case '#':
3280af22 887 sv_setpv(sv,PL_ofmt);
79072805
LW
888 break;
889 case '!':
a5f75d66 890#ifdef VMS
65202027 891 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 892 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 893#else
88e89b8a
PP
894 {
895 int saveerrno = errno;
65202027 896 sv_setnv(sv, (NV)errno);
88e89b8a 897#ifdef OS2
ed344e4f
IZ
898 if (errno == errno_isOS2 || errno == errno_isOS2_set)
899 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 900 else
a5f75d66 901#endif
2304df62 902 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
903 errno = saveerrno;
904 }
905#endif
946ec16e 906 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
907 break;
908 case '<':
3280af22 909 sv_setiv(sv, (IV)PL_uid);
79072805
LW
910 break;
911 case '>':
3280af22 912 sv_setiv(sv, (IV)PL_euid);
79072805
LW
913 break;
914 case '(':
3280af22 915 sv_setiv(sv, (IV)PL_gid);
a52cb5f7 916#ifdef HAS_GETGROUPS
785fb66b 917 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
a52cb5f7 918#endif
79072805
LW
919 goto add_groups;
920 case ')':
3280af22 921 sv_setiv(sv, (IV)PL_egid);
a52cb5f7 922#ifdef HAS_GETGROUPS
785fb66b 923 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
a52cb5f7 924#endif
79072805 925 add_groups:
79072805 926#ifdef HAS_GETGROUPS
79072805 927 {
a0d0e21e 928 Groups_t gary[NGROUPS];
79072805 929 i = getgroups(NGROUPS,gary);
46fc3d4c 930 while (--i >= 0)
785fb66b 931 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
79072805
LW
932 }
933#endif
155aba94 934 (void)SvIOK_on(sv); /* what a wonderful hack! */
79072805 935 break;
cd39f2b6 936#ifndef MACOS_TRADITIONAL
79072805
LW
937 case '0':
938 break;
cd39f2b6 939#endif
79072805 940 }
a0d0e21e 941 return 0;
79072805
LW
942}
943
944int
864dbfa3 945Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
946{
947 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
948
949 if (uf && uf->uf_val)
24f81a43 950 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
951 return 0;
952}
953
954int
864dbfa3 955Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 956{
27da23d5 957 dVAR;
79072805 958 register char *s;
88e89b8a 959 char *ptr;
5aabfad6 960 STRLEN len, klen;
1e422769 961
a0d0e21e 962 s = SvPV(sv,len);
5aabfad6 963 ptr = MgPV(mg,klen);
88e89b8a 964 my_setenv(ptr, s);
1e422769 965
a0d0e21e
LW
966#ifdef DYNAMIC_ENV_FETCH
967 /* We just undefd an environment var. Is a replacement */
968 /* waiting in the wings? */
969 if (!len) {
5aabfad6 970 SV **valp;
6b88bc9c 971 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
5aabfad6 972 s = SvPV(*valp, len);
a0d0e21e
LW
973 }
974#endif
1e422769 975
39e571d4 976#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
977 /* And you'll never guess what the dog had */
978 /* in its mouth... */
3280af22 979 if (PL_tainting) {
1e422769
PP
980 MgTAINTEDDIR_off(mg);
981#ifdef VMS
5aabfad6 982 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769 983 char pathbuf[256], eltbuf[256], *cp, *elt = s;
c623ac67 984 Stat_t sbuf;
1e422769
PP
985 int i = 0, j = 0;
986
987 do { /* DCL$PATH may be a search list */
988 while (1) { /* as may dev portion of any element */
989 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
990 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
991 cando_by_name(S_IWUSR,0,elt) ) {
992 MgTAINTEDDIR_on(mg);
993 return 0;
994 }
995 }
996 if ((cp = strchr(elt, ':')) != Nullch)
997 *cp = '\0';
998 if (my_trnlnm(elt, eltbuf, j++))
999 elt = eltbuf;
1000 else
1001 break;
1002 }
1003 j = 0;
1004 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1005 }
1006#endif /* VMS */
5aabfad6 1007 if (s && klen == 4 && strEQ(ptr,"PATH")) {
a0d0e21e 1008 char *strend = s + len;
463ee0b2
LW
1009
1010 while (s < strend) {
96827780 1011 char tmpbuf[256];
c623ac67 1012 Stat_t st;
5f74f29c 1013 I32 i;
96827780 1014 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 1015 s, strend, ':', &i);
463ee0b2 1016 s++;
96827780
MB
1017 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1018 || *tmpbuf != '/'
c6ed36e1 1019 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1020 MgTAINTEDDIR_on(mg);
1e422769
PP
1021 return 0;
1022 }
463ee0b2 1023 }
79072805
LW
1024 }
1025 }
39e571d4 1026#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1027
79072805
LW
1028 return 0;
1029}
1030
1031int
864dbfa3 1032Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1033{
2d8e6c8d 1034 STRLEN n_a;
dd374669 1035 (void)sv;
2d8e6c8d 1036 my_setenv(MgPV(mg,n_a),Nullch);
85e6fe83
LW
1037 return 0;
1038}
1039
88e89b8a 1040int
864dbfa3 1041Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1042{
27da23d5 1043#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
cea2e8a9 1044 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1045#else
3280af22 1046 if (PL_localizing) {
fb73857a 1047 HE* entry;
2d8e6c8d 1048 STRLEN n_a;
fb73857a
PP
1049 magic_clear_all_env(sv,mg);
1050 hv_iterinit((HV*)sv);
155aba94 1051 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1052 I32 keylen;
1053 my_setenv(hv_iterkey(entry, &keylen),
2d8e6c8d 1054 SvPV(hv_iterval((HV*)sv, entry), n_a));
fb73857a
PP
1055 }
1056 }
1057#endif
1058 return 0;
1059}
1060
1061int
864dbfa3 1062Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1063{
27da23d5 1064 dVAR;
2f42fcb0 1065#ifndef PERL_MICRO
27da23d5 1066#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
cea2e8a9 1067 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 1068#else
4efc5df6 1069# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
7766f137 1070 PerlEnv_clearenv();
4efc5df6
GS
1071# else
1072# ifdef USE_ENVIRON_ARRAY
1073# if defined(USE_ITHREADS)
1074 /* only the parent thread can clobber the process environment */
1075 if (PL_curinterp == aTHX)
1076# endif
1077 {
1078# ifndef PERL_USE_SAFE_PUTENV
50acdf95 1079 if (!PL_use_safe_putenv) {
66b1d557
HM
1080 I32 i;
1081
3280af22 1082 if (environ == PL_origenviron)
f2517201 1083 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM
1084 else
1085 for (i = 0; environ[i]; i++)
f2517201 1086 safesysfree(environ[i]);
50acdf95 1087 }
4efc5df6 1088# endif /* PERL_USE_SAFE_PUTENV */
f2517201 1089
66b1d557 1090 environ[0] = Nullch;
4efc5df6
GS
1091 }
1092# endif /* USE_ENVIRON_ARRAY */
052c2dc6 1093# endif /* PERL_IMPLICIT_SYS || WIN32 */
2f42fcb0
JH
1094#endif /* VMS || EPOC */
1095#endif /* !PERL_MICRO */
dd374669
AL
1096 (void)sv;
1097 (void)mg;
3e3baf6d 1098 return 0;
66b1d557
HM
1099}
1100
64ca3a65 1101#ifndef PERL_MICRO
2d4fcd5e
AJ
1102#ifdef HAS_SIGPROCMASK
1103static void
1104restore_sigmask(pTHX_ SV *save_sv)
1105{
1106 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1107 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1108}
1109#endif
66b1d557 1110int
864dbfa3 1111Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a
PP
1112{
1113 I32 i;
2d8e6c8d 1114 STRLEN n_a;
88e89b8a 1115 /* Are we fetching a signal entry? */
2d8e6c8d 1116 i = whichsig(MgPV(mg,n_a));
e02bfb16 1117 if (i > 0) {
22c35a8c
GS
1118 if(PL_psig_ptr[i])
1119 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1120 else {
85b332e2 1121 Sighandler_t sigstate;
2e34cc90 1122 sigstate = rsignal_state(i);
23ada85b 1123#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1124 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
2e34cc90
CL
1125#endif
1126#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1127 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1128#endif
88e89b8a 1129 /* cache state so we don't fetch it again */
ff68c719 1130 if(sigstate == SIG_IGN)
88e89b8a
PP
1131 sv_setpv(sv,"IGNORE");
1132 else
3280af22 1133 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1134 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
1135 SvTEMP_off(sv);
1136 }
1137 }
1138 return 0;
1139}
1140int
864dbfa3 1141Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1142{
2d4fcd5e
AJ
1143 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1144 * refactoring might be in order.
1145 */
27da23d5 1146 dVAR;
2d8e6c8d 1147 STRLEN n_a;
35a4481c 1148 register const char *s = MgPV(mg,n_a);
dd374669 1149 (void)sv;
2d4fcd5e 1150 if (*s == '_') {
27da23d5 1151 SV** svp = 0;
2d4fcd5e
AJ
1152 if (strEQ(s,"__DIE__"))
1153 svp = &PL_diehook;
1154 else if (strEQ(s,"__WARN__"))
1155 svp = &PL_warnhook;
1156 else
1157 Perl_croak(aTHX_ "No such hook: %s", s);
27da23d5 1158 if (svp && *svp) {
dd374669 1159 SV *to_dec = *svp;
2d4fcd5e
AJ
1160 *svp = 0;
1161 SvREFCNT_dec(to_dec);
1162 }
1163 }
1164 else {
1165 I32 i;
1166 /* Are we clearing a signal entry? */
1167 i = whichsig(s);
e02bfb16 1168 if (i > 0) {
2d4fcd5e
AJ
1169#ifdef HAS_SIGPROCMASK
1170 sigset_t set, save;
1171 SV* save_sv;
1172 /* Avoid having the signal arrive at a bad time, if possible. */
1173 sigemptyset(&set);
1174 sigaddset(&set,i);
1175 sigprocmask(SIG_BLOCK, &set, &save);
1176 ENTER;
1177 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1178 SAVEFREESV(save_sv);
1179 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1180#endif
1181 PERL_ASYNC_CHECK();
1182#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1183 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1184#endif
1185#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1186 PL_sig_defaulting[i] = 1;
5c1546dc 1187 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1188#else
1189 (void)rsignal(i, SIG_DFL);
1190#endif
1191 if(PL_psig_name[i]) {
1192 SvREFCNT_dec(PL_psig_name[i]);
1193 PL_psig_name[i]=0;
1194 }
1195 if(PL_psig_ptr[i]) {
dd374669 1196 SV *to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1197 PL_psig_ptr[i]=0;
1198 LEAVE;
1199 SvREFCNT_dec(to_dec);
1200 }
1201 else
1202 LEAVE;
1203 }
88e89b8a
PP
1204 }
1205 return 0;
1206}
3d37d572 1207
dd374669
AL
1208static void
1209S_raise_signal(pTHX_ int sig)
0a8e0eff
NIS
1210{
1211 /* Set a flag to say this signal is pending */
1212 PL_psig_pend[sig]++;
1213 /* And one to say _a_ signal is pending */
1214 PL_sig_pending = 1;
1215}
1216
1217Signal_t
1218Perl_csighandler(int sig)
1219{
1018e26f
NIS
1220#ifdef PERL_GET_SIG_CONTEXT
1221 dTHXa(PERL_GET_SIG_CONTEXT);
1222#else
85b332e2
CL
1223 dTHX;
1224#endif
23ada85b 1225#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1226 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1227 if (PL_sig_ignoring[sig]) return;
85b332e2 1228#endif
2e34cc90 1229#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1230 if (PL_sig_defaulting[sig])
2e34cc90
CL
1231#ifdef KILL_BY_SIGPRC
1232 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1233#else
1234 exit(1);
1235#endif
1236#endif
4ffa73a3
JH
1237 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1238 /* Call the perl level handler now--
1239 * with risk we may be in malloc() etc. */
1240 (*PL_sighandlerp)(sig);
1241 else
dd374669 1242 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1243}
1244
2e34cc90
CL
1245#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1246void
1247Perl_csighandler_init(void)
1248{
1249 int sig;
27da23d5 1250 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1251
1252 for (sig = 1; sig < SIG_SIZE; sig++) {
1253#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1254 dTHX;
27da23d5 1255 PL_sig_defaulting[sig] = 1;
5c1546dc 1256 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1257#endif
1258#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1259 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1260#endif
1261 }
27da23d5 1262 PL_sig_handlers_initted = 1;
2e34cc90
CL
1263}
1264#endif
1265
0a8e0eff
NIS
1266void
1267Perl_despatch_signals(pTHX)
1268{
1269 int sig;
1270 PL_sig_pending = 0;
1271 for (sig = 1; sig < SIG_SIZE; sig++) {
1272 if (PL_psig_pend[sig]) {
25da4428
JH
1273 PERL_BLOCKSIG_ADD(set, sig);
1274 PL_psig_pend[sig] = 0;
1275 PERL_BLOCKSIG_BLOCK(set);
f5203343 1276 (*PL_sighandlerp)(sig);
25da4428 1277 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1278 }
1279 }
1280}
1281
85e6fe83 1282int
864dbfa3 1283Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1284{
27da23d5 1285 dVAR;
79072805 1286 I32 i;
b7953727 1287 SV** svp = 0;
2d4fcd5e
AJ
1288 /* Need to be careful with SvREFCNT_dec(), because that can have side
1289 * effects (due to closures). We must make sure that the new disposition
1290 * is in place before it is called.
1291 */
1292 SV* to_dec = 0;
e72dc28c 1293 STRLEN len;
2d4fcd5e
AJ
1294#ifdef HAS_SIGPROCMASK
1295 sigset_t set, save;
1296 SV* save_sv;
1297#endif
a0d0e21e 1298
35a4481c 1299 register const char *s = MgPV(mg,len);
748a9306
LW
1300 if (*s == '_') {
1301 if (strEQ(s,"__DIE__"))
3280af22 1302 svp = &PL_diehook;
748a9306 1303 else if (strEQ(s,"__WARN__"))
3280af22 1304 svp = &PL_warnhook;
748a9306 1305 else
cea2e8a9 1306 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1307 i = 0;
4633a7c4 1308 if (*svp) {
2d4fcd5e 1309 to_dec = *svp;
4633a7c4
LW
1310 *svp = 0;
1311 }
748a9306
LW
1312 }
1313 else {
1314 i = whichsig(s); /* ...no, a brick */
e02bfb16 1315 if (i < 0) {
e476b1b5 1316 if (ckWARN(WARN_SIGNAL))
9014280d 1317 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1318 return 0;
1319 }
2d4fcd5e
AJ
1320#ifdef HAS_SIGPROCMASK
1321 /* Avoid having the signal arrive at a bad time, if possible. */
1322 sigemptyset(&set);
1323 sigaddset(&set,i);
1324 sigprocmask(SIG_BLOCK, &set, &save);
1325 ENTER;
1326 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1327 SAVEFREESV(save_sv);
1328 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1329#endif
1330 PERL_ASYNC_CHECK();
2e34cc90 1331#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1332 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1333#endif
23ada85b 1334#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1335 PL_sig_ignoring[i] = 0;
85b332e2 1336#endif
2e34cc90 1337#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1338 PL_sig_defaulting[i] = 0;
2e34cc90 1339#endif
22c35a8c 1340 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1341 to_dec = PL_psig_ptr[i];
22c35a8c 1342 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1343 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1344 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1345 SvREADONLY_on(PL_psig_name[i]);
748a9306 1346 }
a0d0e21e 1347 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1348 if (i) {
5c1546dc 1349 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1350#ifdef HAS_SIGPROCMASK
1351 LEAVE;
1352#endif
1353 }
748a9306
LW
1354 else
1355 *svp = SvREFCNT_inc(sv);
2d4fcd5e
AJ
1356 if(to_dec)
1357 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1358 return 0;
1359 }
e72dc28c 1360 s = SvPV_force(sv,len);
748a9306 1361 if (strEQ(s,"IGNORE")) {
85b332e2 1362 if (i) {
23ada85b 1363#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1364 PL_sig_ignoring[i] = 1;
5c1546dc 1365 (void)rsignal(i, PL_csighandlerp);
85b332e2 1366#else
ff68c719 1367 (void)rsignal(i, SIG_IGN);
85b332e2 1368#endif
2d4fcd5e 1369 }
748a9306
LW
1370 }
1371 else if (strEQ(s,"DEFAULT") || !*s) {
1372 if (i)
2e34cc90
CL
1373#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1374 {
27da23d5 1375 PL_sig_defaulting[i] = 1;
5c1546dc 1376 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1377 }
1378#else
ff68c719 1379 (void)rsignal(i, SIG_DFL);
2e34cc90 1380#endif
748a9306 1381 }
79072805 1382 else {
5aabfad6
PP
1383 /*
1384 * We should warn if HINT_STRICT_REFS, but without
1385 * access to a known hint bit in a known OP, we can't
1386 * tell whether HINT_STRICT_REFS is in force or not.
1387 */
46fc3d4c 1388 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1389 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1390 if (i)
5c1546dc 1391 (void)rsignal(i, PL_csighandlerp);
748a9306
LW
1392 else
1393 *svp = SvREFCNT_inc(sv);
79072805 1394 }
2d4fcd5e
AJ
1395#ifdef HAS_SIGPROCMASK
1396 if(i)
1397 LEAVE;
1398#endif
1399 if(to_dec)
1400 SvREFCNT_dec(to_dec);
79072805
LW
1401 return 0;
1402}
64ca3a65 1403#endif /* !PERL_MICRO */
79072805
LW
1404
1405int
864dbfa3 1406Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1407{
dd374669
AL
1408 (void)sv;
1409 (void)mg;
3280af22 1410 PL_sub_generation++;
463ee0b2
LW
1411 return 0;
1412}
1413
1414int
864dbfa3 1415Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1416{
dd374669
AL
1417 (void)sv;
1418 (void)mg;
a0d0e21e 1419 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1420 PL_amagic_generation++;
463ee0b2 1421
a0d0e21e
LW
1422 return 0;
1423}
463ee0b2 1424
946ec16e 1425int
864dbfa3 1426Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1427{
dd374669 1428 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1429 I32 i = 0;
dd374669 1430 (void)mg;
7719e241 1431
6ff81951 1432 if (hv) {
497b47a8
JH
1433 (void) hv_iterinit(hv);
1434 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1435 i = HvKEYS(hv);
1436 else {
1437 while (hv_iternext(hv))
1438 i++;
1439 }
6ff81951
GS
1440 }
1441
1442 sv_setiv(sv, (IV)i);
1443 return 0;
1444}
1445
1446int
864dbfa3 1447Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1448{
dd374669 1449 (void)mg;
946ec16e
PP
1450 if (LvTARG(sv)) {
1451 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1452 }
1453 return 0;
ac27b0f5 1454}
946ec16e 1455
e336de0d 1456/* caller is responsible for stack switching/cleanup */
565764a8 1457STATIC int
e1ec3a88 1458S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1459{
1460 dSP;
463ee0b2 1461
924508f0
GS
1462 PUSHMARK(SP);
1463 EXTEND(SP, n);
33c27489 1464 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1465 if (n > 1) {
93965878 1466 if (mg->mg_ptr) {
565764a8 1467 if (mg->mg_len >= 0)
79cb57f6 1468 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1469 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1470 PUSHs((SV*)mg->mg_ptr);
1471 }
14befaf4 1472 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1473 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1474 }
1475 }
1476 if (n > 2) {
1477 PUSHs(val);
88e89b8a 1478 }
463ee0b2
LW
1479 PUTBACK;
1480
864dbfa3 1481 return call_method(meth, flags);
946ec16e
PP
1482}
1483
76e3520e 1484STATIC int
e1ec3a88 1485S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1486{
27da23d5 1487 dVAR; dSP;
463ee0b2 1488
a0d0e21e
LW
1489 ENTER;
1490 SAVETMPS;
e788e7d3 1491 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1492
33c27489 1493 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1494 sv_setsv(sv, *PL_stack_sp--);
93965878 1495 }
463ee0b2 1496
d3acc0f7 1497 POPSTACK;
a0d0e21e
LW
1498 FREETMPS;
1499 LEAVE;
1500 return 0;
1501}
463ee0b2 1502
a0d0e21e 1503int
864dbfa3 1504Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1505{
a0d0e21e
LW
1506 if (mg->mg_ptr)
1507 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1508 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1509 return 0;
1510}
1511
1512int
864dbfa3 1513Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1514{
27da23d5 1515 dVAR; dSP;
a60c0954 1516 ENTER;
e788e7d3 1517 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1518 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1519 POPSTACK;
a60c0954 1520 LEAVE;
463ee0b2
LW
1521 return 0;
1522}
1523
1524int
864dbfa3 1525Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1526{
a0d0e21e
LW
1527 return magic_methpack(sv,mg,"DELETE");
1528}
463ee0b2 1529
93965878
NIS
1530
1531U32
864dbfa3 1532Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1533{
27da23d5 1534 dVAR; dSP;
93965878
NIS
1535 U32 retval = 0;
1536
1537 ENTER;
1538 SAVETMPS;
e788e7d3 1539 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1540 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1541 sv = *PL_stack_sp--;
a60c0954 1542 retval = (U32) SvIV(sv)-1;
93965878 1543 }
d3acc0f7 1544 POPSTACK;
93965878
NIS
1545 FREETMPS;
1546 LEAVE;
1547 return retval;
1548}
1549
cea2e8a9
GS
1550int
1551Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1552{
27da23d5 1553 dVAR; dSP;
463ee0b2 1554
e336de0d 1555 ENTER;
e788e7d3 1556 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1557 PUSHMARK(SP);
33c27489 1558 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1559 PUTBACK;
864dbfa3 1560 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1561 POPSTACK;
a60c0954 1562 LEAVE;
a3bcc51e 1563
463ee0b2
LW
1564 return 0;
1565}
1566
1567int
864dbfa3 1568Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1569{
27da23d5 1570 dVAR; dSP;
35a4481c 1571 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1572
1573 ENTER;
a0d0e21e 1574 SAVETMPS;
e788e7d3 1575 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1576 PUSHMARK(SP);
1577 EXTEND(SP, 2);
33c27489 1578 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1579 if (SvOK(key))
1580 PUSHs(key);
1581 PUTBACK;
1582
864dbfa3 1583 if (call_method(meth, G_SCALAR))
3280af22 1584 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1585
d3acc0f7 1586 POPSTACK;
a0d0e21e
LW
1587 FREETMPS;
1588 LEAVE;
79072805
LW
1589 return 0;
1590}
1591
1592int
864dbfa3 1593Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1594{
1595 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1596}
a0d0e21e 1597
a3bcc51e
TP
1598SV *
1599Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1600{
27da23d5 1601 dVAR; dSP;
a3bcc51e
TP
1602 SV *retval = &PL_sv_undef;
1603 SV *tied = SvTIED_obj((SV*)hv, mg);
1604 HV *pkg = SvSTASH((SV*)SvRV(tied));
1605
1606 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1607 SV *key;
1608 if (HvEITER(hv))
1609 /* we are in an iteration so the hash cannot be empty */
1610 return &PL_sv_yes;
1611 /* no xhv_eiter so now use FIRSTKEY */
1612 key = sv_newmortal();
1613 magic_nextpack((SV*)hv, mg, key);
1614 HvEITER(hv) = NULL; /* need to reset iterator */
1615 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1616 }
1617
1618 /* there is a SCALAR method that we can call */
1619 ENTER;
1620 PUSHSTACKi(PERLSI_MAGIC);
1621 PUSHMARK(SP);
1622 EXTEND(SP, 1);
1623 PUSHs(tied);
1624 PUTBACK;
1625
1626 if (call_method("SCALAR", G_SCALAR))
1627 retval = *PL_stack_sp--;
1628 POPSTACK;
1629 LEAVE;
1630 return retval;
1631}
1632
a0d0e21e 1633int
864dbfa3 1634Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1635{
1636 OP *o;
1637 I32 i;
1638 GV* gv;
1639 SV** svp;
2d8e6c8d 1640 STRLEN n_a;
79072805 1641
3280af22 1642 gv = PL_DBline;
79072805 1643 i = SvTRUE(sv);
188ea221 1644 svp = av_fetch(GvAV(gv),
2d8e6c8d 1645 atoi(MgPV(mg,n_a)), FALSE);
5df8de69
DM
1646 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1647 /* set or clear breakpoint in the relevant control op */
1648 if (i)
1649 o->op_flags |= OPf_SPECIAL;
1650 else
1651 o->op_flags &= ~OPf_SPECIAL;
1652 }
79072805
LW
1653 return 0;
1654}
1655
1656int
864dbfa3 1657Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1658{
3280af22 1659 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
79072805
LW
1660 return 0;
1661}
1662
1663int
864dbfa3 1664Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1665{
3280af22 1666 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
a0d0e21e
LW
1667 return 0;
1668}
1669
1670int
864dbfa3 1671Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1672{
1673 SV* lsv = LvTARG(sv);
ac27b0f5 1674
a0d0e21e 1675 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1676 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1677 if (mg && mg->mg_len >= 0) {
a0ed51b3 1678 I32 i = mg->mg_len;
7e2040f0 1679 if (DO_UTF8(lsv))
a0ed51b3
LW
1680 sv_pos_b2u(lsv, &i);
1681 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1682 return 0;
1683 }
1684 }
0c34ef67 1685 SvOK_off(sv);
a0d0e21e
LW
1686 return 0;
1687}
1688
1689int
864dbfa3 1690Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1691{
1692 SV* lsv = LvTARG(sv);
1693 SSize_t pos;
1694 STRLEN len;
c00206c8 1695 STRLEN ulen = 0;
a0d0e21e
LW
1696
1697 mg = 0;
ac27b0f5 1698
a0d0e21e 1699 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1700 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1701 if (!mg) {
1702 if (!SvOK(sv))
1703 return 0;
14befaf4
DM
1704 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1705 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1706 }
1707 else if (!SvOK(sv)) {
565764a8 1708 mg->mg_len = -1;
a0d0e21e
LW
1709 return 0;
1710 }
1711 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1712
c485e607 1713 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1714
7e2040f0 1715 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1716 ulen = sv_len_utf8(lsv);
1717 if (ulen)
1718 len = ulen;
a0ed51b3
LW
1719 }
1720
a0d0e21e
LW
1721 if (pos < 0) {
1722 pos += len;
1723 if (pos < 0)
1724 pos = 0;
1725 }
eb160463 1726 else if (pos > (SSize_t)len)
a0d0e21e 1727 pos = len;
a0ed51b3
LW
1728
1729 if (ulen) {
1730 I32 p = pos;
1731 sv_pos_u2b(lsv, &p, 0);
1732 pos = p;
1733 }
727405f8 1734
565764a8 1735 mg->mg_len = pos;
71be2cbc 1736 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1737
79072805
LW
1738 return 0;
1739}
1740
1741int
864dbfa3 1742Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1743{
dd374669 1744 (void)mg;
8646b087
PP
1745 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1746 SvFAKE_off(sv);
946ec16e 1747 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1748 SvFAKE_on(sv);
1749 }
1750 else
946ec16e 1751 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1752 return 0;
1753}
1754
1755int
864dbfa3 1756Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1757{
79072805 1758 GV* gv;
dd374669 1759 (void)mg;
7a5fd60d 1760
79072805
LW
1761 if (!SvOK(sv))
1762 return 0;
7a5fd60d 1763 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
79072805
LW
1764 if (sv == (SV*)gv)
1765 return 0;
1766 if (GvGP(sv))
88e89b8a 1767 gp_free((GV*)sv);
79072805 1768 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1769 return 0;
1770}
1771
1772int
864dbfa3 1773Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1774{
1775 STRLEN len;
35a4481c
AL
1776 SV * const lsv = LvTARG(sv);
1777 const char * const tmps = SvPV(lsv,len);
6ff81951
GS
1778 I32 offs = LvTARGOFF(sv);
1779 I32 rem = LvTARGLEN(sv);
dd374669 1780 (void)mg;
6ff81951 1781
9aa983d2
JH
1782 if (SvUTF8(lsv))
1783 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1784 if (offs > (I32)len)
6ff81951 1785 offs = len;
eb160463 1786 if (rem + offs > (I32)len)
6ff81951
GS
1787 rem = len - offs;
1788 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1789 if (SvUTF8(lsv))
2ef4b674 1790 SvUTF8_on(sv);
6ff81951
GS
1791 return 0;
1792}
1793
1794int
864dbfa3 1795Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1796{
9aa983d2
JH
1797 STRLEN len;
1798 char *tmps = SvPV(sv, len);
dd374669 1799 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1800 I32 lvoff = LvTARGOFF(sv);
1801 I32 lvlen = LvTARGLEN(sv);
dd374669 1802 (void)mg;
075a4a2b 1803
1aa99e6b 1804 if (DO_UTF8(sv)) {
9aa983d2
JH
1805 sv_utf8_upgrade(lsv);
1806 sv_pos_u2b(lsv, &lvoff, &lvlen);
1807 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1808 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1809 SvUTF8_on(lsv);
1810 }
9bf12eaf 1811 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1812 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1813 LvTARGLEN(sv) = len;
e95af362 1814 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1815 sv_insert(lsv, lvoff, lvlen, tmps, len);
1816 Safefree(tmps);
1aa99e6b 1817 }
b76f3ce2
GB
1818 else {
1819 sv_insert(lsv, lvoff, lvlen, tmps, len);
1820 LvTARGLEN(sv) = len;
1821 }
1822
1aa99e6b 1823
79072805
LW
1824 return 0;
1825}
1826
1827int
864dbfa3 1828Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1829{
565764a8 1830 TAINT_IF((mg->mg_len & 1) ||
155aba94 1831 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
463ee0b2
LW
1832 return 0;
1833}
1834
1835int
864dbfa3 1836Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1837{
dd374669 1838 (void)sv;
3280af22
NIS
1839 if (PL_localizing) {
1840 if (PL_localizing == 1)
565764a8 1841 mg->mg_len <<= 1;
748a9306 1842 else
565764a8 1843 mg->mg_len >>= 1;
a0d0e21e 1844 }
3280af22 1845 else if (PL_tainted)
565764a8 1846 mg->mg_len |= 1;
748a9306 1847 else
565764a8 1848 mg->mg_len &= ~1;
463ee0b2
LW
1849 return 0;
1850}
1851
1852int
864dbfa3 1853Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1854{
35a4481c 1855 SV * const lsv = LvTARG(sv);
dd374669 1856 (void)mg;
6ff81951
GS
1857
1858 if (!lsv) {
0c34ef67 1859 SvOK_off(sv);
6ff81951
GS
1860 return 0;
1861 }
6ff81951 1862
81e118e0 1863 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1864 return 0;
1865}
1866
1867int
864dbfa3 1868Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1869{
dd374669 1870 (void)mg;
79072805
LW
1871 do_vecset(sv); /* XXX slurp this routine */
1872 return 0;
1873}
1874
1875int
864dbfa3 1876Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1877{
71be2cbc 1878 SV *targ = Nullsv;
5f05dabc 1879 if (LvTARGLEN(sv)) {
68dc0745 1880 if (mg->mg_obj) {
74e13ce4 1881 SV *ahv = LvTARG(sv);
6d822dc4
MS
1882 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1883 if (he)
1884 targ = HeVAL(he);
68dc0745
PP
1885 }
1886 else {
3c78fafa 1887 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1888 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1889 targ = AvARRAY(av)[LvTARGOFF(sv)];
1890 }
3280af22 1891 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1892 /* somebody else defined it for us */
1893 SvREFCNT_dec(LvTARG(sv));
1894 LvTARG(sv) = SvREFCNT_inc(targ);
1895 LvTARGLEN(sv) = 0;
1896 SvREFCNT_dec(mg->mg_obj);
1897 mg->mg_obj = Nullsv;
1898 mg->mg_flags &= ~MGf_REFCOUNTED;
1899 }
5f05dabc 1900 }
71be2cbc
PP
1901 else
1902 targ = LvTARG(sv);
3280af22 1903 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1904 return 0;
1905}
1906
1907int
864dbfa3 1908Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 1909{
dd374669 1910 (void)mg;
71be2cbc 1911 if (LvTARGLEN(sv))
68dc0745
PP
1912 vivify_defelem(sv);
1913 if (LvTARG(sv)) {
5f05dabc 1914 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1915 SvSETMAGIC(LvTARG(sv));
1916 }
5f05dabc
PP
1917 return 0;
1918}
1919
71be2cbc 1920void
864dbfa3 1921Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1922{
74e13ce4
GS
1923 MAGIC *mg;
1924 SV *value = Nullsv;
71be2cbc 1925
14befaf4 1926 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 1927 return;
68dc0745 1928 if (mg->mg_obj) {
74e13ce4 1929 SV *ahv = LvTARG(sv);
2d8e6c8d 1930 STRLEN n_a;
6d822dc4
MS
1931 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1932 if (he)
1933 value = HeVAL(he);
3280af22 1934 if (!value || value == &PL_sv_undef)
cea2e8a9 1935 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
71be2cbc 1936 }
68dc0745
PP
1937 else {
1938 AV* av = (AV*)LvTARG(sv);
5aabfad6 1939 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1940 LvTARG(sv) = Nullsv; /* array can't be extended */
1941 else {
1942 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1943 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1944 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1945 }
1946 }
3e3baf6d 1947 (void)SvREFCNT_inc(value);
68dc0745
PP
1948 SvREFCNT_dec(LvTARG(sv));
1949 LvTARG(sv) = value;
71be2cbc 1950 LvTARGLEN(sv) = 0;
68dc0745
PP
1951 SvREFCNT_dec(mg->mg_obj);
1952 mg->mg_obj = Nullsv;
1953 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1954}
1955
1956int
864dbfa3 1957Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS
1958{
1959 AV *av = (AV*)mg->mg_obj;
1960 SV **svp = AvARRAY(av);
1961 I32 i = AvFILLp(av);
dd374669
AL
1962 (void)sv;
1963
810b8aa5 1964 while (i >= 0) {
fdc9a813 1965 if (svp[i]) {
810b8aa5 1966 if (!SvWEAKREF(svp[i]))
cea2e8a9 1967 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5 1968 /* XXX Should we check that it hasn't changed? */
b162af07 1969 SvRV_set(svp[i], 0);
0c34ef67 1970 SvOK_off(svp[i]);
810b8aa5 1971 SvWEAKREF_off(svp[i]);
fdc9a813 1972 svp[i] = Nullsv;
810b8aa5
GS
1973 }
1974 i--;
1975 }
d99b02a1 1976 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
810b8aa5
GS
1977 return 0;
1978}
1979
1980int
864dbfa3 1981Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 1982{
565764a8 1983 mg->mg_len = -1;
c6496cc7 1984 SvSCREAM_off(sv);
93a17b20
LW
1985 return 0;
1986}
1987
1988int
864dbfa3 1989Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 1990{
dd374669 1991 (void)mg;
14befaf4 1992 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
1993 SvVALID_off(sv);
1994 return 0;
1995}
1996
1997int
864dbfa3 1998Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 1999{
dd374669 2000 (void)mg;
14befaf4 2001 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2002 SvCOMPILED_off(sv);
2003 return 0;
2004}
2005
2006int
864dbfa3 2007Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2008{
35a4481c 2009 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2010
2011 if (uf && uf->uf_set)
24f81a43 2012 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2013 return 0;
2014}
2015
c277df42 2016int
faf82a0b
AE
2017Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2018{
dd374669 2019 (void)mg;
faf82a0b
AE
2020 sv_unmagic(sv, PERL_MAGIC_qr);
2021 return 0;
2022}
2023
2024int
864dbfa3 2025Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ
2026{
2027 regexp *re = (regexp *)mg->mg_obj;
2028 ReREFCNT_dec(re);
dd374669 2029 (void)sv;
c277df42
IZ
2030 return 0;
2031}
2032
7a4c00b4 2033#ifdef USE_LOCALE_COLLATE
79072805 2034int
864dbfa3 2035Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2036{
2037 /*
838b5b74 2038 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2039 * and vanished with a faint plop.
2040 */
dd374669 2041 (void)sv;
7a4c00b4
PP
2042 if (mg->mg_ptr) {
2043 Safefree(mg->mg_ptr);
2044 mg->mg_ptr = NULL;
565764a8 2045 mg->mg_len = -1;
7a4c00b4 2046 }
bbce6d69
PP
2047 return 0;
2048}
7a4c00b4 2049#endif /* USE_LOCALE_COLLATE */
bbce6d69 2050
7e8c5dac
HS
2051/* Just clear the UTF-8 cache data. */
2052int
2053Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2054{
dd374669 2055 (void)sv;
7e8c5dac
HS
2056 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2057 mg->mg_ptr = 0;
2058 mg->mg_len = -1; /* The mg_len holds the len cache. */
2059 return 0;
2060}
2061
bbce6d69 2062int
864dbfa3 2063Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2064{
e1ec3a88 2065 register const char *s;
79072805 2066 I32 i;
8990e307 2067 STRLEN len;
79072805 2068 switch (*mg->mg_ptr) {
748a9306 2069 case '\001': /* ^A */
3280af22 2070 sv_setsv(PL_bodytarget, sv);
748a9306 2071 break;
49460fe6 2072 case '\003': /* ^C */
eb160463 2073 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
2074 break;
2075
79072805 2076 case '\004': /* ^D */
b4ab917c
DM
2077#ifdef DEBUGGING
2078 s = SvPV_nolen(sv);
ddcf8bc1 2079 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2080 DEBUG_x(dump_all());
b4ab917c
DM
2081#else
2082 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2083#endif
79072805 2084 break;
28f23441 2085 case '\005': /* ^E */
d0063567 2086 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2087#ifdef MACOS_TRADITIONAL
d0063567 2088 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 2089#else
cd39f2b6 2090# ifdef VMS
d0063567 2091 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2092# else
cd39f2b6 2093# ifdef WIN32
d0063567 2094 SetLastError( SvIV(sv) );
cd39f2b6 2095# else
9fed8b87 2096# ifdef OS2
d0063567 2097 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2098# else
d0063567
DK
2099 /* will anyone ever use this? */
2100 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2101# endif
048c1ddf
IZ
2102# endif
2103# endif
22fae026 2104#endif
d0063567
DK
2105 }
2106 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2107 if (PL_encoding)
2108 SvREFCNT_dec(PL_encoding);
2109 if (SvOK(sv) || SvGMAGICAL(sv)) {
2110 PL_encoding = newSVsv(sv);
2111 }
2112 else {
2113 PL_encoding = Nullsv;
2114 }
2115 }
2116 break;
79072805 2117 case '\006': /* ^F */
3280af22 2118 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2119 break;
a0d0e21e 2120 case '\010': /* ^H */
3280af22 2121 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2122 break;
9d116dd7 2123 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
2124 if (PL_inplace)
2125 Safefree(PL_inplace);
79072805 2126 if (SvOK(sv))
2e0de35c 2127 PL_inplace = savesvpv(sv);
79072805 2128 else
3280af22 2129 PL_inplace = Nullch;
79072805 2130 break;
28f23441 2131 case '\017': /* ^O */
ac27b0f5 2132 if (*(mg->mg_ptr+1) == '\0') {
1bf29663 2133 if (PL_osname) {
ac27b0f5 2134 Safefree(PL_osname);
1bf29663
DM
2135 PL_osname = Nullch;
2136 }
3511154c
DM
2137 if (SvOK(sv)) {
2138 TAINT_PROPER("assigning to $^O");
2e0de35c 2139 PL_osname = savesvpv(sv);
3511154c 2140 }
ac27b0f5
NIS
2141 }
2142 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2143 if (!PL_compiling.cop_io)
2144 PL_compiling.cop_io = newSVsv(sv);
2145 else
2146 sv_setsv(PL_compiling.cop_io,sv);
2147 }
28f23441 2148 break;
79072805 2149 case '\020': /* ^P */
3280af22 2150 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
f2a7f298 2151 if (PL_perldb && !PL_DBsingle)
1ee4443e 2152 init_debugger();
79072805
LW
2153 break;
2154 case '\024': /* ^T */
88e89b8a 2155#ifdef BIG_TIME
6b88bc9c 2156 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2157#else
3280af22 2158 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2159#endif
79072805 2160 break;
fde18df1 2161 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2162 if (*(mg->mg_ptr+1) == '\0') {
2163 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2164 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2165 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2166 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2167 }
599cee73 2168 }
0a378802 2169 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2170 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2171 if (!SvPOK(sv) && PL_localizing) {
2172 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2173 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2174 break;
2175 }
f4fc7782 2176 {
b5477537 2177 STRLEN len, i;
d3a7d8c7 2178 int accumulate = 0 ;
f4fc7782 2179 int any_fatals = 0 ;
35a4481c 2180 const char * const ptr = (char*)SvPV(sv, len) ;
f4fc7782
JH
2181 for (i = 0 ; i < len ; ++i) {
2182 accumulate |= ptr[i] ;
2183 any_fatals |= (ptr[i] & 0xAA) ;
2184 }
d3a7d8c7
GS
2185 if (!accumulate)
2186 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
2187 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2188 PL_compiling.cop_warnings = pWARN_ALL;
2189 PL_dowarn |= G_WARN_ONCE ;
727405f8 2190 }
d3a7d8c7
GS
2191 else {
2192 if (specialWARN(PL_compiling.cop_warnings))
2193 PL_compiling.cop_warnings = newSVsv(sv) ;
2194 else
2195 sv_setsv(PL_compiling.cop_warnings, sv);
2196 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2197 PL_dowarn |= G_WARN_ONCE ;
2198 }
f4fc7782 2199
d3a7d8c7 2200 }
4438c4b7 2201 }
971a9dd3 2202 }
79072805
LW
2203 break;
2204 case '.':
3280af22
NIS
2205 if (PL_localizing) {
2206 if (PL_localizing == 1)
7766f137 2207 SAVESPTR(PL_last_in_gv);
748a9306 2208 }
3280af22 2209 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2210 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2211 break;
2212 case '^':
3280af22 2213 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2214 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2215 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2216 break;
2217 case '~':
3280af22 2218 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2219 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2220 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2221 break;
2222 case '=':
632db599 2223 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2224 break;
2225 case '-':
632db599 2226 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2227 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2228 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2229 break;
2230 case '%':
632db599 2231 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2232 break;
2233 case '|':
4b65379b 2234 {
3280af22 2235 IO *io = GvIOp(PL_defoutgv);
720f287d
AB
2236 if(!io)
2237 break;
4b65379b
CS
2238 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2239 IoFLAGS(io) &= ~IOf_FLUSH;
2240 else {
2241 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2242 PerlIO *ofp = IoOFP(io);
2243 if (ofp)
2244 (void)PerlIO_flush(ofp);
2245 IoFLAGS(io) |= IOf_FLUSH;
2246 }
2247 }
79072805
LW
2248 }
2249 break;
79072805 2250 case '/':
3280af22 2251 SvREFCNT_dec(PL_rs);
8bfdd7d9 2252 PL_rs = newSVsv(sv);
79072805
LW
2253 break;
2254 case '\\':
7889fe52
NIS
2255 if (PL_ors_sv)
2256 SvREFCNT_dec(PL_ors_sv);
009c130f 2257 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2258 PL_ors_sv = newSVsv(sv);
009c130f 2259 }
e3c19b7b 2260 else {
7889fe52 2261 PL_ors_sv = Nullsv;
e3c19b7b 2262 }
79072805
LW
2263 break;
2264 case ',':
7889fe52
NIS
2265 if (PL_ofs_sv)
2266 SvREFCNT_dec(PL_ofs_sv);
2267 if (SvOK(sv) || SvGMAGICAL(sv)) {
2268 PL_ofs_sv = newSVsv(sv);
2269 }
2270 else {
2271 PL_ofs_sv = Nullsv;
2272 }
79072805
LW
2273 break;
2274 case '#':
3280af22
NIS
2275 if (PL_ofmt)
2276 Safefree(PL_ofmt);
2e0de35c 2277 PL_ofmt = savesvpv(sv);
79072805
LW
2278 break;
2279 case '[':
3280af22 2280 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2281 break;
2282 case '?':
ff0cee69 2283#ifdef COMPLEX_STATUS
6b88bc9c
GS
2284 if (PL_localizing == 2) {
2285 PL_statusvalue = LvTARGOFF(sv);
2286 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2287 }
2288 else
2289#endif
2290#ifdef VMSISH_STATUS
2291 if (VMSISH_STATUS)
2292 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2293 else
2294#endif
2295 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2296 break;
2297 case '!':
93189314
JH
2298 {
2299#ifdef VMS
2300# define PERL_VMS_BANG vaxc$errno
2301#else
2302# define PERL_VMS_BANG 0
2303#endif
91487cfc 2304 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2305 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2306 }
79072805
LW
2307 break;
2308 case '<':
3280af22
NIS
2309 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2310 if (PL_delaymagic) {
2311 PL_delaymagic |= DM_RUID;
79072805
LW
2312 break; /* don't do magic till later */
2313 }
2314#ifdef HAS_SETRUID
b28d0864 2315 (void)setruid((Uid_t)PL_uid);
79072805
LW
2316#else
2317#ifdef HAS_SETREUID
3280af22 2318 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2319#else
85e6fe83 2320#ifdef HAS_SETRESUID
b28d0864 2321 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2322#else
75870ed3 2323 if (PL_uid == PL_euid) { /* special case $< = $> */
2324#ifdef PERL_DARWIN
2325 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2326 if (PL_uid != 0 && PerlProc_getuid() == 0)
2327 (void)PerlProc_setuid(0);
2328#endif
b28d0864 2329 (void)PerlProc_setuid(PL_uid);
75870ed3 2330 } else {
d8eceb89 2331 PL_uid = PerlProc_getuid();
cea2e8a9 2332 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2333 }
79072805
LW
2334#endif
2335#endif
85e6fe83 2336#endif
d8eceb89 2337 PL_uid = PerlProc_getuid();
3280af22 2338 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2339 break;
2340 case '>':
3280af22
NIS
2341 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2342 if (PL_delaymagic) {
2343 PL_delaymagic |= DM_EUID;
79072805
LW
2344 break; /* don't do magic till later */
2345 }
2346#ifdef HAS_SETEUID
3280af22 2347 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2348#else
2349#ifdef HAS_SETREUID
b28d0864 2350 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2351#else
2352#ifdef HAS_SETRESUID
6b88bc9c 2353 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2354#else
b28d0864
NIS
2355 if (PL_euid == PL_uid) /* special case $> = $< */
2356 PerlProc_setuid(PL_euid);
a0d0e21e 2357 else {
e8ee3774 2358 PL_euid = PerlProc_geteuid();
cea2e8a9 2359 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2360 }
79072805
LW
2361#endif
2362#endif
85e6fe83 2363#endif
d8eceb89 2364 PL_euid = PerlProc_geteuid();
3280af22 2365 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2366 break;
2367 case '(':
3280af22
NIS
2368 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2369 if (PL_delaymagic) {
2370 PL_delaymagic |= DM_RGID;
79072805
LW
2371 break; /* don't do magic till later */
2372 }
2373#ifdef HAS_SETRGID
b28d0864 2374 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2375#else
2376#ifdef HAS_SETREGID
3280af22 2377 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2378#else
2379#ifdef HAS_SETRESGID
b28d0864 2380 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2381#else
b28d0864
NIS
2382 if (PL_gid == PL_egid) /* special case $( = $) */
2383 (void)PerlProc_setgid(PL_gid);
748a9306 2384 else {
d8eceb89 2385 PL_gid = PerlProc_getgid();
cea2e8a9 2386 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2387 }
79072805
LW
2388#endif
2389#endif
85e6fe83 2390#endif
d8eceb89 2391 PL_gid = PerlProc_getgid();
3280af22 2392 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2393 break;
2394 case ')':
5cd24f17
PP
2395#ifdef HAS_SETGROUPS
2396 {
35a4481c 2397 const char *p = SvPV(sv, len);
5cd24f17
PP
2398 Groups_t gary[NGROUPS];
2399
5cd24f17
PP
2400 while (isSPACE(*p))
2401 ++p;
2d4389e4 2402 PL_egid = Atol(p);
5cd24f17
PP
2403 for (i = 0; i < NGROUPS; ++i) {
2404 while (*p && !isSPACE(*p))
2405 ++p;
2406 while (isSPACE(*p))
2407 ++p;
2408 if (!*p)
2409 break;
2d4389e4 2410 gary[i] = Atol(p);
5cd24f17 2411 }
8cc95fdb
PP
2412 if (i)
2413 (void)setgroups(i, gary);
5cd24f17
PP
2414 }
2415#else /* HAS_SETGROUPS */
b28d0864 2416 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2417#endif /* HAS_SETGROUPS */
3280af22
NIS
2418 if (PL_delaymagic) {
2419 PL_delaymagic |= DM_EGID;
79072805
LW
2420 break; /* don't do magic till later */
2421 }
2422#ifdef HAS_SETEGID
3280af22 2423 (void)setegid((Gid_t)PL_egid);
79072805
LW
2424#else
2425#ifdef HAS_SETREGID
b28d0864 2426 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2427#else
2428#ifdef HAS_SETRESGID
b28d0864 2429 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2430#else
b28d0864
NIS
2431 if (PL_egid == PL_gid) /* special case $) = $( */
2432 (void)PerlProc_setgid(PL_egid);
748a9306 2433 else {
d8eceb89 2434 PL_egid = PerlProc_getegid();
cea2e8a9 2435 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2436 }
79072805
LW
2437#endif
2438#endif
85e6fe83 2439#endif
d8eceb89 2440 PL_egid = PerlProc_getegid();
3280af22 2441 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2442 break;
2443 case ':':
2d8e6c8d 2444 PL_chopset = SvPV_force(sv,len);
79072805 2445 break;
cd39f2b6 2446#ifndef MACOS_TRADITIONAL
79072805 2447 case '0':
e2975953 2448 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2449#ifdef HAS_SETPROCTITLE
2450 /* The BSDs don't show the argv[] in ps(1) output, they
2451 * show a string from the process struct and provide
2452 * the setproctitle() routine to manipulate that. */
2453 {
2454 s = SvPV(sv, len);
98b76f99 2455# if __FreeBSD_version > 410001
9aad2c0e 2456 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2457 * but not the "(perl) suffix from the ps(1)
2458 * output, because that's what ps(1) shows if the
2459 * argv[] is modified. */
6f2ad931 2460 setproctitle("-%s", s);
9aad2c0e 2461# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2462 /* This doesn't really work if you assume that
2463 * $0 = 'foobar'; will wipe out 'perl' from the $0
2464 * because in ps(1) output the result will be like
2465 * sprintf("perl: %s (perl)", s)
2466 * I guess this is a security feature:
2467 * one (a user process) cannot get rid of the original name.
2468 * --jhi */
2469 setproctitle("%s", s);
2470# endif
2471 }
2472#endif
17aa7f3d
JH
2473#if defined(__hpux) && defined(PSTAT_SETCMD)
2474 {
2475 union pstun un;
2476 s = SvPV(sv, len);
6867be6d 2477 un.pst_command = (char *)s;
17aa7f3d
JH
2478 pstat(PSTAT_SETCMD, un, len, 0, 0);
2479 }
2480#endif
3cb9023d 2481 /* PL_origalen is set in perl_parse(). */
a0d0e21e 2482 s = SvPV_force(sv,len);
6f698202
AMS
2483 if (len >= (STRLEN)PL_origalen-1) {
2484 /* Longer than original, will be truncated. We assume that
2485 * PL_origalen bytes are available. */
2486 Copy(s, PL_origargv[0], PL_origalen-1, char);
79072805
LW
2487 }
2488 else {
54bfe034
JH
2489 /* Shorter than original, will be padded. */
2490 Copy(s, PL_origargv[0], len, char);
2491 PL_origargv[0][len] = 0;
2492 memset(PL_origargv[0] + len + 1,
2493 /* Is the space counterintuitive? Yes.
2494 * (You were expecting \0?)
3cb9023d 2495 * Does it work? Seems to. (In Linux 2.4.20 at least.)
54bfe034
JH
2496 * --jhi */
2497 (int)' ',
2498 PL_origalen - len - 1);
79072805 2499 }
ad7eccf4
JD
2500 PL_origargv[0][PL_origalen-1] = 0;
2501 for (i = 1; i < PL_origargc; i++)
2502 PL_origargv[i] = 0;
e2975953 2503 UNLOCK_DOLLARZERO_MUTEX;
79072805 2504 break;
cd39f2b6 2505#endif
79072805
LW
2506 }
2507 return 0;
2508}
2509
2510I32
35a4481c 2511Perl_whichsig(pTHX_ const char *sig)
79072805 2512{
aadb217d 2513 register char* const* sigv;
79072805 2514
aadb217d 2515 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2516 if (strEQ(sig,*sigv))
aadb217d 2517 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2518#ifdef SIGCLD
2519 if (strEQ(sig,"CHLD"))
2520 return SIGCLD;
2521#endif
2522#ifdef SIGCHLD
2523 if (strEQ(sig,"CLD"))
2524 return SIGCHLD;
2525#endif
7f1236c0 2526 return -1;
79072805
LW
2527}
2528
ecfc5424 2529Signal_t
cea2e8a9 2530Perl_sighandler(int sig)
79072805 2531{
1018e26f
NIS
2532#ifdef PERL_GET_SIG_CONTEXT
2533 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2534#else
cea2e8a9 2535 dTHX;
71d280e3 2536#endif
79072805 2537 dSP;
00d579c5 2538 GV *gv = Nullgv;
a0d0e21e 2539 HV *st;
b7953727 2540 SV *sv = Nullsv, *tSv = PL_Sv;
00d579c5 2541 CV *cv = Nullcv;
533c011a 2542 OP *myop = PL_op;
84902520 2543 U32 flags = 0;
3280af22 2544 XPV *tXpv = PL_Xpv;
71d280e3 2545
3280af22 2546 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2547 flags |= 1;
3280af22 2548 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2549 flags |= 4;
3280af22 2550 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2551 flags |= 16;
2552
727405f8 2553 if (!PL_psig_ptr[sig]) {
99ef548b 2554 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2555 PL_sig_name[sig]);
2556 exit(sig);
2557 }
ff0cee69 2558
84902520
TB
2559 /* Max number of items pushed there is 3*n or 4. We cannot fix
2560 infinity, so we fix 4 (in fact 5): */
2561 if (flags & 1) {
3280af22 2562 PL_savestack_ix += 5; /* Protect save in progress. */
c76ac1ee 2563 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
84902520 2564 }
ac27b0f5 2565 if (flags & 4)
3280af22 2566 PL_markstack_ptr++; /* Protect mark. */
84902520 2567 if (flags & 16)
3280af22 2568 PL_scopestack_ix += 1;
84902520 2569 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2570 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2571 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2572 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2573
a0d0e21e 2574 if (!cv || !CvROOT(cv)) {
599cee73 2575 if (ckWARN(WARN_SIGNAL))
9014280d 2576 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2577 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2578 : ((cv && CvGV(cv))
2579 ? GvENAME(CvGV(cv))
2580 : "__ANON__")));
2581 goto cleanup;
79072805
LW
2582 }
2583
22c35a8c
GS
2584 if(PL_psig_name[sig]) {
2585 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2586 flags |= 64;
df3728a2 2587#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2588 PL_sig_sv = sv;
df3728a2 2589#endif
84902520 2590 } else {
ff0cee69 2591 sv = sv_newmortal();
22c35a8c 2592 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2593 }
e336de0d 2594
e788e7d3 2595 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2596 PUSHMARK(SP);
79072805 2597 PUSHs(sv);
79072805 2598 PUTBACK;
a0d0e21e 2599
1b266415 2600 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2601
d3acc0f7 2602 POPSTACK;
1b266415 2603 if (SvTRUE(ERRSV)) {
1d615522 2604#ifndef PERL_MICRO
983dbef6 2605#ifdef HAS_SIGPROCMASK
1b266415
NIS
2606 /* Handler "died", for example to get out of a restart-able read().
2607 * Before we re-do that on its behalf re-enable the signal which was
2608 * blocked by the system when we entered.
2609 */
2610 sigset_t set;
2611 sigemptyset(&set);
2612 sigaddset(&set,sig);
2613 sigprocmask(SIG_UNBLOCK, &set, NULL);
2614#else
2615 /* Not clear if this will work */
2616 (void)rsignal(sig, SIG_IGN);
5c1546dc 2617 (void)rsignal(sig, PL_csighandlerp);
1b266415 2618#endif
1d615522 2619#endif /* !PERL_MICRO */
5df617be 2620 DieNull;
1b266415 2621 }
00d579c5 2622cleanup:
84902520 2623 if (flags & 1)
3280af22 2624 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2625 if (flags & 4)
3280af22 2626 PL_markstack_ptr--;
84902520 2627 if (flags & 16)
3280af22 2628 PL_scopestack_ix -= 1;
84902520
TB
2629 if (flags & 64)
2630 SvREFCNT_dec(sv);
533c011a 2631 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2632
3280af22
NIS
2633 PL_Sv = tSv; /* Restore global temporaries. */
2634 PL_Xpv = tXpv;
53bb94e2 2635 return;
79072805 2636}
4e35701f
NIS
2637
2638
51371543 2639static void
35a4481c 2640restore_magic(pTHX_ const void *p)
51371543 2641{
48944bdf 2642 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
51371543
GS
2643 SV* sv = mgs->mgs_sv;
2644
2645 if (!sv)
2646 return;
2647
2648 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2649 {
f9701176
NC
2650#ifdef PERL_COPY_ON_WRITE
2651 /* While magic was saved (and off) sv_setsv may well have seen
2652 this SV as a prime candidate for COW. */
2653 if (SvIsCOW(sv))
2654 sv_force_normal(sv);
2655#endif
2656
51371543
GS
2657 if (mgs->mgs_flags)
2658 SvFLAGS(sv) |= mgs->mgs_flags;
2659 else
2660 mg_magical(sv);
2661 if (SvGMAGICAL(sv))
2662 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2663 }
2664
2665 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2666
2667 /* If we're still on top of the stack, pop us off. (That condition
2668 * will be satisfied if restore_magic was called explicitly, but *not*
2669 * if it's being called via leave_scope.)
2670 * The reason for doing this is that otherwise, things like sv_2cv()
2671 * may leave alloc gunk on the savestack, and some code
2672 * (e.g. sighandler) doesn't expect that...
2673 */
2674 if (PL_savestack_ix == mgs->mgs_ss_ix)
2675 {
2676 I32 popval = SSPOPINT;
c76ac1ee 2677 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2678 PL_savestack_ix -= 2;
2679 popval = SSPOPINT;
2680 assert(popval == SAVEt_ALLOC);
2681 popval = SSPOPINT;
2682 PL_savestack_ix -= popval;
2683 }
2684
2685}
2686
2687static void
35a4481c 2688unwind_handler_stack(pTHX_ const void *p)
51371543 2689{
27da23d5 2690 dVAR;
e1ec3a88 2691 const U32 flags = *(const U32*)p;
51371543
GS
2692
2693 if (flags & 1)
2694 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2695 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2696#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2697 if (flags & 64)
27da23d5 2698 SvREFCNT_dec(PL_sig_sv);
df3728a2 2699#endif
51371543 2700}
1018e26f
NIS
2701
2702