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