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