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