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