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