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