This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid having NULL entries in the weakref backreference array, and
[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));
f8c7b90f 84#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
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)) {
10516c54 266 const U8 *s = (U8*)SvPV_const(sv, len);
5636d518
DB
267 len = Perl_utf8_length(aTHX_ s, s + len);
268 }
269 else
10516c54 270 (void)SvPV_const(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);
0dbb1585 471 NORETURN_FUNCTION_END;
a29d06ed
MG
472}
473
93a17b20 474U32
864dbfa3 475Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20
LW
476{
477 register I32 paren;
93a17b20 478 register I32 i;
dd374669 479 register const REGEXP *rx;
a197cbdd 480 I32 s1, t1;
93a17b20
LW
481
482 switch (*mg->mg_ptr) {
483 case '1': case '2': case '3': case '4':
484 case '5': case '6': case '7': case '8': case '9': case '&':
aaa362c4 485 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d 486
ffc61ed2 487 paren = atoi(mg->mg_ptr); /* $& is in [0] */
93a17b20 488 getparen:
eb160463 489 if (paren <= (I32)rx->nparens &&
cf93c79d
IZ
490 (s1 = rx->startp[paren]) != -1 &&
491 (t1 = rx->endp[paren]) != -1)
bbce6d69 492 {
cf93c79d 493 i = t1 - s1;
a197cbdd 494 getlen:
a30b2f1f 495 if (i > 0 && RX_MATCH_UTF8(rx)) {
a28509cc 496 const char * const s = rx->subbeg + s1;
768c67ee
JH
497 const U8 *ep;
498 STRLEN el;
ffc61ed2 499
6d5fa195 500 i = t1 - s1;
768c67ee
JH
501 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
502 i = el;
a197cbdd 503 }
ffc61ed2 504 if (i < 0)
0844c848 505 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 506 return i;
93a17b20 507 }
235bddc8
NIS
508 else {
509 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 510 report_uninit(sv);
235bddc8
NIS
511 }
512 }
513 else {
514 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 515 report_uninit(sv);
93a17b20 516 }
748a9306 517 return 0;
93a17b20 518 case '+':
aaa362c4 519 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
d9f97599 520 paren = rx->lastparen;
13f57bf8
CS
521 if (paren)
522 goto getparen;
93a17b20 523 }
748a9306 524 return 0;
a01268b5
JH
525 case '\016': /* ^N */
526 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
527 paren = rx->lastcloseparen;
528 if (paren)
529 goto getparen;
530 }
531 return 0;
93a17b20 532 case '`':
aaa362c4 533 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
534 if (rx->startp[0] != -1) {
535 i = rx->startp[0];
a197cbdd
GS
536 if (i > 0) {
537 s1 = 0;
538 t1 = i;
539 goto getlen;
540 }
93a17b20 541 }
93a17b20 542 }
748a9306 543 return 0;
93a17b20 544 case '\'':
aaa362c4 545 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
cf93c79d
IZ
546 if (rx->endp[0] != -1) {
547 i = rx->sublen - rx->endp[0];
a197cbdd
GS
548 if (i > 0) {
549 s1 = rx->endp[0];
550 t1 = rx->sublen;
551 goto getlen;
552 }
93a17b20 553 }
93a17b20 554 }
748a9306 555 return 0;
93a17b20
LW
556 }
557 magic_get(sv,mg);
2d8e6c8d 558 if (!SvPOK(sv) && SvNIOK(sv)) {
8b6b16e7 559 sv_2pv(sv, 0);
2d8e6c8d 560 }
93a17b20
LW
561 if (SvPOK(sv))
562 return SvCUR(sv);
563 return 0;
564}
565
79072805 566int
864dbfa3 567Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 568{
27da23d5 569 dVAR;
79072805 570 register I32 paren;
35272f84 571 register char *s = NULL;
79072805 572 register I32 i;
d9f97599 573 register REGEXP *rx;
79072805
LW
574
575 switch (*mg->mg_ptr) {
748a9306 576 case '\001': /* ^A */
3280af22 577 sv_setsv(sv, PL_bodytarget);
748a9306 578 break;
e5218da5
GA
579 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
580 if (*(mg->mg_ptr+1) == '\0') {
581 sv_setiv(sv, (IV)PL_minus_c);
582 }
583 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
584 sv_setiv(sv, (IV)STATUS_NATIVE);
585 }
49460fe6
NIS
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
c69006e4 611 sv_setpvn(sv,"",0);
0a378802 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
c69006e4 637 sv_setpvn(sv, "", 0);
0a378802
JH
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 '.':
3280af22 823 if (GvIO(PL_last_in_gv)) {
357c8808 824 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 825 }
79072805
LW
826 break;
827 case '?':
809a5acc 828 {
809a5acc 829 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 830#ifdef COMPLEX_STATUS
6b88bc9c
GS
831 LvTARGOFF(sv) = PL_statusvalue;
832 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 833#endif
809a5acc 834 }
79072805
LW
835 break;
836 case '^':
0daa599b
RGS
837 if (GvIOp(PL_defoutgv))
838 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
839 if (s)
840 sv_setpv(sv,s);
841 else {
3280af22 842 sv_setpv(sv,GvENAME(PL_defoutgv));
79072805
LW
843 sv_catpv(sv,"_TOP");
844 }
845 break;
846 case '~':
0daa599b
RGS
847 if (GvIOp(PL_defoutgv))
848 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 849 if (!s)
3280af22 850 s = GvENAME(PL_defoutgv);
79072805
LW
851 sv_setpv(sv,s);
852 break;
79072805 853 case '=':
0daa599b
RGS
854 if (GvIOp(PL_defoutgv))
855 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
856 break;
857 case '-':
0daa599b
RGS
858 if (GvIOp(PL_defoutgv))
859 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
860 break;
861 case '%':
0daa599b
RGS
862 if (GvIOp(PL_defoutgv))
863 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 864 break;
79072805
LW
865 case ':':
866 break;
867 case '/':
868 break;
869 case '[':
3280af22 870 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
79072805
LW
871 break;
872 case '|':
0daa599b
RGS
873 if (GvIOp(PL_defoutgv))
874 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805
LW
875 break;
876 case ',':
79072805
LW
877 break;
878 case '\\':
b2ce0fda 879 if (PL_ors_sv)
f28098ff 880 sv_copypv(sv, PL_ors_sv);
79072805 881 break;
79072805 882 case '!':
a5f75d66 883#ifdef VMS
65202027 884 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 885 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 886#else
88e89b8a
PP
887 {
888 int saveerrno = errno;
65202027 889 sv_setnv(sv, (NV)errno);
88e89b8a 890#ifdef OS2
ed344e4f
IZ
891 if (errno == errno_isOS2 || errno == errno_isOS2_set)
892 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 893 else
a5f75d66 894#endif
2304df62 895 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
896 errno = saveerrno;
897 }
898#endif
946ec16e 899 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
900 break;
901 case '<':
3280af22 902 sv_setiv(sv, (IV)PL_uid);
79072805
LW
903 break;
904 case '>':
3280af22 905 sv_setiv(sv, (IV)PL_euid);
79072805
LW
906 break;
907 case '(':
3280af22 908 sv_setiv(sv, (IV)PL_gid);
a52cb5f7 909#ifdef HAS_GETGROUPS
a3b680e6 910 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
a52cb5f7 911#endif
79072805
LW
912 goto add_groups;
913 case ')':
3280af22 914 sv_setiv(sv, (IV)PL_egid);
a52cb5f7 915#ifdef HAS_GETGROUPS
a3b680e6 916 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
a52cb5f7 917#endif
79072805 918 add_groups:
79072805 919#ifdef HAS_GETGROUPS
79072805 920 {
a0d0e21e 921 Groups_t gary[NGROUPS];
a3b680e6
AL
922 I32 j = getgroups(NGROUPS,gary);
923 while (--j >= 0)
924 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
79072805
LW
925 }
926#endif
155aba94 927 (void)SvIOK_on(sv); /* what a wonderful hack! */
79072805 928 break;
cd39f2b6 929#ifndef MACOS_TRADITIONAL
79072805
LW
930 case '0':
931 break;
cd39f2b6 932#endif
79072805 933 }
a0d0e21e 934 return 0;
79072805
LW
935}
936
937int
864dbfa3 938Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
939{
940 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
941
942 if (uf && uf->uf_val)
24f81a43 943 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
944 return 0;
945}
946
947int
864dbfa3 948Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 949{
27da23d5 950 dVAR;
b83604b4 951 const char *s;
e62f0680 952 const char *ptr;
5aabfad6 953 STRLEN len, klen;
1e422769 954
b83604b4 955 s = SvPV_const(sv,len);
e62f0680 956 ptr = MgPV_const(mg,klen);
88e89b8a 957 my_setenv(ptr, s);
1e422769 958
a0d0e21e
LW
959#ifdef DYNAMIC_ENV_FETCH
960 /* We just undefd an environment var. Is a replacement */
961 /* waiting in the wings? */
962 if (!len) {
5aabfad6 963 SV **valp;
6b88bc9c 964 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
b83604b4 965 s = SvPV_const(*valp, len);
a0d0e21e
LW
966 }
967#endif
1e422769 968
39e571d4 969#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
970 /* And you'll never guess what the dog had */
971 /* in its mouth... */
3280af22 972 if (PL_tainting) {
1e422769
PP
973 MgTAINTEDDIR_off(mg);
974#ifdef VMS
5aabfad6 975 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1e422769 976 char pathbuf[256], eltbuf[256], *cp, *elt = s;
c623ac67 977 Stat_t sbuf;
1e422769
PP
978 int i = 0, j = 0;
979
980 do { /* DCL$PATH may be a search list */
981 while (1) { /* as may dev portion of any element */
982 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
983 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
984 cando_by_name(S_IWUSR,0,elt) ) {
985 MgTAINTEDDIR_on(mg);
986 return 0;
987 }
988 }
989 if ((cp = strchr(elt, ':')) != Nullch)
990 *cp = '\0';
991 if (my_trnlnm(elt, eltbuf, j++))
992 elt = eltbuf;
993 else
994 break;
995 }
996 j = 0;
997 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
998 }
999#endif /* VMS */
5aabfad6 1000 if (s && klen == 4 && strEQ(ptr,"PATH")) {
b83604b4 1001 const char *strend = s + len;
463ee0b2
LW
1002
1003 while (s < strend) {
96827780 1004 char tmpbuf[256];
c623ac67 1005 Stat_t st;
5f74f29c 1006 I32 i;
96827780 1007 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
fc36a67e 1008 s, strend, ':', &i);
463ee0b2 1009 s++;
96827780
MB
1010 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1011 || *tmpbuf != '/'
c6ed36e1 1012 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1013 MgTAINTEDDIR_on(mg);
1e422769
PP
1014 return 0;
1015 }
463ee0b2 1016 }
79072805
LW
1017 }
1018 }
39e571d4 1019#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1020
79072805
LW
1021 return 0;
1022}
1023
1024int
864dbfa3 1025Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1026{
dd374669 1027 (void)sv;
01b8bcb7 1028 my_setenv(MgPV_nolen_const(mg),Nullch);
85e6fe83
LW
1029 return 0;
1030}
1031
88e89b8a 1032int
864dbfa3 1033Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1034{
27da23d5 1035#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
cea2e8a9 1036 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1037#else
3280af22 1038 if (PL_localizing) {
fb73857a
PP
1039 HE* entry;
1040 magic_clear_all_env(sv,mg);
1041 hv_iterinit((HV*)sv);
155aba94 1042 while ((entry = hv_iternext((HV*)sv))) {
fb73857a
PP
1043 I32 keylen;
1044 my_setenv(hv_iterkey(entry, &keylen),
b83604b4 1045 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
fb73857a
PP
1046 }
1047 }
1048#endif
1049 return 0;
1050}
1051
1052int
864dbfa3 1053Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1054{
27da23d5 1055 dVAR;
2f42fcb0 1056#ifndef PERL_MICRO
27da23d5 1057#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
cea2e8a9 1058 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
3e3baf6d 1059#else
4efc5df6 1060# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
7766f137 1061 PerlEnv_clearenv();
4efc5df6
GS
1062# else
1063# ifdef USE_ENVIRON_ARRAY
1064# if defined(USE_ITHREADS)
1065 /* only the parent thread can clobber the process environment */
1066 if (PL_curinterp == aTHX)
1067# endif
1068 {
1069# ifndef PERL_USE_SAFE_PUTENV
50acdf95 1070 if (!PL_use_safe_putenv) {
66b1d557
HM
1071 I32 i;
1072
3280af22 1073 if (environ == PL_origenviron)
f2517201 1074 environ = (char**)safesysmalloc(sizeof(char*));
66b1d557
HM
1075 else
1076 for (i = 0; environ[i]; i++)
f2517201 1077 safesysfree(environ[i]);
50acdf95 1078 }
4efc5df6 1079# endif /* PERL_USE_SAFE_PUTENV */
f2517201 1080
66b1d557 1081 environ[0] = Nullch;
4efc5df6
GS
1082 }
1083# endif /* USE_ENVIRON_ARRAY */
052c2dc6 1084# endif /* PERL_IMPLICIT_SYS || WIN32 */
2f42fcb0
JH
1085#endif /* VMS || EPOC */
1086#endif /* !PERL_MICRO */
dd374669
AL
1087 (void)sv;
1088 (void)mg;
3e3baf6d 1089 return 0;
66b1d557
HM
1090}
1091
64ca3a65 1092#ifndef PERL_MICRO
2d4fcd5e
AJ
1093#ifdef HAS_SIGPROCMASK
1094static void
1095restore_sigmask(pTHX_ SV *save_sv)
1096{
b83604b4 1097 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
2d4fcd5e
AJ
1098 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1099}
1100#endif
66b1d557 1101int
864dbfa3 1102Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a
PP
1103{
1104 I32 i;
1105 /* Are we fetching a signal entry? */
01b8bcb7 1106 i = whichsig(MgPV_nolen_const(mg));
e02bfb16 1107 if (i > 0) {
22c35a8c
GS
1108 if(PL_psig_ptr[i])
1109 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1110 else {
85b332e2 1111 Sighandler_t sigstate;
2e34cc90 1112 sigstate = rsignal_state(i);
23ada85b 1113#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1114 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
2e34cc90
CL
1115#endif
1116#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1117 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
85b332e2 1118#endif
88e89b8a 1119 /* cache state so we don't fetch it again */
ff68c719 1120 if(sigstate == SIG_IGN)
88e89b8a
PP
1121 sv_setpv(sv,"IGNORE");
1122 else
3280af22 1123 sv_setsv(sv,&PL_sv_undef);
22c35a8c 1124 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a
PP
1125 SvTEMP_off(sv);
1126 }
1127 }
1128 return 0;
1129}
1130int
864dbfa3 1131Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1132{
2d4fcd5e
AJ
1133 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1134 * refactoring might be in order.
1135 */
27da23d5 1136 dVAR;
01b8bcb7 1137 register const char *s = MgPV_nolen_const(mg);
dd374669 1138 (void)sv;
2d4fcd5e 1139 if (*s == '_') {
27da23d5 1140 SV** svp = 0;
2d4fcd5e
AJ
1141 if (strEQ(s,"__DIE__"))
1142 svp = &PL_diehook;
1143 else if (strEQ(s,"__WARN__"))
1144 svp = &PL_warnhook;
1145 else
1146 Perl_croak(aTHX_ "No such hook: %s", s);
27da23d5 1147 if (svp && *svp) {
dd374669 1148 SV *to_dec = *svp;
2d4fcd5e
AJ
1149 *svp = 0;
1150 SvREFCNT_dec(to_dec);
1151 }
1152 }
1153 else {
1154 I32 i;
1155 /* Are we clearing a signal entry? */
1156 i = whichsig(s);
e02bfb16 1157 if (i > 0) {
2d4fcd5e
AJ
1158#ifdef HAS_SIGPROCMASK
1159 sigset_t set, save;
1160 SV* save_sv;
1161 /* Avoid having the signal arrive at a bad time, if possible. */
1162 sigemptyset(&set);
1163 sigaddset(&set,i);
1164 sigprocmask(SIG_BLOCK, &set, &save);
1165 ENTER;
1166 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1167 SAVEFREESV(save_sv);
1168 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1169#endif
1170 PERL_ASYNC_CHECK();
1171#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1172 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1173#endif
1174#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1175 PL_sig_defaulting[i] = 1;
5c1546dc 1176 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1177#else
1178 (void)rsignal(i, SIG_DFL);
1179#endif
1180 if(PL_psig_name[i]) {
1181 SvREFCNT_dec(PL_psig_name[i]);
1182 PL_psig_name[i]=0;
1183 }
1184 if(PL_psig_ptr[i]) {
dd374669 1185 SV *to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1186 PL_psig_ptr[i]=0;
1187 LEAVE;
1188 SvREFCNT_dec(to_dec);
1189 }
1190 else
1191 LEAVE;
1192 }
88e89b8a
PP
1193 }
1194 return 0;
1195}
3d37d572 1196
dd374669
AL
1197static void
1198S_raise_signal(pTHX_ int sig)
0a8e0eff
NIS
1199{
1200 /* Set a flag to say this signal is pending */
1201 PL_psig_pend[sig]++;
1202 /* And one to say _a_ signal is pending */
1203 PL_sig_pending = 1;
1204}
1205
1206Signal_t
1207Perl_csighandler(int sig)
1208{
1018e26f
NIS
1209#ifdef PERL_GET_SIG_CONTEXT
1210 dTHXa(PERL_GET_SIG_CONTEXT);
1211#else
85b332e2
CL
1212 dTHX;
1213#endif
23ada85b 1214#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1215 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1216 if (PL_sig_ignoring[sig]) return;
85b332e2 1217#endif
2e34cc90 1218#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1219 if (PL_sig_defaulting[sig])
2e34cc90
CL
1220#ifdef KILL_BY_SIGPRC
1221 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1222#else
1223 exit(1);
1224#endif
1225#endif
4ffa73a3
JH
1226 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1227 /* Call the perl level handler now--
1228 * with risk we may be in malloc() etc. */
1229 (*PL_sighandlerp)(sig);
1230 else
dd374669 1231 S_raise_signal(aTHX_ sig);
0a8e0eff
NIS
1232}
1233
2e34cc90
CL
1234#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1235void
1236Perl_csighandler_init(void)
1237{
1238 int sig;
27da23d5 1239 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1240
1241 for (sig = 1; sig < SIG_SIZE; sig++) {
1242#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1243 dTHX;
27da23d5 1244 PL_sig_defaulting[sig] = 1;
5c1546dc 1245 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1246#endif
1247#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1248 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1249#endif
1250 }
27da23d5 1251 PL_sig_handlers_initted = 1;
2e34cc90
CL
1252}
1253#endif
1254
0a8e0eff
NIS
1255void
1256Perl_despatch_signals(pTHX)
1257{
1258 int sig;
1259 PL_sig_pending = 0;
1260 for (sig = 1; sig < SIG_SIZE; sig++) {
1261 if (PL_psig_pend[sig]) {
25da4428
JH
1262 PERL_BLOCKSIG_ADD(set, sig);
1263 PL_psig_pend[sig] = 0;
1264 PERL_BLOCKSIG_BLOCK(set);
f5203343 1265 (*PL_sighandlerp)(sig);
25da4428 1266 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1267 }
1268 }
1269}
1270
85e6fe83 1271int
864dbfa3 1272Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1273{
27da23d5 1274 dVAR;
79072805 1275 I32 i;
b7953727 1276 SV** svp = 0;
2d4fcd5e
AJ
1277 /* Need to be careful with SvREFCNT_dec(), because that can have side
1278 * effects (due to closures). We must make sure that the new disposition
1279 * is in place before it is called.
1280 */
1281 SV* to_dec = 0;
e72dc28c 1282 STRLEN len;
2d4fcd5e
AJ
1283#ifdef HAS_SIGPROCMASK
1284 sigset_t set, save;
1285 SV* save_sv;
1286#endif
a0d0e21e 1287
d5263905 1288 register const char *s = MgPV_const(mg,len);
748a9306
LW
1289 if (*s == '_') {
1290 if (strEQ(s,"__DIE__"))
3280af22 1291 svp = &PL_diehook;
748a9306 1292 else if (strEQ(s,"__WARN__"))
3280af22 1293 svp = &PL_warnhook;
748a9306 1294 else
cea2e8a9 1295 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1296 i = 0;
4633a7c4 1297 if (*svp) {
2d4fcd5e 1298 to_dec = *svp;
4633a7c4
LW
1299 *svp = 0;
1300 }
748a9306
LW
1301 }
1302 else {
1303 i = whichsig(s); /* ...no, a brick */
86d86cad 1304 if (i <= 0) {
e476b1b5 1305 if (ckWARN(WARN_SIGNAL))
9014280d 1306 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1307 return 0;
1308 }
2d4fcd5e
AJ
1309#ifdef HAS_SIGPROCMASK
1310 /* Avoid having the signal arrive at a bad time, if possible. */
1311 sigemptyset(&set);
1312 sigaddset(&set,i);
1313 sigprocmask(SIG_BLOCK, &set, &save);
1314 ENTER;
1315 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1316 SAVEFREESV(save_sv);
1317 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1318#endif
1319 PERL_ASYNC_CHECK();
2e34cc90 1320#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1321 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1322#endif
23ada85b 1323#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1324 PL_sig_ignoring[i] = 0;
85b332e2 1325#endif
2e34cc90 1326#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1327 PL_sig_defaulting[i] = 0;
2e34cc90 1328#endif
22c35a8c 1329 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1330 to_dec = PL_psig_ptr[i];
22c35a8c 1331 PL_psig_ptr[i] = SvREFCNT_inc(sv);
88e89b8a 1332 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1333 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1334 SvREADONLY_on(PL_psig_name[i]);
748a9306 1335 }
a0d0e21e 1336 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
2d4fcd5e 1337 if (i) {
5c1546dc 1338 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1339#ifdef HAS_SIGPROCMASK
1340 LEAVE;
1341#endif
1342 }
748a9306
LW
1343 else
1344 *svp = SvREFCNT_inc(sv);
2d4fcd5e
AJ
1345 if(to_dec)
1346 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1347 return 0;
1348 }
e72dc28c 1349 s = SvPV_force(sv,len);
748a9306 1350 if (strEQ(s,"IGNORE")) {
85b332e2 1351 if (i) {
23ada85b 1352#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1353 PL_sig_ignoring[i] = 1;
5c1546dc 1354 (void)rsignal(i, PL_csighandlerp);
85b332e2 1355#else
ff68c719 1356 (void)rsignal(i, SIG_IGN);
85b332e2 1357#endif
2d4fcd5e 1358 }
748a9306
LW
1359 }
1360 else if (strEQ(s,"DEFAULT") || !*s) {
1361 if (i)
2e34cc90
CL
1362#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1363 {
27da23d5 1364 PL_sig_defaulting[i] = 1;
5c1546dc 1365 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1366 }
1367#else
ff68c719 1368 (void)rsignal(i, SIG_DFL);
2e34cc90 1369#endif
748a9306 1370 }
79072805 1371 else {
5aabfad6
PP
1372 /*
1373 * We should warn if HINT_STRICT_REFS, but without
1374 * access to a known hint bit in a known OP, we can't
1375 * tell whether HINT_STRICT_REFS is in force or not.
1376 */
46fc3d4c 1377 if (!strchr(s,':') && !strchr(s,'\''))
e72dc28c 1378 sv_insert(sv, 0, 0, "main::", 6);
748a9306 1379 if (i)
5c1546dc 1380 (void)rsignal(i, PL_csighandlerp);
748a9306
LW
1381 else
1382 *svp = SvREFCNT_inc(sv);
79072805 1383 }
2d4fcd5e
AJ
1384#ifdef HAS_SIGPROCMASK
1385 if(i)
1386 LEAVE;
1387#endif
1388 if(to_dec)
1389 SvREFCNT_dec(to_dec);
79072805
LW
1390 return 0;
1391}
64ca3a65 1392#endif /* !PERL_MICRO */
79072805
LW
1393
1394int
864dbfa3 1395Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1396{
dd374669
AL
1397 (void)sv;
1398 (void)mg;
3280af22 1399 PL_sub_generation++;
463ee0b2
LW
1400 return 0;
1401}
1402
1403int
864dbfa3 1404Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1405{
dd374669
AL
1406 (void)sv;
1407 (void)mg;
a0d0e21e 1408 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
3280af22 1409 PL_amagic_generation++;
463ee0b2 1410
a0d0e21e
LW
1411 return 0;
1412}
463ee0b2 1413
946ec16e 1414int
864dbfa3 1415Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1416{
dd374669 1417 HV * const hv = (HV*)LvTARG(sv);
6ff81951 1418 I32 i = 0;
dd374669 1419 (void)mg;
7719e241 1420
6ff81951 1421 if (hv) {
497b47a8
JH
1422 (void) hv_iterinit(hv);
1423 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1424 i = HvKEYS(hv);
1425 else {
1426 while (hv_iternext(hv))
1427 i++;
1428 }
6ff81951
GS
1429 }
1430
1431 sv_setiv(sv, (IV)i);
1432 return 0;
1433}
1434
1435int
864dbfa3 1436Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1437{
dd374669 1438 (void)mg;
946ec16e
PP
1439 if (LvTARG(sv)) {
1440 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
946ec16e
PP
1441 }
1442 return 0;
ac27b0f5 1443}
946ec16e 1444
e336de0d 1445/* caller is responsible for stack switching/cleanup */
565764a8 1446STATIC int
e1ec3a88 1447S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e
LW
1448{
1449 dSP;
463ee0b2 1450
924508f0
GS
1451 PUSHMARK(SP);
1452 EXTEND(SP, n);
33c27489 1453 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1454 if (n > 1) {
93965878 1455 if (mg->mg_ptr) {
565764a8 1456 if (mg->mg_len >= 0)
79cb57f6 1457 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
565764a8 1458 else if (mg->mg_len == HEf_SVKEY)
93965878
NIS
1459 PUSHs((SV*)mg->mg_ptr);
1460 }
14befaf4 1461 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
565764a8 1462 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
93965878
NIS
1463 }
1464 }
1465 if (n > 2) {
1466 PUSHs(val);
88e89b8a 1467 }
463ee0b2
LW
1468 PUTBACK;
1469
864dbfa3 1470 return call_method(meth, flags);
946ec16e
PP
1471}
1472
76e3520e 1473STATIC int
e1ec3a88 1474S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1475{
27da23d5 1476 dVAR; dSP;
463ee0b2 1477
a0d0e21e
LW
1478 ENTER;
1479 SAVETMPS;
e788e7d3 1480 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1481
33c27489 1482 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1483 sv_setsv(sv, *PL_stack_sp--);
93965878 1484 }
463ee0b2 1485
d3acc0f7 1486 POPSTACK;
a0d0e21e
LW
1487 FREETMPS;
1488 LEAVE;
1489 return 0;
1490}
463ee0b2 1491
a0d0e21e 1492int
864dbfa3 1493Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1494{
a0d0e21e
LW
1495 if (mg->mg_ptr)
1496 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1497 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1498 return 0;
1499}
1500
1501int
864dbfa3 1502Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1503{
27da23d5 1504 dVAR; dSP;
a60c0954 1505 ENTER;
e788e7d3 1506 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1507 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1508 POPSTACK;
a60c0954 1509 LEAVE;
463ee0b2
LW
1510 return 0;
1511}
1512
1513int
864dbfa3 1514Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1515{
a0d0e21e
LW
1516 return magic_methpack(sv,mg,"DELETE");
1517}
463ee0b2 1518
93965878
NIS
1519
1520U32
864dbfa3 1521Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1522{
27da23d5 1523 dVAR; dSP;
93965878
NIS
1524 U32 retval = 0;
1525
1526 ENTER;
1527 SAVETMPS;
e788e7d3 1528 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1529 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1530 sv = *PL_stack_sp--;
a60c0954 1531 retval = (U32) SvIV(sv)-1;
93965878 1532 }
d3acc0f7 1533 POPSTACK;
93965878
NIS
1534 FREETMPS;
1535 LEAVE;
1536 return retval;
1537}
1538
cea2e8a9
GS
1539int
1540Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1541{
27da23d5 1542 dVAR; dSP;
463ee0b2 1543
e336de0d 1544 ENTER;
e788e7d3 1545 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1546 PUSHMARK(SP);
33c27489 1547 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1548 PUTBACK;
864dbfa3 1549 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1550 POPSTACK;
a60c0954 1551 LEAVE;
a3bcc51e 1552
463ee0b2
LW
1553 return 0;
1554}
1555
1556int
864dbfa3 1557Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1558{
27da23d5 1559 dVAR; dSP;
35a4481c 1560 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2
LW
1561
1562 ENTER;
a0d0e21e 1563 SAVETMPS;
e788e7d3 1564 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1565 PUSHMARK(SP);
1566 EXTEND(SP, 2);
33c27489 1567 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1568 if (SvOK(key))
1569 PUSHs(key);
1570 PUTBACK;
1571
864dbfa3 1572 if (call_method(meth, G_SCALAR))
3280af22 1573 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1574
d3acc0f7 1575 POPSTACK;
a0d0e21e
LW
1576 FREETMPS;
1577 LEAVE;
79072805
LW
1578 return 0;
1579}
1580
1581int
864dbfa3 1582Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1583{
1584 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1585}
a0d0e21e 1586
a3bcc51e
TP
1587SV *
1588Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1589{
27da23d5 1590 dVAR; dSP;
a3bcc51e
TP
1591 SV *retval = &PL_sv_undef;
1592 SV *tied = SvTIED_obj((SV*)hv, mg);
1593 HV *pkg = SvSTASH((SV*)SvRV(tied));
1594
1595 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1596 SV *key;
bfcb3514 1597 if (HvEITER_get(hv))
a3bcc51e
TP
1598 /* we are in an iteration so the hash cannot be empty */
1599 return &PL_sv_yes;
1600 /* no xhv_eiter so now use FIRSTKEY */
1601 key = sv_newmortal();
1602 magic_nextpack((SV*)hv, mg, key);
bfcb3514 1603 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1604 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1605 }
1606
1607 /* there is a SCALAR method that we can call */
1608 ENTER;
1609 PUSHSTACKi(PERLSI_MAGIC);
1610 PUSHMARK(SP);
1611 EXTEND(SP, 1);
1612 PUSHs(tied);
1613 PUTBACK;
1614
1615 if (call_method("SCALAR", G_SCALAR))
1616 retval = *PL_stack_sp--;
1617 POPSTACK;
1618 LEAVE;
1619 return retval;
1620}
1621
a0d0e21e 1622int
864dbfa3 1623Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805
LW
1624{
1625 OP *o;
1626 I32 i;
1627 GV* gv;
1628 SV** svp;
1629
3280af22 1630 gv = PL_DBline;
79072805 1631 i = SvTRUE(sv);
188ea221 1632 svp = av_fetch(GvAV(gv),
01b8bcb7 1633 atoi(MgPV_nolen_const(mg)), FALSE);
5df8de69
DM
1634 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1635 /* set or clear breakpoint in the relevant control op */
1636 if (i)
1637 o->op_flags |= OPf_SPECIAL;
1638 else
1639 o->op_flags &= ~OPf_SPECIAL;
1640 }
79072805
LW
1641 return 0;
1642}
1643
1644int
864dbfa3 1645Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1646{
83bf042f
NC
1647 AV *obj = (AV*)mg->mg_obj;
1648 if (obj) {
1649 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1650 } else {
1651 SvOK_off(sv);
1652 }
79072805
LW
1653 return 0;
1654}
1655
1656int
864dbfa3 1657Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1658{
83bf042f
NC
1659 AV *obj = (AV*)mg->mg_obj;
1660 if (obj) {
1661 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1662 } else {
1663 if (ckWARN(WARN_MISC))
1664 Perl_warner(aTHX_ packWARN(WARN_MISC),
1665 "Attempt to set length of freed array");
1666 }
1667 return 0;
1668}
1669
1670int
1671Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1672{
53c1dcc0 1673 PERL_UNUSED_ARG(sv);
94f3782b
DM
1674 /* during global destruction, mg_obj may already have been freed */
1675 if (PL_in_clean_all)
1ea47f64 1676 return 0;
94f3782b 1677
83bf042f
NC
1678 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1679
1680 if (mg) {
1681 /* arylen scalar holds a pointer back to the array, but doesn't own a
1682 reference. Hence the we (the array) are about to go away with it
1683 still pointing at us. Clear its pointer, else it would be pointing
1684 at free memory. See the comment in sv_magic about reference loops,
1685 and why it can't own a reference to us. */
1686 mg->mg_obj = 0;
1687 }
a0d0e21e
LW
1688 return 0;
1689}
1690
1691int
864dbfa3 1692Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1693{
1694 SV* lsv = LvTARG(sv);
ac27b0f5 1695
a0d0e21e 1696 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
14befaf4 1697 mg = mg_find(lsv, PERL_MAGIC_regex_global);
565764a8 1698 if (mg && mg->mg_len >= 0) {
a0ed51b3 1699 I32 i = mg->mg_len;
7e2040f0 1700 if (DO_UTF8(lsv))
a0ed51b3
LW
1701 sv_pos_b2u(lsv, &i);
1702 sv_setiv(sv, i + PL_curcop->cop_arybase);
a0d0e21e
LW
1703 return 0;
1704 }
1705 }
0c34ef67 1706 SvOK_off(sv);
a0d0e21e
LW
1707 return 0;
1708}
1709
1710int
864dbfa3 1711Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e
LW
1712{
1713 SV* lsv = LvTARG(sv);
1714 SSize_t pos;
1715 STRLEN len;
c00206c8 1716 STRLEN ulen = 0;
a0d0e21e
LW
1717
1718 mg = 0;
ac27b0f5 1719
a0d0e21e 1720 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
14befaf4 1721 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1722 if (!mg) {
1723 if (!SvOK(sv))
1724 return 0;
14befaf4
DM
1725 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1726 mg = mg_find(lsv, PERL_MAGIC_regex_global);
a0d0e21e
LW
1727 }
1728 else if (!SvOK(sv)) {
565764a8 1729 mg->mg_len = -1;
a0d0e21e
LW
1730 return 0;
1731 }
1732 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1733
c485e607 1734 pos = SvIV(sv) - PL_curcop->cop_arybase;
a0ed51b3 1735
7e2040f0 1736 if (DO_UTF8(lsv)) {
a0ed51b3
LW
1737 ulen = sv_len_utf8(lsv);
1738 if (ulen)
1739 len = ulen;
a0ed51b3
LW
1740 }
1741
a0d0e21e
LW
1742 if (pos < 0) {
1743 pos += len;
1744 if (pos < 0)
1745 pos = 0;
1746 }
eb160463 1747 else if (pos > (SSize_t)len)
a0d0e21e 1748 pos = len;
a0ed51b3
LW
1749
1750 if (ulen) {
1751 I32 p = pos;
1752 sv_pos_u2b(lsv, &p, 0);
1753 pos = p;
1754 }
727405f8 1755
565764a8 1756 mg->mg_len = pos;
71be2cbc 1757 mg->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 1758
79072805
LW
1759 return 0;
1760}
1761
1762int
864dbfa3 1763Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1764{
dd374669 1765 (void)mg;
8646b087
PP
1766 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1767 SvFAKE_off(sv);
946ec16e 1768 gv_efullname3(sv,((GV*)sv), "*");
8646b087
PP
1769 SvFAKE_on(sv);
1770 }
1771 else
946ec16e 1772 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
79072805
LW
1773 return 0;
1774}
1775
1776int
864dbfa3 1777Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
79072805 1778{
79072805 1779 GV* gv;
dd374669 1780 (void)mg;
7a5fd60d 1781
79072805
LW
1782 if (!SvOK(sv))
1783 return 0;
7a5fd60d 1784 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
79072805
LW
1785 if (sv == (SV*)gv)
1786 return 0;
1787 if (GvGP(sv))
88e89b8a 1788 gp_free((GV*)sv);
79072805 1789 GvGP(sv) = gp_ref(GvGP(gv));
79072805
LW
1790 return 0;
1791}
1792
1793int
864dbfa3 1794Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
1795{
1796 STRLEN len;
35a4481c 1797 SV * const lsv = LvTARG(sv);
b83604b4 1798 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
1799 I32 offs = LvTARGOFF(sv);
1800 I32 rem = LvTARGLEN(sv);
dd374669 1801 (void)mg;
6ff81951 1802
9aa983d2
JH
1803 if (SvUTF8(lsv))
1804 sv_pos_u2b(lsv, &offs, &rem);
eb160463 1805 if (offs > (I32)len)
6ff81951 1806 offs = len;
eb160463 1807 if (rem + offs > (I32)len)
6ff81951
GS
1808 rem = len - offs;
1809 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 1810 if (SvUTF8(lsv))
2ef4b674 1811 SvUTF8_on(sv);
6ff81951
GS
1812 return 0;
1813}
1814
1815int
864dbfa3 1816Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 1817{
9aa983d2 1818 STRLEN len;
b83604b4 1819 const char *tmps = SvPV_const(sv, len);
dd374669 1820 SV * const lsv = LvTARG(sv);
9aa983d2
JH
1821 I32 lvoff = LvTARGOFF(sv);
1822 I32 lvlen = LvTARGLEN(sv);
dd374669 1823 (void)mg;
075a4a2b 1824
1aa99e6b 1825 if (DO_UTF8(sv)) {
9aa983d2
JH
1826 sv_utf8_upgrade(lsv);
1827 sv_pos_u2b(lsv, &lvoff, &lvlen);
1828 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 1829 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
1830 SvUTF8_on(lsv);
1831 }
9bf12eaf 1832 else if (lsv && SvUTF8(lsv)) {
9aa983d2 1833 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 1834 LvTARGLEN(sv) = len;
e95af362 1835 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
9aa983d2
JH
1836 sv_insert(lsv, lvoff, lvlen, tmps, len);
1837 Safefree(tmps);
1aa99e6b 1838 }
b76f3ce2
GB
1839 else {
1840 sv_insert(lsv, lvoff, lvlen, tmps, len);
1841 LvTARGLEN(sv) = len;
1842 }
1843
1aa99e6b 1844
79072805
LW
1845 return 0;
1846}
1847
1848int
864dbfa3 1849Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1850{
565764a8 1851 TAINT_IF((mg->mg_len & 1) ||
155aba94 1852 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
463ee0b2
LW
1853 return 0;
1854}
1855
1856int
864dbfa3 1857Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1858{
dd374669 1859 (void)sv;
3280af22
NIS
1860 if (PL_localizing) {
1861 if (PL_localizing == 1)
565764a8 1862 mg->mg_len <<= 1;
748a9306 1863 else
565764a8 1864 mg->mg_len >>= 1;
a0d0e21e 1865 }
3280af22 1866 else if (PL_tainted)
565764a8 1867 mg->mg_len |= 1;
748a9306 1868 else
565764a8 1869 mg->mg_len &= ~1;
463ee0b2
LW
1870 return 0;
1871}
1872
1873int
864dbfa3 1874Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1875{
35a4481c 1876 SV * const lsv = LvTARG(sv);
dd374669 1877 (void)mg;
6ff81951
GS
1878
1879 if (!lsv) {
0c34ef67 1880 SvOK_off(sv);
6ff81951
GS
1881 return 0;
1882 }
6ff81951 1883
81e118e0 1884 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951
GS
1885 return 0;
1886}
1887
1888int
864dbfa3 1889Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 1890{
dd374669 1891 (void)mg;
79072805
LW
1892 do_vecset(sv); /* XXX slurp this routine */
1893 return 0;
1894}
1895
1896int
864dbfa3 1897Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 1898{
71be2cbc 1899 SV *targ = Nullsv;
5f05dabc 1900 if (LvTARGLEN(sv)) {
68dc0745 1901 if (mg->mg_obj) {
74e13ce4 1902 SV *ahv = LvTARG(sv);
6d822dc4
MS
1903 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1904 if (he)
1905 targ = HeVAL(he);
68dc0745
PP
1906 }
1907 else {
3c78fafa 1908 AV* av = (AV*)LvTARG(sv);
68dc0745
PP
1909 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1910 targ = AvARRAY(av)[LvTARGOFF(sv)];
1911 }
3280af22 1912 if (targ && targ != &PL_sv_undef) {
68dc0745
PP
1913 /* somebody else defined it for us */
1914 SvREFCNT_dec(LvTARG(sv));
1915 LvTARG(sv) = SvREFCNT_inc(targ);
1916 LvTARGLEN(sv) = 0;
1917 SvREFCNT_dec(mg->mg_obj);
1918 mg->mg_obj = Nullsv;
1919 mg->mg_flags &= ~MGf_REFCOUNTED;
1920 }
5f05dabc 1921 }
71be2cbc
PP
1922 else
1923 targ = LvTARG(sv);
3280af22 1924 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
1925 return 0;
1926}
1927
1928int
864dbfa3 1929Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 1930{
dd374669 1931 (void)mg;
71be2cbc 1932 if (LvTARGLEN(sv))
68dc0745
PP
1933 vivify_defelem(sv);
1934 if (LvTARG(sv)) {
5f05dabc 1935 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
1936 SvSETMAGIC(LvTARG(sv));
1937 }
5f05dabc
PP
1938 return 0;
1939}
1940
71be2cbc 1941void
864dbfa3 1942Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 1943{
74e13ce4
GS
1944 MAGIC *mg;
1945 SV *value = Nullsv;
71be2cbc 1946
14befaf4 1947 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 1948 return;
68dc0745 1949 if (mg->mg_obj) {
74e13ce4 1950 SV *ahv = LvTARG(sv);
6d822dc4
MS
1951 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1952 if (he)
1953 value = HeVAL(he);
3280af22 1954 if (!value || value == &PL_sv_undef)
ce5030a2 1955 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
71be2cbc 1956 }
68dc0745
PP
1957 else {
1958 AV* av = (AV*)LvTARG(sv);
5aabfad6 1959 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
68dc0745
PP
1960 LvTARG(sv) = Nullsv; /* array can't be extended */
1961 else {
1962 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 1963 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 1964 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
1965 }
1966 }
3e3baf6d 1967 (void)SvREFCNT_inc(value);
68dc0745
PP
1968 SvREFCNT_dec(LvTARG(sv));
1969 LvTARG(sv) = value;
71be2cbc 1970 LvTARGLEN(sv) = 0;
68dc0745
PP
1971 SvREFCNT_dec(mg->mg_obj);
1972 mg->mg_obj = Nullsv;
1973 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
1974}
1975
1976int
864dbfa3 1977Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5
GS
1978{
1979 AV *av = (AV*)mg->mg_obj;
1980 SV **svp = AvARRAY(av);
1981 I32 i = AvFILLp(av);
dd374669
AL
1982 (void)sv;
1983
810b8aa5 1984 while (i >= 0) {
fdc9a813 1985 if (svp[i]) {
810b8aa5 1986 if (!SvWEAKREF(svp[i]))
cea2e8a9 1987 Perl_croak(aTHX_ "panic: magic_killbackrefs");
810b8aa5 1988 /* XXX Should we check that it hasn't changed? */
b162af07 1989 SvRV_set(svp[i], 0);
0c34ef67 1990 SvOK_off(svp[i]);
810b8aa5 1991 SvWEAKREF_off(svp[i]);
fdc9a813 1992 svp[i] = Nullsv;
810b8aa5
GS
1993 }
1994 i--;
1995 }
d99b02a1 1996 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
810b8aa5
GS
1997 return 0;
1998}
1999
2000int
864dbfa3 2001Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2002{
565764a8 2003 mg->mg_len = -1;
c6496cc7 2004 SvSCREAM_off(sv);
93a17b20
LW
2005 return 0;
2006}
2007
2008int
864dbfa3 2009Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
79072805 2010{
dd374669 2011 (void)mg;
14befaf4 2012 sv_unmagic(sv, PERL_MAGIC_bm);
79072805
LW
2013 SvVALID_off(sv);
2014 return 0;
2015}
2016
2017int
864dbfa3 2018Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
55497cff 2019{
dd374669 2020 (void)mg;
14befaf4 2021 sv_unmagic(sv, PERL_MAGIC_fm);
55497cff
PP
2022 SvCOMPILED_off(sv);
2023 return 0;
2024}
2025
2026int
864dbfa3 2027Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2028{
35a4481c 2029 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805
LW
2030
2031 if (uf && uf->uf_set)
24f81a43 2032 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2033 return 0;
2034}
2035
c277df42 2036int
faf82a0b
AE
2037Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2038{
dd374669 2039 (void)mg;
faf82a0b
AE
2040 sv_unmagic(sv, PERL_MAGIC_qr);
2041 return 0;
2042}
2043
2044int
864dbfa3 2045Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
c277df42
IZ
2046{
2047 regexp *re = (regexp *)mg->mg_obj;
2048 ReREFCNT_dec(re);
dd374669 2049 (void)sv;
c277df42
IZ
2050 return 0;
2051}
2052
7a4c00b4 2053#ifdef USE_LOCALE_COLLATE
79072805 2054int
864dbfa3 2055Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69
PP
2056{
2057 /*
838b5b74 2058 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2059 * and vanished with a faint plop.
2060 */
dd374669 2061 (void)sv;
7a4c00b4
PP
2062 if (mg->mg_ptr) {
2063 Safefree(mg->mg_ptr);
2064 mg->mg_ptr = NULL;
565764a8 2065 mg->mg_len = -1;
7a4c00b4 2066 }
bbce6d69
PP
2067 return 0;
2068}
7a4c00b4 2069#endif /* USE_LOCALE_COLLATE */
bbce6d69 2070
7e8c5dac
HS
2071/* Just clear the UTF-8 cache data. */
2072int
2073Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2074{
dd374669 2075 (void)sv;
7e8c5dac
HS
2076 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2077 mg->mg_ptr = 0;
2078 mg->mg_len = -1; /* The mg_len holds the len cache. */
2079 return 0;
2080}
2081
bbce6d69 2082int
864dbfa3 2083Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2084{
e1ec3a88 2085 register const char *s;
79072805 2086 I32 i;
8990e307 2087 STRLEN len;
79072805 2088 switch (*mg->mg_ptr) {
748a9306 2089 case '\001': /* ^A */
3280af22 2090 sv_setsv(PL_bodytarget, sv);
748a9306 2091 break;
49460fe6 2092 case '\003': /* ^C */
eb160463 2093 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
49460fe6
NIS
2094 break;
2095
79072805 2096 case '\004': /* ^D */
b4ab917c 2097#ifdef DEBUGGING
b83604b4 2098 s = SvPV_nolen_const(sv);
ddcf8bc1 2099 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2100 DEBUG_x(dump_all());
b4ab917c
DM
2101#else
2102 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2103#endif
79072805 2104 break;
28f23441 2105 case '\005': /* ^E */
d0063567 2106 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2107#ifdef MACOS_TRADITIONAL
d0063567 2108 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
28f23441 2109#else
cd39f2b6 2110# ifdef VMS
d0063567 2111 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
048c1ddf 2112# else
cd39f2b6 2113# ifdef WIN32
d0063567 2114 SetLastError( SvIV(sv) );
cd39f2b6 2115# else
9fed8b87 2116# ifdef OS2
d0063567 2117 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
9fed8b87 2118# else
d0063567
DK
2119 /* will anyone ever use this? */
2120 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
cd39f2b6 2121# endif
048c1ddf
IZ
2122# endif
2123# endif
22fae026 2124#endif
d0063567
DK
2125 }
2126 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2127 if (PL_encoding)
2128 SvREFCNT_dec(PL_encoding);
2129 if (SvOK(sv) || SvGMAGICAL(sv)) {
2130 PL_encoding = newSVsv(sv);
2131 }
2132 else {
2133 PL_encoding = Nullsv;
2134 }
2135 }
2136 break;
79072805 2137 case '\006': /* ^F */
3280af22 2138 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805 2139 break;
a0d0e21e 2140 case '\010': /* ^H */
3280af22 2141 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
a0d0e21e 2142 break;
9d116dd7 2143 case '\011': /* ^I */ /* NOT \t in EBCDIC */
3280af22
NIS
2144 if (PL_inplace)
2145 Safefree(PL_inplace);
79072805 2146 if (SvOK(sv))
2e0de35c 2147 PL_inplace = savesvpv(sv);
79072805 2148 else
3280af22 2149 PL_inplace = Nullch;
79072805 2150 break;
28f23441 2151 case '\017': /* ^O */
ac27b0f5 2152 if (*(mg->mg_ptr+1) == '\0') {
1bf29663 2153 if (PL_osname) {
ac27b0f5 2154 Safefree(PL_osname);
1bf29663
DM
2155 PL_osname = Nullch;
2156 }
3511154c
DM
2157 if (SvOK(sv)) {
2158 TAINT_PROPER("assigning to $^O");
2e0de35c 2159 PL_osname = savesvpv(sv);
3511154c 2160 }
ac27b0f5
NIS
2161 }
2162 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2163 if (!PL_compiling.cop_io)
2164 PL_compiling.cop_io = newSVsv(sv);
2165 else
2166 sv_setsv(PL_compiling.cop_io,sv);
2167 }
28f23441 2168 break;
79072805 2169 case '\020': /* ^P */
3280af22 2170 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
f2a7f298 2171 if (PL_perldb && !PL_DBsingle)
1ee4443e 2172 init_debugger();
79072805
LW
2173 break;
2174 case '\024': /* ^T */
88e89b8a 2175#ifdef BIG_TIME
6b88bc9c 2176 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2177#else
3280af22 2178 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
88e89b8a 2179#endif
79072805 2180 break;
fde18df1 2181 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2182 if (*(mg->mg_ptr+1) == '\0') {
2183 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2184 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
ac27b0f5 2185 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2186 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2187 }
599cee73 2188 }
0a378802 2189 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2190 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2191 if (!SvPOK(sv) && PL_localizing) {
2192 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2193 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2194 break;
2195 }
f4fc7782 2196 {
b5477537 2197 STRLEN len, i;
d3a7d8c7 2198 int accumulate = 0 ;
f4fc7782 2199 int any_fatals = 0 ;
b83604b4 2200 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2201 for (i = 0 ; i < len ; ++i) {
2202 accumulate |= ptr[i] ;
2203 any_fatals |= (ptr[i] & 0xAA) ;
2204 }
d3a7d8c7
GS
2205 if (!accumulate)
2206 PL_compiling.cop_warnings = pWARN_NONE;
f4fc7782
JH
2207 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2208 PL_compiling.cop_warnings = pWARN_ALL;
2209 PL_dowarn |= G_WARN_ONCE ;
727405f8 2210 }
d3a7d8c7
GS
2211 else {
2212 if (specialWARN(PL_compiling.cop_warnings))
2213 PL_compiling.cop_warnings = newSVsv(sv) ;
2214 else
2215 sv_setsv(PL_compiling.cop_warnings, sv);
2216 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2217 PL_dowarn |= G_WARN_ONCE ;
2218 }
f4fc7782 2219
d3a7d8c7 2220 }
4438c4b7 2221 }
971a9dd3 2222 }
79072805
LW
2223 break;
2224 case '.':
3280af22
NIS
2225 if (PL_localizing) {
2226 if (PL_localizing == 1)
7766f137 2227 SAVESPTR(PL_last_in_gv);
748a9306 2228 }
3280af22 2229 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2230 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2231 break;
2232 case '^':
3280af22 2233 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2234 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2235 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2236 break;
2237 case '~':
3280af22 2238 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2239 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
7a5fd60d 2240 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
79072805
LW
2241 break;
2242 case '=':
632db599 2243 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2244 break;
2245 case '-':
632db599 2246 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
3280af22
NIS
2247 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2248 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2249 break;
2250 case '%':
632db599 2251 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2252 break;
2253 case '|':
4b65379b 2254 {
3280af22 2255 IO *io = GvIOp(PL_defoutgv);
720f287d
AB
2256 if(!io)
2257 break;
4b65379b
CS
2258 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2259 IoFLAGS(io) &= ~IOf_FLUSH;
2260 else {
2261 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2262 PerlIO *ofp = IoOFP(io);
2263 if (ofp)
2264 (void)PerlIO_flush(ofp);
2265 IoFLAGS(io) |= IOf_FLUSH;
2266 }
2267 }
79072805
LW
2268 }
2269 break;
79072805 2270 case '/':
3280af22 2271 SvREFCNT_dec(PL_rs);
8bfdd7d9 2272 PL_rs = newSVsv(sv);
79072805
LW
2273 break;
2274 case '\\':
7889fe52
NIS
2275 if (PL_ors_sv)
2276 SvREFCNT_dec(PL_ors_sv);
009c130f 2277 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2278 PL_ors_sv = newSVsv(sv);
009c130f 2279 }
e3c19b7b 2280 else {
7889fe52 2281 PL_ors_sv = Nullsv;
e3c19b7b 2282 }
79072805
LW
2283 break;
2284 case ',':
7889fe52
NIS
2285 if (PL_ofs_sv)
2286 SvREFCNT_dec(PL_ofs_sv);
2287 if (SvOK(sv) || SvGMAGICAL(sv)) {
2288 PL_ofs_sv = newSVsv(sv);
2289 }
2290 else {
2291 PL_ofs_sv = Nullsv;
2292 }
79072805 2293 break;
79072805 2294 case '[':
3280af22 2295 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
79072805
LW
2296 break;
2297 case '?':
ff0cee69 2298#ifdef COMPLEX_STATUS
6b88bc9c
GS
2299 if (PL_localizing == 2) {
2300 PL_statusvalue = LvTARGOFF(sv);
2301 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2302 }
2303 else
2304#endif
2305#ifdef VMSISH_STATUS
2306 if (VMSISH_STATUS)
2307 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2308 else
2309#endif
e5218da5 2310 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
79072805
LW
2311 break;
2312 case '!':
93189314
JH
2313 {
2314#ifdef VMS
2315# define PERL_VMS_BANG vaxc$errno
2316#else
2317# define PERL_VMS_BANG 0
2318#endif
91487cfc 2319 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2320 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2321 }
79072805
LW
2322 break;
2323 case '<':
3280af22
NIS
2324 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2325 if (PL_delaymagic) {
2326 PL_delaymagic |= DM_RUID;
79072805
LW
2327 break; /* don't do magic till later */
2328 }
2329#ifdef HAS_SETRUID
b28d0864 2330 (void)setruid((Uid_t)PL_uid);
79072805
LW
2331#else
2332#ifdef HAS_SETREUID
3280af22 2333 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2334#else
85e6fe83 2335#ifdef HAS_SETRESUID
b28d0864 2336 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2337#else
75870ed3 2338 if (PL_uid == PL_euid) { /* special case $< = $> */
2339#ifdef PERL_DARWIN
2340 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2341 if (PL_uid != 0 && PerlProc_getuid() == 0)
2342 (void)PerlProc_setuid(0);
2343#endif
b28d0864 2344 (void)PerlProc_setuid(PL_uid);
75870ed3 2345 } else {
d8eceb89 2346 PL_uid = PerlProc_getuid();
cea2e8a9 2347 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2348 }
79072805
LW
2349#endif
2350#endif
85e6fe83 2351#endif
d8eceb89 2352 PL_uid = PerlProc_getuid();
3280af22 2353 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2354 break;
2355 case '>':
3280af22
NIS
2356 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2357 if (PL_delaymagic) {
2358 PL_delaymagic |= DM_EUID;
79072805
LW
2359 break; /* don't do magic till later */
2360 }
2361#ifdef HAS_SETEUID
3280af22 2362 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2363#else
2364#ifdef HAS_SETREUID
b28d0864 2365 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2366#else
2367#ifdef HAS_SETRESUID
6b88bc9c 2368 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2369#else
b28d0864
NIS
2370 if (PL_euid == PL_uid) /* special case $> = $< */
2371 PerlProc_setuid(PL_euid);
a0d0e21e 2372 else {
e8ee3774 2373 PL_euid = PerlProc_geteuid();
cea2e8a9 2374 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2375 }
79072805
LW
2376#endif
2377#endif
85e6fe83 2378#endif
d8eceb89 2379 PL_euid = PerlProc_geteuid();
3280af22 2380 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2381 break;
2382 case '(':
3280af22
NIS
2383 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2384 if (PL_delaymagic) {
2385 PL_delaymagic |= DM_RGID;
79072805
LW
2386 break; /* don't do magic till later */
2387 }
2388#ifdef HAS_SETRGID
b28d0864 2389 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2390#else
2391#ifdef HAS_SETREGID
3280af22 2392 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2393#else
2394#ifdef HAS_SETRESGID
b28d0864 2395 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2396#else
b28d0864
NIS
2397 if (PL_gid == PL_egid) /* special case $( = $) */
2398 (void)PerlProc_setgid(PL_gid);
748a9306 2399 else {
d8eceb89 2400 PL_gid = PerlProc_getgid();
cea2e8a9 2401 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2402 }
79072805
LW
2403#endif
2404#endif
85e6fe83 2405#endif
d8eceb89 2406 PL_gid = PerlProc_getgid();
3280af22 2407 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2408 break;
2409 case ')':
5cd24f17
PP
2410#ifdef HAS_SETGROUPS
2411 {
b83604b4 2412 const char *p = SvPV_const(sv, len);
5cd24f17
PP
2413 Groups_t gary[NGROUPS];
2414
5cd24f17
PP
2415 while (isSPACE(*p))
2416 ++p;
2d4389e4 2417 PL_egid = Atol(p);
5cd24f17
PP
2418 for (i = 0; i < NGROUPS; ++i) {
2419 while (*p && !isSPACE(*p))
2420 ++p;
2421 while (isSPACE(*p))
2422 ++p;
2423 if (!*p)
2424 break;
2d4389e4 2425 gary[i] = Atol(p);
5cd24f17 2426 }
8cc95fdb
PP
2427 if (i)
2428 (void)setgroups(i, gary);
5cd24f17
PP
2429 }
2430#else /* HAS_SETGROUPS */
b28d0864 2431 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
5cd24f17 2432#endif /* HAS_SETGROUPS */
3280af22
NIS
2433 if (PL_delaymagic) {
2434 PL_delaymagic |= DM_EGID;
79072805
LW
2435 break; /* don't do magic till later */
2436 }
2437#ifdef HAS_SETEGID
3280af22 2438 (void)setegid((Gid_t)PL_egid);
79072805
LW
2439#else
2440#ifdef HAS_SETREGID
b28d0864 2441 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2442#else
2443#ifdef HAS_SETRESGID
b28d0864 2444 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2445#else
b28d0864
NIS
2446 if (PL_egid == PL_gid) /* special case $) = $( */
2447 (void)PerlProc_setgid(PL_egid);
748a9306 2448 else {
d8eceb89 2449 PL_egid = PerlProc_getegid();
cea2e8a9 2450 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2451 }
79072805
LW
2452#endif
2453#endif
85e6fe83 2454#endif
d8eceb89 2455 PL_egid = PerlProc_getegid();
3280af22 2456 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2457 break;
2458 case ':':
2d8e6c8d 2459 PL_chopset = SvPV_force(sv,len);
79072805 2460 break;
cd39f2b6 2461#ifndef MACOS_TRADITIONAL
79072805 2462 case '0':
e2975953 2463 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2464#ifdef HAS_SETPROCTITLE
2465 /* The BSDs don't show the argv[] in ps(1) output, they
2466 * show a string from the process struct and provide
2467 * the setproctitle() routine to manipulate that. */
2468 {
b83604b4 2469 s = SvPV_const(sv, len);
98b76f99 2470# if __FreeBSD_version > 410001
9aad2c0e 2471 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2472 * but not the "(perl) suffix from the ps(1)
2473 * output, because that's what ps(1) shows if the
2474 * argv[] is modified. */
6f2ad931 2475 setproctitle("-%s", s);
9aad2c0e 2476# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2477 /* This doesn't really work if you assume that
2478 * $0 = 'foobar'; will wipe out 'perl' from the $0
2479 * because in ps(1) output the result will be like
2480 * sprintf("perl: %s (perl)", s)
2481 * I guess this is a security feature:
2482 * one (a user process) cannot get rid of the original name.
2483 * --jhi */
2484 setproctitle("%s", s);
2485# endif
2486 }
2487#endif
17aa7f3d
JH
2488#if defined(__hpux) && defined(PSTAT_SETCMD)
2489 {
2490 union pstun un;
b83604b4 2491 s = SvPV_const(sv, len);
6867be6d 2492 un.pst_command = (char *)s;
17aa7f3d
JH
2493 pstat(PSTAT_SETCMD, un, len, 0, 0);
2494 }
2495#endif
3cb9023d 2496 /* PL_origalen is set in perl_parse(). */
a0d0e21e 2497 s = SvPV_force(sv,len);
6f698202
AMS
2498 if (len >= (STRLEN)PL_origalen-1) {
2499 /* Longer than original, will be truncated. We assume that
2500 * PL_origalen bytes are available. */
2501 Copy(s, PL_origargv[0], PL_origalen-1, char);
79072805
LW
2502 }
2503 else {
54bfe034
JH
2504 /* Shorter than original, will be padded. */
2505 Copy(s, PL_origargv[0], len, char);
2506 PL_origargv[0][len] = 0;
2507 memset(PL_origargv[0] + len + 1,
2508 /* Is the space counterintuitive? Yes.
2509 * (You were expecting \0?)
3cb9023d 2510 * Does it work? Seems to. (In Linux 2.4.20 at least.)
54bfe034
JH
2511 * --jhi */
2512 (int)' ',
2513 PL_origalen - len - 1);
79072805 2514 }
ad7eccf4
JD
2515 PL_origargv[0][PL_origalen-1] = 0;
2516 for (i = 1; i < PL_origargc; i++)
2517 PL_origargv[i] = 0;
e2975953 2518 UNLOCK_DOLLARZERO_MUTEX;
79072805 2519 break;
cd39f2b6 2520#endif
79072805
LW
2521 }
2522 return 0;
2523}
2524
2525I32
35a4481c 2526Perl_whichsig(pTHX_ const char *sig)
79072805 2527{
aadb217d 2528 register char* const* sigv;
79072805 2529
aadb217d 2530 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2531 if (strEQ(sig,*sigv))
aadb217d 2532 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2533#ifdef SIGCLD
2534 if (strEQ(sig,"CHLD"))
2535 return SIGCLD;
2536#endif
2537#ifdef SIGCHLD
2538 if (strEQ(sig,"CLD"))
2539 return SIGCHLD;
2540#endif
7f1236c0 2541 return -1;
79072805
LW
2542}
2543
ecfc5424 2544Signal_t
cea2e8a9 2545Perl_sighandler(int sig)
79072805 2546{
1018e26f
NIS
2547#ifdef PERL_GET_SIG_CONTEXT
2548 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2549#else
cea2e8a9 2550 dTHX;
71d280e3 2551#endif
79072805 2552 dSP;
00d579c5 2553 GV *gv = Nullgv;
a0d0e21e 2554 HV *st;
b7953727 2555 SV *sv = Nullsv, *tSv = PL_Sv;
00d579c5 2556 CV *cv = Nullcv;
533c011a 2557 OP *myop = PL_op;
84902520 2558 U32 flags = 0;
3280af22 2559 XPV *tXpv = PL_Xpv;
71d280e3 2560
3280af22 2561 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2562 flags |= 1;
3280af22 2563 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2564 flags |= 4;
3280af22 2565 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2566 flags |= 16;
2567
727405f8 2568 if (!PL_psig_ptr[sig]) {
99ef548b 2569 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2570 PL_sig_name[sig]);
2571 exit(sig);
2572 }
ff0cee69 2573
84902520
TB
2574 /* Max number of items pushed there is 3*n or 4. We cannot fix
2575 infinity, so we fix 4 (in fact 5): */
2576 if (flags & 1) {
3280af22 2577 PL_savestack_ix += 5; /* Protect save in progress. */
c76ac1ee 2578 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
84902520 2579 }
ac27b0f5 2580 if (flags & 4)
3280af22 2581 PL_markstack_ptr++; /* Protect mark. */
84902520 2582 if (flags & 16)
3280af22 2583 PL_scopestack_ix += 1;
84902520 2584 /* sv_2cv is too complicated, try a simpler variant first: */
ac27b0f5 2585 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
84902520 2586 || SvTYPE(cv) != SVt_PVCV)
22c35a8c 2587 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
84902520 2588
a0d0e21e 2589 if (!cv || !CvROOT(cv)) {
599cee73 2590 if (ckWARN(WARN_SIGNAL))
9014280d 2591 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2592 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2593 : ((cv && CvGV(cv))
2594 ? GvENAME(CvGV(cv))
2595 : "__ANON__")));
2596 goto cleanup;
79072805
LW
2597 }
2598
22c35a8c
GS
2599 if(PL_psig_name[sig]) {
2600 sv = SvREFCNT_inc(PL_psig_name[sig]);
84902520 2601 flags |= 64;
df3728a2 2602#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2603 PL_sig_sv = sv;
df3728a2 2604#endif
84902520 2605 } else {
ff0cee69 2606 sv = sv_newmortal();
22c35a8c 2607 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2608 }
e336de0d 2609
e788e7d3 2610 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2611 PUSHMARK(SP);
79072805 2612 PUSHs(sv);
79072805 2613 PUTBACK;
a0d0e21e 2614
1b266415 2615 call_sv((SV*)cv, G_DISCARD|G_EVAL);
79072805 2616
d3acc0f7 2617 POPSTACK;
1b266415 2618 if (SvTRUE(ERRSV)) {
1d615522 2619#ifndef PERL_MICRO
983dbef6 2620#ifdef HAS_SIGPROCMASK
1b266415
NIS
2621 /* Handler "died", for example to get out of a restart-able read().
2622 * Before we re-do that on its behalf re-enable the signal which was
2623 * blocked by the system when we entered.
2624 */
2625 sigset_t set;
2626 sigemptyset(&set);
2627 sigaddset(&set,sig);
2628 sigprocmask(SIG_UNBLOCK, &set, NULL);
2629#else
2630 /* Not clear if this will work */
2631 (void)rsignal(sig, SIG_IGN);
5c1546dc 2632 (void)rsignal(sig, PL_csighandlerp);
1b266415 2633#endif
1d615522 2634#endif /* !PERL_MICRO */
5df617be 2635 DieNull;
1b266415 2636 }
00d579c5 2637cleanup:
84902520 2638 if (flags & 1)
3280af22 2639 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 2640 if (flags & 4)
3280af22 2641 PL_markstack_ptr--;
84902520 2642 if (flags & 16)
3280af22 2643 PL_scopestack_ix -= 1;
84902520
TB
2644 if (flags & 64)
2645 SvREFCNT_dec(sv);
533c011a 2646 PL_op = myop; /* Apparently not needed... */
ac27b0f5 2647
3280af22
NIS
2648 PL_Sv = tSv; /* Restore global temporaries. */
2649 PL_Xpv = tXpv;
53bb94e2 2650 return;
79072805 2651}
4e35701f
NIS
2652
2653
51371543 2654static void
35a4481c 2655restore_magic(pTHX_ const void *p)
51371543 2656{
48944bdf 2657 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
51371543
GS
2658 SV* sv = mgs->mgs_sv;
2659
2660 if (!sv)
2661 return;
2662
2663 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2664 {
f8c7b90f 2665#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
2666 /* While magic was saved (and off) sv_setsv may well have seen
2667 this SV as a prime candidate for COW. */
2668 if (SvIsCOW(sv))
2669 sv_force_normal(sv);
2670#endif
2671
51371543
GS
2672 if (mgs->mgs_flags)
2673 SvFLAGS(sv) |= mgs->mgs_flags;
2674 else
2675 mg_magical(sv);
2676 if (SvGMAGICAL(sv))
2677 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2678 }
2679
2680 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2681
2682 /* If we're still on top of the stack, pop us off. (That condition
2683 * will be satisfied if restore_magic was called explicitly, but *not*
2684 * if it's being called via leave_scope.)
2685 * The reason for doing this is that otherwise, things like sv_2cv()
2686 * may leave alloc gunk on the savestack, and some code
2687 * (e.g. sighandler) doesn't expect that...
2688 */
2689 if (PL_savestack_ix == mgs->mgs_ss_ix)
2690 {
2691 I32 popval = SSPOPINT;
c76ac1ee 2692 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
2693 PL_savestack_ix -= 2;
2694 popval = SSPOPINT;
2695 assert(popval == SAVEt_ALLOC);
2696 popval = SSPOPINT;
2697 PL_savestack_ix -= popval;
2698 }
2699
2700}
2701
2702static void
35a4481c 2703unwind_handler_stack(pTHX_ const void *p)
51371543 2704{
27da23d5 2705 dVAR;
e1ec3a88 2706 const U32 flags = *(const U32*)p;
51371543
GS
2707
2708 if (flags & 1)
2709 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2710 /* cxstack_ix-- Not needed, die already unwound it. */
df3728a2 2711#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 2712 if (flags & 64)
27da23d5 2713 SvREFCNT_dec(PL_sig_sv);
df3728a2 2714#endif
51371543 2715}
1018e26f 2716
66610fdd
RGS
2717/*
2718 * Local variables:
2719 * c-indentation-style: bsd
2720 * c-basic-offset: 4
2721 * indent-tabs-mode: t
2722 * End:
2723 *
37442d52
RGS
2724 * ex: set ts=8 sts=4 sw=4 noet:
2725 */