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