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