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