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