This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Simplify magic logic in av.c:av_store
[perl5.git] / mg.c
CommitLineData
a0d0e21e 1/* mg.c
79072805 2 *
1129b882
NC
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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/*
4ac71550
TC
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.
14 *
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
79072805
LW
16 */
17
ccfc67b7
JH
18/*
19=head1 Magical Functions
166f8a29
DM
20
21"Magic" is special data attached to SV structures in order to give them
22"magical" properties. When any Perl code tries to read from, or assign to,
23an SV marked as magical, it calls the 'get' or 'set' function associated
24with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 25give it a chance to update its internal value (get on $. writes the line
166f8a29
DM
26number of the last read filehandle into to the SV's IV slot), while
27set is called after an SV has been written to, in order to allow it to make
ddfa107c 28use of its changed value (set on $/ copies the SV's new value to the
166f8a29
DM
29PL_rs global variable).
30
31Magic is implemented as a linked list of MAGIC structures attached to the
32SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33of functions that implement the get(), set(), length() etc functions,
34plus space for some flags and pointers. For example, a tied variable has
35a MAGIC structure that contains a pointer to the object associated with the
36tie.
37
ccfc67b7
JH
38*/
39
79072805 40#include "EXTERN.h"
864dbfa3 41#define PERL_IN_MG_C
79072805
LW
42#include "perl.h"
43
5cd24f17 44#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
b7953727
JH
45# ifdef I_GRP
46# include <grp.h>
47# endif
188ea221
CS
48#endif
49
757f63d8
SP
50#if defined(HAS_SETGROUPS)
51# ifndef NGROUPS
52# define NGROUPS 32
53# endif
54#endif
55
17aa7f3d
JH
56#ifdef __hpux
57# include <sys/pstat.h>
58#endif
59
7636ea95
AB
60#ifdef HAS_PRCTL_SET_NAME
61# include <sys/prctl.h>
62#endif
63
8aad04aa 64#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 65Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
8aad04aa 66#else
e69880a5 67Signal_t Perl_csighandler(int sig);
8aad04aa 68#endif
e69880a5 69
9cffb111
OS
70#ifdef __Lynx__
71/* Missing protos on LynxOS */
72void setruid(uid_t id);
73void seteuid(uid_t id);
74void setrgid(uid_t id);
75void setegid(uid_t id);
76#endif
77
c07a80fd
PP
78/*
79 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
80 */
81
82struct magic_state {
83 SV* mgs_sv;
455ece5e 84 I32 mgs_ss_ix;
f9c6fee5
CS
85 U32 mgs_magical;
86 bool mgs_readonly;
150b625d 87 bool mgs_bumped;
c07a80fd 88};
455ece5e 89/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS
90
91STATIC void
8fb26106 92S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
c07a80fd 93{
97aff369 94 dVAR;
455ece5e 95 MGS* mgs;
150b625d 96 bool bumped = FALSE;
7918f24d
NC
97
98 PERL_ARGS_ASSERT_SAVE_MAGIC;
99
150b625d
DM
100 /* we shouldn't really be called here with RC==0, but it can sometimes
101 * happen via mg_clear() (which also shouldn't be called when RC==0,
102 * but it can happen). Handle this case gracefully(ish) by not RC++
103 * and thus avoiding the resultant double free */
104 if (SvREFCNT(sv) > 0) {
105 /* guard against sv getting freed midway through the mg clearing,
106 * by holding a private reference for the duration. */
107 SvREFCNT_inc_simple_void_NN(sv);
108 bumped = TRUE;
109 }
8985fe98 110
c07a80fd 111 assert(SvMAGICAL(sv));
d8b2590f
NC
112 /* Turning READONLY off for a copy-on-write scalar (including shared
113 hash keys) is a bad idea. */
765f542d 114 if (SvIsCOW(sv))
9a265e59 115 sv_force_normal_flags(sv, 0);
c07a80fd 116
8772537c 117 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD
118
119 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd 120 mgs->mgs_sv = sv;
f9c6fee5
CS
121 mgs->mgs_magical = SvMAGICAL(sv);
122 mgs->mgs_readonly = SvREADONLY(sv) != 0;
455ece5e 123 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
150b625d 124 mgs->mgs_bumped = bumped;
c07a80fd
PP
125
126 SvMAGICAL_off(sv);
127 SvREADONLY_off(sv);
085bde85
NC
128 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
129 /* No public flags are set, so promote any private flags to public. */
130 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
131 }
c07a80fd
PP
132}
133
954c1994
GS
134/*
135=for apidoc mg_magical
136
137Turns on the magical status of an SV. See C<sv_magic>.
138
139=cut
140*/
141
8990e307 142void
864dbfa3 143Perl_mg_magical(pTHX_ SV *sv)
8990e307 144{
e1ec3a88 145 const MAGIC* mg;
7918f24d 146 PERL_ARGS_ASSERT_MG_MAGICAL;
96a5add6 147 PERL_UNUSED_CONTEXT;
f9c6fee5
CS
148
149 SvMAGICAL_off(sv);
218787bd 150 if ((mg = SvMAGIC(sv))) {
218787bd
VP
151 do {
152 const MGVTBL* const vtbl = mg->mg_virtual;
153 if (vtbl) {
154 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
155 SvGMAGICAL_on(sv);
156 if (vtbl->svt_set)
157 SvSMAGICAL_on(sv);
158 if (vtbl->svt_clear)
159 SvRMAGICAL_on(sv);
160 }
161 } while ((mg = mg->mg_moremagic));
162 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
163 SvRMAGICAL_on(sv);
8990e307
LW
164 }
165}
166
954c1994
GS
167/*
168=for apidoc mg_get
169
170Do magic after a value is retrieved from the SV. See C<sv_magic>.
171
172=cut
173*/
174
79072805 175int
864dbfa3 176Perl_mg_get(pTHX_ SV *sv)
79072805 177{
97aff369 178 dVAR;
35a4481c 179 const I32 mgs_ix = SSNEW(sizeof(MGS));
f9c6fee5 180 bool have_new = 0;
ff76feab 181 MAGIC *newmg, *head, *cur, *mg;
6683b158 182
7918f24d
NC
183 PERL_ARGS_ASSERT_MG_GET;
184
407287f9
FC
185 if (PL_localizing == 1 && sv == DEFSV) return 0;
186
455ece5e 187 save_magic(mgs_ix, sv);
463ee0b2 188
ff76feab
AMS
189 /* We must call svt_get(sv, mg) for each valid entry in the linked
190 list of magic. svt_get() may delete the current entry, add new
191 magic to the head of the list, or upgrade the SV. AMS 20010810 */
192
193 newmg = cur = head = mg = SvMAGIC(sv);
194 while (mg) {
35a4481c 195 const MGVTBL * const vtbl = mg->mg_virtual;
f9c6fee5 196 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
ff76feab 197
2b260de0 198 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
16c91539 199 vtbl->svt_get(aTHX_ sv, mg);
b77f7d40 200
58f82c5c
DM
201 /* guard against magic having been deleted - eg FETCH calling
202 * untie */
f9c6fee5
CS
203 if (!SvMAGIC(sv)) {
204 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
58f82c5c 205 break;
f9c6fee5 206 }
b77f7d40 207
f9c6fee5 208 /* recalculate flags if this entry was deleted. */
ff76feab 209 if (mg->mg_flags & MGf_GSKIP)
f9c6fee5 210 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
a0d0e21e 211 }
ff76feab 212
f9c6fee5 213 mg = nextmg;
ff76feab 214
0723351e 215 if (have_new) {
ff76feab
AMS
216 /* Have we finished with the new entries we saw? Start again
217 where we left off (unless there are more new entries). */
218 if (mg == head) {
0723351e 219 have_new = 0;
ff76feab
AMS
220 mg = cur;
221 head = newmg;
222 }
223 }
224
225 /* Were any new entries added? */
0723351e
NC
226 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
227 have_new = 1;
ff76feab
AMS
228 cur = mg;
229 mg = newmg;
f9c6fee5 230 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
760ac839 231 }
79072805 232 }
463ee0b2 233
8772537c 234 restore_magic(INT2PTR(void *, (IV)mgs_ix));
79072805
LW
235 return 0;
236}
237
954c1994
GS
238/*
239=for apidoc mg_set
240
241Do magic after a value is assigned to the SV. See C<sv_magic>.
242
243=cut
244*/
245
79072805 246int
864dbfa3 247Perl_mg_set(pTHX_ SV *sv)
79072805 248{
97aff369 249 dVAR;
35a4481c 250 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 251 MAGIC* mg;
463ee0b2
LW
252 MAGIC* nextmg;
253
7918f24d
NC
254 PERL_ARGS_ASSERT_MG_SET;
255
b5ed8c44
FC
256 if (PL_localizing == 2 && sv == DEFSV) return 0;
257
455ece5e 258 save_magic(mgs_ix, sv);
463ee0b2
LW
259
260 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 261 const MGVTBL* vtbl = mg->mg_virtual;
463ee0b2 262 nextmg = mg->mg_moremagic; /* it may delete itself */
a0d0e21e
LW
263 if (mg->mg_flags & MGf_GSKIP) {
264 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
f9c6fee5 265 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
a0d0e21e 266 }
e0a73de4 267 if (PL_localizing == 2
b5ed8c44 268 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
e7cbf6c6 269 continue;
2b260de0 270 if (vtbl && vtbl->svt_set)
16c91539 271 vtbl->svt_set(aTHX_ sv, mg);
79072805 272 }
463ee0b2 273
8772537c 274 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW
275 return 0;
276}
277
954c1994
GS
278/*
279=for apidoc mg_length
280
281Report on the SV's length. See C<sv_magic>.
282
283=cut
284*/
285
79072805 286U32
864dbfa3 287Perl_mg_length(pTHX_ SV *sv)
79072805 288{
97aff369 289 dVAR;
79072805 290 MAGIC* mg;
463ee0b2 291 STRLEN len;
463ee0b2 292
7918f24d
NC
293 PERL_ARGS_ASSERT_MG_LENGTH;
294
79072805 295 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 296 const MGVTBL * const vtbl = mg->mg_virtual;
2b260de0 297 if (vtbl && vtbl->svt_len) {
35a4481c 298 const I32 mgs_ix = SSNEW(sizeof(MGS));
455ece5e 299 save_magic(mgs_ix, sv);
a0d0e21e 300 /* omit MGf_GSKIP -- not changed here */
16c91539 301 len = vtbl->svt_len(aTHX_ sv, mg);
8772537c 302 restore_magic(INT2PTR(void*, (IV)mgs_ix));
85e6fe83
LW
303 return len;
304 }
305 }
306
d0644529
NC
307 {
308 /* You can't know whether it's UTF-8 until you get the string again...
309 */
10516c54 310 const U8 *s = (U8*)SvPV_const(sv, len);
d0644529
NC
311
312 if (DO_UTF8(sv)) {
313 len = utf8_length(s, s + len);
314 }
5636d518 315 }
463ee0b2 316 return len;
79072805
LW
317}
318
8fb26106 319I32
864dbfa3 320Perl_mg_size(pTHX_ SV *sv)
93965878
NIS
321{
322 MAGIC* mg;
ac27b0f5 323
7918f24d
NC
324 PERL_ARGS_ASSERT_MG_SIZE;
325
93965878 326 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 327 const MGVTBL* const vtbl = mg->mg_virtual;
2b260de0 328 if (vtbl && vtbl->svt_len) {
35a4481c
AL
329 const I32 mgs_ix = SSNEW(sizeof(MGS));
330 I32 len;
455ece5e 331 save_magic(mgs_ix, sv);
93965878 332 /* omit MGf_GSKIP -- not changed here */
16c91539 333 len = vtbl->svt_len(aTHX_ sv, mg);
8772537c 334 restore_magic(INT2PTR(void*, (IV)mgs_ix));
93965878
NIS
335 return len;
336 }
337 }
338
339 switch(SvTYPE(sv)) {
340 case SVt_PVAV:
502c6561 341 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
93965878
NIS
342 case SVt_PVHV:
343 /* FIXME */
344 default:
cea2e8a9 345 Perl_croak(aTHX_ "Size magic not implemented");
93965878
NIS
346 break;
347 }
348 return 0;
349}
350
954c1994
GS
351/*
352=for apidoc mg_clear
353
354Clear something magical that the SV represents. See C<sv_magic>.
355
356=cut
357*/
358
79072805 359int
864dbfa3 360Perl_mg_clear(pTHX_ SV *sv)
79072805 361{
35a4481c 362 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 363 MAGIC* mg;
8ac77ac9 364 MAGIC *nextmg;
463ee0b2 365
7918f24d
NC
366 PERL_ARGS_ASSERT_MG_CLEAR;
367
455ece5e 368 save_magic(mgs_ix, sv);
463ee0b2 369
8ac77ac9 370 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
35a4481c 371 const MGVTBL* const vtbl = mg->mg_virtual;
a0d0e21e 372 /* omit GSKIP -- never set here */
727405f8 373
8ac77ac9
NC
374 nextmg = mg->mg_moremagic; /* it may delete itself */
375
2b260de0 376 if (vtbl && vtbl->svt_clear)
16c91539 377 vtbl->svt_clear(aTHX_ sv, mg);
79072805 378 }
463ee0b2 379
8772537c 380 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW
381 return 0;
382}
383
ed624ca8 384static MAGIC*
39de7f53
FR
385S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
386{
387 PERL_UNUSED_CONTEXT;
388
389 assert(flags <= 1);
390
391 if (sv) {
392 MAGIC *mg;
393
394 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
395 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
396 return mg;
397 }
398 }
399 }
400
401 return NULL;
402}
403
954c1994
GS
404/*
405=for apidoc mg_find
406
407Finds the magic pointer for type matching the SV. See C<sv_magic>.
408
409=cut
410*/
411
93a17b20 412MAGIC*
35a4481c 413Perl_mg_find(pTHX_ const SV *sv, int type)
93a17b20 414{
39de7f53
FR
415 return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
416}
417
418/*
419=for apidoc mg_findext
420
421Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
422C<sv_magicext>.
423
424=cut
425*/
426
427MAGIC*
428Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
429{
430 return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
93a17b20
LW
431}
432
954c1994
GS
433/*
434=for apidoc mg_copy
435
436Copies the magic from one SV to another. See C<sv_magic>.
437
438=cut
439*/
440
79072805 441int
864dbfa3 442Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 443{
463ee0b2 444 int count = 0;
79072805 445 MAGIC* mg;
7918f24d
NC
446
447 PERL_ARGS_ASSERT_MG_COPY;
448
463ee0b2 449 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 450 const MGVTBL* const vtbl = mg->mg_virtual;
68795e93 451 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
16c91539 452 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
68795e93 453 }
823a54a3
AL
454 else {
455 const char type = mg->mg_type;
1e73acc8 456 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
823a54a3
AL
457 sv_magic(nsv,
458 (type == PERL_MAGIC_tied)
459 ? SvTIED_obj(sv, mg)
460 : (type == PERL_MAGIC_regdata && mg->mg_obj)
461 ? sv
462 : mg->mg_obj,
463 toLOWER(type), key, klen);
464 count++;
465 }
79072805 466 }
79072805 467 }
463ee0b2 468 return count;
79072805
LW
469}
470
954c1994 471/*
0cbee0a4
DM
472=for apidoc mg_localize
473
9711599e
CS
474Copy some of the magic from an existing SV to new localized version of that
475SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
476taint, pos).
477
af7df257 478If setmagic is false then no set magic will be called on the new (empty) SV.
9711599e
CS
479This typically means that assignment will soon follow (e.g. 'local $x = $y'),
480and that will handle the magic.
0cbee0a4
DM
481
482=cut
483*/
484
485void
af7df257 486Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
0cbee0a4 487{
97aff369 488 dVAR;
0cbee0a4 489 MAGIC *mg;
7918f24d
NC
490
491 PERL_ARGS_ASSERT_MG_LOCALIZE;
492
658a9f31
JD
493 if (nsv == DEFSV)
494 return;
495
0cbee0a4 496 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
2b1b43ea 497 const MGVTBL* const vtbl = mg->mg_virtual;
e0a73de4 498 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
0cbee0a4 499 continue;
0cbee0a4 500
a5063e7c 501 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
16c91539 502 (void)vtbl->svt_local(aTHX_ nsv, mg);
a5063e7c 503 else
0cbee0a4
DM
504 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
505 mg->mg_ptr, mg->mg_len);
a5063e7c 506
0cbee0a4 507 /* container types should remain read-only across localization */
b2b95e4c 508 if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv);
0cbee0a4
DM
509 }
510
511 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
512 SvFLAGS(nsv) |= SvMAGICAL(sv);
af7df257 513 if (setmagic) {
9711599e
CS
514 PL_localizing = 1;
515 SvSETMAGIC(nsv);
516 PL_localizing = 0;
517 }
0cbee0a4
DM
518 }
519}
520
d9088386
Z
521#define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
522static void
523S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
524{
525 const MGVTBL* const vtbl = mg->mg_virtual;
526 if (vtbl && vtbl->svt_free)
527 vtbl->svt_free(aTHX_ sv, mg);
528 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
529 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
530 Safefree(mg->mg_ptr);
531 else if (mg->mg_len == HEf_SVKEY)
532 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
533 }
534 if (mg->mg_flags & MGf_REFCOUNTED)
535 SvREFCNT_dec(mg->mg_obj);
536 Safefree(mg);
537}
538
0cbee0a4 539/*
954c1994
GS
540=for apidoc mg_free
541
542Free any magic storage used by the SV. See C<sv_magic>.
543
544=cut
545*/
546
79072805 547int
864dbfa3 548Perl_mg_free(pTHX_ SV *sv)
79072805
LW
549{
550 MAGIC* mg;
551 MAGIC* moremagic;
7918f24d
NC
552
553 PERL_ARGS_ASSERT_MG_FREE;
554
79072805 555 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
79072805 556 moremagic = mg->mg_moremagic;
d9088386 557 mg_free_struct(sv, mg);
c826f41b 558 SvMAGIC_set(sv, moremagic);
79072805 559 }
b162af07 560 SvMAGIC_set(sv, NULL);
68f8932e 561 SvMAGICAL_off(sv);
79072805
LW
562 return 0;
563}
564
d9088386
Z
565/*
566=for apidoc Am|void|mg_free_type|SV *sv|int how
567
568Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
569
570=cut
571*/
572
573void
574Perl_mg_free_type(pTHX_ SV *sv, int how)
575{
576 MAGIC *mg, *prevmg, *moremg;
577 PERL_ARGS_ASSERT_MG_FREE_TYPE;
578 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
579 MAGIC *newhead;
580 moremg = mg->mg_moremagic;
581 if (mg->mg_type == how) {
582 /* temporarily move to the head of the magic chain, in case
583 custom free code relies on this historical aspect of mg_free */
584 if (prevmg) {
585 prevmg->mg_moremagic = moremg;
586 mg->mg_moremagic = SvMAGIC(sv);
587 SvMAGIC_set(sv, mg);
588 }
589 newhead = mg->mg_moremagic;
590 mg_free_struct(sv, mg);
591 SvMAGIC_set(sv, newhead);
592 mg = prevmg;
593 }
594 }
595 mg_magical(sv);
596}
597
79072805 598#include <signal.h>
79072805 599
942e002e 600U32
864dbfa3 601Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 602{
97aff369 603 dVAR;
8772537c 604 PERL_UNUSED_ARG(sv);
6cef1e77 605
7918f24d
NC
606 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
607
0bd48802
AL
608 if (PL_curpm) {
609 register const REGEXP * const rx = PM_GETRE(PL_curpm);
610 if (rx) {
a678b0e4
YO
611 if (mg->mg_obj) { /* @+ */
612 /* return the number possible */
07bc277f 613 return RX_NPARENS(rx);
a678b0e4 614 } else { /* @- */
07bc277f 615 I32 paren = RX_LASTPAREN(rx);
a678b0e4
YO
616
617 /* return the last filled */
f46c4081 618 while ( paren >= 0
07bc277f
NC
619 && (RX_OFFS(rx)[paren].start == -1
620 || RX_OFFS(rx)[paren].end == -1) )
f46c4081 621 paren--;
a678b0e4
YO
622 return (U32)paren;
623 }
0bd48802 624 }
8f580fb8 625 }
ac27b0f5 626
942e002e 627 return (U32)-1;
6cef1e77
IZ
628}
629
630int
864dbfa3 631Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 632{
97aff369 633 dVAR;
7918f24d
NC
634
635 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
636
0bd48802
AL
637 if (PL_curpm) {
638 register const REGEXP * const rx = PM_GETRE(PL_curpm);
639 if (rx) {
640 register const I32 paren = mg->mg_len;
641 register I32 s;
642 register I32 t;
643 if (paren < 0)
644 return 0;
07bc277f
NC
645 if (paren <= (I32)RX_NPARENS(rx) &&
646 (s = RX_OFFS(rx)[paren].start) != -1 &&
647 (t = RX_OFFS(rx)[paren].end) != -1)
0bd48802
AL
648 {
649 register I32 i;
650 if (mg->mg_obj) /* @+ */
651 i = t;
652 else /* @- */
653 i = s;
654
655 if (i > 0 && RX_MATCH_UTF8(rx)) {
07bc277f 656 const char * const b = RX_SUBBEG(rx);
0bd48802 657 if (b)
f5a63d97 658 i = utf8_length((U8*)b, (U8*)(b+i));
0bd48802 659 }
727405f8 660
0bd48802 661 sv_setiv(sv, i);
1aa99e6b 662 }
0bd48802 663 }
6cef1e77
IZ
664 }
665 return 0;
666}
667
e4b89193 668int
a29d06ed
MG
669Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
670{
7918f24d 671 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
d4c19fe8
AL
672 PERL_UNUSED_ARG(sv);
673 PERL_UNUSED_ARG(mg);
6ad8f254 674 Perl_croak_no_modify(aTHX);
0dbb1585 675 NORETURN_FUNCTION_END;
a29d06ed
MG
676}
677
93a17b20 678U32
864dbfa3 679Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
93a17b20 680{
97aff369 681 dVAR;
93a17b20 682 register I32 paren;
93a17b20 683 register I32 i;
2fdbfb4d
AB
684 register const REGEXP * rx;
685 const char * const remaining = mg->mg_ptr + 1;
93a17b20 686
7918f24d
NC
687 PERL_ARGS_ASSERT_MAGIC_LEN;
688
93a17b20 689 switch (*mg->mg_ptr) {
2fdbfb4d
AB
690 case '\020':
691 if (*remaining == '\0') { /* ^P */
692 break;
693 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
694 goto do_prematch;
695 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
696 goto do_postmatch;
697 }
698 break;
699 case '\015': /* $^MATCH */
700 if (strEQ(remaining, "ATCH")) {
701 goto do_match;
702 } else {
703 break;
704 }
705 case '`':
706 do_prematch:
f1b875a0 707 paren = RX_BUFF_IDX_PREMATCH;
2fdbfb4d
AB
708 goto maybegetparen;
709 case '\'':
710 do_postmatch:
f1b875a0 711 paren = RX_BUFF_IDX_POSTMATCH;
2fdbfb4d
AB
712 goto maybegetparen;
713 case '&':
714 do_match:
f1b875a0 715 paren = RX_BUFF_IDX_FULLMATCH;
2fdbfb4d 716 goto maybegetparen;
93a17b20 717 case '1': case '2': case '3': case '4':
2fdbfb4d
AB
718 case '5': case '6': case '7': case '8': case '9':
719 paren = atoi(mg->mg_ptr);
720 maybegetparen:
aaa362c4 721 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2fdbfb4d
AB
722 getparen:
723 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
cf93c79d 724
ffc61ed2 725 if (i < 0)
0844c848 726 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
ffc61ed2 727 return i;
2fdbfb4d 728 } else {
235bddc8 729 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 730 report_uninit(sv);
2fdbfb4d 731 return 0;
93a17b20 732 }
93a17b20 733 case '+':
aaa362c4 734 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
07bc277f 735 paren = RX_LASTPAREN(rx);
13f57bf8
CS
736 if (paren)
737 goto getparen;
93a17b20 738 }
748a9306 739 return 0;
a01268b5
JH
740 case '\016': /* ^N */
741 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
07bc277f 742 paren = RX_LASTCLOSEPAREN(rx);
a01268b5
JH
743 if (paren)
744 goto getparen;
745 }
746 return 0;
93a17b20
LW
747 }
748 magic_get(sv,mg);
2d8e6c8d 749 if (!SvPOK(sv) && SvNIOK(sv)) {
8b6b16e7 750 sv_2pv(sv, 0);
2d8e6c8d 751 }
93a17b20
LW
752 if (SvPOK(sv))
753 return SvCUR(sv);
754 return 0;
755}
756
ad3296c6 757#define SvRTRIM(sv) STMT_START { \
eae92ea0
GA
758 if (SvPOK(sv)) { \
759 STRLEN len = SvCUR(sv); \
760 char * const p = SvPVX(sv); \
8e6b4db6
PC
761 while (len > 0 && isSPACE(p[len-1])) \
762 --len; \
763 SvCUR_set(sv, len); \
764 p[len] = '\0'; \
765 } \
ad3296c6
SH
766} STMT_END
767
8b850bd5
NC
768void
769Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
770{
7918f24d
NC
771 PERL_ARGS_ASSERT_EMULATE_COP_IO;
772
8b850bd5
NC
773 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
774 sv_setsv(sv, &PL_sv_undef);
775 else {
776 sv_setpvs(sv, "");
777 SvUTF8_off(sv);
778 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
20439bc7 779 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
8b850bd5
NC
780 assert(value);
781 sv_catsv(sv, value);
782 }
783 sv_catpvs(sv, "\0");
784 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
20439bc7 785 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
8b850bd5
NC
786 assert(value);
787 sv_catsv(sv, value);
788 }
789 }
790}
791
79072805 792int
864dbfa3 793Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 794{
27da23d5 795 dVAR;
79072805 796 register I32 paren;
db7198b5 797 register const char *s = NULL;
d9f97599 798 register REGEXP *rx;
823a54a3
AL
799 const char * const remaining = mg->mg_ptr + 1;
800 const char nextchar = *remaining;
79072805 801
7918f24d
NC
802 PERL_ARGS_ASSERT_MAGIC_GET;
803
79072805 804 switch (*mg->mg_ptr) {
748a9306 805 case '\001': /* ^A */
3280af22 806 sv_setsv(sv, PL_bodytarget);
125b9982
NT
807 if (SvTAINTED(PL_bodytarget))
808 SvTAINTED_on(sv);
748a9306 809 break;
e5218da5 810 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
823a54a3 811 if (nextchar == '\0') {
e5218da5
GA
812 sv_setiv(sv, (IV)PL_minus_c);
813 }
823a54a3 814 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
e5218da5
GA
815 sv_setiv(sv, (IV)STATUS_NATIVE);
816 }
49460fe6
NIS
817 break;
818
79072805 819 case '\004': /* ^D */
aea4f609 820 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
79072805 821 break;
28f23441 822 case '\005': /* ^E */
823a54a3 823 if (nextchar == '\0') {
e37778c2 824#if defined(VMS)
0a378802
JH
825 {
826# include <descrip.h>
827# include <starlet.h>
828 char msg[255];
829 $DESCRIPTOR(msgdsc,msg);
830 sv_setnv(sv,(NV) vaxc$errno);
831 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
832 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
833 else
76f68e9b 834 sv_setpvs(sv,"");
0a378802 835 }
4b645107 836#elif defined(OS2)
0a378802
JH
837 if (!(_emx_env & 0x200)) { /* Under DOS */
838 sv_setnv(sv, (NV)errno);
839 sv_setpv(sv, errno ? Strerror(errno) : "");
840 } else {
841 if (errno != errno_isOS2) {
823a54a3 842 const int tmp = _syserrno();
0a378802
JH
843 if (tmp) /* 2nd call to _syserrno() makes it 0 */
844 Perl_rc = tmp;
845 }
846 sv_setnv(sv, (NV)Perl_rc);
847 sv_setpv(sv, os2error(Perl_rc));
848 }
4b645107 849#elif defined(WIN32)
0a378802 850 {
d4c19fe8 851 const DWORD dwErr = GetLastError();
0a378802 852 sv_setnv(sv, (NV)dwErr);
823a54a3 853 if (dwErr) {
0a378802
JH
854 PerlProc_GetOSError(sv, dwErr);
855 }
856 else
76f68e9b 857 sv_setpvs(sv, "");
0a378802
JH
858 SetLastError(dwErr);
859 }
22fae026 860#else
f6c8f21d 861 {
4ee39169 862 dSAVE_ERRNO;
f6c8f21d 863 sv_setnv(sv, (NV)errno);
666ea192 864 sv_setpv(sv, errno ? Strerror(errno) : "");
4ee39169 865 RESTORE_ERRNO;
f6c8f21d 866 }
28f23441 867#endif
ad3296c6 868 SvRTRIM(sv);
0a378802
JH
869 SvNOK_on(sv); /* what a wonderful hack! */
870 }
823a54a3 871 else if (strEQ(remaining, "NCODING"))
0a378802
JH
872 sv_setsv(sv, PL_encoding);
873 break;
79072805 874 case '\006': /* ^F */
3280af22 875 sv_setiv(sv, (IV)PL_maxsysfd);
79072805 876 break;
9ebf26ad
FR
877 case '\007': /* ^GLOBAL_PHASE */
878 if (strEQ(remaining, "LOBAL_PHASE")) {
879 sv_setpvn(sv, PL_phase_names[PL_phase],
880 strlen(PL_phase_names[PL_phase]));
881 }
882 break;
a0d0e21e 883 case '\010': /* ^H */
3280af22 884 sv_setiv(sv, (IV)PL_hints);
a0d0e21e 885 break;
9d116dd7 886 case '\011': /* ^I */ /* NOT \t in EBCDIC */
120f7abe 887 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
79072805 888 break;
ac27b0f5 889 case '\017': /* ^O & ^OPEN */
823a54a3 890 if (nextchar == '\0') {
ac27b0f5 891 sv_setpv(sv, PL_osname);
3511154c
DM
892 SvTAINTED_off(sv);
893 }
823a54a3 894 else if (strEQ(remaining, "PEN")) {
8b850bd5 895 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
ac27b0f5 896 }
28f23441 897 break;
9ebf26ad 898 case '\020':
cde0cee5
YO
899 if (nextchar == '\0') { /* ^P */
900 sv_setiv(sv, (IV)PL_perldb);
901 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
902 goto do_prematch_fetch;
903 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
904 goto do_postmatch_fetch;
905 }
79072805 906 break;
fb73857a 907 case '\023': /* ^S */
823a54a3 908 if (nextchar == '\0') {
bc177e6b 909 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
0c34ef67 910 SvOK_off(sv);
3280af22 911 else if (PL_in_eval)
6dc8a9e4 912 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
a4268c0a
AMS
913 else
914 sv_setiv(sv, 0);
d58bf5aa 915 }
fb73857a 916 break;
79072805 917 case '\024': /* ^T */
823a54a3 918 if (nextchar == '\0') {
88e89b8a 919#ifdef BIG_TIME
7c36658b 920 sv_setnv(sv, PL_basetime);
88e89b8a 921#else
7c36658b 922 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 923#endif
7c36658b 924 }
823a54a3 925 else if (strEQ(remaining, "AINT"))
9aa05f58
RGS
926 sv_setiv(sv, PL_tainting
927 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
928 : 0);
7c36658b 929 break;
e07ea26a 930 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
823a54a3 931 if (strEQ(remaining, "NICODE"))
a05d7ebb 932 sv_setuv(sv, (UV) PL_unicode);
823a54a3 933 else if (strEQ(remaining, "TF8LOCALE"))
7cebcbc0 934 sv_setuv(sv, (UV) PL_utf8locale);
e07ea26a
NC
935 else if (strEQ(remaining, "TF8CACHE"))
936 sv_setiv(sv, (IV) PL_utf8cache);
fde18df1
JH
937 break;
938 case '\027': /* ^W & $^WARNING_BITS */
823a54a3 939 if (nextchar == '\0')
4438c4b7 940 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
823a54a3 941 else if (strEQ(remaining, "ARNING_BITS")) {
013b78e8 942 if (PL_compiling.cop_warnings == pWARN_NONE) {
4438c4b7 943 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
013b78e8
RGS
944 }
945 else if (PL_compiling.cop_warnings == pWARN_STD) {
666ea192
JH
946 sv_setpvn(
947 sv,
948 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
949 WARNsize
950 );
013b78e8 951 }
d3a7d8c7 952 else if (PL_compiling.cop_warnings == pWARN_ALL) {
75b6c4ca
RGS
953 /* Get the bit mask for $warnings::Bits{all}, because
954 * it could have been extended by warnings::register */
6673a63c 955 HV * const bits=get_hv("warnings::Bits", 0);
f5a63d97
AL
956 if (bits) {
957 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
958 if (bits_all)
959 sv_setsv(sv, *bits_all);
75b6c4ca
RGS
960 }
961 else {
962 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
963 }
ac27b0f5 964 }
4438c4b7 965 else {
72dc9ed5
NC
966 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
967 *PL_compiling.cop_warnings);
ac27b0f5 968 }
d3a7d8c7 969 SvPOK_only(sv);
4438c4b7 970 }
79072805 971 break;
cde0cee5
YO
972 case '\015': /* $^MATCH */
973 if (strEQ(remaining, "ATCH")) {
79072805
LW
974 case '1': case '2': case '3': case '4':
975 case '5': case '6': case '7': case '8': case '9': case '&':
cde0cee5
YO
976 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
977 /*
159b6efe 978 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
cde0cee5
YO
979 * XXX Does the new way break anything?
980 */
981 paren = atoi(mg->mg_ptr); /* $& is in [0] */
2fdbfb4d 982 CALLREG_NUMBUF_FETCH(rx,paren,sv);
cde0cee5
YO
983 break;
984 }
985 sv_setsv(sv,&PL_sv_undef);
79072805
LW
986 }
987 break;
988 case '+':
aaa362c4 989 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
07bc277f
NC
990 if (RX_LASTPAREN(rx)) {
991 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
44a2ac75
YO
992 break;
993 }
79072805 994 }
3280af22 995 sv_setsv(sv,&PL_sv_undef);
79072805 996 break;
a01268b5
JH
997 case '\016': /* ^N */
998 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
07bc277f
NC
999 if (RX_LASTCLOSEPAREN(rx)) {
1000 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
44a2ac75
YO
1001 break;
1002 }
1003
a01268b5
JH
1004 }
1005 sv_setsv(sv,&PL_sv_undef);
1006 break;
79072805 1007 case '`':
cde0cee5 1008 do_prematch_fetch:
aaa362c4 1009 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2fdbfb4d 1010 CALLREG_NUMBUF_FETCH(rx,-2,sv);
93b32b6d 1011 break;
79072805 1012 }
3280af22 1013 sv_setsv(sv,&PL_sv_undef);
79072805
LW
1014 break;
1015 case '\'':
cde0cee5 1016 do_postmatch_fetch:
aaa362c4 1017 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2fdbfb4d 1018 CALLREG_NUMBUF_FETCH(rx,-1,sv);
93b32b6d 1019 break;
79072805 1020 }
3280af22 1021 sv_setsv(sv,&PL_sv_undef);
79072805
LW
1022 break;
1023 case '.':
3280af22 1024 if (GvIO(PL_last_in_gv)) {
357c8808 1025 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
79072805 1026 }
79072805
LW
1027 break;
1028 case '?':
809a5acc 1029 {
809a5acc 1030 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 1031#ifdef COMPLEX_STATUS
41cb7b2b 1032 SvUPGRADE(sv, SVt_PVLV);
6b88bc9c
GS
1033 LvTARGOFF(sv) = PL_statusvalue;
1034 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 1035#endif
809a5acc 1036 }
79072805
LW
1037 break;
1038 case '^':
acbe1b9d 1039 if (GvIOp(PL_defoutgv))
099be4f1 1040 s = IoTOP_NAME(GvIOp(PL_defoutgv));
79072805
LW
1041 if (s)
1042 sv_setpv(sv,s);
1043 else {
3280af22 1044 sv_setpv(sv,GvENAME(PL_defoutgv));
cb421d5e 1045 sv_catpvs(sv,"_TOP");
79072805
LW
1046 }
1047 break;
1048 case '~':
acbe1b9d 1049 if (GvIOp(PL_defoutgv))
0daa599b 1050 s = IoFMT_NAME(GvIOp(PL_defoutgv));
79072805 1051 if (!s)
3280af22 1052 s = GvENAME(PL_defoutgv);
79072805
LW
1053 sv_setpv(sv,s);
1054 break;
79072805 1055 case '=':
099be4f1 1056 if (GvIO(PL_defoutgv))
0daa599b 1057 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
79072805
LW
1058 break;
1059 case '-':
099be4f1 1060 if (GvIO(PL_defoutgv))
0daa599b 1061 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
79072805
LW
1062 break;
1063 case '%':
099be4f1 1064 if (GvIO(PL_defoutgv))
0daa599b 1065 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
79072805 1066 break;
79072805
LW
1067 case ':':
1068 break;
1069 case '/':
1070 break;
1071 case '[':
e1dccc0d 1072 sv_setiv(sv, 0);
79072805
LW
1073 break;
1074 case '|':
099be4f1 1075 if (GvIO(PL_defoutgv))
0daa599b 1076 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
79072805 1077 break;
79072805 1078 case '\\':
b2ce0fda 1079 if (PL_ors_sv)
f28098ff 1080 sv_copypv(sv, PL_ors_sv);
79072805 1081 break;
0e219455 1082 case '$': /* $$ */
9cdac2a2
FC
1083 {
1084 IV const pid = (IV)PerlProc_getpid();
1085 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid)
1086 /* never set manually, or at least not since last fork */
1087 sv_setiv(sv, pid);
1088 /* else a value has been assigned manually, so do nothing */
1089 }
0e219455
MM
1090 break;
1091
79072805 1092 case '!':
666d8aa2
CB
1093 {
1094 dSAVE_ERRNO;
a5f75d66 1095#ifdef VMS
65202027 1096 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
a5f75d66 1097#else
65202027 1098 sv_setnv(sv, (NV)errno);
666d8aa2 1099#endif
88e89b8a 1100#ifdef OS2
ed344e4f
IZ
1101 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1102 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 1103 else
a5f75d66 1104#endif
666ea192 1105 sv_setpv(sv, errno ? Strerror(errno) : "");
be1cf43c
NC
1106 if (SvPOKp(sv))
1107 SvPOK_on(sv); /* may have got removed during taint processing */
4ee39169 1108 RESTORE_ERRNO;
88e89b8a 1109 }
666d8aa2 1110
ad3296c6 1111 SvRTRIM(sv);
946ec16e 1112 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
1113 break;
1114 case '<':
3280af22 1115 sv_setiv(sv, (IV)PL_uid);
79072805
LW
1116 break;
1117 case '>':
3280af22 1118 sv_setiv(sv, (IV)PL_euid);
79072805
LW
1119 break;
1120 case '(':
3280af22 1121 sv_setiv(sv, (IV)PL_gid);
79072805
LW
1122 goto add_groups;
1123 case ')':
3280af22 1124 sv_setiv(sv, (IV)PL_egid);
79072805 1125 add_groups:
79072805 1126#ifdef HAS_GETGROUPS
79072805 1127 {
57d7c65e 1128 Groups_t *gary = NULL;
fb45abb2 1129 I32 i, num_groups = getgroups(0, gary);
57d7c65e
JC
1130 Newx(gary, num_groups, Groups_t);
1131 num_groups = getgroups(num_groups, gary);
fb45abb2
GA
1132 for (i = 0; i < num_groups; i++)
1133 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
57d7c65e 1134 Safefree(gary);
79072805 1135 }
155aba94 1136 (void)SvIOK_on(sv); /* what a wonderful hack! */
cd70abae 1137#endif
79072805 1138 break;
79072805
LW
1139 case '0':
1140 break;
1141 }
a0d0e21e 1142 return 0;
79072805
LW
1143}
1144
1145int
864dbfa3 1146Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1147{
8772537c 1148 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 1149
7918f24d
NC
1150 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1151
79072805 1152 if (uf && uf->uf_val)
24f81a43 1153 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
1154 return 0;
1155}
1156
1157int
864dbfa3 1158Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1159{
27da23d5 1160 dVAR;
9ae3433d 1161 STRLEN len = 0, klen;
666ea192 1162 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
fabdb6c0 1163 const char * const ptr = MgPV_const(mg,klen);
88e89b8a 1164 my_setenv(ptr, s);
1e422769 1165
7918f24d
NC
1166 PERL_ARGS_ASSERT_MAGIC_SETENV;
1167
a0d0e21e
LW
1168#ifdef DYNAMIC_ENV_FETCH
1169 /* We just undefd an environment var. Is a replacement */
1170 /* waiting in the wings? */
1171 if (!len) {
fabdb6c0
AL
1172 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1173 if (valp)
4ab59fcc 1174 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW
1175 }
1176#endif
1e422769 1177
39e571d4 1178#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
1179 /* And you'll never guess what the dog had */
1180 /* in its mouth... */
3280af22 1181 if (PL_tainting) {
1e422769
PP
1182 MgTAINTEDDIR_off(mg);
1183#ifdef VMS
5aabfad6 1184 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
b8ffc8df 1185 char pathbuf[256], eltbuf[256], *cp, *elt;
1e422769
PP
1186 int i = 0, j = 0;
1187
6fca0082 1188 my_strlcpy(eltbuf, s, sizeof(eltbuf));
b8ffc8df 1189 elt = eltbuf;
1e422769
PP
1190 do { /* DCL$PATH may be a search list */
1191 while (1) { /* as may dev portion of any element */
1192 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1193 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1194 cando_by_name(S_IWUSR,0,elt) ) {
1195 MgTAINTEDDIR_on(mg);
1196 return 0;
1197 }
1198 }
bd61b366 1199 if ((cp = strchr(elt, ':')) != NULL)
1e422769
PP
1200 *cp = '\0';
1201 if (my_trnlnm(elt, eltbuf, j++))
1202 elt = eltbuf;
1203 else
1204 break;
1205 }
1206 j = 0;
1207 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1208 }
1209#endif /* VMS */
5aabfad6 1210 if (s && klen == 4 && strEQ(ptr,"PATH")) {
8772537c 1211 const char * const strend = s + len;
463ee0b2
LW
1212
1213 while (s < strend) {
96827780 1214 char tmpbuf[256];
c623ac67 1215 Stat_t st;
5f74f29c 1216 I32 i;
f5a63d97
AL
1217#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1218 const char path_sep = '|';
1219#else
1220 const char path_sep = ':';
1221#endif
96827780 1222 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
427eaa01 1223 s, strend, path_sep, &i);
463ee0b2 1224 s++;
bb7a0f54 1225 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
326b5008
CB
1226#ifdef VMS
1227 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1228#else
1229 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1230#endif
c6ed36e1 1231 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1232 MgTAINTEDDIR_on(mg);
1e422769
PP
1233 return 0;
1234 }
463ee0b2 1235 }
79072805
LW
1236 }
1237 }
39e571d4 1238#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1239
79072805
LW
1240 return 0;
1241}
1242
1243int
864dbfa3 1244Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1245{
7918f24d 1246 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
8772537c 1247 PERL_UNUSED_ARG(sv);
bd61b366 1248 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW
1249 return 0;
1250}
1251
88e89b8a 1252int
864dbfa3 1253Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1254{
97aff369 1255 dVAR;
7918f24d 1256 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
65e66c80 1257 PERL_UNUSED_ARG(mg);
b0269e46 1258#if defined(VMS)
cea2e8a9 1259 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1260#else
3280af22 1261 if (PL_localizing) {
fb73857a 1262 HE* entry;
b0269e46 1263 my_clearenv();
85fbaab2
NC
1264 hv_iterinit(MUTABLE_HV(sv));
1265 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
fb73857a
PP
1266 I32 keylen;
1267 my_setenv(hv_iterkey(entry, &keylen),
85fbaab2 1268 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
fb73857a
PP
1269 }
1270 }
1271#endif
1272 return 0;
1273}
1274
1275int
864dbfa3 1276Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1277{
27da23d5 1278 dVAR;
7918f24d 1279 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
8772537c
AL
1280 PERL_UNUSED_ARG(sv);
1281 PERL_UNUSED_ARG(mg);
b0269e46
AB
1282#if defined(VMS)
1283 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1284#else
1285 my_clearenv();
1286#endif
3e3baf6d 1287 return 0;
66b1d557
HM
1288}
1289
64ca3a65 1290#ifndef PERL_MICRO
2d4fcd5e
AJ
1291#ifdef HAS_SIGPROCMASK
1292static void
1293restore_sigmask(pTHX_ SV *save_sv)
1294{
0bd48802 1295 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
f5a63d97 1296 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
2d4fcd5e
AJ
1297}
1298#endif
66b1d557 1299int
864dbfa3 1300Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1301{
97aff369 1302 dVAR;
88e89b8a 1303 /* Are we fetching a signal entry? */
708854f2 1304 int i = (I16)mg->mg_private;
7918f24d
NC
1305
1306 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1307
708854f2 1308 if (!i) {
84c7b88c
BF
1309 STRLEN siglen;
1310 const char * sig = MgPV_const(mg, siglen);
1311 mg->mg_private = i = whichsig_pvn(sig, siglen);
708854f2
NC
1312 }
1313
e02bfb16 1314 if (i > 0) {
22c35a8c
GS
1315 if(PL_psig_ptr[i])
1316 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1317 else {
46da273f 1318 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1319#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
46da273f
AL
1320 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1321 sigstate = SIG_IGN;
2e34cc90
CL
1322#endif
1323#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
46da273f
AL
1324 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1325 sigstate = SIG_DFL;
85b332e2 1326#endif
88e89b8a 1327 /* cache state so we don't fetch it again */
8aad04aa 1328 if(sigstate == (Sighandler_t) SIG_IGN)
6502358f 1329 sv_setpvs(sv,"IGNORE");
88e89b8a 1330 else
3280af22 1331 sv_setsv(sv,&PL_sv_undef);
46da273f 1332 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a
PP
1333 SvTEMP_off(sv);
1334 }
1335 }
1336 return 0;
1337}
1338int
864dbfa3 1339Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1340{
7918f24d 1341 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
179c85a2 1342
38a124f0 1343 magic_setsig(NULL, mg);
179c85a2 1344 return sv_unmagic(sv, mg->mg_type);
88e89b8a 1345}
3d37d572 1346
0a8e0eff 1347Signal_t
8aad04aa 1348#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 1349Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
8aad04aa 1350#else
0a8e0eff 1351Perl_csighandler(int sig)
8aad04aa 1352#endif
0a8e0eff 1353{
1018e26f
NIS
1354#ifdef PERL_GET_SIG_CONTEXT
1355 dTHXa(PERL_GET_SIG_CONTEXT);
1356#else
85b332e2
CL
1357 dTHX;
1358#endif
23ada85b 1359#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1360 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1361 if (PL_sig_ignoring[sig]) return;
85b332e2 1362#endif
2e34cc90 1363#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1364 if (PL_sig_defaulting[sig])
2e34cc90
CL
1365#ifdef KILL_BY_SIGPRC
1366 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1367#else
1368 exit(1);
1369#endif
1370#endif
406878dd 1371 if (
853d2c32
RGS
1372#ifdef SIGILL
1373 sig == SIGILL ||
1374#endif
1375#ifdef SIGBUS
1376 sig == SIGBUS ||
1377#endif
1378#ifdef SIGSEGV
1379 sig == SIGSEGV ||
1380#endif
1381 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
4ffa73a3 1382 /* Call the perl level handler now--
31c91b43 1383 * with risk we may be in malloc() or being destructed etc. */
6e324d09 1384#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1385 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1386#else
1387 (*PL_sighandlerp)(sig);
92807b6d 1388#endif
406878dd 1389 else {
31c91b43 1390 if (!PL_psig_pend) return;
406878dd
GA
1391 /* Set a flag to say this signal is pending, that is awaiting delivery after
1392 * the current Perl opcode completes */
1393 PL_psig_pend[sig]++;
1394
1395#ifndef SIG_PENDING_DIE_COUNT
1396# define SIG_PENDING_DIE_COUNT 120
1397#endif
fe13d51d 1398 /* Add one to say _a_ signal is pending */
406878dd
GA
1399 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1400 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1401 (unsigned long)SIG_PENDING_DIE_COUNT);
1402 }
0a8e0eff
NIS
1403}
1404
2e34cc90
CL
1405#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1406void
1407Perl_csighandler_init(void)
1408{
1409 int sig;
27da23d5 1410 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1411
1412 for (sig = 1; sig < SIG_SIZE; sig++) {
1413#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1414 dTHX;
27da23d5 1415 PL_sig_defaulting[sig] = 1;
5c1546dc 1416 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1417#endif
1418#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1419 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1420#endif
1421 }
27da23d5 1422 PL_sig_handlers_initted = 1;
2e34cc90
CL
1423}
1424#endif
1425
7fe50b8b
LT
1426#if defined HAS_SIGPROCMASK
1427static void
1428unblock_sigmask(pTHX_ void* newset)
1429{
1430 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1431}
1432#endif
1433
0a8e0eff
NIS
1434void
1435Perl_despatch_signals(pTHX)
1436{
97aff369 1437 dVAR;
0a8e0eff
NIS
1438 int sig;
1439 PL_sig_pending = 0;
1440 for (sig = 1; sig < SIG_SIZE; sig++) {
1441 if (PL_psig_pend[sig]) {
d0166017 1442 dSAVE_ERRNO;
7fe50b8b 1443#ifdef HAS_SIGPROCMASK
55534442
LT
1444 /* From sigaction(2) (FreeBSD man page):
1445 * | Signal routines normally execute with the signal that
1446 * | caused their invocation blocked, but other signals may
1447 * | yet occur.
1448 * Emulation of this behavior (from within Perl) is enabled
1449 * using sigprocmask
1450 */
1451 int was_blocked;
1452 sigset_t newset, oldset;
1453
1454 sigemptyset(&newset);
1455 sigaddset(&newset, sig);
1456 sigprocmask(SIG_BLOCK, &newset, &oldset);
1457 was_blocked = sigismember(&oldset, sig);
7fe50b8b
LT
1458 if (!was_blocked) {
1459 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1460 ENTER;
1461 SAVEFREESV(save_sv);
1462 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1463 }
55534442 1464#endif
25da4428 1465 PL_psig_pend[sig] = 0;
6e324d09 1466#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1467 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1468#else
1469 (*PL_sighandlerp)(sig);
92807b6d 1470#endif
7fe50b8b 1471#ifdef HAS_SIGPROCMASK
55534442 1472 if (!was_blocked)
7fe50b8b 1473 LEAVE;
55534442 1474#endif
d0166017 1475 RESTORE_ERRNO;
0a8e0eff
NIS
1476 }
1477 }
1478}
1479
38a124f0 1480/* sv of NULL signifies that we're acting as magic_clearsig. */
85e6fe83 1481int
864dbfa3 1482Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1483{
27da23d5 1484 dVAR;
79072805 1485 I32 i;
cbbf8932 1486 SV** svp = NULL;
2d4fcd5e
AJ
1487 /* Need to be careful with SvREFCNT_dec(), because that can have side
1488 * effects (due to closures). We must make sure that the new disposition
1489 * is in place before it is called.
1490 */
cbbf8932 1491 SV* to_dec = NULL;
e72dc28c 1492 STRLEN len;
2d4fcd5e
AJ
1493#ifdef HAS_SIGPROCMASK
1494 sigset_t set, save;
1495 SV* save_sv;
1496#endif
d5263905 1497 register const char *s = MgPV_const(mg,len);
7918f24d
NC
1498
1499 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1500
748a9306 1501 if (*s == '_') {
84c7b88c 1502 if (memEQs(s, len, "__DIE__"))
3280af22 1503 svp = &PL_diehook;
84c7b88c 1504 else if (memEQs(s, len, "__WARN__")
38a124f0
NC
1505 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1506 /* Merge the existing behaviours, which are as follows:
1507 magic_setsig, we always set svp to &PL_warnhook
1508 (hence we always change the warnings handler)
1509 For magic_clearsig, we don't change the warnings handler if it's
1510 set to the &PL_warnhook. */
3280af22 1511 svp = &PL_warnhook;
84c7b88c
BF
1512 } else if (sv) {
1513 SV *tmp = sv_newmortal();
1514 Perl_croak(aTHX_ "No such hook: %s",
1515 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1516 }
748a9306 1517 i = 0;
38a124f0 1518 if (svp && *svp) {
9289f461
RGS
1519 if (*svp != PERL_WARNHOOK_FATAL)
1520 to_dec = *svp;
cbbf8932 1521 *svp = NULL;
4633a7c4 1522 }
748a9306
LW
1523 }
1524 else {
708854f2
NC
1525 i = (I16)mg->mg_private;
1526 if (!i) {
84c7b88c 1527 i = whichsig_pvn(s, len); /* ...no, a brick */
58a26b12 1528 mg->mg_private = (U16)i;
708854f2 1529 }
86d86cad 1530 if (i <= 0) {
84c7b88c
BF
1531 if (sv) {
1532 SV *tmp = sv_newmortal();
1533 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1534 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1535 }
748a9306
LW
1536 return 0;
1537 }
2d4fcd5e
AJ
1538#ifdef HAS_SIGPROCMASK
1539 /* Avoid having the signal arrive at a bad time, if possible. */
1540 sigemptyset(&set);
1541 sigaddset(&set,i);
1542 sigprocmask(SIG_BLOCK, &set, &save);
1543 ENTER;
9ff8e806 1544 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
2d4fcd5e
AJ
1545 SAVEFREESV(save_sv);
1546 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1547#endif
1548 PERL_ASYNC_CHECK();
2e34cc90 1549#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1550 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1551#endif
23ada85b 1552#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1553 PL_sig_ignoring[i] = 0;
85b332e2 1554#endif
2e34cc90 1555#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1556 PL_sig_defaulting[i] = 0;
2e34cc90 1557#endif
2d4fcd5e 1558 to_dec = PL_psig_ptr[i];
38a124f0
NC
1559 if (sv) {
1560 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1561 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
79fd3822
NC
1562
1563 /* Signals don't change name during the program's execution, so once
1564 they're cached in the appropriate slot of PL_psig_name, they can
1565 stay there.
1566
1567 Ideally we'd find some way of making SVs at (C) compile time, or
1568 at least, doing most of the work. */
1569 if (!PL_psig_name[i]) {
1570 PL_psig_name[i] = newSVpvn(s, len);
1571 SvREADONLY_on(PL_psig_name[i]);
1572 }
38a124f0 1573 } else {
79fd3822 1574 SvREFCNT_dec(PL_psig_name[i]);
38a124f0
NC
1575 PL_psig_name[i] = NULL;
1576 PL_psig_ptr[i] = NULL;
1577 }
748a9306 1578 }
38a124f0 1579 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
2d4fcd5e 1580 if (i) {
5c1546dc 1581 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1582 }
748a9306 1583 else
b37c2d43 1584 *svp = SvREFCNT_inc_simple_NN(sv);
38a124f0 1585 } else {
9dfa190b
NC
1586 if (sv && SvOK(sv)) {
1587 s = SvPV_force(sv, len);
1588 } else {
1589 sv = NULL;
1590 }
84c7b88c 1591 if (sv && memEQs(s, len,"IGNORE")) {
9dfa190b 1592 if (i) {
23ada85b 1593#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
9dfa190b
NC
1594 PL_sig_ignoring[i] = 1;
1595 (void)rsignal(i, PL_csighandlerp);
85b332e2 1596#else
9dfa190b 1597 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1598#endif
9dfa190b 1599 }
2d4fcd5e 1600 }
84c7b88c 1601 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
9dfa190b 1602 if (i) {
2e34cc90 1603#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
9dfa190b
NC
1604 PL_sig_defaulting[i] = 1;
1605 (void)rsignal(i, PL_csighandlerp);
2e34cc90 1606#else
9dfa190b 1607 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1608#endif
9dfa190b
NC
1609 }
1610 }
1611 else {
1612 /*
1613 * We should warn if HINT_STRICT_REFS, but without
1614 * access to a known hint bit in a known OP, we can't
1615 * tell whether HINT_STRICT_REFS is in force or not.
1616 */
1617 if (!strchr(s,':') && !strchr(s,'\''))
1618 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1619 SV_GMAGIC);
1620 if (i)
1621 (void)rsignal(i, PL_csighandlerp);
1622 else
1623 *svp = SvREFCNT_inc_simple_NN(sv);
136e0459 1624 }
748a9306 1625 }
9dfa190b 1626
2d4fcd5e
AJ
1627#ifdef HAS_SIGPROCMASK
1628 if(i)
1629 LEAVE;
1630#endif
ef8d46e8 1631 SvREFCNT_dec(to_dec);
79072805
LW
1632 return 0;
1633}
64ca3a65 1634#endif /* !PERL_MICRO */
79072805
LW
1635
1636int
864dbfa3 1637Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1638{
97aff369 1639 dVAR;
7918f24d 1640 PERL_ARGS_ASSERT_MAGIC_SETISA;
8772537c 1641 PERL_UNUSED_ARG(sv);
e1a479c5 1642
89c14e2e 1643 /* Skip _isaelem because _isa will handle it shortly */
354b0578 1644 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
89c14e2e
BB
1645 return 0;
1646
0e446081 1647 return magic_clearisa(NULL, mg);
463ee0b2
LW
1648}
1649
0e446081 1650/* sv of NULL signifies that we're acting as magic_setisa. */
463ee0b2 1651int
52b45067
RD
1652Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1653{
1654 dVAR;
1655 HV* stash;
1656
7918f24d
NC
1657 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1658
52b45067 1659 /* Bail out if destruction is going on */
627364f1 1660 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
52b45067 1661
0e446081
NC
1662 if (sv)
1663 av_clear(MUTABLE_AV(sv));
52b45067 1664
6624142a
FC
1665 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1666 /* This occurs with setisa_elem magic, which calls this
1667 same function. */
1668 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1669
1670 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1671 SV **svp = AvARRAY((AV *)mg->mg_obj);
1672 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1673 while (items--) {
1674 stash = GvSTASH((GV *)*svp++);
1675 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1676 }
1677
1678 return 0;
1679 }
1680
52b45067 1681 stash = GvSTASH(
6624142a 1682 (const GV *)mg->mg_obj
52b45067
RD
1683 );
1684
00169e2c
FC
1685 /* The stash may have been detached from the symbol table, so check its
1686 name before doing anything. */
1687 if (stash && HvENAME_get(stash))
5562fa71 1688 mro_isa_changed_in(stash);
52b45067
RD
1689
1690 return 0;
1691}
1692
1693int
864dbfa3 1694Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1695{
97aff369 1696 dVAR;
7918f24d 1697 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
8772537c
AL
1698 PERL_UNUSED_ARG(sv);
1699 PERL_UNUSED_ARG(mg);
3280af22 1700 PL_amagic_generation++;
463ee0b2 1701
a0d0e21e
LW
1702 return 0;
1703}
463ee0b2 1704
946ec16e 1705int
864dbfa3 1706Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1707{
85fbaab2 1708 HV * const hv = MUTABLE_HV(LvTARG(sv));
6ff81951 1709 I32 i = 0;
7918f24d
NC
1710
1711 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
8772537c 1712 PERL_UNUSED_ARG(mg);
7719e241 1713
6ff81951 1714 if (hv) {
497b47a8 1715 (void) hv_iterinit(hv);
ad64d0ec 1716 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1b95d04f 1717 i = HvUSEDKEYS(hv);
497b47a8
JH
1718 else {
1719 while (hv_iternext(hv))
1720 i++;
1721 }
6ff81951
GS
1722 }
1723
1724 sv_setiv(sv, (IV)i);
1725 return 0;
1726}
1727
1728int
864dbfa3 1729Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1730{
7918f24d 1731 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
8772537c 1732 PERL_UNUSED_ARG(mg);
946ec16e 1733 if (LvTARG(sv)) {
85fbaab2 1734 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
946ec16e
PP
1735 }
1736 return 0;
ac27b0f5 1737}
946ec16e 1738
efaf3674
DM
1739/*
1740=for apidoc magic_methcall
1741
1742Invoke a magic method (like FETCH).
1743
2baee27b
FC
1744C<sv> and C<mg> are the tied thingy and the tie magic.
1745
1746C<meth> is the name of the method to call.
1747
1748C<argc> is the number of args (in addition to $self) to pass to the method.
1749
1750The C<flags> can be:
1751
1752 G_DISCARD invoke method with G_DISCARD flag and don't
1753 return a value
1754 G_UNDEF_FILL fill the stack with argc pointers to
1755 PL_sv_undef
1756
1757The arguments themselves are any values following the C<flags> argument.
efaf3674
DM
1758
1759Returns the SV (if any) returned by the method, or NULL on failure.
1760
1761
1762=cut
1763*/
1764
1765SV*
c7a0c747 1766Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
046b0c7d 1767 U32 argc, ...)
a0d0e21e 1768{
97aff369 1769 dVAR;
a0d0e21e 1770 dSP;
efaf3674 1771 SV* ret = NULL;
463ee0b2 1772
7918f24d
NC
1773 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1774
efaf3674 1775 ENTER;
d1d7a15d
NC
1776
1777 if (flags & G_WRITING_TO_STDERR) {
1778 SAVETMPS;
1779
1780 save_re_context();
1781 SAVESPTR(PL_stderrgv);
1782 PL_stderrgv = NULL;
1783 }
1784
efaf3674 1785 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1786 PUSHMARK(SP);
efaf3674 1787
67549bd2
NC
1788 EXTEND(SP, argc+1);
1789 PUSHs(SvTIED_obj(sv, mg));
1790 if (flags & G_UNDEF_FILL) {
1791 while (argc--) {
efaf3674 1792 PUSHs(&PL_sv_undef);
93965878 1793 }
67549bd2 1794 } else if (argc > 0) {
046b0c7d
NC
1795 va_list args;
1796 va_start(args, argc);
1797
1798 do {
1799 SV *const sv = va_arg(args, SV *);
1800 PUSHs(sv);
1801 } while (--argc);
1802
1803 va_end(args);
88e89b8a 1804 }
463ee0b2 1805 PUTBACK;
efaf3674
DM
1806 if (flags & G_DISCARD) {
1807 call_method(meth, G_SCALAR|G_DISCARD);
1808 }
1809 else {
1810 if (call_method(meth, G_SCALAR))
1811 ret = *PL_stack_sp--;
1812 }
1813 POPSTACK;
d1d7a15d
NC
1814 if (flags & G_WRITING_TO_STDERR)
1815 FREETMPS;
efaf3674
DM
1816 LEAVE;
1817 return ret;
1818}
1819
1820
1821/* wrapper for magic_methcall that creates the first arg */
463ee0b2 1822
efaf3674 1823STATIC SV*
c7a0c747 1824S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
efaf3674
DM
1825 int n, SV *val)
1826{
1827 dVAR;
1828 SV* arg1 = NULL;
1829
1830 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1831
1832 if (mg->mg_ptr) {
1833 if (mg->mg_len >= 0) {
db4b3a1d 1834 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
efaf3674
DM
1835 }
1836 else if (mg->mg_len == HEf_SVKEY)
1837 arg1 = MUTABLE_SV(mg->mg_ptr);
1838 }
1839 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
db4b3a1d 1840 arg1 = newSViv((IV)(mg->mg_len));
efaf3674
DM
1841 sv_2mortal(arg1);
1842 }
1843 if (!arg1) {
046b0c7d 1844 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
efaf3674 1845 }
046b0c7d 1846 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
946ec16e
PP
1847}
1848
76e3520e 1849STATIC int
e1ec3a88 1850S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1851{
efaf3674
DM
1852 dVAR;
1853 SV* ret;
463ee0b2 1854
7918f24d
NC
1855 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1856
efaf3674
DM
1857 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1858 if (ret)
1859 sv_setsv(sv, ret);
a0d0e21e
LW
1860 return 0;
1861}
463ee0b2 1862
a0d0e21e 1863int
864dbfa3 1864Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1865{
7918f24d
NC
1866 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1867
fd69380d 1868 if (mg->mg_type == PERL_MAGIC_tiedelem)
a0d0e21e 1869 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1870 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1871 return 0;
1872}
1873
1874int
864dbfa3 1875Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1876{
efaf3674 1877 dVAR;
b112cff9
DM
1878 MAGIC *tmg;
1879 SV *val;
7918f24d
NC
1880
1881 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1882
b112cff9
DM
1883 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1884 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1885 * public flags indicate its value based on copying from $val. Doing
1886 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1887 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1888 * wrong if $val happened to be tainted, as sv hasn't got magic
1889 * enabled, even though taint magic is in the chain. In which case,
1890 * fake up a temporary tainted value (this is easier than temporarily
1891 * re-enabling magic on sv). */
1892
1893 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1894 && (tmg->mg_len & 1))
1895 {
1896 val = sv_mortalcopy(sv);
1897 SvTAINTED_on(val);
1898 }
1899 else
1900 val = sv;
1901
efaf3674 1902 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
463ee0b2
LW
1903 return 0;
1904}
1905
1906int
864dbfa3 1907Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1908{
7918f24d
NC
1909 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1910
a0d0e21e
LW
1911 return magic_methpack(sv,mg,"DELETE");
1912}
463ee0b2 1913
93965878
NIS
1914
1915U32
864dbfa3 1916Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1917{
efaf3674 1918 dVAR;
22846ab4 1919 I32 retval = 0;
efaf3674 1920 SV* retsv;
93965878 1921
7918f24d
NC
1922 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1923
efaf3674
DM
1924 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1925 if (retsv) {
1926 retval = SvIV(retsv)-1;
22846ab4
AB
1927 if (retval < -1)
1928 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
93965878 1929 }
22846ab4 1930 return (U32) retval;
93965878
NIS
1931}
1932
cea2e8a9
GS
1933int
1934Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1935{
efaf3674 1936 dVAR;
463ee0b2 1937
7918f24d
NC
1938 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1939
046b0c7d 1940 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
463ee0b2
LW
1941 return 0;
1942}
1943
1944int
864dbfa3 1945Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1946{
efaf3674
DM
1947 dVAR;
1948 SV* ret;
463ee0b2 1949
7918f24d
NC
1950 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1951
046b0c7d
NC
1952 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1953 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
efaf3674
DM
1954 if (ret)
1955 sv_setsv(key,ret);
79072805
LW
1956 return 0;
1957}
1958
1959int
1146e912 1960Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e 1961{
7918f24d
NC
1962 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1963
a0d0e21e 1964 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1965}
a0d0e21e 1966
a3bcc51e
TP
1967SV *
1968Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1969{
efaf3674 1970 dVAR;
5fcbf73d 1971 SV *retval;
ad64d0ec
NC
1972 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1973 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
a3bcc51e 1974
7918f24d
NC
1975 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1976
a3bcc51e
TP
1977 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1978 SV *key;
bfcb3514 1979 if (HvEITER_get(hv))
a3bcc51e
TP
1980 /* we are in an iteration so the hash cannot be empty */
1981 return &PL_sv_yes;
1982 /* no xhv_eiter so now use FIRSTKEY */
1983 key = sv_newmortal();
ad64d0ec 1984 magic_nextpack(MUTABLE_SV(hv), mg, key);
bfcb3514 1985 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1986 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1987 }
1988
1989 /* there is a SCALAR method that we can call */
046b0c7d 1990 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
efaf3674 1991 if (!retval)
5fcbf73d 1992 retval = &PL_sv_undef;
a3bcc51e
TP
1993 return retval;
1994}
1995
a0d0e21e 1996int
864dbfa3 1997Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1998{
97aff369 1999 dVAR;
8772537c
AL
2000 GV * const gv = PL_DBline;
2001 const I32 i = SvTRUE(sv);
2002 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 2003 atoi(MgPV_nolen_const(mg)), FALSE);
7918f24d
NC
2004
2005 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2006
8772537c
AL
2007 if (svp && SvIOKp(*svp)) {
2008 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2009 if (o) {
2010 /* set or clear breakpoint in the relevant control op */
2011 if (i)
2012 o->op_flags |= OPf_SPECIAL;
2013 else
2014 o->op_flags &= ~OPf_SPECIAL;
2015 }
5df8de69 2016 }
79072805
LW
2017 return 0;
2018}
2019
2020int
8772537c 2021Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 2022{
97aff369 2023 dVAR;
502c6561 2024 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
2025
2026 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2027
83bf042f 2028 if (obj) {
e1dccc0d 2029 sv_setiv(sv, AvFILL(obj));
83bf042f
NC
2030 } else {
2031 SvOK_off(sv);
2032 }
79072805
LW
2033 return 0;
2034}
2035
2036int
864dbfa3 2037Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 2038{
97aff369 2039 dVAR;
502c6561 2040 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
2041
2042 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2043
83bf042f 2044 if (obj) {
e1dccc0d 2045 av_fill(obj, SvIV(sv));
83bf042f 2046 } else {
a2a5de95
NC
2047 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2048 "Attempt to set length of freed array");
83bf042f
NC
2049 }
2050 return 0;
2051}
2052
2053int
2054Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2055{
97aff369 2056 dVAR;
7918f24d
NC
2057
2058 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
53c1dcc0 2059 PERL_UNUSED_ARG(sv);
7918f24d 2060
94f3782b
DM
2061 /* during global destruction, mg_obj may already have been freed */
2062 if (PL_in_clean_all)
1ea47f64 2063 return 0;
94f3782b 2064
83bf042f
NC
2065 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2066
2067 if (mg) {
2068 /* arylen scalar holds a pointer back to the array, but doesn't own a
2069 reference. Hence the we (the array) are about to go away with it
2070 still pointing at us. Clear its pointer, else it would be pointing
2071 at free memory. See the comment in sv_magic about reference loops,
2072 and why it can't own a reference to us. */
2073 mg->mg_obj = 0;
2074 }
a0d0e21e
LW
2075 return 0;
2076}
2077
2078int
864dbfa3 2079Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2080{
97aff369 2081 dVAR;
16eb5365 2082 SV* const lsv = LvTARG(sv);
7918f24d
NC
2083
2084 PERL_ARGS_ASSERT_MAGIC_GETPOS;
16eb5365 2085 PERL_UNUSED_ARG(mg);
ac27b0f5 2086
a0d0e21e 2087 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
3881461a
AL
2088 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2089 if (found && found->mg_len >= 0) {
2090 I32 i = found->mg_len;
7e2040f0 2091 if (DO_UTF8(lsv))
a0ed51b3 2092 sv_pos_b2u(lsv, &i);
e1dccc0d 2093 sv_setiv(sv, i);
a0d0e21e
LW
2094 return 0;
2095 }
2096 }
0c34ef67 2097 SvOK_off(sv);
a0d0e21e
LW
2098 return 0;
2099}
2100
2101int
864dbfa3 2102Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2103{
97aff369 2104 dVAR;
16eb5365 2105 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
2106 SSize_t pos;
2107 STRLEN len;
c00206c8 2108 STRLEN ulen = 0;
53d44271 2109 MAGIC* found;
a0d0e21e 2110
7918f24d 2111 PERL_ARGS_ASSERT_MAGIC_SETPOS;
16eb5365 2112 PERL_UNUSED_ARG(mg);
ac27b0f5 2113
a0d0e21e 2114 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
3881461a
AL
2115 found = mg_find(lsv, PERL_MAGIC_regex_global);
2116 else
2117 found = NULL;
2118 if (!found) {
a0d0e21e
LW
2119 if (!SvOK(sv))
2120 return 0;
d83f0a82
NC
2121#ifdef PERL_OLD_COPY_ON_WRITE
2122 if (SvIsCOW(lsv))
2123 sv_force_normal_flags(lsv, 0);
2124#endif
3881461a 2125 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
53d44271 2126 NULL, 0);
a0d0e21e
LW
2127 }
2128 else if (!SvOK(sv)) {
3881461a 2129 found->mg_len = -1;
a0d0e21e
LW
2130 return 0;
2131 }
2132 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2133
e1dccc0d 2134 pos = SvIV(sv);
a0ed51b3 2135
7e2040f0 2136 if (DO_UTF8(lsv)) {
a0ed51b3
LW
2137 ulen = sv_len_utf8(lsv);
2138 if (ulen)
2139 len = ulen;
a0ed51b3
LW
2140 }
2141
a0d0e21e
LW
2142 if (pos < 0) {
2143 pos += len;
2144 if (pos < 0)
2145 pos = 0;
2146 }
eb160463 2147 else if (pos > (SSize_t)len)
a0d0e21e 2148 pos = len;
a0ed51b3
LW
2149
2150 if (ulen) {
2151 I32 p = pos;
2152 sv_pos_u2b(lsv, &p, 0);
2153 pos = p;
2154 }
727405f8 2155
3881461a
AL
2156 found->mg_len = pos;
2157 found->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 2158
79072805
LW
2159 return 0;
2160}
2161
2162int
864dbfa3 2163Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
2164{
2165 STRLEN len;
35a4481c 2166 SV * const lsv = LvTARG(sv);
b83604b4 2167 const char * const tmps = SvPV_const(lsv,len);
777f7c56
EB
2168 STRLEN offs = LvTARGOFF(sv);
2169 STRLEN rem = LvTARGLEN(sv);
83f78d1a
FC
2170 const bool negoff = LvFLAGS(sv) & 1;
2171 const bool negrem = LvFLAGS(sv) & 2;
7918f24d
NC
2172
2173 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
8772537c 2174 PERL_UNUSED_ARG(mg);
6ff81951 2175
83f78d1a
FC
2176 if (!translate_substr_offsets(
2177 SvUTF8(lsv) ? sv_len_utf8(lsv) : len,
2178 negoff ? -(IV)offs : (IV)offs, !negoff,
2179 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
2180 )) {
2181 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2182 sv_setsv_nomg(sv, &PL_sv_undef);
2183 return 0;
2184 }
2185
9aa983d2 2186 if (SvUTF8(lsv))
d931b1be 2187 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
1c900557 2188 sv_setpvn(sv, tmps + offs, rem);
9aa983d2 2189 if (SvUTF8(lsv))
2ef4b674 2190 SvUTF8_on(sv);
6ff81951
GS
2191 return 0;
2192}
2193
2194int
864dbfa3 2195Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 2196{
97aff369 2197 dVAR;
83f78d1a 2198 STRLEN len, lsv_len, oldtarglen, newtarglen;
5fcbf73d 2199 const char * const tmps = SvPV_const(sv, len);
dd374669 2200 SV * const lsv = LvTARG(sv);
777f7c56
EB
2201 STRLEN lvoff = LvTARGOFF(sv);
2202 STRLEN lvlen = LvTARGLEN(sv);
83f78d1a
FC
2203 const bool negoff = LvFLAGS(sv) & 1;
2204 const bool neglen = LvFLAGS(sv) & 2;
7918f24d
NC
2205
2206 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
8772537c 2207 PERL_UNUSED_ARG(mg);
075a4a2b 2208
a74fb2cd
FC
2209 SvGETMAGIC(lsv);
2210 if (SvROK(lsv))
2211 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2212 "Attempt to use reference as lvalue in substr"
2213 );
83f78d1a
FC
2214 if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv);
2215 else (void)SvPV_nomg(lsv,lsv_len);
2216 if (!translate_substr_offsets(
2217 lsv_len,
2218 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2219 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2220 ))
2221 Perl_croak(aTHX_ "substr outside of string");
2222 oldtarglen = lvlen;
1aa99e6b 2223 if (DO_UTF8(sv)) {
9aa983d2 2224 sv_utf8_upgrade(lsv);
d931b1be 2225 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
a74fb2cd 2226 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
83f78d1a 2227 newtarglen = sv_len_utf8(sv);
9aa983d2
JH
2228 SvUTF8_on(lsv);
2229 }
9bf12eaf 2230 else if (lsv && SvUTF8(lsv)) {
5fcbf73d 2231 const char *utf8;
d931b1be 2232 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
83f78d1a 2233 newtarglen = len;
5fcbf73d 2234 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
a74fb2cd 2235 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
5fcbf73d 2236 Safefree(utf8);
1aa99e6b 2237 }
b76f3ce2 2238 else {
a74fb2cd 2239 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
83f78d1a 2240 newtarglen = len;
b76f3ce2 2241 }
83f78d1a
FC
2242 if (!neglen) LvTARGLEN(sv) = newtarglen;
2243 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
b76f3ce2 2244
79072805
LW
2245 return 0;
2246}
2247
2248int
864dbfa3 2249Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2250{
97aff369 2251 dVAR;
7918f24d
NC
2252
2253 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
8772537c 2254 PERL_UNUSED_ARG(sv);
7918f24d 2255
27cc343c 2256 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
2257 return 0;
2258}
2259
2260int
864dbfa3 2261Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2262{
97aff369 2263 dVAR;
7918f24d
NC
2264
2265 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
8772537c 2266 PERL_UNUSED_ARG(sv);
7918f24d 2267
b01e650a
DM
2268 /* update taint status */
2269 if (PL_tainted)
2270 mg->mg_len |= 1;
2271 else
2272 mg->mg_len &= ~1;
463ee0b2
LW
2273 return 0;
2274}
2275
2276int
864dbfa3 2277Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 2278{
35a4481c 2279 SV * const lsv = LvTARG(sv);
7918f24d
NC
2280
2281 PERL_ARGS_ASSERT_MAGIC_GETVEC;
8772537c 2282 PERL_UNUSED_ARG(mg);
6ff81951 2283
6136c704
AL
2284 if (lsv)
2285 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2286 else
0c34ef67 2287 SvOK_off(sv);
6ff81951 2288
6ff81951
GS
2289 return 0;
2290}
2291
2292int
864dbfa3 2293Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2294{
7918f24d 2295 PERL_ARGS_ASSERT_MAGIC_SETVEC;
8772537c 2296 PERL_UNUSED_ARG(mg);
79072805
LW
2297 do_vecset(sv); /* XXX slurp this routine */
2298 return 0;
2299}
2300
2301int
1e6bda93
FC
2302Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg)
2303{
2304 PERL_ARGS_ASSERT_MAGIC_SETVSTRING;
2305
2306 if (SvPOKp(sv)) {
2307 SV * const vecsv = sv_newmortal();
2308 scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
2309 if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0;
2310 }
2311 return sv_unmagic(sv, mg->mg_type);
2312}
2313
2314int
864dbfa3 2315Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2316{
97aff369 2317 dVAR;
a0714e2c 2318 SV *targ = NULL;
7918f24d
NC
2319
2320 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2321
5f05dabc 2322 if (LvTARGLEN(sv)) {
68dc0745 2323 if (mg->mg_obj) {
8772537c 2324 SV * const ahv = LvTARG(sv);
85fbaab2 2325 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
6d822dc4
MS
2326 if (he)
2327 targ = HeVAL(he);
68dc0745
PP
2328 }
2329 else {
502c6561 2330 AV *const av = MUTABLE_AV(LvTARG(sv));
68dc0745
PP
2331 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2332 targ = AvARRAY(av)[LvTARGOFF(sv)];
2333 }
46da273f 2334 if (targ && (targ != &PL_sv_undef)) {
68dc0745
PP
2335 /* somebody else defined it for us */
2336 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2337 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745
PP
2338 LvTARGLEN(sv) = 0;
2339 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2340 mg->mg_obj = NULL;
68dc0745
PP
2341 mg->mg_flags &= ~MGf_REFCOUNTED;
2342 }
5f05dabc 2343 }
71be2cbc
PP
2344 else
2345 targ = LvTARG(sv);
3280af22 2346 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2347 return 0;
2348}
2349
2350int
864dbfa3 2351Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2352{
7918f24d 2353 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
8772537c 2354 PERL_UNUSED_ARG(mg);
71be2cbc 2355 if (LvTARGLEN(sv))
68dc0745
PP
2356 vivify_defelem(sv);
2357 if (LvTARG(sv)) {
5f05dabc 2358 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2359 SvSETMAGIC(LvTARG(sv));
2360 }
5f05dabc
PP
2361 return 0;
2362}
2363
71be2cbc 2364void
864dbfa3 2365Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2366{
97aff369 2367 dVAR;
74e13ce4 2368 MAGIC *mg;
a0714e2c 2369 SV *value = NULL;
71be2cbc 2370
7918f24d
NC
2371 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2372
14befaf4 2373 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2374 return;
68dc0745 2375 if (mg->mg_obj) {
8772537c 2376 SV * const ahv = LvTARG(sv);
85fbaab2 2377 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
6d822dc4
MS
2378 if (he)
2379 value = HeVAL(he);
3280af22 2380 if (!value || value == &PL_sv_undef)
be2597df 2381 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
71be2cbc 2382 }
68dc0745 2383 else {
502c6561 2384 AV *const av = MUTABLE_AV(LvTARG(sv));
5aabfad6 2385 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
a0714e2c 2386 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2387 else {
d4c19fe8 2388 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2389 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2390 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2391 }
2392 }
b37c2d43 2393 SvREFCNT_inc_simple_void(value);
68dc0745
PP
2394 SvREFCNT_dec(LvTARG(sv));
2395 LvTARG(sv) = value;
71be2cbc 2396 LvTARGLEN(sv) = 0;
68dc0745 2397 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2398 mg->mg_obj = NULL;
68dc0745 2399 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2400}
2401
2402int
864dbfa3 2403Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2404{
7918f24d 2405 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
5648c0ae
DM
2406 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2407 return 0;
810b8aa5
GS
2408}
2409
2410int
864dbfa3 2411Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2412{
7918f24d 2413 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
96a5add6 2414 PERL_UNUSED_CONTEXT;
0177730e 2415 PERL_UNUSED_ARG(sv);
565764a8 2416 mg->mg_len = -1;
93a17b20
LW
2417 return 0;
2418}
2419
2420int
864dbfa3 2421Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2422{
35a4481c 2423 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 2424
7918f24d
NC
2425 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2426
79072805 2427 if (uf && uf->uf_set)
24f81a43 2428 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2429 return 0;
2430}
2431
c277df42 2432int
faf82a0b
AE
2433Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2434{
488344d2 2435 const char type = mg->mg_type;
7918f24d
NC
2436
2437 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2438
488344d2
NC
2439 if (type == PERL_MAGIC_qr) {
2440 } else if (type == PERL_MAGIC_bm) {
2441 SvTAIL_off(sv);
2442 SvVALID_off(sv);
0177730e
NC
2443 } else if (type == PERL_MAGIC_study) {
2444 if (!isGV_with_GP(sv))
2445 SvSCREAM_off(sv);
488344d2
NC
2446 } else {
2447 assert(type == PERL_MAGIC_fm);
488344d2
NC
2448 }
2449 return sv_unmagic(sv, type);
faf82a0b
AE
2450}
2451
7a4c00b4 2452#ifdef USE_LOCALE_COLLATE
79072805 2453int
864dbfa3 2454Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 2455{
7918f24d
NC
2456 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2457
bbce6d69 2458 /*
838b5b74 2459 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2460 * and vanished with a faint plop.
2461 */
96a5add6 2462 PERL_UNUSED_CONTEXT;
8772537c 2463 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2464 if (mg->mg_ptr) {
2465 Safefree(mg->mg_ptr);
2466 mg->mg_ptr = NULL;
565764a8 2467 mg->mg_len = -1;
7a4c00b4 2468 }
bbce6d69
PP
2469 return 0;
2470}
7a4c00b4 2471#endif /* USE_LOCALE_COLLATE */
bbce6d69 2472
7e8c5dac
HS
2473/* Just clear the UTF-8 cache data. */
2474int
2475Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2476{
7918f24d 2477 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
96a5add6 2478 PERL_UNUSED_CONTEXT;
8772537c 2479 PERL_UNUSED_ARG(sv);
7e8c5dac 2480 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2481 mg->mg_ptr = NULL;
7e8c5dac
HS
2482 mg->mg_len = -1; /* The mg_len holds the len cache. */
2483 return 0;
2484}
2485
bbce6d69 2486int
864dbfa3 2487Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2488{
97aff369 2489 dVAR;
e1ec3a88 2490 register const char *s;
2fdbfb4d
AB
2491 register I32 paren;
2492 register const REGEXP * rx;
2493 const char * const remaining = mg->mg_ptr + 1;
79072805 2494 I32 i;
8990e307 2495 STRLEN len;
125b9982 2496 MAGIC *tmg;
2fdbfb4d 2497
7918f24d
NC
2498 PERL_ARGS_ASSERT_MAGIC_SET;
2499
79072805 2500 switch (*mg->mg_ptr) {
2fdbfb4d
AB
2501 case '\015': /* $^MATCH */
2502 if (strEQ(remaining, "ATCH"))
2503 goto do_match;
2504 case '`': /* ${^PREMATCH} caught below */
2505 do_prematch:
f1b875a0 2506 paren = RX_BUFF_IDX_PREMATCH;
2fdbfb4d
AB
2507 goto setparen;
2508 case '\'': /* ${^POSTMATCH} caught below */
2509 do_postmatch:
f1b875a0 2510 paren = RX_BUFF_IDX_POSTMATCH;
2fdbfb4d
AB
2511 goto setparen;
2512 case '&':
2513 do_match:
f1b875a0 2514 paren = RX_BUFF_IDX_FULLMATCH;
2fdbfb4d
AB
2515 goto setparen;
2516 case '1': case '2': case '3': case '4':
2517 case '5': case '6': case '7': case '8': case '9':
104a8018 2518 paren = atoi(mg->mg_ptr);
2fdbfb4d 2519 setparen:
1e05feb3 2520 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2fdbfb4d 2521 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
1e05feb3 2522 } else {
2fdbfb4d
AB
2523 /* Croak with a READONLY error when a numbered match var is
2524 * set without a previous pattern match. Unless it's C<local $1>
2525 */
2526 if (!PL_localizing) {
6ad8f254 2527 Perl_croak_no_modify(aTHX);
2fdbfb4d
AB
2528 }
2529 }
9b9e0be4 2530 break;
748a9306 2531 case '\001': /* ^A */
3280af22 2532 sv_setsv(PL_bodytarget, sv);
64eff8b7
DM
2533 FmLINES(PL_bodytarget) = 0;
2534 if (SvPOK(PL_bodytarget)) {
2535 char *s = SvPVX(PL_bodytarget);
2536 while ( ((s = strchr(s, '\n'))) ) {
2537 FmLINES(PL_bodytarget)++;
2538 s++;
2539 }
2540 }
125b9982
NT
2541 /* mg_set() has temporarily made sv non-magical */
2542 if (PL_tainting) {
2543 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2544 SvTAINTED_on(PL_bodytarget);
2545 else
2546 SvTAINTED_off(PL_bodytarget);
2547 }
748a9306 2548 break;
49460fe6 2549 case '\003': /* ^C */
f2338a2e 2550 PL_minus_c = cBOOL(SvIV(sv));
49460fe6
NIS
2551 break;
2552
79072805 2553 case '\004': /* ^D */
b4ab917c 2554#ifdef DEBUGGING
b83604b4 2555 s = SvPV_nolen_const(sv);
ddcf8bc1 2556 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
a58fb6f9
CS
2557 if (DEBUG_x_TEST || DEBUG_B_TEST)
2558 dump_all_perl(!DEBUG_B_TEST);
b4ab917c 2559#else
38ab35f8 2560 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2561#endif
79072805 2562 break;
28f23441 2563 case '\005': /* ^E */
d0063567 2564 if (*(mg->mg_ptr+1) == '\0') {
e37778c2 2565#ifdef VMS
38ab35f8 2566 set_vaxc_errno(SvIV(sv));
e37778c2
NC
2567#else
2568# ifdef WIN32
d0063567 2569 SetLastError( SvIV(sv) );
e37778c2
NC
2570# else
2571# ifdef OS2
38ab35f8 2572 os2_setsyserrno(SvIV(sv));
e37778c2 2573# else
d0063567 2574 /* will anyone ever use this? */
38ab35f8 2575 SETERRNO(SvIV(sv), 4);
048c1ddf
IZ
2576# endif
2577# endif
22fae026 2578#endif
d0063567
DK
2579 }
2580 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
ef8d46e8 2581 SvREFCNT_dec(PL_encoding);
d0063567
DK
2582 if (SvOK(sv) || SvGMAGICAL(sv)) {
2583 PL_encoding = newSVsv(sv);
2584 }
2585 else {
a0714e2c 2586 PL_encoding = NULL;
d0063567
DK
2587 }
2588 }
2589 break;
79072805 2590 case '\006': /* ^F */
38ab35f8 2591 PL_maxsysfd = SvIV(sv);
79072805 2592 break;
a0d0e21e 2593 case '\010': /* ^H */
38ab35f8 2594 PL_hints = SvIV(sv);
a0d0e21e 2595 break;
9d116dd7 2596 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2597 Safefree(PL_inplace);
bd61b366 2598 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2599 break;
28f23441 2600 case '\017': /* ^O */
ac27b0f5 2601 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2602 Safefree(PL_osname);
bd61b366 2603 PL_osname = NULL;
3511154c
DM
2604 if (SvOK(sv)) {
2605 TAINT_PROPER("assigning to $^O");
2e0de35c 2606 PL_osname = savesvpv(sv);
3511154c 2607 }
ac27b0f5
NIS
2608 }
2609 else if (strEQ(mg->mg_ptr, "\017PEN")) {
8b850bd5
NC
2610 STRLEN len;
2611 const char *const start = SvPV(sv, len);
b54fc2b6 2612 const char *out = (const char*)memchr(start, '\0', len);
8b850bd5 2613 SV *tmp;
8b850bd5
NC
2614
2615
2616 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
f747ebd6 2617 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
8b850bd5
NC
2618
2619 /* Opening for input is more common than opening for output, so
2620 ensure that hints for input are sooner on linked list. */
59cd0e26 2621 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
f747ebd6
Z
2622 SvUTF8(sv))
2623 : newSVpvs_flags("", SvUTF8(sv));
2624 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2625 mg_set(tmp);
8b850bd5 2626
f747ebd6
Z
2627 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2628 SvUTF8(sv));
2629 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2630 mg_set(tmp);
ac27b0f5 2631 }
28f23441 2632 break;
79072805 2633 case '\020': /* ^P */
2fdbfb4d
AB
2634 if (*remaining == '\0') { /* ^P */
2635 PL_perldb = SvIV(sv);
2636 if (PL_perldb && !PL_DBsingle)
2637 init_debugger();
2638 break;
2639 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2640 goto do_prematch;
2641 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2642 goto do_postmatch;
2643 }
9b9e0be4 2644 break;
79072805 2645 case '\024': /* ^T */
88e89b8a 2646#ifdef BIG_TIME
6b88bc9c 2647 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2648#else
38ab35f8 2649 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2650#endif
79072805 2651 break;
e07ea26a
NC
2652 case '\025': /* ^UTF8CACHE */
2653 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2654 PL_utf8cache = (signed char) sv_2iv(sv);
2655 }
2656 break;
fde18df1 2657 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2658 if (*(mg->mg_ptr+1) == '\0') {
2659 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2660 i = SvIV(sv);
ac27b0f5 2661 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2662 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2663 }
599cee73 2664 }
0a378802 2665 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2666 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2667 if (!SvPOK(sv) && PL_localizing) {
2668 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2669 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2670 break;
2671 }
f4fc7782 2672 {
b5477537 2673 STRLEN len, i;
d3a7d8c7 2674 int accumulate = 0 ;
f4fc7782 2675 int any_fatals = 0 ;
b83604b4 2676 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2677 for (i = 0 ; i < len ; ++i) {
2678 accumulate |= ptr[i] ;
2679 any_fatals |= (ptr[i] & 0xAA) ;
2680 }
4243c432
NC
2681 if (!accumulate) {
2682 if (!specialWARN(PL_compiling.cop_warnings))
2683 PerlMemShared_free(PL_compiling.cop_warnings);
2684 PL_compiling.cop_warnings = pWARN_NONE;
2685 }
72dc9ed5
NC
2686 /* Yuck. I can't see how to abstract this: */
2687 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2688 WARN_ALL) && !any_fatals) {
4243c432
NC
2689 if (!specialWARN(PL_compiling.cop_warnings))
2690 PerlMemShared_free(PL_compiling.cop_warnings);
f4fc7782
JH
2691 PL_compiling.cop_warnings = pWARN_ALL;
2692 PL_dowarn |= G_WARN_ONCE ;
727405f8 2693 }
d3a7d8c7 2694 else {
72dc9ed5
NC
2695 STRLEN len;
2696 const char *const p = SvPV_const(sv, len);
2697
2698 PL_compiling.cop_warnings
8ee4cf24 2699 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC
2700 p, len);
2701
d3a7d8c7
GS
2702 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2703 PL_dowarn |= G_WARN_ONCE ;
2704 }
f4fc7782 2705
d3a7d8c7 2706 }
4438c4b7 2707 }
971a9dd3 2708 }
79072805
LW
2709 break;
2710 case '.':
3280af22
NIS
2711 if (PL_localizing) {
2712 if (PL_localizing == 1)
7766f137 2713 SAVESPTR(PL_last_in_gv);
748a9306 2714 }
3280af22 2715 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2716 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2717 break;
2718 case '^':
acbe1b9d
FC
2719 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2720 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2721 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2722 break;
2723 case '~':
acbe1b9d
FC
2724 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2725 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2726 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2727 break;
2728 case '=':
acbe1b9d 2729 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2730 break;
2731 case '-':
acbe1b9d
FC
2732 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2733 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
099be4f1 2734 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2735 break;
2736 case '%':
acbe1b9d 2737 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2738 break;
2739 case '|':
4b65379b 2740 {
099be4f1 2741 IO * const io = GvIO(PL_defoutgv);
720f287d
AB
2742 if(!io)
2743 break;
38ab35f8 2744 if ((SvIV(sv)) == 0)
4b65379b
CS
2745 IoFLAGS(io) &= ~IOf_FLUSH;
2746 else {
2747 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2748 PerlIO *ofp = IoOFP(io);
2749 if (ofp)
2750 (void)PerlIO_flush(ofp);
2751 IoFLAGS(io) |= IOf_FLUSH;
2752 }
2753 }
79072805
LW
2754 }
2755 break;
79072805 2756 case '/':
3280af22 2757 SvREFCNT_dec(PL_rs);
8bfdd7d9 2758 PL_rs = newSVsv(sv);
79072805
LW
2759 break;
2760 case '\\':
ef8d46e8 2761 SvREFCNT_dec(PL_ors_sv);
009c130f 2762 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2763 PL_ors_sv = newSVsv(sv);
009c130f 2764 }
e3c19b7b 2765 else {
a0714e2c 2766 PL_ors_sv = NULL;
e3c19b7b 2767 }
79072805 2768 break;
7d69d4a6
FC
2769 case '[':
2770 if (SvIV(sv) != 0)
2771 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
2772 break;
79072805 2773 case '?':
ff0cee69 2774#ifdef COMPLEX_STATUS
6b88bc9c 2775 if (PL_localizing == 2) {
41cb7b2b 2776 SvUPGRADE(sv, SVt_PVLV);
6b88bc9c
GS
2777 PL_statusvalue = LvTARGOFF(sv);
2778 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2779 }
2780 else
2781#endif
2782#ifdef VMSISH_STATUS
2783 if (VMSISH_STATUS)
fb38d079 2784 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2785 else
2786#endif
38ab35f8 2787 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW
2788 break;
2789 case '!':
93189314
JH
2790 {
2791#ifdef VMS
2792# define PERL_VMS_BANG vaxc$errno
2793#else
2794# define PERL_VMS_BANG 0
2795#endif
91487cfc 2796 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2797 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2798 }
79072805
LW
2799 break;
2800 case '<':
38ab35f8 2801 PL_uid = SvIV(sv);
3280af22
NIS
2802 if (PL_delaymagic) {
2803 PL_delaymagic |= DM_RUID;
79072805
LW
2804 break; /* don't do magic till later */
2805 }
2806#ifdef HAS_SETRUID
b28d0864 2807 (void)setruid((Uid_t)PL_uid);
79072805
LW
2808#else
2809#ifdef HAS_SETREUID
3280af22 2810 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2811#else
85e6fe83 2812#ifdef HAS_SETRESUID
b28d0864 2813 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2814#else
75870ed3 2815 if (PL_uid == PL_euid) { /* special case $< = $> */
2816#ifdef PERL_DARWIN
2817 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2818 if (PL_uid != 0 && PerlProc_getuid() == 0)
2819 (void)PerlProc_setuid(0);
2820#endif
b28d0864 2821 (void)PerlProc_setuid(PL_uid);
75870ed3 2822 } else {
d8eceb89 2823 PL_uid = PerlProc_getuid();
cea2e8a9 2824 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2825 }
79072805
LW
2826#endif
2827#endif
85e6fe83 2828#endif
d8eceb89 2829 PL_uid = PerlProc_getuid();
79072805
LW
2830 break;
2831 case '>':
38ab35f8 2832 PL_euid = SvIV(sv);
3280af22
NIS
2833 if (PL_delaymagic) {
2834 PL_delaymagic |= DM_EUID;
79072805
LW
2835 break; /* don't do magic till later */
2836 }
2837#ifdef HAS_SETEUID
3280af22 2838 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2839#else
2840#ifdef HAS_SETREUID
b28d0864 2841 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2842#else
2843#ifdef HAS_SETRESUID
6b88bc9c 2844 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2845#else
b28d0864
NIS
2846 if (PL_euid == PL_uid) /* special case $> = $< */
2847 PerlProc_setuid(PL_euid);
a0d0e21e 2848 else {
e8ee3774 2849 PL_euid = PerlProc_geteuid();
cea2e8a9 2850 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2851 }
79072805
LW
2852#endif
2853#endif
85e6fe83 2854#endif
d8eceb89 2855 PL_euid = PerlProc_geteuid();
79072805
LW
2856 break;
2857 case '(':
38ab35f8 2858 PL_gid = SvIV(sv);
3280af22
NIS
2859 if (PL_delaymagic) {
2860 PL_delaymagic |= DM_RGID;
79072805
LW
2861 break; /* don't do magic till later */
2862 }
2863#ifdef HAS_SETRGID
b28d0864 2864 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2865#else
2866#ifdef HAS_SETREGID
3280af22 2867 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2868#else
2869#ifdef HAS_SETRESGID
a058c516 2870 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1);
79072805 2871#else
b28d0864
NIS
2872 if (PL_gid == PL_egid) /* special case $( = $) */
2873 (void)PerlProc_setgid(PL_gid);
748a9306 2874 else {
d8eceb89 2875 PL_gid = PerlProc_getgid();
cea2e8a9 2876 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2877 }
79072805
LW
2878#endif
2879#endif
85e6fe83 2880#endif
d8eceb89 2881 PL_gid = PerlProc_getgid();
79072805
LW
2882 break;
2883 case ')':
5cd24f17
PP
2884#ifdef HAS_SETGROUPS
2885 {
b83604b4 2886 const char *p = SvPV_const(sv, len);
757f63d8 2887 Groups_t *gary = NULL;
fb4089e0 2888#ifdef _SC_NGROUPS_MAX
2889 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2890
2891 if (maxgrp < 0)
2892 maxgrp = NGROUPS;
2893#else
2894 int maxgrp = NGROUPS;
2895#endif
757f63d8
SP
2896
2897 while (isSPACE(*p))
2898 ++p;
2899 PL_egid = Atol(p);
fb4089e0 2900 for (i = 0; i < maxgrp; ++i) {
757f63d8
SP
2901 while (*p && !isSPACE(*p))
2902 ++p;
2903 while (isSPACE(*p))
2904 ++p;
2905 if (!*p)
2906 break;
2907 if(!gary)
2908 Newx(gary, i + 1, Groups_t);
2909 else
2910 Renew(gary, i + 1, Groups_t);
2911 gary[i] = Atol(p);
2912 }
2913 if (i)
2914 (void)setgroups(i, gary);
f5a63d97 2915 Safefree(gary);
5cd24f17
PP
2916 }
2917#else /* HAS_SETGROUPS */
38ab35f8 2918 PL_egid = SvIV(sv);
5cd24f17 2919#endif /* HAS_SETGROUPS */
3280af22
NIS
2920 if (PL_delaymagic) {
2921 PL_delaymagic |= DM_EGID;
79072805
LW
2922 break; /* don't do magic till later */
2923 }
2924#ifdef HAS_SETEGID
3280af22 2925 (void)setegid((Gid_t)PL_egid);
79072805
LW
2926#else
2927#ifdef HAS_SETREGID
b28d0864 2928 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2929#else
2930#ifdef HAS_SETRESGID
b28d0864 2931 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2932#else
b28d0864
NIS
2933 if (PL_egid == PL_gid) /* special case $) = $( */
2934 (void)PerlProc_setgid(PL_egid);
748a9306 2935 else {
d8eceb89 2936 PL_egid = PerlProc_getegid();
cea2e8a9 2937 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2938 }
79072805
LW
2939#endif
2940#endif
85e6fe83 2941#endif
d8eceb89 2942 PL_egid = PerlProc_getegid();
79072805
LW
2943 break;
2944 case ':':
2d8e6c8d 2945 PL_chopset = SvPV_force(sv,len);
79072805 2946 break;
9cdac2a2
FC
2947 case '$': /* $$ */
2948 /* Store the pid in mg->mg_obj so we can tell when a fork has
2949 occurred. mg->mg_obj points to *$ by default, so clear it. */
2950 if (isGV(mg->mg_obj)) {
2951 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2952 SvREFCNT_dec(mg->mg_obj);
2953 mg->mg_flags |= MGf_REFCOUNTED;
2954 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2955 }
2956 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2957 break;
79072805 2958 case '0':
e2975953 2959 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2960#ifdef HAS_SETPROCTITLE
2961 /* The BSDs don't show the argv[] in ps(1) output, they
2962 * show a string from the process struct and provide
2963 * the setproctitle() routine to manipulate that. */
a2722ac9 2964 if (PL_origalen != 1) {
b83604b4 2965 s = SvPV_const(sv, len);
98b76f99 2966# if __FreeBSD_version > 410001
9aad2c0e 2967 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2968 * but not the "(perl) suffix from the ps(1)
2969 * output, because that's what ps(1) shows if the
2970 * argv[] is modified. */
6f2ad931 2971 setproctitle("-%s", s);
9aad2c0e 2972# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2973 /* This doesn't really work if you assume that
2974 * $0 = 'foobar'; will wipe out 'perl' from the $0
2975 * because in ps(1) output the result will be like
2976 * sprintf("perl: %s (perl)", s)
2977 * I guess this is a security feature:
2978 * one (a user process) cannot get rid of the original name.
2979 * --jhi */
2980 setproctitle("%s", s);
2981# endif
2982 }
9d3968b2 2983#elif defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2984 if (PL_origalen != 1) {
17aa7f3d 2985 union pstun un;
b83604b4 2986 s = SvPV_const(sv, len);
6867be6d 2987 un.pst_command = (char *)s;
17aa7f3d
JH
2988 pstat(PSTAT_SETCMD, un, len, 0, 0);
2989 }
9d3968b2 2990#else
2d2af554
GA
2991 if (PL_origalen > 1) {
2992 /* PL_origalen is set in perl_parse(). */
2993 s = SvPV_force(sv,len);
2994 if (len >= (STRLEN)PL_origalen-1) {
2995 /* Longer than original, will be truncated. We assume that
2996 * PL_origalen bytes are available. */
2997 Copy(s, PL_origargv[0], PL_origalen-1, char);
2998 }
2999 else {
3000 /* Shorter than original, will be padded. */
235ac35d 3001#ifdef PERL_DARWIN
60777a0d
JH
3002 /* Special case for Mac OS X: see [perl #38868] */
3003 const int pad = 0;
235ac35d 3004#else
8a89a4f1
MB
3005 /* Is the space counterintuitive? Yes.
3006 * (You were expecting \0?)
3007 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3008 * --jhi */
60777a0d 3009 const int pad = ' ';
235ac35d 3010#endif
60777a0d
JH
3011 Copy(s, PL_origargv[0], len, char);
3012 PL_origargv[0][len] = 0;
3013 memset(PL_origargv[0] + len + 1,
3014 pad, PL_origalen - len - 1);
2d2af554
GA
3015 }
3016 PL_origargv[0][PL_origalen-1] = 0;
3017 for (i = 1; i < PL_origargc; i++)
3018 PL_origargv[i] = 0;
7636ea95
AB
3019#ifdef HAS_PRCTL_SET_NAME
3020 /* Set the legacy process name in addition to the POSIX name on Linux */
3021 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3022 /* diag_listed_as: SKIPME */
3023 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3024 }
3025#endif
79072805 3026 }
9d3968b2 3027#endif
e2975953 3028 UNLOCK_DOLLARZERO_MUTEX;
79072805
LW
3029 break;
3030 }
3031 return 0;
3032}
3033
3034I32
84c7b88c
BF
3035Perl_whichsig_sv(pTHX_ SV *sigsv)
3036{
3037 const char *sigpv;
3038 STRLEN siglen;
3039 PERL_ARGS_ASSERT_WHICHSIG_SV;
3040 PERL_UNUSED_CONTEXT;
3041 sigpv = SvPV_const(sigsv, siglen);
3042 return whichsig_pvn(sigpv, siglen);
3043}
3044
3045I32
3046Perl_whichsig_pv(pTHX_ const char *sig)
3047{
3048 PERL_ARGS_ASSERT_WHICHSIG_PV;
3049 PERL_UNUSED_CONTEXT;
3050 return whichsig_pvn(sig, strlen(sig));
3051}
3052
3053I32
3054Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
79072805 3055{
aadb217d 3056 register char* const* sigv;
7918f24d 3057
84c7b88c 3058 PERL_ARGS_ASSERT_WHICHSIG_PVN;
96a5add6 3059 PERL_UNUSED_CONTEXT;
79072805 3060
aadb217d 3061 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
84c7b88c 3062 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
aadb217d 3063 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805 3064#ifdef SIGCLD
84c7b88c 3065 if (memEQs(sig, len, "CHLD"))
79072805
LW
3066 return SIGCLD;
3067#endif
3068#ifdef SIGCHLD
84c7b88c 3069 if (memEQs(sig, len, "CLD"))
79072805
LW
3070 return SIGCHLD;
3071#endif
7f1236c0 3072 return -1;
79072805
LW
3073}
3074
ecfc5424 3075Signal_t
1e82f5a6 3076#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3077Perl_sighandler(int sig, siginfo_t *sip, void *uap)
1e82f5a6
SH
3078#else
3079Perl_sighandler(int sig)
3080#endif
79072805 3081{
1018e26f
NIS
3082#ifdef PERL_GET_SIG_CONTEXT
3083 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 3084#else
cea2e8a9 3085 dTHX;
71d280e3 3086#endif
79072805 3087 dSP;
a0714e2c
SS
3088 GV *gv = NULL;
3089 SV *sv = NULL;
8772537c 3090 SV * const tSv = PL_Sv;
601f1833 3091 CV *cv = NULL;
533c011a 3092 OP *myop = PL_op;
84902520 3093 U32 flags = 0;
8772537c 3094 XPV * const tXpv = PL_Xpv;
0c4d3b5e 3095 I32 old_ss_ix = PL_savestack_ix;
71d280e3 3096
84902520 3097
727405f8 3098 if (!PL_psig_ptr[sig]) {
99ef548b 3099 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
3100 PL_sig_name[sig]);
3101 exit(sig);
3102 }
ff0cee69 3103
a0d63a7b
DM
3104 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3105 /* Max number of items pushed there is 3*n or 4. We cannot fix
3106 infinity, so we fix 4 (in fact 5): */
3107 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3108 flags |= 1;
3109 PL_savestack_ix += 5; /* Protect save in progress. */
3110 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3111 }
84902520 3112 }
84902520 3113 /* sv_2cv is too complicated, try a simpler variant first: */
ea726b52 3114 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
8772537c
AL
3115 || SvTYPE(cv) != SVt_PVCV) {
3116 HV *st;
f2c0649b 3117 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 3118 }
84902520 3119
a0d0e21e 3120 if (!cv || !CvROOT(cv)) {
a2a5de95
NC
3121 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3122 PL_sig_name[sig], (gv ? GvENAME(gv)
3123 : ((cv && CvGV(cv))
3124 ? GvENAME(CvGV(cv))
3125 : "__ANON__")));
00d579c5 3126 goto cleanup;
79072805
LW
3127 }
3128
0c4d3b5e
DM
3129 sv = PL_psig_name[sig]
3130 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3131 : newSVpv(PL_sig_name[sig],0);
72048cfe 3132 flags |= 8;
0c4d3b5e
DM
3133 SAVEFREESV(sv);
3134
a0d63a7b
DM
3135 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3136 /* make sure our assumption about the size of the SAVEs are correct:
3137 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3138 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3139 }
e336de0d 3140
e788e7d3 3141 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 3142 PUSHMARK(SP);
79072805 3143 PUSHs(sv);
8aad04aa
JH
3144#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3145 {
3146 struct sigaction oact;
3147
3148 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
8aad04aa
JH
3149 if (sip) {
3150 HV *sih = newHV();
ad64d0ec 3151 SV *rv = newRV_noinc(MUTABLE_SV(sih));
8aad04aa
JH
3152 /* The siginfo fields signo, code, errno, pid, uid,
3153 * addr, status, and band are defined by POSIX/SUSv3. */
85771703
NC
3154 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3155 (void)hv_stores(sih, "code", newSViv(sip->si_code));
79dec0f4 3156#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. */
85771703
NC
3157 hv_stores(sih, "errno", newSViv(sip->si_errno));
3158 hv_stores(sih, "status", newSViv(sip->si_status));
3159 hv_stores(sih, "uid", newSViv(sip->si_uid));
3160 hv_stores(sih, "pid", newSViv(sip->si_pid));
3161 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3162 hv_stores(sih, "band", newSViv(sip->si_band));
79dec0f4 3163#endif
8aad04aa 3164 EXTEND(SP, 2);
ad64d0ec 3165 PUSHs(rv);
22f1178f 3166 mPUSHp((char *)sip, sizeof(*sip));
8aad04aa 3167 }
b4552a27 3168
8aad04aa
JH
3169 }
3170 }
3171#endif
79072805 3172 PUTBACK;
a0d0e21e 3173
ad64d0ec 3174 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
79072805 3175
d3acc0f7 3176 POPSTACK;
1b266415 3177 if (SvTRUE(ERRSV)) {
c22d665b 3178#ifndef PERL_MICRO
1b266415
NIS
3179 /* Handler "died", for example to get out of a restart-able read().
3180 * Before we re-do that on its behalf re-enable the signal which was
3181 * blocked by the system when we entered.
3182 */
c22d665b 3183#ifdef HAS_SIGPROCMASK
d488af49 3184#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3185 if (sip || uap)
c22d665b
LT
3186#endif
3187 {
3188 sigset_t set;
3189 sigemptyset(&set);
3190 sigaddset(&set,sig);
3191 sigprocmask(SIG_UNBLOCK, &set, NULL);
3192 }
3193#else
1b266415
NIS
3194 /* Not clear if this will work */
3195 (void)rsignal(sig, SIG_IGN);
5c1546dc 3196 (void)rsignal(sig, PL_csighandlerp);
c22d665b
LT
3197#endif
3198#endif /* !PERL_MICRO */
c5df3096 3199 die_sv(ERRSV);
1b266415 3200 }
00d579c5 3201cleanup:
0c4d3b5e
DM
3202 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3203 PL_savestack_ix = old_ss_ix;
72048cfe 3204 if (flags & 8)
84902520 3205 SvREFCNT_dec(sv);
533c011a 3206 PL_op = myop; /* Apparently not needed... */
ac27b0f5 3207
3280af22
NIS
3208 PL_Sv = tSv; /* Restore global temporaries. */
3209 PL_Xpv = tXpv;
53bb94e2 3210 return;
79072805 3211}
4e35701f
NIS
3212
3213
51371543 3214static void
8772537c 3215S_restore_magic(pTHX_ const void *p)
51371543 3216{
97aff369 3217 dVAR;
8772537c
AL
3218 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3219 SV* const sv = mgs->mgs_sv;
150b625d 3220 bool bumped;
51371543
GS
3221
3222 if (!sv)
3223 return;
3224
3225 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3226 {
f8c7b90f 3227#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
3228 /* While magic was saved (and off) sv_setsv may well have seen
3229 this SV as a prime candidate for COW. */
3230 if (SvIsCOW(sv))
e424a81e 3231 sv_force_normal_flags(sv, 0);
f9701176
NC
3232#endif
3233
f9c6fee5
CS
3234 if (mgs->mgs_readonly)
3235 SvREADONLY_on(sv);
3236 if (mgs->mgs_magical)
3237 SvFLAGS(sv) |= mgs->mgs_magical;
51371543
GS
3238 else
3239 mg_magical(sv);
2b77b520
YST
3240 if (SvGMAGICAL(sv)) {
3241 /* downgrade public flags to private,
3242 and discard any other private flags */
3243
10edeb5d
JH
3244 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3245 if (pubflags) {
3246 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3247 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2b77b520
YST
3248 }
3249 }
51371543
GS
3250 }
3251
150b625d 3252 bumped = mgs->mgs_bumped;
51371543
GS
3253 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3254
3255 /* If we're still on top of the stack, pop us off. (That condition
3256 * will be satisfied if restore_magic was called explicitly, but *not*
3257 * if it's being called via leave_scope.)
3258 * The reason for doing this is that otherwise, things like sv_2cv()
3259 * may leave alloc gunk on the savestack, and some code
3260 * (e.g. sighandler) doesn't expect that...
3261 */
3262 if (PL_savestack_ix == mgs->mgs_ss_ix)
3263 {
1be36ce0
NC
3264 UV popval = SSPOPUV;
3265 assert(popval == SAVEt_DESTRUCTOR_X);
51371543 3266 PL_savestack_ix -= 2;
1be36ce0
NC
3267 popval = SSPOPUV;
3268 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3269 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
51371543 3270 }
150b625d
DM
3271 if (bumped) {
3272 if (SvREFCNT(sv) == 1) {
3273 /* We hold the last reference to this SV, which implies that the
3274 SV was deleted as a side effect of the routines we called.
3275 So artificially keep it alive a bit longer.
3276 We avoid turning on the TEMP flag, which can cause the SV's
3277 buffer to get stolen (and maybe other stuff). */
3278 int was_temp = SvTEMP(sv);
3279 sv_2mortal(sv);
3280 if (!was_temp) {
3281 SvTEMP_off(sv);
3282 }
3283 SvOK_off(sv);
8985fe98 3284 }
150b625d
DM
3285 else
3286 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
8985fe98 3287 }
51371543
GS
3288}
3289
0c4d3b5e
DM
3290/* clean up the mess created by Perl_sighandler().
3291 * Note that this is only called during an exit in a signal handler;
3292 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
9a7f166c 3293 * skipped over. */
0c4d3b5e 3294
51371543 3295static void
8772537c 3296S_unwind_handler_stack(pTHX_ const void *p)
51371543 3297{
27da23d5 3298 dVAR;
0c4d3b5e 3299 PERL_UNUSED_ARG(p);
7918f24d 3300
0c4d3b5e 3301 PL_savestack_ix -= 5; /* Unprotect save in progress. */
51371543 3302}
1018e26f 3303
66610fdd 3304/*
b3ca2e83
NC
3305=for apidoc magic_sethint
3306
3307Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC
3308C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3309anything that would need a deep copy. Maybe we should warn if we find a
3310reference.
b3ca2e83
NC
3311
3312=cut
3313*/
3314int
3315Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3316{
3317 dVAR;
ad64d0ec 3318 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
59cd0e26 3319 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
b3ca2e83 3320
7918f24d
NC
3321 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3322
e6e3e454
NC
3323 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3324 an alternative leaf in there, with PL_compiling.cop_hints being used if
3325 it's NULL. If needed for threads, the alternative could lock a mutex,
3326 or take other more complex action. */
3327
5b9c0671
NC
3328 /* Something changed in %^H, so it will need to be restored on scope exit.
3329 Doing this here saves a lot of doing it manually in perl code (and
3330 forgetting to do it, and consequent subtle errors. */
3331 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z
3332 CopHINTHASH_set(&PL_compiling,
3333 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
b3ca2e83
NC
3334 return 0;
3335}
3336
3337/*
f175cff5 3338=for apidoc magic_clearhint
b3ca2e83 3339
c28fe1ec
NC
3340Triggered by a delete from %^H, records the key to
3341C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC
3342
3343=cut
3344*/
3345int
3346Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3347{
3348 dVAR;
7918f24d
NC
3349
3350 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
f5a63d97
AL
3351 PERL_UNUSED_ARG(sv);
3352
b3ca2e83
NC
3353 assert(mg->mg_len == HEf_SVKEY);
3354
b3f24c00
MHM
3355 PERL_UNUSED_ARG(sv);
3356
5b9c0671 3357 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z
3358 CopHINTHASH_set(&PL_compiling,
3359 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3360 MUTABLE_SV(mg->mg_ptr), 0, 0));
b3ca2e83
NC
3361 return 0;
3362}
3363
3364/*
f747ebd6
Z
3365=for apidoc magic_clearhints
3366
3367Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3368
3369=cut
3370*/
3371int
3372Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3373{
3374 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3375 PERL_UNUSED_ARG(sv);
3376 PERL_UNUSED_ARG(mg);
20439bc7
Z
3377 cophh_free(CopHINTHASH_get(&PL_compiling));
3378 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
f747ebd6
Z
3379 return 0;
3380}
3381
3382/*
66610fdd
RGS
3383 * Local variables:
3384 * c-indentation-style: bsd
3385 * c-basic-offset: 4
3386 * indent-tabs-mode: t
3387 * End:
3388 *
37442d52
RGS
3389 * ex: set ts=8 sts=4 sw=4 noet:
3390 */