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