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