This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make hash-rt85026.t less noisy
[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;
179c85a2 1365
38a124f0 1366 magic_setsig(NULL, mg);
179c85a2 1367 return sv_unmagic(sv, mg->mg_type);
88e89b8a 1368}
3d37d572 1369
0a8e0eff 1370Signal_t
8aad04aa 1371#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 1372Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
8aad04aa 1373#else
0a8e0eff 1374Perl_csighandler(int sig)
8aad04aa 1375#endif
0a8e0eff 1376{
1018e26f
NIS
1377#ifdef PERL_GET_SIG_CONTEXT
1378 dTHXa(PERL_GET_SIG_CONTEXT);
1379#else
85b332e2
CL
1380 dTHX;
1381#endif
23ada85b 1382#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1383 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1384 if (PL_sig_ignoring[sig]) return;
85b332e2 1385#endif
2e34cc90 1386#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1387 if (PL_sig_defaulting[sig])
2e34cc90
CL
1388#ifdef KILL_BY_SIGPRC
1389 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1390#else
1391 exit(1);
1392#endif
1393#endif
406878dd 1394 if (
853d2c32
RGS
1395#ifdef SIGILL
1396 sig == SIGILL ||
1397#endif
1398#ifdef SIGBUS
1399 sig == SIGBUS ||
1400#endif
1401#ifdef SIGSEGV
1402 sig == SIGSEGV ||
1403#endif
1404 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
4ffa73a3 1405 /* Call the perl level handler now--
31c91b43 1406 * with risk we may be in malloc() or being destructed etc. */
6e324d09 1407#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1408 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1409#else
1410 (*PL_sighandlerp)(sig);
92807b6d 1411#endif
406878dd 1412 else {
31c91b43 1413 if (!PL_psig_pend) return;
406878dd
GA
1414 /* Set a flag to say this signal is pending, that is awaiting delivery after
1415 * the current Perl opcode completes */
1416 PL_psig_pend[sig]++;
1417
1418#ifndef SIG_PENDING_DIE_COUNT
1419# define SIG_PENDING_DIE_COUNT 120
1420#endif
fe13d51d 1421 /* Add one to say _a_ signal is pending */
406878dd
GA
1422 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1423 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1424 (unsigned long)SIG_PENDING_DIE_COUNT);
1425 }
0a8e0eff
NIS
1426}
1427
2e34cc90
CL
1428#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1429void
1430Perl_csighandler_init(void)
1431{
1432 int sig;
27da23d5 1433 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1434
1435 for (sig = 1; sig < SIG_SIZE; sig++) {
1436#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1437 dTHX;
27da23d5 1438 PL_sig_defaulting[sig] = 1;
5c1546dc 1439 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1440#endif
1441#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1442 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1443#endif
1444 }
27da23d5 1445 PL_sig_handlers_initted = 1;
2e34cc90
CL
1446}
1447#endif
1448
7fe50b8b
LT
1449#if defined HAS_SIGPROCMASK
1450static void
1451unblock_sigmask(pTHX_ void* newset)
1452{
1453 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1454}
1455#endif
1456
0a8e0eff
NIS
1457void
1458Perl_despatch_signals(pTHX)
1459{
97aff369 1460 dVAR;
0a8e0eff
NIS
1461 int sig;
1462 PL_sig_pending = 0;
1463 for (sig = 1; sig < SIG_SIZE; sig++) {
1464 if (PL_psig_pend[sig]) {
d0166017 1465 dSAVE_ERRNO;
7fe50b8b 1466#ifdef HAS_SIGPROCMASK
55534442
LT
1467 /* From sigaction(2) (FreeBSD man page):
1468 * | Signal routines normally execute with the signal that
1469 * | caused their invocation blocked, but other signals may
1470 * | yet occur.
1471 * Emulation of this behavior (from within Perl) is enabled
1472 * using sigprocmask
1473 */
1474 int was_blocked;
1475 sigset_t newset, oldset;
1476
1477 sigemptyset(&newset);
1478 sigaddset(&newset, sig);
1479 sigprocmask(SIG_BLOCK, &newset, &oldset);
1480 was_blocked = sigismember(&oldset, sig);
7fe50b8b
LT
1481 if (!was_blocked) {
1482 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1483 ENTER;
1484 SAVEFREESV(save_sv);
1485 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1486 }
55534442 1487#endif
25da4428 1488 PL_psig_pend[sig] = 0;
6e324d09 1489#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1490 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1491#else
1492 (*PL_sighandlerp)(sig);
92807b6d 1493#endif
7fe50b8b 1494#ifdef HAS_SIGPROCMASK
55534442 1495 if (!was_blocked)
7fe50b8b 1496 LEAVE;
55534442 1497#endif
d0166017 1498 RESTORE_ERRNO;
0a8e0eff
NIS
1499 }
1500 }
1501}
1502
38a124f0 1503/* sv of NULL signifies that we're acting as magic_clearsig. */
85e6fe83 1504int
864dbfa3 1505Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1506{
27da23d5 1507 dVAR;
79072805 1508 I32 i;
cbbf8932 1509 SV** svp = NULL;
2d4fcd5e
AJ
1510 /* Need to be careful with SvREFCNT_dec(), because that can have side
1511 * effects (due to closures). We must make sure that the new disposition
1512 * is in place before it is called.
1513 */
cbbf8932 1514 SV* to_dec = NULL;
e72dc28c 1515 STRLEN len;
2d4fcd5e
AJ
1516#ifdef HAS_SIGPROCMASK
1517 sigset_t set, save;
1518 SV* save_sv;
1519#endif
d5263905 1520 register const char *s = MgPV_const(mg,len);
7918f24d
NC
1521
1522 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1523
748a9306
LW
1524 if (*s == '_') {
1525 if (strEQ(s,"__DIE__"))
3280af22 1526 svp = &PL_diehook;
38a124f0
NC
1527 else if (strEQ(s,"__WARN__")
1528 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1529 /* Merge the existing behaviours, which are as follows:
1530 magic_setsig, we always set svp to &PL_warnhook
1531 (hence we always change the warnings handler)
1532 For magic_clearsig, we don't change the warnings handler if it's
1533 set to the &PL_warnhook. */
3280af22 1534 svp = &PL_warnhook;
38a124f0 1535 } else if (sv)
cea2e8a9 1536 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1537 i = 0;
38a124f0 1538 if (svp && *svp) {
9289f461
RGS
1539 if (*svp != PERL_WARNHOOK_FATAL)
1540 to_dec = *svp;
cbbf8932 1541 *svp = NULL;
4633a7c4 1542 }
748a9306
LW
1543 }
1544 else {
708854f2
NC
1545 i = (I16)mg->mg_private;
1546 if (!i) {
58a26b12
NC
1547 i = whichsig(s); /* ...no, a brick */
1548 mg->mg_private = (U16)i;
708854f2 1549 }
86d86cad 1550 if (i <= 0) {
a2a5de95
NC
1551 if (sv)
1552 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1553 return 0;
1554 }
2d4fcd5e
AJ
1555#ifdef HAS_SIGPROCMASK
1556 /* Avoid having the signal arrive at a bad time, if possible. */
1557 sigemptyset(&set);
1558 sigaddset(&set,i);
1559 sigprocmask(SIG_BLOCK, &set, &save);
1560 ENTER;
9ff8e806 1561 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
2d4fcd5e
AJ
1562 SAVEFREESV(save_sv);
1563 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1564#endif
1565 PERL_ASYNC_CHECK();
2e34cc90 1566#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1567 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1568#endif
23ada85b 1569#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1570 PL_sig_ignoring[i] = 0;
85b332e2 1571#endif
2e34cc90 1572#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1573 PL_sig_defaulting[i] = 0;
2e34cc90 1574#endif
2d4fcd5e 1575 to_dec = PL_psig_ptr[i];
38a124f0
NC
1576 if (sv) {
1577 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1578 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
79fd3822
NC
1579
1580 /* Signals don't change name during the program's execution, so once
1581 they're cached in the appropriate slot of PL_psig_name, they can
1582 stay there.
1583
1584 Ideally we'd find some way of making SVs at (C) compile time, or
1585 at least, doing most of the work. */
1586 if (!PL_psig_name[i]) {
1587 PL_psig_name[i] = newSVpvn(s, len);
1588 SvREADONLY_on(PL_psig_name[i]);
1589 }
38a124f0 1590 } else {
79fd3822 1591 SvREFCNT_dec(PL_psig_name[i]);
38a124f0
NC
1592 PL_psig_name[i] = NULL;
1593 PL_psig_ptr[i] = NULL;
1594 }
748a9306 1595 }
38a124f0 1596 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
2d4fcd5e 1597 if (i) {
5c1546dc 1598 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1599 }
748a9306 1600 else
b37c2d43 1601 *svp = SvREFCNT_inc_simple_NN(sv);
38a124f0 1602 } else {
9dfa190b
NC
1603 if (sv && SvOK(sv)) {
1604 s = SvPV_force(sv, len);
1605 } else {
1606 sv = NULL;
1607 }
1608 if (sv && strEQ(s,"IGNORE")) {
1609 if (i) {
23ada85b 1610#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
9dfa190b
NC
1611 PL_sig_ignoring[i] = 1;
1612 (void)rsignal(i, PL_csighandlerp);
85b332e2 1613#else
9dfa190b 1614 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1615#endif
9dfa190b 1616 }
2d4fcd5e 1617 }
9dfa190b
NC
1618 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1619 if (i) {
2e34cc90 1620#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
9dfa190b
NC
1621 PL_sig_defaulting[i] = 1;
1622 (void)rsignal(i, PL_csighandlerp);
2e34cc90 1623#else
9dfa190b 1624 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1625#endif
9dfa190b
NC
1626 }
1627 }
1628 else {
1629 /*
1630 * We should warn if HINT_STRICT_REFS, but without
1631 * access to a known hint bit in a known OP, we can't
1632 * tell whether HINT_STRICT_REFS is in force or not.
1633 */
1634 if (!strchr(s,':') && !strchr(s,'\''))
1635 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1636 SV_GMAGIC);
1637 if (i)
1638 (void)rsignal(i, PL_csighandlerp);
1639 else
1640 *svp = SvREFCNT_inc_simple_NN(sv);
136e0459 1641 }
748a9306 1642 }
9dfa190b 1643
2d4fcd5e
AJ
1644#ifdef HAS_SIGPROCMASK
1645 if(i)
1646 LEAVE;
1647#endif
ef8d46e8 1648 SvREFCNT_dec(to_dec);
79072805
LW
1649 return 0;
1650}
64ca3a65 1651#endif /* !PERL_MICRO */
79072805
LW
1652
1653int
864dbfa3 1654Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1655{
97aff369 1656 dVAR;
7918f24d 1657 PERL_ARGS_ASSERT_MAGIC_SETISA;
8772537c 1658 PERL_UNUSED_ARG(sv);
e1a479c5 1659
89c14e2e 1660 /* Skip _isaelem because _isa will handle it shortly */
354b0578 1661 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
89c14e2e
BB
1662 return 0;
1663
0e446081 1664 return magic_clearisa(NULL, mg);
463ee0b2
LW
1665}
1666
0e446081 1667/* sv of NULL signifies that we're acting as magic_setisa. */
463ee0b2 1668int
52b45067
RD
1669Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1670{
1671 dVAR;
1672 HV* stash;
1673
7918f24d
NC
1674 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1675
52b45067 1676 /* Bail out if destruction is going on */
627364f1 1677 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
52b45067 1678
0e446081
NC
1679 if (sv)
1680 av_clear(MUTABLE_AV(sv));
52b45067 1681
6624142a
FC
1682 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1683 /* This occurs with setisa_elem magic, which calls this
1684 same function. */
1685 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1686
1687 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1688 SV **svp = AvARRAY((AV *)mg->mg_obj);
1689 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1690 while (items--) {
1691 stash = GvSTASH((GV *)*svp++);
1692 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1693 }
1694
1695 return 0;
1696 }
1697
52b45067 1698 stash = GvSTASH(
6624142a 1699 (const GV *)mg->mg_obj
52b45067
RD
1700 );
1701
00169e2c
FC
1702 /* The stash may have been detached from the symbol table, so check its
1703 name before doing anything. */
1704 if (stash && HvENAME_get(stash))
5562fa71 1705 mro_isa_changed_in(stash);
52b45067
RD
1706
1707 return 0;
1708}
1709
1710int
864dbfa3 1711Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1712{
97aff369 1713 dVAR;
7918f24d 1714 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
8772537c
AL
1715 PERL_UNUSED_ARG(sv);
1716 PERL_UNUSED_ARG(mg);
3280af22 1717 PL_amagic_generation++;
463ee0b2 1718
a0d0e21e
LW
1719 return 0;
1720}
463ee0b2 1721
946ec16e 1722int
864dbfa3 1723Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1724{
85fbaab2 1725 HV * const hv = MUTABLE_HV(LvTARG(sv));
6ff81951 1726 I32 i = 0;
7918f24d
NC
1727
1728 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
8772537c 1729 PERL_UNUSED_ARG(mg);
7719e241 1730
6ff81951 1731 if (hv) {
497b47a8 1732 (void) hv_iterinit(hv);
ad64d0ec 1733 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1b95d04f 1734 i = HvUSEDKEYS(hv);
497b47a8
JH
1735 else {
1736 while (hv_iternext(hv))
1737 i++;
1738 }
6ff81951
GS
1739 }
1740
1741 sv_setiv(sv, (IV)i);
1742 return 0;
1743}
1744
1745int
864dbfa3 1746Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1747{
7918f24d 1748 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
8772537c 1749 PERL_UNUSED_ARG(mg);
946ec16e 1750 if (LvTARG(sv)) {
85fbaab2 1751 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
946ec16e
PP
1752 }
1753 return 0;
ac27b0f5 1754}
946ec16e 1755
efaf3674
DM
1756/*
1757=for apidoc magic_methcall
1758
1759Invoke a magic method (like FETCH).
1760
b6538e4f 1761* sv and mg are the tied thingy and the tie magic;
efaf3674 1762* meth is the name of the method to call;
1a1a5af7
DM
1763* argc is the number of args (in addition to $self) to pass to the method;
1764 the args themselves are any values following the argc argument.
efaf3674
DM
1765* flags:
1766 G_DISCARD: invoke method with G_DISCARD flag and don't return a value
1a1a5af7 1767 G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef.
efaf3674
DM
1768
1769Returns the SV (if any) returned by the method, or NULL on failure.
1770
1771
1772=cut
1773*/
1774
1775SV*
c7a0c747 1776Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
046b0c7d 1777 U32 argc, ...)
a0d0e21e 1778{
97aff369 1779 dVAR;
a0d0e21e 1780 dSP;
efaf3674 1781 SV* ret = NULL;
463ee0b2 1782
7918f24d
NC
1783 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1784
efaf3674 1785 ENTER;
d1d7a15d
NC
1786
1787 if (flags & G_WRITING_TO_STDERR) {
1788 SAVETMPS;
1789
1790 save_re_context();
1791 SAVESPTR(PL_stderrgv);
1792 PL_stderrgv = NULL;
1793 }
1794
efaf3674 1795 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1796 PUSHMARK(SP);
efaf3674 1797
67549bd2
NC
1798 EXTEND(SP, argc+1);
1799 PUSHs(SvTIED_obj(sv, mg));
1800 if (flags & G_UNDEF_FILL) {
1801 while (argc--) {
efaf3674 1802 PUSHs(&PL_sv_undef);
93965878 1803 }
67549bd2 1804 } else if (argc > 0) {
046b0c7d
NC
1805 va_list args;
1806 va_start(args, argc);
1807
1808 do {
1809 SV *const sv = va_arg(args, SV *);
1810 PUSHs(sv);
1811 } while (--argc);
1812
1813 va_end(args);
88e89b8a 1814 }
463ee0b2 1815 PUTBACK;
efaf3674
DM
1816 if (flags & G_DISCARD) {
1817 call_method(meth, G_SCALAR|G_DISCARD);
1818 }
1819 else {
1820 if (call_method(meth, G_SCALAR))
1821 ret = *PL_stack_sp--;
1822 }
1823 POPSTACK;
d1d7a15d
NC
1824 if (flags & G_WRITING_TO_STDERR)
1825 FREETMPS;
efaf3674
DM
1826 LEAVE;
1827 return ret;
1828}
1829
1830
1831/* wrapper for magic_methcall that creates the first arg */
463ee0b2 1832
efaf3674 1833STATIC SV*
c7a0c747 1834S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
efaf3674
DM
1835 int n, SV *val)
1836{
1837 dVAR;
1838 SV* arg1 = NULL;
1839
1840 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1841
1842 if (mg->mg_ptr) {
1843 if (mg->mg_len >= 0) {
db4b3a1d 1844 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
efaf3674
DM
1845 }
1846 else if (mg->mg_len == HEf_SVKEY)
1847 arg1 = MUTABLE_SV(mg->mg_ptr);
1848 }
1849 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
db4b3a1d 1850 arg1 = newSViv((IV)(mg->mg_len));
efaf3674
DM
1851 sv_2mortal(arg1);
1852 }
1853 if (!arg1) {
046b0c7d 1854 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
efaf3674 1855 }
046b0c7d 1856 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
946ec16e
PP
1857}
1858
76e3520e 1859STATIC int
e1ec3a88 1860S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1861{
efaf3674
DM
1862 dVAR;
1863 SV* ret;
463ee0b2 1864
7918f24d
NC
1865 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1866
efaf3674
DM
1867 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1868 if (ret)
1869 sv_setsv(sv, ret);
a0d0e21e
LW
1870 return 0;
1871}
463ee0b2 1872
a0d0e21e 1873int
864dbfa3 1874Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1875{
7918f24d
NC
1876 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1877
fd69380d 1878 if (mg->mg_type == PERL_MAGIC_tiedelem)
a0d0e21e 1879 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1880 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1881 return 0;
1882}
1883
1884int
864dbfa3 1885Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1886{
efaf3674 1887 dVAR;
b112cff9
DM
1888 MAGIC *tmg;
1889 SV *val;
7918f24d
NC
1890
1891 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1892
b112cff9
DM
1893 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1894 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1895 * public flags indicate its value based on copying from $val. Doing
1896 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1897 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1898 * wrong if $val happened to be tainted, as sv hasn't got magic
1899 * enabled, even though taint magic is in the chain. In which case,
1900 * fake up a temporary tainted value (this is easier than temporarily
1901 * re-enabling magic on sv). */
1902
1903 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1904 && (tmg->mg_len & 1))
1905 {
1906 val = sv_mortalcopy(sv);
1907 SvTAINTED_on(val);
1908 }
1909 else
1910 val = sv;
1911
efaf3674 1912 magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
463ee0b2
LW
1913 return 0;
1914}
1915
1916int
864dbfa3 1917Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1918{
7918f24d
NC
1919 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1920
a0d0e21e
LW
1921 return magic_methpack(sv,mg,"DELETE");
1922}
463ee0b2 1923
93965878
NIS
1924
1925U32
864dbfa3 1926Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1927{
efaf3674 1928 dVAR;
22846ab4 1929 I32 retval = 0;
efaf3674 1930 SV* retsv;
93965878 1931
7918f24d
NC
1932 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1933
efaf3674
DM
1934 retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1935 if (retsv) {
1936 retval = SvIV(retsv)-1;
22846ab4
AB
1937 if (retval < -1)
1938 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
93965878 1939 }
22846ab4 1940 return (U32) retval;
93965878
NIS
1941}
1942
cea2e8a9
GS
1943int
1944Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1945{
efaf3674 1946 dVAR;
463ee0b2 1947
7918f24d
NC
1948 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1949
046b0c7d 1950 Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
463ee0b2
LW
1951 return 0;
1952}
1953
1954int
864dbfa3 1955Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1956{
efaf3674
DM
1957 dVAR;
1958 SV* ret;
463ee0b2 1959
7918f24d
NC
1960 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1961
046b0c7d
NC
1962 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1963 : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
efaf3674
DM
1964 if (ret)
1965 sv_setsv(key,ret);
79072805
LW
1966 return 0;
1967}
1968
1969int
1146e912 1970Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e 1971{
7918f24d
NC
1972 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1973
a0d0e21e 1974 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1975}
a0d0e21e 1976
a3bcc51e
TP
1977SV *
1978Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1979{
efaf3674 1980 dVAR;
5fcbf73d 1981 SV *retval;
ad64d0ec
NC
1982 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1983 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
a3bcc51e 1984
7918f24d
NC
1985 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1986
a3bcc51e
TP
1987 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1988 SV *key;
bfcb3514 1989 if (HvEITER_get(hv))
a3bcc51e
TP
1990 /* we are in an iteration so the hash cannot be empty */
1991 return &PL_sv_yes;
1992 /* no xhv_eiter so now use FIRSTKEY */
1993 key = sv_newmortal();
ad64d0ec 1994 magic_nextpack(MUTABLE_SV(hv), mg, key);
bfcb3514 1995 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1996 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1997 }
1998
1999 /* there is a SCALAR method that we can call */
046b0c7d 2000 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
efaf3674 2001 if (!retval)
5fcbf73d 2002 retval = &PL_sv_undef;
a3bcc51e
TP
2003 return retval;
2004}
2005
a0d0e21e 2006int
864dbfa3 2007Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 2008{
97aff369 2009 dVAR;
8772537c
AL
2010 GV * const gv = PL_DBline;
2011 const I32 i = SvTRUE(sv);
2012 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 2013 atoi(MgPV_nolen_const(mg)), FALSE);
7918f24d
NC
2014
2015 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2016
8772537c
AL
2017 if (svp && SvIOKp(*svp)) {
2018 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2019 if (o) {
2020 /* set or clear breakpoint in the relevant control op */
2021 if (i)
2022 o->op_flags |= OPf_SPECIAL;
2023 else
2024 o->op_flags &= ~OPf_SPECIAL;
2025 }
5df8de69 2026 }
79072805
LW
2027 return 0;
2028}
2029
2030int
8772537c 2031Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 2032{
97aff369 2033 dVAR;
502c6561 2034 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
2035
2036 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2037
83bf042f 2038 if (obj) {
fc15ae8f 2039 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
83bf042f
NC
2040 } else {
2041 SvOK_off(sv);
2042 }
79072805
LW
2043 return 0;
2044}
2045
2046int
864dbfa3 2047Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 2048{
97aff369 2049 dVAR;
502c6561 2050 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
2051
2052 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2053
83bf042f 2054 if (obj) {
fc15ae8f 2055 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
83bf042f 2056 } else {
a2a5de95
NC
2057 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2058 "Attempt to set length of freed array");
83bf042f
NC
2059 }
2060 return 0;
2061}
2062
2063int
2064Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2065{
97aff369 2066 dVAR;
7918f24d
NC
2067
2068 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
53c1dcc0 2069 PERL_UNUSED_ARG(sv);
7918f24d 2070
94f3782b
DM
2071 /* during global destruction, mg_obj may already have been freed */
2072 if (PL_in_clean_all)
1ea47f64 2073 return 0;
94f3782b 2074
83bf042f
NC
2075 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2076
2077 if (mg) {
2078 /* arylen scalar holds a pointer back to the array, but doesn't own a
2079 reference. Hence the we (the array) are about to go away with it
2080 still pointing at us. Clear its pointer, else it would be pointing
2081 at free memory. See the comment in sv_magic about reference loops,
2082 and why it can't own a reference to us. */
2083 mg->mg_obj = 0;
2084 }
a0d0e21e
LW
2085 return 0;
2086}
2087
2088int
864dbfa3 2089Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2090{
97aff369 2091 dVAR;
8772537c 2092 SV* const lsv = LvTARG(sv);
7918f24d
NC
2093
2094 PERL_ARGS_ASSERT_MAGIC_GETPOS;
3881461a 2095 PERL_UNUSED_ARG(mg);
ac27b0f5 2096
a0d0e21e 2097 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
3881461a
AL
2098 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2099 if (found && found->mg_len >= 0) {
2100 I32 i = found->mg_len;
7e2040f0 2101 if (DO_UTF8(lsv))
a0ed51b3 2102 sv_pos_b2u(lsv, &i);
fc15ae8f 2103 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
a0d0e21e
LW
2104 return 0;
2105 }
2106 }
0c34ef67 2107 SvOK_off(sv);
a0d0e21e
LW
2108 return 0;
2109}
2110
2111int
864dbfa3 2112Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2113{
97aff369 2114 dVAR;
8772537c 2115 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
2116 SSize_t pos;
2117 STRLEN len;
c00206c8 2118 STRLEN ulen = 0;
53d44271 2119 MAGIC* found;
a0d0e21e 2120
7918f24d 2121 PERL_ARGS_ASSERT_MAGIC_SETPOS;
3881461a 2122 PERL_UNUSED_ARG(mg);
ac27b0f5 2123
a0d0e21e 2124 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
3881461a
AL
2125 found = mg_find(lsv, PERL_MAGIC_regex_global);
2126 else
2127 found = NULL;
2128 if (!found) {
a0d0e21e
LW
2129 if (!SvOK(sv))
2130 return 0;
d83f0a82
NC
2131#ifdef PERL_OLD_COPY_ON_WRITE
2132 if (SvIsCOW(lsv))
2133 sv_force_normal_flags(lsv, 0);
2134#endif
3881461a 2135 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
53d44271 2136 NULL, 0);
a0d0e21e
LW
2137 }
2138 else if (!SvOK(sv)) {
3881461a 2139 found->mg_len = -1;
a0d0e21e
LW
2140 return 0;
2141 }
2142 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2143
fc15ae8f 2144 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
a0ed51b3 2145
7e2040f0 2146 if (DO_UTF8(lsv)) {
a0ed51b3
LW
2147 ulen = sv_len_utf8(lsv);
2148 if (ulen)
2149 len = ulen;
a0ed51b3
LW
2150 }
2151
a0d0e21e
LW
2152 if (pos < 0) {
2153 pos += len;
2154 if (pos < 0)
2155 pos = 0;
2156 }
eb160463 2157 else if (pos > (SSize_t)len)
a0d0e21e 2158 pos = len;
a0ed51b3
LW
2159
2160 if (ulen) {
2161 I32 p = pos;
2162 sv_pos_u2b(lsv, &p, 0);
2163 pos = p;
2164 }
727405f8 2165
3881461a
AL
2166 found->mg_len = pos;
2167 found->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 2168
79072805
LW
2169 return 0;
2170}
2171
2172int
864dbfa3 2173Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
2174{
2175 STRLEN len;
35a4481c 2176 SV * const lsv = LvTARG(sv);
b83604b4 2177 const char * const tmps = SvPV_const(lsv,len);
777f7c56
EB
2178 STRLEN offs = LvTARGOFF(sv);
2179 STRLEN rem = LvTARGLEN(sv);
7918f24d
NC
2180
2181 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
8772537c 2182 PERL_UNUSED_ARG(mg);
6ff81951 2183
9aa983d2 2184 if (SvUTF8(lsv))
d931b1be 2185 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
777f7c56 2186 if (offs > len)
6ff81951 2187 offs = len;
777f7c56 2188 if (rem > len - offs)
6ff81951 2189 rem = len - offs;
1c900557 2190 sv_setpvn(sv, tmps + offs, rem);
9aa983d2 2191 if (SvUTF8(lsv))
2ef4b674 2192 SvUTF8_on(sv);
6ff81951
GS
2193 return 0;
2194}
2195
2196int
864dbfa3 2197Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 2198{
97aff369 2199 dVAR;
9aa983d2 2200 STRLEN len;
5fcbf73d 2201 const char * const tmps = SvPV_const(sv, len);
dd374669 2202 SV * const lsv = LvTARG(sv);
777f7c56
EB
2203 STRLEN lvoff = LvTARGOFF(sv);
2204 STRLEN lvlen = LvTARGLEN(sv);
7918f24d
NC
2205
2206 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
8772537c 2207 PERL_UNUSED_ARG(mg);
075a4a2b 2208
1aa99e6b 2209 if (DO_UTF8(sv)) {
9aa983d2 2210 sv_utf8_upgrade(lsv);
d931b1be 2211 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
9aa983d2 2212 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 2213 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
2214 SvUTF8_on(lsv);
2215 }
9bf12eaf 2216 else if (lsv && SvUTF8(lsv)) {
5fcbf73d 2217 const char *utf8;
d931b1be 2218 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
b76f3ce2 2219 LvTARGLEN(sv) = len;
5fcbf73d
AL
2220 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2221 sv_insert(lsv, lvoff, lvlen, utf8, len);
2222 Safefree(utf8);
1aa99e6b 2223 }
b76f3ce2
GB
2224 else {
2225 sv_insert(lsv, lvoff, lvlen, tmps, len);
2226 LvTARGLEN(sv) = len;
2227 }
2228
79072805
LW
2229 return 0;
2230}
2231
2232int
864dbfa3 2233Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2234{
97aff369 2235 dVAR;
7918f24d
NC
2236
2237 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
8772537c 2238 PERL_UNUSED_ARG(sv);
7918f24d 2239
27cc343c 2240 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
2241 return 0;
2242}
2243
2244int
864dbfa3 2245Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2246{
97aff369 2247 dVAR;
7918f24d
NC
2248
2249 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
8772537c 2250 PERL_UNUSED_ARG(sv);
7918f24d 2251
b01e650a
DM
2252 /* update taint status */
2253 if (PL_tainted)
2254 mg->mg_len |= 1;
2255 else
2256 mg->mg_len &= ~1;
463ee0b2
LW
2257 return 0;
2258}
2259
2260int
864dbfa3 2261Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 2262{
35a4481c 2263 SV * const lsv = LvTARG(sv);
7918f24d
NC
2264
2265 PERL_ARGS_ASSERT_MAGIC_GETVEC;
8772537c 2266 PERL_UNUSED_ARG(mg);
6ff81951 2267
6136c704
AL
2268 if (lsv)
2269 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2270 else
0c34ef67 2271 SvOK_off(sv);
6ff81951 2272
6ff81951
GS
2273 return 0;
2274}
2275
2276int
864dbfa3 2277Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2278{
7918f24d 2279 PERL_ARGS_ASSERT_MAGIC_SETVEC;
8772537c 2280 PERL_UNUSED_ARG(mg);
79072805
LW
2281 do_vecset(sv); /* XXX slurp this routine */
2282 return 0;
2283}
2284
2285int
864dbfa3 2286Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2287{
97aff369 2288 dVAR;
a0714e2c 2289 SV *targ = NULL;
7918f24d
NC
2290
2291 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2292
5f05dabc 2293 if (LvTARGLEN(sv)) {
68dc0745 2294 if (mg->mg_obj) {
8772537c 2295 SV * const ahv = LvTARG(sv);
85fbaab2 2296 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
6d822dc4
MS
2297 if (he)
2298 targ = HeVAL(he);
68dc0745
PP
2299 }
2300 else {
502c6561 2301 AV *const av = MUTABLE_AV(LvTARG(sv));
68dc0745
PP
2302 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2303 targ = AvARRAY(av)[LvTARGOFF(sv)];
2304 }
46da273f 2305 if (targ && (targ != &PL_sv_undef)) {
68dc0745
PP
2306 /* somebody else defined it for us */
2307 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2308 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745
PP
2309 LvTARGLEN(sv) = 0;
2310 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2311 mg->mg_obj = NULL;
68dc0745
PP
2312 mg->mg_flags &= ~MGf_REFCOUNTED;
2313 }
5f05dabc 2314 }
71be2cbc
PP
2315 else
2316 targ = LvTARG(sv);
3280af22 2317 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2318 return 0;
2319}
2320
2321int
864dbfa3 2322Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2323{
7918f24d 2324 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
8772537c 2325 PERL_UNUSED_ARG(mg);
71be2cbc 2326 if (LvTARGLEN(sv))
68dc0745
PP
2327 vivify_defelem(sv);
2328 if (LvTARG(sv)) {
5f05dabc 2329 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2330 SvSETMAGIC(LvTARG(sv));
2331 }
5f05dabc
PP
2332 return 0;
2333}
2334
71be2cbc 2335void
864dbfa3 2336Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2337{
97aff369 2338 dVAR;
74e13ce4 2339 MAGIC *mg;
a0714e2c 2340 SV *value = NULL;
71be2cbc 2341
7918f24d
NC
2342 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2343
14befaf4 2344 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2345 return;
68dc0745 2346 if (mg->mg_obj) {
8772537c 2347 SV * const ahv = LvTARG(sv);
85fbaab2 2348 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
6d822dc4
MS
2349 if (he)
2350 value = HeVAL(he);
3280af22 2351 if (!value || value == &PL_sv_undef)
be2597df 2352 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
71be2cbc 2353 }
68dc0745 2354 else {
502c6561 2355 AV *const av = MUTABLE_AV(LvTARG(sv));
5aabfad6 2356 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
a0714e2c 2357 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2358 else {
d4c19fe8 2359 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2360 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2361 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2362 }
2363 }
b37c2d43 2364 SvREFCNT_inc_simple_void(value);
68dc0745
PP
2365 SvREFCNT_dec(LvTARG(sv));
2366 LvTARG(sv) = value;
71be2cbc 2367 LvTARGLEN(sv) = 0;
68dc0745 2368 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2369 mg->mg_obj = NULL;
68dc0745 2370 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2371}
2372
2373int
864dbfa3 2374Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2375{
7918f24d 2376 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
5648c0ae
DM
2377 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2378 return 0;
810b8aa5
GS
2379}
2380
2381int
864dbfa3 2382Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2383{
7918f24d 2384 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
96a5add6 2385 PERL_UNUSED_CONTEXT;
565764a8 2386 mg->mg_len = -1;
1f730e6c
FC
2387 if (!isGV_with_GP(sv))
2388 SvSCREAM_off(sv);
93a17b20
LW
2389 return 0;
2390}
2391
2392int
864dbfa3 2393Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2394{
35a4481c 2395 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 2396
7918f24d
NC
2397 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2398
79072805 2399 if (uf && uf->uf_set)
24f81a43 2400 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2401 return 0;
2402}
2403
c277df42 2404int
faf82a0b
AE
2405Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2406{
488344d2 2407 const char type = mg->mg_type;
7918f24d
NC
2408
2409 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2410
488344d2
NC
2411 if (type == PERL_MAGIC_qr) {
2412 } else if (type == PERL_MAGIC_bm) {
2413 SvTAIL_off(sv);
2414 SvVALID_off(sv);
2415 } else {
2416 assert(type == PERL_MAGIC_fm);
488344d2
NC
2417 }
2418 return sv_unmagic(sv, type);
faf82a0b
AE
2419}
2420
7a4c00b4 2421#ifdef USE_LOCALE_COLLATE
79072805 2422int
864dbfa3 2423Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 2424{
7918f24d
NC
2425 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2426
bbce6d69 2427 /*
838b5b74 2428 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2429 * and vanished with a faint plop.
2430 */
96a5add6 2431 PERL_UNUSED_CONTEXT;
8772537c 2432 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2433 if (mg->mg_ptr) {
2434 Safefree(mg->mg_ptr);
2435 mg->mg_ptr = NULL;
565764a8 2436 mg->mg_len = -1;
7a4c00b4 2437 }
bbce6d69
PP
2438 return 0;
2439}
7a4c00b4 2440#endif /* USE_LOCALE_COLLATE */
bbce6d69 2441
7e8c5dac
HS
2442/* Just clear the UTF-8 cache data. */
2443int
2444Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2445{
7918f24d 2446 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
96a5add6 2447 PERL_UNUSED_CONTEXT;
8772537c 2448 PERL_UNUSED_ARG(sv);
7e8c5dac 2449 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2450 mg->mg_ptr = NULL;
7e8c5dac
HS
2451 mg->mg_len = -1; /* The mg_len holds the len cache. */
2452 return 0;
2453}
2454
bbce6d69 2455int
864dbfa3 2456Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2457{
97aff369 2458 dVAR;
e1ec3a88 2459 register const char *s;
2fdbfb4d
AB
2460 register I32 paren;
2461 register const REGEXP * rx;
2462 const char * const remaining = mg->mg_ptr + 1;
79072805 2463 I32 i;
8990e307 2464 STRLEN len;
125b9982 2465 MAGIC *tmg;
2fdbfb4d 2466
7918f24d
NC
2467 PERL_ARGS_ASSERT_MAGIC_SET;
2468
79072805 2469 switch (*mg->mg_ptr) {
2fdbfb4d
AB
2470 case '\015': /* $^MATCH */
2471 if (strEQ(remaining, "ATCH"))
2472 goto do_match;
2473 case '`': /* ${^PREMATCH} caught below */
2474 do_prematch:
f1b875a0 2475 paren = RX_BUFF_IDX_PREMATCH;
2fdbfb4d
AB
2476 goto setparen;
2477 case '\'': /* ${^POSTMATCH} caught below */
2478 do_postmatch:
f1b875a0 2479 paren = RX_BUFF_IDX_POSTMATCH;
2fdbfb4d
AB
2480 goto setparen;
2481 case '&':
2482 do_match:
f1b875a0 2483 paren = RX_BUFF_IDX_FULLMATCH;
2fdbfb4d
AB
2484 goto setparen;
2485 case '1': case '2': case '3': case '4':
2486 case '5': case '6': case '7': case '8': case '9':
104a8018 2487 paren = atoi(mg->mg_ptr);
2fdbfb4d 2488 setparen:
1e05feb3 2489 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2fdbfb4d 2490 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
1e05feb3 2491 } else {
2fdbfb4d
AB
2492 /* Croak with a READONLY error when a numbered match var is
2493 * set without a previous pattern match. Unless it's C<local $1>
2494 */
2495 if (!PL_localizing) {
6ad8f254 2496 Perl_croak_no_modify(aTHX);
2fdbfb4d
AB
2497 }
2498 }
9b9e0be4 2499 break;
748a9306 2500 case '\001': /* ^A */
3280af22 2501 sv_setsv(PL_bodytarget, sv);
125b9982
NT
2502 /* mg_set() has temporarily made sv non-magical */
2503 if (PL_tainting) {
2504 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2505 SvTAINTED_on(PL_bodytarget);
2506 else
2507 SvTAINTED_off(PL_bodytarget);
2508 }
748a9306 2509 break;
49460fe6 2510 case '\003': /* ^C */
f2338a2e 2511 PL_minus_c = cBOOL(SvIV(sv));
49460fe6
NIS
2512 break;
2513
79072805 2514 case '\004': /* ^D */
b4ab917c 2515#ifdef DEBUGGING
b83604b4 2516 s = SvPV_nolen_const(sv);
ddcf8bc1 2517 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
a58fb6f9
CS
2518 if (DEBUG_x_TEST || DEBUG_B_TEST)
2519 dump_all_perl(!DEBUG_B_TEST);
b4ab917c 2520#else
38ab35f8 2521 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2522#endif
79072805 2523 break;
28f23441 2524 case '\005': /* ^E */
d0063567 2525 if (*(mg->mg_ptr+1) == '\0') {
e37778c2 2526#ifdef VMS
38ab35f8 2527 set_vaxc_errno(SvIV(sv));
e37778c2
NC
2528#else
2529# ifdef WIN32
d0063567 2530 SetLastError( SvIV(sv) );
e37778c2
NC
2531# else
2532# ifdef OS2
38ab35f8 2533 os2_setsyserrno(SvIV(sv));
e37778c2 2534# else
d0063567 2535 /* will anyone ever use this? */
38ab35f8 2536 SETERRNO(SvIV(sv), 4);
048c1ddf
IZ
2537# endif
2538# endif
22fae026 2539#endif
d0063567
DK
2540 }
2541 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
ef8d46e8 2542 SvREFCNT_dec(PL_encoding);
d0063567
DK
2543 if (SvOK(sv) || SvGMAGICAL(sv)) {
2544 PL_encoding = newSVsv(sv);
2545 }
2546 else {
a0714e2c 2547 PL_encoding = NULL;
d0063567
DK
2548 }
2549 }
2550 break;
79072805 2551 case '\006': /* ^F */
38ab35f8 2552 PL_maxsysfd = SvIV(sv);
79072805 2553 break;
a0d0e21e 2554 case '\010': /* ^H */
38ab35f8 2555 PL_hints = SvIV(sv);
a0d0e21e 2556 break;
9d116dd7 2557 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2558 Safefree(PL_inplace);
bd61b366 2559 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2560 break;
28f23441 2561 case '\017': /* ^O */
ac27b0f5 2562 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2563 Safefree(PL_osname);
bd61b366 2564 PL_osname = NULL;
3511154c
DM
2565 if (SvOK(sv)) {
2566 TAINT_PROPER("assigning to $^O");
2e0de35c 2567 PL_osname = savesvpv(sv);
3511154c 2568 }
ac27b0f5
NIS
2569 }
2570 else if (strEQ(mg->mg_ptr, "\017PEN")) {
8b850bd5
NC
2571 STRLEN len;
2572 const char *const start = SvPV(sv, len);
b54fc2b6 2573 const char *out = (const char*)memchr(start, '\0', len);
8b850bd5 2574 SV *tmp;
8b850bd5
NC
2575
2576
2577 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
f747ebd6 2578 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
8b850bd5
NC
2579
2580 /* Opening for input is more common than opening for output, so
2581 ensure that hints for input are sooner on linked list. */
59cd0e26 2582 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
f747ebd6
Z
2583 SvUTF8(sv))
2584 : newSVpvs_flags("", SvUTF8(sv));
2585 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2586 mg_set(tmp);
8b850bd5 2587
f747ebd6
Z
2588 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2589 SvUTF8(sv));
2590 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2591 mg_set(tmp);
ac27b0f5 2592 }
28f23441 2593 break;
79072805 2594 case '\020': /* ^P */
2fdbfb4d
AB
2595 if (*remaining == '\0') { /* ^P */
2596 PL_perldb = SvIV(sv);
2597 if (PL_perldb && !PL_DBsingle)
2598 init_debugger();
2599 break;
2600 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2601 goto do_prematch;
2602 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2603 goto do_postmatch;
2604 }
9b9e0be4 2605 break;
79072805 2606 case '\024': /* ^T */
88e89b8a 2607#ifdef BIG_TIME
6b88bc9c 2608 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2609#else
38ab35f8 2610 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2611#endif
79072805 2612 break;
e07ea26a
NC
2613 case '\025': /* ^UTF8CACHE */
2614 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2615 PL_utf8cache = (signed char) sv_2iv(sv);
2616 }
2617 break;
fde18df1 2618 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2619 if (*(mg->mg_ptr+1) == '\0') {
2620 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2621 i = SvIV(sv);
ac27b0f5 2622 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2623 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2624 }
599cee73 2625 }
0a378802 2626 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2627 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2628 if (!SvPOK(sv) && PL_localizing) {
2629 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2630 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2631 break;
2632 }
f4fc7782 2633 {
b5477537 2634 STRLEN len, i;
d3a7d8c7 2635 int accumulate = 0 ;
f4fc7782 2636 int any_fatals = 0 ;
b83604b4 2637 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2638 for (i = 0 ; i < len ; ++i) {
2639 accumulate |= ptr[i] ;
2640 any_fatals |= (ptr[i] & 0xAA) ;
2641 }
4243c432
NC
2642 if (!accumulate) {
2643 if (!specialWARN(PL_compiling.cop_warnings))
2644 PerlMemShared_free(PL_compiling.cop_warnings);
2645 PL_compiling.cop_warnings = pWARN_NONE;
2646 }
72dc9ed5
NC
2647 /* Yuck. I can't see how to abstract this: */
2648 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2649 WARN_ALL) && !any_fatals) {
4243c432
NC
2650 if (!specialWARN(PL_compiling.cop_warnings))
2651 PerlMemShared_free(PL_compiling.cop_warnings);
f4fc7782
JH
2652 PL_compiling.cop_warnings = pWARN_ALL;
2653 PL_dowarn |= G_WARN_ONCE ;
727405f8 2654 }
d3a7d8c7 2655 else {
72dc9ed5
NC
2656 STRLEN len;
2657 const char *const p = SvPV_const(sv, len);
2658
2659 PL_compiling.cop_warnings
8ee4cf24 2660 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC
2661 p, len);
2662
d3a7d8c7
GS
2663 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2664 PL_dowarn |= G_WARN_ONCE ;
2665 }
f4fc7782 2666
d3a7d8c7 2667 }
4438c4b7 2668 }
971a9dd3 2669 }
79072805
LW
2670 break;
2671 case '.':
3280af22
NIS
2672 if (PL_localizing) {
2673 if (PL_localizing == 1)
7766f137 2674 SAVESPTR(PL_last_in_gv);
748a9306 2675 }
3280af22 2676 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2677 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2678 break;
2679 case '^':
099be4f1
DM
2680 if (isGV_with_GP(PL_defoutgv)) {
2681 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2682 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2683 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2684 }
79072805
LW
2685 break;
2686 case '~':
099be4f1
DM
2687 if (isGV_with_GP(PL_defoutgv)) {
2688 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2689 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2690 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2691 }
79072805
LW
2692 break;
2693 case '=':
099be4f1
DM
2694 if (isGV_with_GP(PL_defoutgv))
2695 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2696 break;
2697 case '-':
099be4f1
DM
2698 if (isGV_with_GP(PL_defoutgv)) {
2699 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2700 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2701 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2702 }
79072805
LW
2703 break;
2704 case '%':
099be4f1
DM
2705 if (isGV_with_GP(PL_defoutgv))
2706 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2707 break;
2708 case '|':
4b65379b 2709 {
099be4f1 2710 IO * const io = GvIO(PL_defoutgv);
720f287d
AB
2711 if(!io)
2712 break;
38ab35f8 2713 if ((SvIV(sv)) == 0)
4b65379b
CS
2714 IoFLAGS(io) &= ~IOf_FLUSH;
2715 else {
2716 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2717 PerlIO *ofp = IoOFP(io);
2718 if (ofp)
2719 (void)PerlIO_flush(ofp);
2720 IoFLAGS(io) |= IOf_FLUSH;
2721 }
2722 }
79072805
LW
2723 }
2724 break;
79072805 2725 case '/':
3280af22 2726 SvREFCNT_dec(PL_rs);
8bfdd7d9 2727 PL_rs = newSVsv(sv);
79072805
LW
2728 break;
2729 case '\\':
ef8d46e8 2730 SvREFCNT_dec(PL_ors_sv);
009c130f 2731 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2732 PL_ors_sv = newSVsv(sv);
009c130f 2733 }
e3c19b7b 2734 else {
a0714e2c 2735 PL_ors_sv = NULL;
e3c19b7b 2736 }
79072805 2737 break;
79072805 2738 case '[':
38ab35f8 2739 CopARYBASE_set(&PL_compiling, SvIV(sv));
79072805
LW
2740 break;
2741 case '?':
ff0cee69 2742#ifdef COMPLEX_STATUS
6b88bc9c 2743 if (PL_localizing == 2) {
41cb7b2b 2744 SvUPGRADE(sv, SVt_PVLV);
6b88bc9c
GS
2745 PL_statusvalue = LvTARGOFF(sv);
2746 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2747 }
2748 else
2749#endif
2750#ifdef VMSISH_STATUS
2751 if (VMSISH_STATUS)
fb38d079 2752 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2753 else
2754#endif
38ab35f8 2755 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW
2756 break;
2757 case '!':
93189314
JH
2758 {
2759#ifdef VMS
2760# define PERL_VMS_BANG vaxc$errno
2761#else
2762# define PERL_VMS_BANG 0
2763#endif
91487cfc 2764 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2765 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2766 }
79072805
LW
2767 break;
2768 case '<':
38ab35f8 2769 PL_uid = SvIV(sv);
3280af22
NIS
2770 if (PL_delaymagic) {
2771 PL_delaymagic |= DM_RUID;
79072805
LW
2772 break; /* don't do magic till later */
2773 }
2774#ifdef HAS_SETRUID
b28d0864 2775 (void)setruid((Uid_t)PL_uid);
79072805
LW
2776#else
2777#ifdef HAS_SETREUID
3280af22 2778 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2779#else
85e6fe83 2780#ifdef HAS_SETRESUID
b28d0864 2781 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2782#else
75870ed3 2783 if (PL_uid == PL_euid) { /* special case $< = $> */
2784#ifdef PERL_DARWIN
2785 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2786 if (PL_uid != 0 && PerlProc_getuid() == 0)
2787 (void)PerlProc_setuid(0);
2788#endif
b28d0864 2789 (void)PerlProc_setuid(PL_uid);
75870ed3 2790 } else {
d8eceb89 2791 PL_uid = PerlProc_getuid();
cea2e8a9 2792 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2793 }
79072805
LW
2794#endif
2795#endif
85e6fe83 2796#endif
d8eceb89 2797 PL_uid = PerlProc_getuid();
79072805
LW
2798 break;
2799 case '>':
38ab35f8 2800 PL_euid = SvIV(sv);
3280af22
NIS
2801 if (PL_delaymagic) {
2802 PL_delaymagic |= DM_EUID;
79072805
LW
2803 break; /* don't do magic till later */
2804 }
2805#ifdef HAS_SETEUID
3280af22 2806 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2807#else
2808#ifdef HAS_SETREUID
b28d0864 2809 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2810#else
2811#ifdef HAS_SETRESUID
6b88bc9c 2812 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2813#else
b28d0864
NIS
2814 if (PL_euid == PL_uid) /* special case $> = $< */
2815 PerlProc_setuid(PL_euid);
a0d0e21e 2816 else {
e8ee3774 2817 PL_euid = PerlProc_geteuid();
cea2e8a9 2818 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2819 }
79072805
LW
2820#endif
2821#endif
85e6fe83 2822#endif
d8eceb89 2823 PL_euid = PerlProc_geteuid();
79072805
LW
2824 break;
2825 case '(':
38ab35f8 2826 PL_gid = SvIV(sv);
3280af22
NIS
2827 if (PL_delaymagic) {
2828 PL_delaymagic |= DM_RGID;
79072805
LW
2829 break; /* don't do magic till later */
2830 }
2831#ifdef HAS_SETRGID
b28d0864 2832 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2833#else
2834#ifdef HAS_SETREGID
3280af22 2835 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2836#else
2837#ifdef HAS_SETRESGID
b28d0864 2838 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2839#else
b28d0864
NIS
2840 if (PL_gid == PL_egid) /* special case $( = $) */
2841 (void)PerlProc_setgid(PL_gid);
748a9306 2842 else {
d8eceb89 2843 PL_gid = PerlProc_getgid();
cea2e8a9 2844 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2845 }
79072805
LW
2846#endif
2847#endif
85e6fe83 2848#endif
d8eceb89 2849 PL_gid = PerlProc_getgid();
79072805
LW
2850 break;
2851 case ')':
5cd24f17
PP
2852#ifdef HAS_SETGROUPS
2853 {
b83604b4 2854 const char *p = SvPV_const(sv, len);
757f63d8 2855 Groups_t *gary = NULL;
fb4089e0 2856#ifdef _SC_NGROUPS_MAX
2857 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2858
2859 if (maxgrp < 0)
2860 maxgrp = NGROUPS;
2861#else
2862 int maxgrp = NGROUPS;
2863#endif
757f63d8
SP
2864
2865 while (isSPACE(*p))
2866 ++p;
2867 PL_egid = Atol(p);
fb4089e0 2868 for (i = 0; i < maxgrp; ++i) {
757f63d8
SP
2869 while (*p && !isSPACE(*p))
2870 ++p;
2871 while (isSPACE(*p))
2872 ++p;
2873 if (!*p)
2874 break;
2875 if(!gary)
2876 Newx(gary, i + 1, Groups_t);
2877 else
2878 Renew(gary, i + 1, Groups_t);
2879 gary[i] = Atol(p);
2880 }
2881 if (i)
2882 (void)setgroups(i, gary);
f5a63d97 2883 Safefree(gary);
5cd24f17
PP
2884 }
2885#else /* HAS_SETGROUPS */
38ab35f8 2886 PL_egid = SvIV(sv);
5cd24f17 2887#endif /* HAS_SETGROUPS */
3280af22
NIS
2888 if (PL_delaymagic) {
2889 PL_delaymagic |= DM_EGID;
79072805
LW
2890 break; /* don't do magic till later */
2891 }
2892#ifdef HAS_SETEGID
3280af22 2893 (void)setegid((Gid_t)PL_egid);
79072805
LW
2894#else
2895#ifdef HAS_SETREGID
b28d0864 2896 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2897#else
2898#ifdef HAS_SETRESGID
b28d0864 2899 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2900#else
b28d0864
NIS
2901 if (PL_egid == PL_gid) /* special case $) = $( */
2902 (void)PerlProc_setgid(PL_egid);
748a9306 2903 else {
d8eceb89 2904 PL_egid = PerlProc_getegid();
cea2e8a9 2905 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2906 }
79072805
LW
2907#endif
2908#endif
85e6fe83 2909#endif
d8eceb89 2910 PL_egid = PerlProc_getegid();
79072805
LW
2911 break;
2912 case ':':
2d8e6c8d 2913 PL_chopset = SvPV_force(sv,len);
79072805
LW
2914 break;
2915 case '0':
e2975953 2916 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2917#ifdef HAS_SETPROCTITLE
2918 /* The BSDs don't show the argv[] in ps(1) output, they
2919 * show a string from the process struct and provide
2920 * the setproctitle() routine to manipulate that. */
a2722ac9 2921 if (PL_origalen != 1) {
b83604b4 2922 s = SvPV_const(sv, len);
98b76f99 2923# if __FreeBSD_version > 410001
9aad2c0e 2924 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2925 * but not the "(perl) suffix from the ps(1)
2926 * output, because that's what ps(1) shows if the
2927 * argv[] is modified. */
6f2ad931 2928 setproctitle("-%s", s);
9aad2c0e 2929# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2930 /* This doesn't really work if you assume that
2931 * $0 = 'foobar'; will wipe out 'perl' from the $0
2932 * because in ps(1) output the result will be like
2933 * sprintf("perl: %s (perl)", s)
2934 * I guess this is a security feature:
2935 * one (a user process) cannot get rid of the original name.
2936 * --jhi */
2937 setproctitle("%s", s);
2938# endif
2939 }
9d3968b2 2940#elif defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2941 if (PL_origalen != 1) {
17aa7f3d 2942 union pstun un;
b83604b4 2943 s = SvPV_const(sv, len);
6867be6d 2944 un.pst_command = (char *)s;
17aa7f3d
JH
2945 pstat(PSTAT_SETCMD, un, len, 0, 0);
2946 }
9d3968b2 2947#else
2d2af554
GA
2948 if (PL_origalen > 1) {
2949 /* PL_origalen is set in perl_parse(). */
2950 s = SvPV_force(sv,len);
2951 if (len >= (STRLEN)PL_origalen-1) {
2952 /* Longer than original, will be truncated. We assume that
2953 * PL_origalen bytes are available. */
2954 Copy(s, PL_origargv[0], PL_origalen-1, char);
2955 }
2956 else {
2957 /* Shorter than original, will be padded. */
235ac35d 2958#ifdef PERL_DARWIN
60777a0d
JH
2959 /* Special case for Mac OS X: see [perl #38868] */
2960 const int pad = 0;
235ac35d 2961#else
8a89a4f1
MB
2962 /* Is the space counterintuitive? Yes.
2963 * (You were expecting \0?)
2964 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2965 * --jhi */
60777a0d 2966 const int pad = ' ';
235ac35d 2967#endif
60777a0d
JH
2968 Copy(s, PL_origargv[0], len, char);
2969 PL_origargv[0][len] = 0;
2970 memset(PL_origargv[0] + len + 1,
2971 pad, PL_origalen - len - 1);
2d2af554
GA
2972 }
2973 PL_origargv[0][PL_origalen-1] = 0;
2974 for (i = 1; i < PL_origargc; i++)
2975 PL_origargv[i] = 0;
7636ea95
AB
2976#ifdef HAS_PRCTL_SET_NAME
2977 /* Set the legacy process name in addition to the POSIX name on Linux */
2978 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2979 /* diag_listed_as: SKIPME */
2980 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2981 }
2982#endif
79072805 2983 }
9d3968b2 2984#endif
e2975953 2985 UNLOCK_DOLLARZERO_MUTEX;
79072805
LW
2986 break;
2987 }
2988 return 0;
2989}
2990
2991I32
35a4481c 2992Perl_whichsig(pTHX_ const char *sig)
79072805 2993{
aadb217d 2994 register char* const* sigv;
7918f24d
NC
2995
2996 PERL_ARGS_ASSERT_WHICHSIG;
96a5add6 2997 PERL_UNUSED_CONTEXT;
79072805 2998
aadb217d 2999 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 3000 if (strEQ(sig,*sigv))
aadb217d 3001 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
3002#ifdef SIGCLD
3003 if (strEQ(sig,"CHLD"))
3004 return SIGCLD;
3005#endif
3006#ifdef SIGCHLD
3007 if (strEQ(sig,"CLD"))
3008 return SIGCHLD;
3009#endif
7f1236c0 3010 return -1;
79072805
LW
3011}
3012
ecfc5424 3013Signal_t
1e82f5a6 3014#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3015Perl_sighandler(int sig, siginfo_t *sip, void *uap)
1e82f5a6
SH
3016#else
3017Perl_sighandler(int sig)
3018#endif
79072805 3019{
1018e26f
NIS
3020#ifdef PERL_GET_SIG_CONTEXT
3021 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 3022#else
cea2e8a9 3023 dTHX;
71d280e3 3024#endif
79072805 3025 dSP;
a0714e2c
SS
3026 GV *gv = NULL;
3027 SV *sv = NULL;
8772537c 3028 SV * const tSv = PL_Sv;
601f1833 3029 CV *cv = NULL;
533c011a 3030 OP *myop = PL_op;
84902520 3031 U32 flags = 0;
8772537c 3032 XPV * const tXpv = PL_Xpv;
0c4d3b5e 3033 I32 old_ss_ix = PL_savestack_ix;
71d280e3 3034
84902520 3035
727405f8 3036 if (!PL_psig_ptr[sig]) {
99ef548b 3037 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
3038 PL_sig_name[sig]);
3039 exit(sig);
3040 }
ff0cee69 3041
a0d63a7b
DM
3042 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3043 /* Max number of items pushed there is 3*n or 4. We cannot fix
3044 infinity, so we fix 4 (in fact 5): */
3045 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3046 flags |= 1;
3047 PL_savestack_ix += 5; /* Protect save in progress. */
3048 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3049 }
84902520 3050 }
84902520 3051 /* sv_2cv is too complicated, try a simpler variant first: */
ea726b52 3052 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
8772537c
AL
3053 || SvTYPE(cv) != SVt_PVCV) {
3054 HV *st;
f2c0649b 3055 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 3056 }
84902520 3057
a0d0e21e 3058 if (!cv || !CvROOT(cv)) {
a2a5de95
NC
3059 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3060 PL_sig_name[sig], (gv ? GvENAME(gv)
3061 : ((cv && CvGV(cv))
3062 ? GvENAME(CvGV(cv))
3063 : "__ANON__")));
00d579c5 3064 goto cleanup;
79072805
LW
3065 }
3066
0c4d3b5e
DM
3067 sv = PL_psig_name[sig]
3068 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3069 : newSVpv(PL_sig_name[sig],0);
72048cfe 3070 flags |= 8;
0c4d3b5e
DM
3071 SAVEFREESV(sv);
3072
a0d63a7b
DM
3073 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3074 /* make sure our assumption about the size of the SAVEs are correct:
3075 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3076 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3077 }
e336de0d 3078
e788e7d3 3079 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 3080 PUSHMARK(SP);
79072805 3081 PUSHs(sv);
8aad04aa
JH
3082#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3083 {
3084 struct sigaction oact;
3085
3086 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
8aad04aa
JH
3087 if (sip) {
3088 HV *sih = newHV();
ad64d0ec 3089 SV *rv = newRV_noinc(MUTABLE_SV(sih));
8aad04aa
JH
3090 /* The siginfo fields signo, code, errno, pid, uid,
3091 * addr, status, and band are defined by POSIX/SUSv3. */
85771703
NC
3092 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3093 (void)hv_stores(sih, "code", newSViv(sip->si_code));
79dec0f4 3094#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
3095 hv_stores(sih, "errno", newSViv(sip->si_errno));
3096 hv_stores(sih, "status", newSViv(sip->si_status));
3097 hv_stores(sih, "uid", newSViv(sip->si_uid));
3098 hv_stores(sih, "pid", newSViv(sip->si_pid));
3099 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3100 hv_stores(sih, "band", newSViv(sip->si_band));
79dec0f4 3101#endif
8aad04aa 3102 EXTEND(SP, 2);
ad64d0ec 3103 PUSHs(rv);
22f1178f 3104 mPUSHp((char *)sip, sizeof(*sip));
8aad04aa 3105 }
b4552a27 3106
8aad04aa
JH
3107 }
3108 }
3109#endif
79072805 3110 PUTBACK;
a0d0e21e 3111
ad64d0ec 3112 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
79072805 3113
d3acc0f7 3114 POPSTACK;
1b266415 3115 if (SvTRUE(ERRSV)) {
c22d665b 3116#ifndef PERL_MICRO
1b266415
NIS
3117 /* Handler "died", for example to get out of a restart-able read().
3118 * Before we re-do that on its behalf re-enable the signal which was
3119 * blocked by the system when we entered.
3120 */
c22d665b 3121#ifdef HAS_SIGPROCMASK
d488af49 3122#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3123 if (sip || uap)
c22d665b
LT
3124#endif
3125 {
3126 sigset_t set;
3127 sigemptyset(&set);
3128 sigaddset(&set,sig);
3129 sigprocmask(SIG_UNBLOCK, &set, NULL);
3130 }
3131#else
1b266415
NIS
3132 /* Not clear if this will work */
3133 (void)rsignal(sig, SIG_IGN);
5c1546dc 3134 (void)rsignal(sig, PL_csighandlerp);
c22d665b
LT
3135#endif
3136#endif /* !PERL_MICRO */
c5df3096 3137 die_sv(ERRSV);
1b266415 3138 }
00d579c5 3139cleanup:
0c4d3b5e
DM
3140 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3141 PL_savestack_ix = old_ss_ix;
72048cfe 3142 if (flags & 8)
84902520 3143 SvREFCNT_dec(sv);
533c011a 3144 PL_op = myop; /* Apparently not needed... */
ac27b0f5 3145
3280af22
NIS
3146 PL_Sv = tSv; /* Restore global temporaries. */
3147 PL_Xpv = tXpv;
53bb94e2 3148 return;
79072805 3149}
4e35701f
NIS
3150
3151
51371543 3152static void
8772537c 3153S_restore_magic(pTHX_ const void *p)
51371543 3154{
97aff369 3155 dVAR;
8772537c
AL
3156 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3157 SV* const sv = mgs->mgs_sv;
150b625d 3158 bool bumped;
51371543
GS
3159
3160 if (!sv)
3161 return;
3162
3163 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3164 {
f8c7b90f 3165#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
3166 /* While magic was saved (and off) sv_setsv may well have seen
3167 this SV as a prime candidate for COW. */
3168 if (SvIsCOW(sv))
e424a81e 3169 sv_force_normal_flags(sv, 0);
f9701176
NC
3170#endif
3171
f9c6fee5
CS
3172 if (mgs->mgs_readonly)
3173 SvREADONLY_on(sv);
3174 if (mgs->mgs_magical)
3175 SvFLAGS(sv) |= mgs->mgs_magical;
51371543
GS
3176 else
3177 mg_magical(sv);
2b77b520
YST
3178 if (SvGMAGICAL(sv)) {
3179 /* downgrade public flags to private,
3180 and discard any other private flags */
3181
10edeb5d
JH
3182 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3183 if (pubflags) {
3184 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3185 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2b77b520
YST
3186 }
3187 }
51371543
GS
3188 }
3189
150b625d 3190 bumped = mgs->mgs_bumped;
51371543
GS
3191 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3192
3193 /* If we're still on top of the stack, pop us off. (That condition
3194 * will be satisfied if restore_magic was called explicitly, but *not*
3195 * if it's being called via leave_scope.)
3196 * The reason for doing this is that otherwise, things like sv_2cv()
3197 * may leave alloc gunk on the savestack, and some code
3198 * (e.g. sighandler) doesn't expect that...
3199 */
3200 if (PL_savestack_ix == mgs->mgs_ss_ix)
3201 {
1be36ce0
NC
3202 UV popval = SSPOPUV;
3203 assert(popval == SAVEt_DESTRUCTOR_X);
51371543 3204 PL_savestack_ix -= 2;
1be36ce0
NC
3205 popval = SSPOPUV;
3206 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3207 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
51371543 3208 }
150b625d
DM
3209 if (bumped) {
3210 if (SvREFCNT(sv) == 1) {
3211 /* We hold the last reference to this SV, which implies that the
3212 SV was deleted as a side effect of the routines we called.
3213 So artificially keep it alive a bit longer.
3214 We avoid turning on the TEMP flag, which can cause the SV's
3215 buffer to get stolen (and maybe other stuff). */
3216 int was_temp = SvTEMP(sv);
3217 sv_2mortal(sv);
3218 if (!was_temp) {
3219 SvTEMP_off(sv);
3220 }
3221 SvOK_off(sv);
8985fe98 3222 }
150b625d
DM
3223 else
3224 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
8985fe98 3225 }
51371543
GS
3226}
3227
0c4d3b5e
DM
3228/* clean up the mess created by Perl_sighandler().
3229 * Note that this is only called during an exit in a signal handler;
3230 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
9a7f166c 3231 * skipped over. */
0c4d3b5e 3232
51371543 3233static void
8772537c 3234S_unwind_handler_stack(pTHX_ const void *p)
51371543 3235{
27da23d5 3236 dVAR;
0c4d3b5e 3237 PERL_UNUSED_ARG(p);
7918f24d 3238
0c4d3b5e 3239 PL_savestack_ix -= 5; /* Unprotect save in progress. */
51371543 3240}
1018e26f 3241
66610fdd 3242/*
b3ca2e83
NC
3243=for apidoc magic_sethint
3244
3245Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC
3246C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3247anything that would need a deep copy. Maybe we should warn if we find a
3248reference.
b3ca2e83
NC
3249
3250=cut
3251*/
3252int
3253Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3254{
3255 dVAR;
ad64d0ec 3256 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
59cd0e26 3257 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
b3ca2e83 3258
7918f24d
NC
3259 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3260
e6e3e454
NC
3261 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3262 an alternative leaf in there, with PL_compiling.cop_hints being used if
3263 it's NULL. If needed for threads, the alternative could lock a mutex,
3264 or take other more complex action. */
3265
5b9c0671
NC
3266 /* Something changed in %^H, so it will need to be restored on scope exit.
3267 Doing this here saves a lot of doing it manually in perl code (and
3268 forgetting to do it, and consequent subtle errors. */
3269 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z
3270 CopHINTHASH_set(&PL_compiling,
3271 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
b3ca2e83
NC
3272 return 0;
3273}
3274
3275/*
f175cff5 3276=for apidoc magic_clearhint
b3ca2e83 3277
c28fe1ec
NC
3278Triggered by a delete from %^H, records the key to
3279C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC
3280
3281=cut
3282*/
3283int
3284Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3285{
3286 dVAR;
7918f24d
NC
3287
3288 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
f5a63d97
AL
3289 PERL_UNUSED_ARG(sv);
3290
b3ca2e83
NC
3291 assert(mg->mg_len == HEf_SVKEY);
3292
b3f24c00
MHM
3293 PERL_UNUSED_ARG(sv);
3294
5b9c0671 3295 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z
3296 CopHINTHASH_set(&PL_compiling,
3297 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3298 MUTABLE_SV(mg->mg_ptr), 0, 0));
b3ca2e83
NC
3299 return 0;
3300}
3301
3302/*
f747ebd6
Z
3303=for apidoc magic_clearhints
3304
3305Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3306
3307=cut
3308*/
3309int
3310Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3311{
3312 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3313 PERL_UNUSED_ARG(sv);
3314 PERL_UNUSED_ARG(mg);
20439bc7
Z
3315 cophh_free(CopHINTHASH_get(&PL_compiling));
3316 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
f747ebd6
Z
3317 return 0;
3318}
3319
3320/*
66610fdd
RGS
3321 * Local variables:
3322 * c-indentation-style: bsd
3323 * c-basic-offset: 4
3324 * indent-tabs-mode: t
3325 * End:
3326 *
37442d52
RGS
3327 * ex: set ts=8 sts=4 sw=4 noet:
3328 */