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