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