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