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