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