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