This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump ExtUtils-Install to 1.52 (because of CPAN persnickityness)
[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
470If empty is false then no set magic will be called on the new (empty) SV.
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
9711599e 478Perl_mg_localize(pTHX_ SV *sv, SV *nsv, I32 empty)
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);
9711599e
CS
502 if (empty) {
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
LW
1028 break;
1029 case ',':
79072805
LW
1030 break;
1031 case '\\':
b2ce0fda 1032 if (PL_ors_sv)
f28098ff 1033 sv_copypv(sv, PL_ors_sv);
79072805 1034 break;
79072805 1035 case '!':
a5f75d66 1036#ifdef VMS
65202027 1037 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
88e89b8a 1038 sv_setpv(sv, errno ? Strerror(errno) : "");
a5f75d66 1039#else
88e89b8a 1040 {
8772537c 1041 const int saveerrno = errno;
65202027 1042 sv_setnv(sv, (NV)errno);
88e89b8a 1043#ifdef OS2
ed344e4f
IZ
1044 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1045 sv_setpv(sv, os2error(Perl_rc));
88e89b8a 1046 else
a5f75d66 1047#endif
666ea192 1048 sv_setpv(sv, errno ? Strerror(errno) : "");
88e89b8a
PP
1049 errno = saveerrno;
1050 }
1051#endif
ad3296c6 1052 SvRTRIM(sv);
946ec16e 1053 SvNOK_on(sv); /* what a wonderful hack! */
79072805
LW
1054 break;
1055 case '<':
3280af22 1056 sv_setiv(sv, (IV)PL_uid);
79072805
LW
1057 break;
1058 case '>':
3280af22 1059 sv_setiv(sv, (IV)PL_euid);
79072805
LW
1060 break;
1061 case '(':
3280af22 1062 sv_setiv(sv, (IV)PL_gid);
79072805
LW
1063 goto add_groups;
1064 case ')':
3280af22 1065 sv_setiv(sv, (IV)PL_egid);
79072805 1066 add_groups:
79072805 1067#ifdef HAS_GETGROUPS
79072805 1068 {
57d7c65e 1069 Groups_t *gary = NULL;
fb45abb2 1070 I32 i, num_groups = getgroups(0, gary);
57d7c65e
JC
1071 Newx(gary, num_groups, Groups_t);
1072 num_groups = getgroups(num_groups, gary);
fb45abb2
GA
1073 for (i = 0; i < num_groups; i++)
1074 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
57d7c65e 1075 Safefree(gary);
79072805 1076 }
155aba94 1077 (void)SvIOK_on(sv); /* what a wonderful hack! */
cd70abae 1078#endif
79072805 1079 break;
cd39f2b6 1080#ifndef MACOS_TRADITIONAL
79072805
LW
1081 case '0':
1082 break;
cd39f2b6 1083#endif
79072805 1084 }
a0d0e21e 1085 return 0;
79072805
LW
1086}
1087
1088int
864dbfa3 1089Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1090{
8772537c 1091 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 1092
7918f24d
NC
1093 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1094
79072805 1095 if (uf && uf->uf_val)
24f81a43 1096 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW
1097 return 0;
1098}
1099
1100int
864dbfa3 1101Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1102{
27da23d5 1103 dVAR;
9ae3433d 1104 STRLEN len = 0, klen;
666ea192 1105 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
fabdb6c0 1106 const char * const ptr = MgPV_const(mg,klen);
88e89b8a 1107 my_setenv(ptr, s);
1e422769 1108
7918f24d
NC
1109 PERL_ARGS_ASSERT_MAGIC_SETENV;
1110
a0d0e21e
LW
1111#ifdef DYNAMIC_ENV_FETCH
1112 /* We just undefd an environment var. Is a replacement */
1113 /* waiting in the wings? */
1114 if (!len) {
fabdb6c0
AL
1115 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1116 if (valp)
4ab59fcc 1117 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW
1118 }
1119#endif
1e422769 1120
39e571d4 1121#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
79072805
LW
1122 /* And you'll never guess what the dog had */
1123 /* in its mouth... */
3280af22 1124 if (PL_tainting) {
1e422769
PP
1125 MgTAINTEDDIR_off(mg);
1126#ifdef VMS
5aabfad6 1127 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
b8ffc8df 1128 char pathbuf[256], eltbuf[256], *cp, *elt;
c623ac67 1129 Stat_t sbuf;
1e422769
PP
1130 int i = 0, j = 0;
1131
6fca0082 1132 my_strlcpy(eltbuf, s, sizeof(eltbuf));
b8ffc8df 1133 elt = eltbuf;
1e422769
PP
1134 do { /* DCL$PATH may be a search list */
1135 while (1) { /* as may dev portion of any element */
1136 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1137 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1138 cando_by_name(S_IWUSR,0,elt) ) {
1139 MgTAINTEDDIR_on(mg);
1140 return 0;
1141 }
1142 }
bd61b366 1143 if ((cp = strchr(elt, ':')) != NULL)
1e422769
PP
1144 *cp = '\0';
1145 if (my_trnlnm(elt, eltbuf, j++))
1146 elt = eltbuf;
1147 else
1148 break;
1149 }
1150 j = 0;
1151 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1152 }
1153#endif /* VMS */
5aabfad6 1154 if (s && klen == 4 && strEQ(ptr,"PATH")) {
8772537c 1155 const char * const strend = s + len;
463ee0b2
LW
1156
1157 while (s < strend) {
96827780 1158 char tmpbuf[256];
c623ac67 1159 Stat_t st;
5f74f29c 1160 I32 i;
f5a63d97
AL
1161#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1162 const char path_sep = '|';
1163#else
1164 const char path_sep = ':';
1165#endif
96827780 1166 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
427eaa01 1167 s, strend, path_sep, &i);
463ee0b2 1168 s++;
bb7a0f54 1169 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
326b5008
CB
1170#ifdef VMS
1171 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1172#else
1173 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1174#endif
c6ed36e1 1175 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
8990e307 1176 MgTAINTEDDIR_on(mg);
1e422769
PP
1177 return 0;
1178 }
463ee0b2 1179 }
79072805
LW
1180 }
1181 }
39e571d4 1182#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1e422769 1183
79072805
LW
1184 return 0;
1185}
1186
1187int
864dbfa3 1188Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1189{
7918f24d 1190 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
8772537c 1191 PERL_UNUSED_ARG(sv);
bd61b366 1192 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW
1193 return 0;
1194}
1195
88e89b8a 1196int
864dbfa3 1197Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1198{
97aff369 1199 dVAR;
7918f24d 1200 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
65e66c80 1201 PERL_UNUSED_ARG(mg);
b0269e46 1202#if defined(VMS)
cea2e8a9 1203 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1204#else
3280af22 1205 if (PL_localizing) {
fb73857a 1206 HE* entry;
b0269e46 1207 my_clearenv();
85fbaab2
NC
1208 hv_iterinit(MUTABLE_HV(sv));
1209 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
fb73857a
PP
1210 I32 keylen;
1211 my_setenv(hv_iterkey(entry, &keylen),
85fbaab2 1212 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
fb73857a
PP
1213 }
1214 }
1215#endif
1216 return 0;
1217}
1218
1219int
864dbfa3 1220Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1221{
27da23d5 1222 dVAR;
7918f24d 1223 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
8772537c
AL
1224 PERL_UNUSED_ARG(sv);
1225 PERL_UNUSED_ARG(mg);
b0269e46
AB
1226#if defined(VMS)
1227 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1228#else
1229 my_clearenv();
1230#endif
3e3baf6d 1231 return 0;
66b1d557
HM
1232}
1233
64ca3a65 1234#ifndef PERL_MICRO
2d4fcd5e
AJ
1235#ifdef HAS_SIGPROCMASK
1236static void
1237restore_sigmask(pTHX_ SV *save_sv)
1238{
0bd48802 1239 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
f5a63d97 1240 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
2d4fcd5e
AJ
1241}
1242#endif
66b1d557 1243int
864dbfa3 1244Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1245{
97aff369 1246 dVAR;
88e89b8a 1247 /* Are we fetching a signal entry? */
8772537c 1248 const I32 i = whichsig(MgPV_nolen_const(mg));
7918f24d
NC
1249
1250 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1251
e02bfb16 1252 if (i > 0) {
22c35a8c
GS
1253 if(PL_psig_ptr[i])
1254 sv_setsv(sv,PL_psig_ptr[i]);
88e89b8a 1255 else {
46da273f 1256 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1257#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
46da273f
AL
1258 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1259 sigstate = SIG_IGN;
2e34cc90
CL
1260#endif
1261#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
46da273f
AL
1262 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1263 sigstate = SIG_DFL;
85b332e2 1264#endif
88e89b8a 1265 /* cache state so we don't fetch it again */
8aad04aa 1266 if(sigstate == (Sighandler_t) SIG_IGN)
6502358f 1267 sv_setpvs(sv,"IGNORE");
88e89b8a 1268 else
3280af22 1269 sv_setsv(sv,&PL_sv_undef);
46da273f 1270 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a
PP
1271 SvTEMP_off(sv);
1272 }
1273 }
1274 return 0;
1275}
1276int
864dbfa3 1277Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1278{
2d4fcd5e
AJ
1279 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1280 * refactoring might be in order.
1281 */
27da23d5 1282 dVAR;
8772537c 1283 register const char * const s = MgPV_nolen_const(mg);
7918f24d 1284 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
8772537c 1285 PERL_UNUSED_ARG(sv);
2d4fcd5e 1286 if (*s == '_') {
cbbf8932 1287 SV** svp = NULL;
2d4fcd5e
AJ
1288 if (strEQ(s,"__DIE__"))
1289 svp = &PL_diehook;
b274dc4e 1290 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
2d4fcd5e 1291 svp = &PL_warnhook;
27da23d5 1292 if (svp && *svp) {
b274dc4e 1293 SV *const to_dec = *svp;
cbbf8932 1294 *svp = NULL;
b274dc4e 1295 SvREFCNT_dec(to_dec);
2d4fcd5e
AJ
1296 }
1297 }
1298 else {
2d4fcd5e 1299 /* Are we clearing a signal entry? */
8772537c 1300 const I32 i = whichsig(s);
e02bfb16 1301 if (i > 0) {
2d4fcd5e
AJ
1302#ifdef HAS_SIGPROCMASK
1303 sigset_t set, save;
1304 SV* save_sv;
1305 /* Avoid having the signal arrive at a bad time, if possible. */
1306 sigemptyset(&set);
1307 sigaddset(&set,i);
1308 sigprocmask(SIG_BLOCK, &set, &save);
1309 ENTER;
9ff8e806 1310 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
2d4fcd5e
AJ
1311 SAVEFREESV(save_sv);
1312 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1313#endif
1314 PERL_ASYNC_CHECK();
1315#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1316 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2d4fcd5e
AJ
1317#endif
1318#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1319 PL_sig_defaulting[i] = 1;
5c1546dc 1320 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e 1321#else
8aad04aa 1322 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2d4fcd5e
AJ
1323#endif
1324 if(PL_psig_name[i]) {
1325 SvREFCNT_dec(PL_psig_name[i]);
1326 PL_psig_name[i]=0;
1327 }
1328 if(PL_psig_ptr[i]) {
6136c704 1329 SV * const to_dec=PL_psig_ptr[i];
2d4fcd5e
AJ
1330 PL_psig_ptr[i]=0;
1331 LEAVE;
1332 SvREFCNT_dec(to_dec);
1333 }
1334 else
1335 LEAVE;
1336 }
88e89b8a
PP
1337 }
1338 return 0;
1339}
3d37d572 1340
0a8e0eff 1341Signal_t
8aad04aa 1342#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 1343Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
8aad04aa 1344#else
0a8e0eff 1345Perl_csighandler(int sig)
8aad04aa 1346#endif
0a8e0eff 1347{
1018e26f
NIS
1348#ifdef PERL_GET_SIG_CONTEXT
1349 dTHXa(PERL_GET_SIG_CONTEXT);
1350#else
85b332e2
CL
1351 dTHX;
1352#endif
23ada85b 1353#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1354 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1355 if (PL_sig_ignoring[sig]) return;
85b332e2 1356#endif
2e34cc90 1357#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1358 if (PL_sig_defaulting[sig])
2e34cc90
CL
1359#ifdef KILL_BY_SIGPRC
1360 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1361#else
1362 exit(1);
1363#endif
1364#endif
406878dd 1365 if (
853d2c32
RGS
1366#ifdef SIGILL
1367 sig == SIGILL ||
1368#endif
1369#ifdef SIGBUS
1370 sig == SIGBUS ||
1371#endif
1372#ifdef SIGSEGV
1373 sig == SIGSEGV ||
1374#endif
1375 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
4ffa73a3
JH
1376 /* Call the perl level handler now--
1377 * with risk we may be in malloc() etc. */
6e324d09 1378#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1379 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1380#else
1381 (*PL_sighandlerp)(sig);
92807b6d 1382#endif
406878dd
GA
1383 else {
1384 /* Set a flag to say this signal is pending, that is awaiting delivery after
1385 * the current Perl opcode completes */
1386 PL_psig_pend[sig]++;
1387
1388#ifndef SIG_PENDING_DIE_COUNT
1389# define SIG_PENDING_DIE_COUNT 120
1390#endif
1391 /* And one to say _a_ signal is pending */
1392 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1393 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1394 (unsigned long)SIG_PENDING_DIE_COUNT);
1395 }
0a8e0eff
NIS
1396}
1397
2e34cc90
CL
1398#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1399void
1400Perl_csighandler_init(void)
1401{
1402 int sig;
27da23d5 1403 if (PL_sig_handlers_initted) return;
2e34cc90
CL
1404
1405 for (sig = 1; sig < SIG_SIZE; sig++) {
1406#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1407 dTHX;
27da23d5 1408 PL_sig_defaulting[sig] = 1;
5c1546dc 1409 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL
1410#endif
1411#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1412 PL_sig_ignoring[sig] = 0;
2e34cc90
CL
1413#endif
1414 }
27da23d5 1415 PL_sig_handlers_initted = 1;
2e34cc90
CL
1416}
1417#endif
1418
0a8e0eff
NIS
1419void
1420Perl_despatch_signals(pTHX)
1421{
97aff369 1422 dVAR;
0a8e0eff
NIS
1423 int sig;
1424 PL_sig_pending = 0;
1425 for (sig = 1; sig < SIG_SIZE; sig++) {
1426 if (PL_psig_pend[sig]) {
25da4428
JH
1427 PERL_BLOCKSIG_ADD(set, sig);
1428 PL_psig_pend[sig] = 0;
1429 PERL_BLOCKSIG_BLOCK(set);
6e324d09 1430#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
80626cf1 1431 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09
CB
1432#else
1433 (*PL_sighandlerp)(sig);
92807b6d 1434#endif
25da4428 1435 PERL_BLOCKSIG_UNBLOCK(set);
0a8e0eff
NIS
1436 }
1437 }
1438}
1439
85e6fe83 1440int
864dbfa3 1441Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1442{
27da23d5 1443 dVAR;
79072805 1444 I32 i;
cbbf8932 1445 SV** svp = NULL;
2d4fcd5e
AJ
1446 /* Need to be careful with SvREFCNT_dec(), because that can have side
1447 * effects (due to closures). We must make sure that the new disposition
1448 * is in place before it is called.
1449 */
cbbf8932 1450 SV* to_dec = NULL;
e72dc28c 1451 STRLEN len;
2d4fcd5e
AJ
1452#ifdef HAS_SIGPROCMASK
1453 sigset_t set, save;
1454 SV* save_sv;
1455#endif
d5263905 1456 register const char *s = MgPV_const(mg,len);
7918f24d
NC
1457
1458 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1459
748a9306
LW
1460 if (*s == '_') {
1461 if (strEQ(s,"__DIE__"))
3280af22 1462 svp = &PL_diehook;
748a9306 1463 else if (strEQ(s,"__WARN__"))
3280af22 1464 svp = &PL_warnhook;
748a9306 1465 else
cea2e8a9 1466 Perl_croak(aTHX_ "No such hook: %s", s);
748a9306 1467 i = 0;
4633a7c4 1468 if (*svp) {
9289f461
RGS
1469 if (*svp != PERL_WARNHOOK_FATAL)
1470 to_dec = *svp;
cbbf8932 1471 *svp = NULL;
4633a7c4 1472 }
748a9306
LW
1473 }
1474 else {
1475 i = whichsig(s); /* ...no, a brick */
86d86cad 1476 if (i <= 0) {
e476b1b5 1477 if (ckWARN(WARN_SIGNAL))
9014280d 1478 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
748a9306
LW
1479 return 0;
1480 }
2d4fcd5e
AJ
1481#ifdef HAS_SIGPROCMASK
1482 /* Avoid having the signal arrive at a bad time, if possible. */
1483 sigemptyset(&set);
1484 sigaddset(&set,i);
1485 sigprocmask(SIG_BLOCK, &set, &save);
1486 ENTER;
9ff8e806 1487 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
2d4fcd5e
AJ
1488 SAVEFREESV(save_sv);
1489 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1490#endif
1491 PERL_ASYNC_CHECK();
2e34cc90 1492#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
27da23d5 1493 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1494#endif
23ada85b 1495#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1496 PL_sig_ignoring[i] = 0;
85b332e2 1497#endif
2e34cc90 1498#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1499 PL_sig_defaulting[i] = 0;
2e34cc90 1500#endif
22c35a8c 1501 SvREFCNT_dec(PL_psig_name[i]);
2d4fcd5e 1502 to_dec = PL_psig_ptr[i];
46da273f 1503 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
88e89b8a 1504 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
e72dc28c 1505 PL_psig_name[i] = newSVpvn(s, len);
22c35a8c 1506 SvREADONLY_on(PL_psig_name[i]);
748a9306 1507 }
6e592b3a 1508 if (isGV_with_GP(sv) || SvROK(sv)) {
2d4fcd5e 1509 if (i) {
5c1546dc 1510 (void)rsignal(i, PL_csighandlerp);
2d4fcd5e
AJ
1511#ifdef HAS_SIGPROCMASK
1512 LEAVE;
1513#endif
1514 }
748a9306 1515 else
b37c2d43 1516 *svp = SvREFCNT_inc_simple_NN(sv);
2d4fcd5e
AJ
1517 if(to_dec)
1518 SvREFCNT_dec(to_dec);
a0d0e21e
LW
1519 return 0;
1520 }
baf38871 1521 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
748a9306 1522 if (strEQ(s,"IGNORE")) {
85b332e2 1523 if (i) {
23ada85b 1524#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1525 PL_sig_ignoring[i] = 1;
5c1546dc 1526 (void)rsignal(i, PL_csighandlerp);
85b332e2 1527#else
8aad04aa 1528 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1529#endif
2d4fcd5e 1530 }
748a9306
LW
1531 }
1532 else if (strEQ(s,"DEFAULT") || !*s) {
1533 if (i)
2e34cc90
CL
1534#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1535 {
27da23d5 1536 PL_sig_defaulting[i] = 1;
5c1546dc 1537 (void)rsignal(i, PL_csighandlerp);
2e34cc90
CL
1538 }
1539#else
8aad04aa 1540 (void)rsignal(i, (Sighandler_t) SIG_DFL);
2e34cc90 1541#endif
748a9306 1542 }
79072805 1543 else {
5aabfad6
PP
1544 /*
1545 * We should warn if HINT_STRICT_REFS, but without
1546 * access to a known hint bit in a known OP, we can't
1547 * tell whether HINT_STRICT_REFS is in force or not.
1548 */
46fc3d4c 1549 if (!strchr(s,':') && !strchr(s,'\''))
84335ee9
NC
1550 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1551 SV_GMAGIC);
748a9306 1552 if (i)
5c1546dc 1553 (void)rsignal(i, PL_csighandlerp);
748a9306 1554 else
46da273f 1555 *svp = SvREFCNT_inc_simple_NN(sv);
79072805 1556 }
2d4fcd5e
AJ
1557#ifdef HAS_SIGPROCMASK
1558 if(i)
1559 LEAVE;
1560#endif
1561 if(to_dec)
1562 SvREFCNT_dec(to_dec);
79072805
LW
1563 return 0;
1564}
64ca3a65 1565#endif /* !PERL_MICRO */
79072805
LW
1566
1567int
864dbfa3 1568Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1569{
97aff369 1570 dVAR;
08aeb9f7 1571 HV* stash;
7918f24d
NC
1572
1573 PERL_ARGS_ASSERT_MAGIC_SETISA;
8772537c 1574 PERL_UNUSED_ARG(sv);
e1a479c5 1575
08aeb9f7
BB
1576 /* Bail out if destruction is going on */
1577 if(PL_dirty) return 0;
1578
89c14e2e
BB
1579 /* Skip _isaelem because _isa will handle it shortly */
1580 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1581 return 0;
1582
70cd14a1
CB
1583 /* XXX Once it's possible, we need to
1584 detect that our @ISA is aliased in
1585 other stashes, and act on the stashes
1586 of all of the aliases */
1587
e1a479c5
BB
1588 /* The first case occurs via setisa,
1589 the second via setisa_elem, which
1590 calls this same magic */
08aeb9f7
BB
1591 stash = GvSTASH(
1592 SvTYPE(mg->mg_obj) == SVt_PVGV
159b6efe
NC
1593 ? (const GV *)mg->mg_obj
1594 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
e1a479c5
BB
1595 );
1596
5562fa71
RGS
1597 if (stash)
1598 mro_isa_changed_in(stash);
08aeb9f7 1599
463ee0b2
LW
1600 return 0;
1601}
1602
1603int
52b45067
RD
1604Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1605{
1606 dVAR;
1607 HV* stash;
1608
7918f24d
NC
1609 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1610
52b45067
RD
1611 /* Bail out if destruction is going on */
1612 if(PL_dirty) return 0;
1613
502c6561 1614 av_clear(MUTABLE_AV(sv));
52b45067
RD
1615
1616 /* XXX see comments in magic_setisa */
1617 stash = GvSTASH(
1618 SvTYPE(mg->mg_obj) == SVt_PVGV
159b6efe
NC
1619 ? (const GV *)mg->mg_obj
1620 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
52b45067
RD
1621 );
1622
5562fa71
RGS
1623 if (stash)
1624 mro_isa_changed_in(stash);
52b45067
RD
1625
1626 return 0;
1627}
1628
1629int
864dbfa3 1630Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1631{
97aff369 1632 dVAR;
7918f24d 1633 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
8772537c
AL
1634 PERL_UNUSED_ARG(sv);
1635 PERL_UNUSED_ARG(mg);
3280af22 1636 PL_amagic_generation++;
463ee0b2 1637
a0d0e21e
LW
1638 return 0;
1639}
463ee0b2 1640
946ec16e 1641int
864dbfa3 1642Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1643{
85fbaab2 1644 HV * const hv = MUTABLE_HV(LvTARG(sv));
6ff81951 1645 I32 i = 0;
7918f24d
NC
1646
1647 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
8772537c 1648 PERL_UNUSED_ARG(mg);
7719e241 1649
6ff81951 1650 if (hv) {
497b47a8 1651 (void) hv_iterinit(hv);
ad64d0ec 1652 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
497b47a8
JH
1653 i = HvKEYS(hv);
1654 else {
1655 while (hv_iternext(hv))
1656 i++;
1657 }
6ff81951
GS
1658 }
1659
1660 sv_setiv(sv, (IV)i);
1661 return 0;
1662}
1663
1664int
864dbfa3 1665Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1666{
7918f24d 1667 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
8772537c 1668 PERL_UNUSED_ARG(mg);
946ec16e 1669 if (LvTARG(sv)) {
85fbaab2 1670 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
946ec16e
PP
1671 }
1672 return 0;
ac27b0f5 1673}
946ec16e 1674
e336de0d 1675/* caller is responsible for stack switching/cleanup */
565764a8 1676STATIC int
e1ec3a88 1677S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
a0d0e21e 1678{
97aff369 1679 dVAR;
a0d0e21e 1680 dSP;
463ee0b2 1681
7918f24d
NC
1682 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1683
924508f0
GS
1684 PUSHMARK(SP);
1685 EXTEND(SP, n);
33c27489 1686 PUSHs(SvTIED_obj(sv, mg));
ac27b0f5 1687 if (n > 1) {
93965878 1688 if (mg->mg_ptr) {
565764a8 1689 if (mg->mg_len >= 0)
6e449a3a 1690 mPUSHp(mg->mg_ptr, mg->mg_len);
565764a8 1691 else if (mg->mg_len == HEf_SVKEY)
ad64d0ec 1692 PUSHs(MUTABLE_SV(mg->mg_ptr));
93965878 1693 }
14befaf4 1694 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
6e449a3a 1695 mPUSHi(mg->mg_len);
93965878
NIS
1696 }
1697 }
1698 if (n > 2) {
1699 PUSHs(val);
88e89b8a 1700 }
463ee0b2
LW
1701 PUTBACK;
1702
864dbfa3 1703 return call_method(meth, flags);
946ec16e
PP
1704}
1705
76e3520e 1706STATIC int
e1ec3a88 1707S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
a0d0e21e 1708{
27da23d5 1709 dVAR; dSP;
463ee0b2 1710
7918f24d
NC
1711 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1712
a0d0e21e
LW
1713 ENTER;
1714 SAVETMPS;
e788e7d3 1715 PUSHSTACKi(PERLSI_MAGIC);
463ee0b2 1716
33c27489 1717 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
3280af22 1718 sv_setsv(sv, *PL_stack_sp--);
93965878 1719 }
463ee0b2 1720
d3acc0f7 1721 POPSTACK;
a0d0e21e
LW
1722 FREETMPS;
1723 LEAVE;
1724 return 0;
1725}
463ee0b2 1726
a0d0e21e 1727int
864dbfa3 1728Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1729{
7918f24d
NC
1730 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1731
a0d0e21e
LW
1732 if (mg->mg_ptr)
1733 mg->mg_flags |= MGf_GSKIP;
58f82c5c 1734 magic_methpack(sv,mg,"FETCH");
463ee0b2
LW
1735 return 0;
1736}
1737
1738int
864dbfa3 1739Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 1740{
27da23d5 1741 dVAR; dSP;
7918f24d
NC
1742
1743 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1744
a60c0954 1745 ENTER;
e788e7d3 1746 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1747 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
d3acc0f7 1748 POPSTACK;
a60c0954 1749 LEAVE;
463ee0b2
LW
1750 return 0;
1751}
1752
1753int
864dbfa3 1754Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 1755{
7918f24d
NC
1756 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1757
a0d0e21e
LW
1758 return magic_methpack(sv,mg,"DELETE");
1759}
463ee0b2 1760
93965878
NIS
1761
1762U32
864dbfa3 1763Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 1764{
27da23d5 1765 dVAR; dSP;
22846ab4 1766 I32 retval = 0;
93965878 1767
7918f24d
NC
1768 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1769
93965878
NIS
1770 ENTER;
1771 SAVETMPS;
e788e7d3 1772 PUSHSTACKi(PERLSI_MAGIC);
33c27489 1773 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
3280af22 1774 sv = *PL_stack_sp--;
22846ab4
AB
1775 retval = SvIV(sv)-1;
1776 if (retval < -1)
1777 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
93965878 1778 }
d3acc0f7 1779 POPSTACK;
93965878
NIS
1780 FREETMPS;
1781 LEAVE;
22846ab4 1782 return (U32) retval;
93965878
NIS
1783}
1784
cea2e8a9
GS
1785int
1786Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1787{
27da23d5 1788 dVAR; dSP;
463ee0b2 1789
7918f24d
NC
1790 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1791
e336de0d 1792 ENTER;
e788e7d3 1793 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1794 PUSHMARK(SP);
33c27489 1795 XPUSHs(SvTIED_obj(sv, mg));
463ee0b2 1796 PUTBACK;
864dbfa3 1797 call_method("CLEAR", G_SCALAR|G_DISCARD);
d3acc0f7 1798 POPSTACK;
a60c0954 1799 LEAVE;
a3bcc51e 1800
463ee0b2
LW
1801 return 0;
1802}
1803
1804int
864dbfa3 1805Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 1806{
27da23d5 1807 dVAR; dSP;
666ea192 1808 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
463ee0b2 1809
7918f24d
NC
1810 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1811
463ee0b2 1812 ENTER;
a0d0e21e 1813 SAVETMPS;
e788e7d3 1814 PUSHSTACKi(PERLSI_MAGIC);
924508f0
GS
1815 PUSHMARK(SP);
1816 EXTEND(SP, 2);
33c27489 1817 PUSHs(SvTIED_obj(sv, mg));
463ee0b2
LW
1818 if (SvOK(key))
1819 PUSHs(key);
1820 PUTBACK;
1821
864dbfa3 1822 if (call_method(meth, G_SCALAR))
3280af22 1823 sv_setsv(key, *PL_stack_sp--);
463ee0b2 1824
d3acc0f7 1825 POPSTACK;
a0d0e21e
LW
1826 FREETMPS;
1827 LEAVE;
79072805
LW
1828 return 0;
1829}
1830
1831int
1146e912 1832Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e 1833{
7918f24d
NC
1834 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1835
a0d0e21e 1836 return magic_methpack(sv,mg,"EXISTS");
ac27b0f5 1837}
a0d0e21e 1838
a3bcc51e
TP
1839SV *
1840Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1841{
27da23d5 1842 dVAR; dSP;
5fcbf73d 1843 SV *retval;
ad64d0ec
NC
1844 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1845 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
a3bcc51e 1846
7918f24d
NC
1847 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1848
a3bcc51e
TP
1849 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1850 SV *key;
bfcb3514 1851 if (HvEITER_get(hv))
a3bcc51e
TP
1852 /* we are in an iteration so the hash cannot be empty */
1853 return &PL_sv_yes;
1854 /* no xhv_eiter so now use FIRSTKEY */
1855 key = sv_newmortal();
ad64d0ec 1856 magic_nextpack(MUTABLE_SV(hv), mg, key);
bfcb3514 1857 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP
1858 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1859 }
1860
1861 /* there is a SCALAR method that we can call */
1862 ENTER;
1863 PUSHSTACKi(PERLSI_MAGIC);
1864 PUSHMARK(SP);
1865 EXTEND(SP, 1);
1866 PUSHs(tied);
1867 PUTBACK;
1868
1869 if (call_method("SCALAR", G_SCALAR))
1870 retval = *PL_stack_sp--;
5fcbf73d
AL
1871 else
1872 retval = &PL_sv_undef;
a3bcc51e
TP
1873 POPSTACK;
1874 LEAVE;
1875 return retval;
1876}
1877
a0d0e21e 1878int
864dbfa3 1879Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 1880{
97aff369 1881 dVAR;
8772537c
AL
1882 GV * const gv = PL_DBline;
1883 const I32 i = SvTRUE(sv);
1884 SV ** const svp = av_fetch(GvAV(gv),
01b8bcb7 1885 atoi(MgPV_nolen_const(mg)), FALSE);
7918f24d
NC
1886
1887 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1888
8772537c
AL
1889 if (svp && SvIOKp(*svp)) {
1890 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1891 if (o) {
1892 /* set or clear breakpoint in the relevant control op */
1893 if (i)
1894 o->op_flags |= OPf_SPECIAL;
1895 else
1896 o->op_flags &= ~OPf_SPECIAL;
1897 }
5df8de69 1898 }
79072805
LW
1899 return 0;
1900}
1901
1902int
8772537c 1903Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 1904{
97aff369 1905 dVAR;
502c6561 1906 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
1907
1908 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1909
83bf042f 1910 if (obj) {
fc15ae8f 1911 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
83bf042f
NC
1912 } else {
1913 SvOK_off(sv);
1914 }
79072805
LW
1915 return 0;
1916}
1917
1918int
864dbfa3 1919Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 1920{
97aff369 1921 dVAR;
502c6561 1922 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC
1923
1924 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1925
83bf042f 1926 if (obj) {
fc15ae8f 1927 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
83bf042f
NC
1928 } else {
1929 if (ckWARN(WARN_MISC))
1930 Perl_warner(aTHX_ packWARN(WARN_MISC),
1931 "Attempt to set length of freed array");
1932 }
1933 return 0;
1934}
1935
1936int
1937Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1938{
97aff369 1939 dVAR;
7918f24d
NC
1940
1941 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
53c1dcc0 1942 PERL_UNUSED_ARG(sv);
7918f24d 1943
94f3782b
DM
1944 /* during global destruction, mg_obj may already have been freed */
1945 if (PL_in_clean_all)
1ea47f64 1946 return 0;
94f3782b 1947
83bf042f
NC
1948 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1949
1950 if (mg) {
1951 /* arylen scalar holds a pointer back to the array, but doesn't own a
1952 reference. Hence the we (the array) are about to go away with it
1953 still pointing at us. Clear its pointer, else it would be pointing
1954 at free memory. See the comment in sv_magic about reference loops,
1955 and why it can't own a reference to us. */
1956 mg->mg_obj = 0;
1957 }
a0d0e21e
LW
1958 return 0;
1959}
1960
1961int
864dbfa3 1962Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1963{
97aff369 1964 dVAR;
8772537c 1965 SV* const lsv = LvTARG(sv);
7918f24d
NC
1966
1967 PERL_ARGS_ASSERT_MAGIC_GETPOS;
3881461a 1968 PERL_UNUSED_ARG(mg);
ac27b0f5 1969
a0d0e21e 1970 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
3881461a
AL
1971 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1972 if (found && found->mg_len >= 0) {
1973 I32 i = found->mg_len;
7e2040f0 1974 if (DO_UTF8(lsv))
a0ed51b3 1975 sv_pos_b2u(lsv, &i);
fc15ae8f 1976 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
a0d0e21e
LW
1977 return 0;
1978 }
1979 }
0c34ef67 1980 SvOK_off(sv);
a0d0e21e
LW
1981 return 0;
1982}
1983
1984int
864dbfa3 1985Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 1986{
97aff369 1987 dVAR;
8772537c 1988 SV* const lsv = LvTARG(sv);
a0d0e21e
LW
1989 SSize_t pos;
1990 STRLEN len;
c00206c8 1991 STRLEN ulen = 0;
53d44271 1992 MAGIC* found;
a0d0e21e 1993
7918f24d 1994 PERL_ARGS_ASSERT_MAGIC_SETPOS;
3881461a 1995 PERL_UNUSED_ARG(mg);
ac27b0f5 1996
a0d0e21e 1997 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
3881461a
AL
1998 found = mg_find(lsv, PERL_MAGIC_regex_global);
1999 else
2000 found = NULL;
2001 if (!found) {
a0d0e21e
LW
2002 if (!SvOK(sv))
2003 return 0;
d83f0a82
NC
2004#ifdef PERL_OLD_COPY_ON_WRITE
2005 if (SvIsCOW(lsv))
2006 sv_force_normal_flags(lsv, 0);
2007#endif
3881461a 2008 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
53d44271 2009 NULL, 0);
a0d0e21e
LW
2010 }
2011 else if (!SvOK(sv)) {
3881461a 2012 found->mg_len = -1;
a0d0e21e
LW
2013 return 0;
2014 }
2015 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2016
fc15ae8f 2017 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
a0ed51b3 2018
7e2040f0 2019 if (DO_UTF8(lsv)) {
a0ed51b3
LW
2020 ulen = sv_len_utf8(lsv);
2021 if (ulen)
2022 len = ulen;
a0ed51b3
LW
2023 }
2024
a0d0e21e
LW
2025 if (pos < 0) {
2026 pos += len;
2027 if (pos < 0)
2028 pos = 0;
2029 }
eb160463 2030 else if (pos > (SSize_t)len)
a0d0e21e 2031 pos = len;
a0ed51b3
LW
2032
2033 if (ulen) {
2034 I32 p = pos;
2035 sv_pos_u2b(lsv, &p, 0);
2036 pos = p;
2037 }
727405f8 2038
3881461a
AL
2039 found->mg_len = pos;
2040 found->mg_flags &= ~MGf_MINMATCH;
a0d0e21e 2041
79072805
LW
2042 return 0;
2043}
2044
2045int
864dbfa3 2046Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS
2047{
2048 STRLEN len;
35a4481c 2049 SV * const lsv = LvTARG(sv);
b83604b4 2050 const char * const tmps = SvPV_const(lsv,len);
6ff81951
GS
2051 I32 offs = LvTARGOFF(sv);
2052 I32 rem = LvTARGLEN(sv);
7918f24d
NC
2053
2054 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
8772537c 2055 PERL_UNUSED_ARG(mg);
6ff81951 2056
9aa983d2
JH
2057 if (SvUTF8(lsv))
2058 sv_pos_u2b(lsv, &offs, &rem);
eb160463 2059 if (offs > (I32)len)
6ff81951 2060 offs = len;
eb160463 2061 if (rem + offs > (I32)len)
6ff81951
GS
2062 rem = len - offs;
2063 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
9aa983d2 2064 if (SvUTF8(lsv))
2ef4b674 2065 SvUTF8_on(sv);
6ff81951
GS
2066 return 0;
2067}
2068
2069int
864dbfa3 2070Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 2071{
97aff369 2072 dVAR;
9aa983d2 2073 STRLEN len;
5fcbf73d 2074 const char * const tmps = SvPV_const(sv, len);
dd374669 2075 SV * const lsv = LvTARG(sv);
9aa983d2
JH
2076 I32 lvoff = LvTARGOFF(sv);
2077 I32 lvlen = LvTARGLEN(sv);
7918f24d
NC
2078
2079 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
8772537c 2080 PERL_UNUSED_ARG(mg);
075a4a2b 2081
1aa99e6b 2082 if (DO_UTF8(sv)) {
9aa983d2
JH
2083 sv_utf8_upgrade(lsv);
2084 sv_pos_u2b(lsv, &lvoff, &lvlen);
2085 sv_insert(lsv, lvoff, lvlen, tmps, len);
b76f3ce2 2086 LvTARGLEN(sv) = sv_len_utf8(sv);
9aa983d2
JH
2087 SvUTF8_on(lsv);
2088 }
9bf12eaf 2089 else if (lsv && SvUTF8(lsv)) {
5fcbf73d 2090 const char *utf8;
9aa983d2 2091 sv_pos_u2b(lsv, &lvoff, &lvlen);
b76f3ce2 2092 LvTARGLEN(sv) = len;
5fcbf73d
AL
2093 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2094 sv_insert(lsv, lvoff, lvlen, utf8, len);
2095 Safefree(utf8);
1aa99e6b 2096 }
b76f3ce2
GB
2097 else {
2098 sv_insert(lsv, lvoff, lvlen, tmps, len);
2099 LvTARGLEN(sv) = len;
2100 }
2101
1aa99e6b 2102
79072805
LW
2103 return 0;
2104}
2105
2106int
864dbfa3 2107Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2108{
97aff369 2109 dVAR;
7918f24d
NC
2110
2111 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
8772537c 2112 PERL_UNUSED_ARG(sv);
7918f24d 2113
27cc343c 2114 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
463ee0b2
LW
2115 return 0;
2116}
2117
2118int
864dbfa3 2119Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2120{
97aff369 2121 dVAR;
7918f24d
NC
2122
2123 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
8772537c 2124 PERL_UNUSED_ARG(sv);
7918f24d 2125
b01e650a
DM
2126 /* update taint status */
2127 if (PL_tainted)
2128 mg->mg_len |= 1;
2129 else
2130 mg->mg_len &= ~1;
463ee0b2
LW
2131 return 0;
2132}
2133
2134int
864dbfa3 2135Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 2136{
35a4481c 2137 SV * const lsv = LvTARG(sv);
7918f24d
NC
2138
2139 PERL_ARGS_ASSERT_MAGIC_GETVEC;
8772537c 2140 PERL_UNUSED_ARG(mg);
6ff81951 2141
6136c704
AL
2142 if (lsv)
2143 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2144 else
0c34ef67 2145 SvOK_off(sv);
6ff81951 2146
6ff81951
GS
2147 return 0;
2148}
2149
2150int
864dbfa3 2151Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2152{
7918f24d 2153 PERL_ARGS_ASSERT_MAGIC_SETVEC;
8772537c 2154 PERL_UNUSED_ARG(mg);
79072805
LW
2155 do_vecset(sv); /* XXX slurp this routine */
2156 return 0;
2157}
2158
2159int
864dbfa3 2160Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2161{
97aff369 2162 dVAR;
a0714e2c 2163 SV *targ = NULL;
7918f24d
NC
2164
2165 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2166
5f05dabc 2167 if (LvTARGLEN(sv)) {
68dc0745 2168 if (mg->mg_obj) {
8772537c 2169 SV * const ahv = LvTARG(sv);
85fbaab2 2170 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
6d822dc4
MS
2171 if (he)
2172 targ = HeVAL(he);
68dc0745
PP
2173 }
2174 else {
502c6561 2175 AV *const av = MUTABLE_AV(LvTARG(sv));
68dc0745
PP
2176 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2177 targ = AvARRAY(av)[LvTARGOFF(sv)];
2178 }
46da273f 2179 if (targ && (targ != &PL_sv_undef)) {
68dc0745
PP
2180 /* somebody else defined it for us */
2181 SvREFCNT_dec(LvTARG(sv));
b37c2d43 2182 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
68dc0745
PP
2183 LvTARGLEN(sv) = 0;
2184 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2185 mg->mg_obj = NULL;
68dc0745
PP
2186 mg->mg_flags &= ~MGf_REFCOUNTED;
2187 }
5f05dabc 2188 }
71be2cbc
PP
2189 else
2190 targ = LvTARG(sv);
3280af22 2191 sv_setsv(sv, targ ? targ : &PL_sv_undef);
71be2cbc
PP
2192 return 0;
2193}
2194
2195int
864dbfa3 2196Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2197{
7918f24d 2198 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
8772537c 2199 PERL_UNUSED_ARG(mg);
71be2cbc 2200 if (LvTARGLEN(sv))
68dc0745
PP
2201 vivify_defelem(sv);
2202 if (LvTARG(sv)) {
5f05dabc 2203 sv_setsv(LvTARG(sv), sv);
68dc0745
PP
2204 SvSETMAGIC(LvTARG(sv));
2205 }
5f05dabc
PP
2206 return 0;
2207}
2208
71be2cbc 2209void
864dbfa3 2210Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2211{
97aff369 2212 dVAR;
74e13ce4 2213 MAGIC *mg;
a0714e2c 2214 SV *value = NULL;
71be2cbc 2215
7918f24d
NC
2216 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2217
14befaf4 2218 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
71be2cbc 2219 return;
68dc0745 2220 if (mg->mg_obj) {
8772537c 2221 SV * const ahv = LvTARG(sv);
85fbaab2 2222 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
6d822dc4
MS
2223 if (he)
2224 value = HeVAL(he);
3280af22 2225 if (!value || value == &PL_sv_undef)
be2597df 2226 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
71be2cbc 2227 }
68dc0745 2228 else {
502c6561 2229 AV *const av = MUTABLE_AV(LvTARG(sv));
5aabfad6 2230 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
a0714e2c 2231 LvTARG(sv) = NULL; /* array can't be extended */
68dc0745 2232 else {
d4c19fe8 2233 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
3280af22 2234 if (!svp || (value = *svp) == &PL_sv_undef)
cea2e8a9 2235 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
68dc0745
PP
2236 }
2237 }
b37c2d43 2238 SvREFCNT_inc_simple_void(value);
68dc0745
PP
2239 SvREFCNT_dec(LvTARG(sv));
2240 LvTARG(sv) = value;
71be2cbc 2241 LvTARGLEN(sv) = 0;
68dc0745 2242 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2243 mg->mg_obj = NULL;
68dc0745 2244 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc
PP
2245}
2246
2247int
864dbfa3 2248Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2249{
7918f24d 2250 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
502c6561 2251 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
810b8aa5
GS
2252}
2253
2254int
864dbfa3 2255Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2256{
7918f24d 2257 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
96a5add6 2258 PERL_UNUSED_CONTEXT;
565764a8 2259 mg->mg_len = -1;
c6496cc7 2260 SvSCREAM_off(sv);
93a17b20
LW
2261 return 0;
2262}
2263
2264int
864dbfa3 2265Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2266{
35a4481c 2267 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 2268
7918f24d
NC
2269 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2270
79072805 2271 if (uf && uf->uf_set)
24f81a43 2272 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW
2273 return 0;
2274}
2275
c277df42 2276int
faf82a0b
AE
2277Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2278{
488344d2 2279 const char type = mg->mg_type;
7918f24d
NC
2280
2281 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2282
488344d2
NC
2283 if (type == PERL_MAGIC_qr) {
2284 } else if (type == PERL_MAGIC_bm) {
2285 SvTAIL_off(sv);
2286 SvVALID_off(sv);
2287 } else {
2288 assert(type == PERL_MAGIC_fm);
2289 SvCOMPILED_off(sv);
2290 }
2291 return sv_unmagic(sv, type);
faf82a0b
AE
2292}
2293
7a4c00b4 2294#ifdef USE_LOCALE_COLLATE
79072805 2295int
864dbfa3 2296Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 2297{
7918f24d
NC
2298 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2299
bbce6d69 2300 /*
838b5b74 2301 * RenE<eacute> Descartes said "I think not."
bbce6d69
PP
2302 * and vanished with a faint plop.
2303 */
96a5add6 2304 PERL_UNUSED_CONTEXT;
8772537c 2305 PERL_UNUSED_ARG(sv);
7a4c00b4
PP
2306 if (mg->mg_ptr) {
2307 Safefree(mg->mg_ptr);
2308 mg->mg_ptr = NULL;
565764a8 2309 mg->mg_len = -1;
7a4c00b4 2310 }
bbce6d69
PP
2311 return 0;
2312}
7a4c00b4 2313#endif /* USE_LOCALE_COLLATE */
bbce6d69 2314
7e8c5dac
HS
2315/* Just clear the UTF-8 cache data. */
2316int
2317Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2318{
7918f24d 2319 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
96a5add6 2320 PERL_UNUSED_CONTEXT;
8772537c 2321 PERL_UNUSED_ARG(sv);
7e8c5dac 2322 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2323 mg->mg_ptr = NULL;
7e8c5dac
HS
2324 mg->mg_len = -1; /* The mg_len holds the len cache. */
2325 return 0;
2326}
2327
bbce6d69 2328int
864dbfa3 2329Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2330{
97aff369 2331 dVAR;
e1ec3a88 2332 register const char *s;
2fdbfb4d
AB
2333 register I32 paren;
2334 register const REGEXP * rx;
2335 const char * const remaining = mg->mg_ptr + 1;
79072805 2336 I32 i;
8990e307 2337 STRLEN len;
2fdbfb4d 2338
7918f24d
NC
2339 PERL_ARGS_ASSERT_MAGIC_SET;
2340
79072805 2341 switch (*mg->mg_ptr) {
2fdbfb4d
AB
2342 case '\015': /* $^MATCH */
2343 if (strEQ(remaining, "ATCH"))
2344 goto do_match;
2345 case '`': /* ${^PREMATCH} caught below */
2346 do_prematch:
f1b875a0 2347 paren = RX_BUFF_IDX_PREMATCH;
2fdbfb4d
AB
2348 goto setparen;
2349 case '\'': /* ${^POSTMATCH} caught below */
2350 do_postmatch:
f1b875a0 2351 paren = RX_BUFF_IDX_POSTMATCH;
2fdbfb4d
AB
2352 goto setparen;
2353 case '&':
2354 do_match:
f1b875a0 2355 paren = RX_BUFF_IDX_FULLMATCH;
2fdbfb4d
AB
2356 goto setparen;
2357 case '1': case '2': case '3': case '4':
2358 case '5': case '6': case '7': case '8': case '9':
104a8018 2359 paren = atoi(mg->mg_ptr);
2fdbfb4d 2360 setparen:
1e05feb3 2361 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2fdbfb4d
AB
2362 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2363 break;
1e05feb3 2364 } else {
2fdbfb4d
AB
2365 /* Croak with a READONLY error when a numbered match var is
2366 * set without a previous pattern match. Unless it's C<local $1>
2367 */
2368 if (!PL_localizing) {
f1f66076 2369 Perl_croak(aTHX_ "%s", PL_no_modify);
2fdbfb4d
AB
2370 }
2371 }
748a9306 2372 case '\001': /* ^A */
3280af22 2373 sv_setsv(PL_bodytarget, sv);
748a9306 2374 break;
49460fe6 2375 case '\003': /* ^C */
38ab35f8 2376 PL_minus_c = (bool)SvIV(sv);
49460fe6
NIS
2377 break;
2378
79072805 2379 case '\004': /* ^D */
b4ab917c 2380#ifdef DEBUGGING
b83604b4 2381 s = SvPV_nolen_const(sv);
ddcf8bc1 2382 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
79072805 2383 DEBUG_x(dump_all());
b4ab917c 2384#else
38ab35f8 2385 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2386#endif
79072805 2387 break;
28f23441 2388 case '\005': /* ^E */
d0063567 2389 if (*(mg->mg_ptr+1) == '\0') {
cd39f2b6 2390#ifdef MACOS_TRADITIONAL
38ab35f8 2391 gMacPerl_OSErr = SvIV(sv);
28f23441 2392#else
cd39f2b6 2393# ifdef VMS
38ab35f8 2394 set_vaxc_errno(SvIV(sv));
048c1ddf 2395# else
cd39f2b6 2396# ifdef WIN32
d0063567 2397 SetLastError( SvIV(sv) );
cd39f2b6 2398# else
9fed8b87 2399# ifdef OS2
38ab35f8 2400 os2_setsyserrno(SvIV(sv));
9fed8b87 2401# else
d0063567 2402 /* will anyone ever use this? */
38ab35f8 2403 SETERRNO(SvIV(sv), 4);
cd39f2b6 2404# endif
048c1ddf
IZ
2405# endif
2406# endif
22fae026 2407#endif
d0063567
DK
2408 }
2409 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2410 if (PL_encoding)
2411 SvREFCNT_dec(PL_encoding);
2412 if (SvOK(sv) || SvGMAGICAL(sv)) {
2413 PL_encoding = newSVsv(sv);
2414 }
2415 else {
a0714e2c 2416 PL_encoding = NULL;
d0063567
DK
2417 }
2418 }
2419 break;
79072805 2420 case '\006': /* ^F */
38ab35f8 2421 PL_maxsysfd = SvIV(sv);
79072805 2422 break;
a0d0e21e 2423 case '\010': /* ^H */
38ab35f8 2424 PL_hints = SvIV(sv);
a0d0e21e 2425 break;
9d116dd7 2426 case '\011': /* ^I */ /* NOT \t in EBCDIC */
43c5f42d 2427 Safefree(PL_inplace);
bd61b366 2428 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
da78da6e 2429 break;
28f23441 2430 case '\017': /* ^O */
ac27b0f5 2431 if (*(mg->mg_ptr+1) == '\0') {
43c5f42d 2432 Safefree(PL_osname);
bd61b366 2433 PL_osname = NULL;
3511154c
DM
2434 if (SvOK(sv)) {
2435 TAINT_PROPER("assigning to $^O");
2e0de35c 2436 PL_osname = savesvpv(sv);
3511154c 2437 }
ac27b0f5
NIS
2438 }
2439 else if (strEQ(mg->mg_ptr, "\017PEN")) {
8b850bd5
NC
2440 STRLEN len;
2441 const char *const start = SvPV(sv, len);
b54fc2b6 2442 const char *out = (const char*)memchr(start, '\0', len);
8b850bd5
NC
2443 SV *tmp;
2444 struct refcounted_he *tmp_he;
2445
2446
2447 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2448 PL_hints
2449 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2450
2451 /* Opening for input is more common than opening for output, so
2452 ensure that hints for input are sooner on linked list. */
59cd0e26
NC
2453 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2454 SVs_TEMP | SvUTF8(sv))
76f68e9b 2455 : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
8b850bd5
NC
2456
2457 tmp_he
2458 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
84bafc02
NC
2459 newSVpvs_flags("open>", SVs_TEMP),
2460 tmp);
8b850bd5
NC
2461
2462 /* The UTF-8 setting is carried over */
2463 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2464
11bcd5da 2465 PL_compiling.cop_hints_hash
8b850bd5 2466 = Perl_refcounted_he_new(aTHX_ tmp_he,
84bafc02
NC
2467 newSVpvs_flags("open<", SVs_TEMP),
2468 tmp);
ac27b0f5 2469 }
28f23441 2470 break;
79072805 2471 case '\020': /* ^P */
2fdbfb4d
AB
2472 if (*remaining == '\0') { /* ^P */
2473 PL_perldb = SvIV(sv);
2474 if (PL_perldb && !PL_DBsingle)
2475 init_debugger();
2476 break;
2477 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2478 goto do_prematch;
2479 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2480 goto do_postmatch;
2481 }
79072805 2482 case '\024': /* ^T */
88e89b8a 2483#ifdef BIG_TIME
6b88bc9c 2484 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 2485#else
38ab35f8 2486 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 2487#endif
79072805 2488 break;
e07ea26a
NC
2489 case '\025': /* ^UTF8CACHE */
2490 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2491 PL_utf8cache = (signed char) sv_2iv(sv);
2492 }
2493 break;
fde18df1 2494 case '\027': /* ^W & $^WARNING_BITS */
4438c4b7
JH
2495 if (*(mg->mg_ptr+1) == '\0') {
2496 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
38ab35f8 2497 i = SvIV(sv);
ac27b0f5 2498 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
0453d815 2499 | (i ? G_WARN_ON : G_WARN_OFF) ;
4438c4b7 2500 }
599cee73 2501 }
0a378802 2502 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
4438c4b7 2503 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
d775746e
GS
2504 if (!SvPOK(sv) && PL_localizing) {
2505 sv_setpvn(sv, WARN_NONEstring, WARNsize);
d3a7d8c7 2506 PL_compiling.cop_warnings = pWARN_NONE;
d775746e
GS
2507 break;
2508 }
f4fc7782 2509 {
b5477537 2510 STRLEN len, i;
d3a7d8c7 2511 int accumulate = 0 ;
f4fc7782 2512 int any_fatals = 0 ;
b83604b4 2513 const char * const ptr = SvPV_const(sv, len) ;
f4fc7782
JH
2514 for (i = 0 ; i < len ; ++i) {
2515 accumulate |= ptr[i] ;
2516 any_fatals |= (ptr[i] & 0xAA) ;
2517 }
4243c432
NC
2518 if (!accumulate) {
2519 if (!specialWARN(PL_compiling.cop_warnings))
2520 PerlMemShared_free(PL_compiling.cop_warnings);
2521 PL_compiling.cop_warnings = pWARN_NONE;
2522 }
72dc9ed5
NC
2523 /* Yuck. I can't see how to abstract this: */
2524 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2525 WARN_ALL) && !any_fatals) {
4243c432
NC
2526 if (!specialWARN(PL_compiling.cop_warnings))
2527 PerlMemShared_free(PL_compiling.cop_warnings);
f4fc7782
JH
2528 PL_compiling.cop_warnings = pWARN_ALL;
2529 PL_dowarn |= G_WARN_ONCE ;
727405f8 2530 }
d3a7d8c7 2531 else {
72dc9ed5
NC
2532 STRLEN len;
2533 const char *const p = SvPV_const(sv, len);
2534
2535 PL_compiling.cop_warnings
8ee4cf24 2536 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
72dc9ed5
NC
2537 p, len);
2538
d3a7d8c7
GS
2539 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2540 PL_dowarn |= G_WARN_ONCE ;
2541 }
f4fc7782 2542
d3a7d8c7 2543 }
4438c4b7 2544 }
971a9dd3 2545 }
79072805
LW
2546 break;
2547 case '.':
3280af22
NIS
2548 if (PL_localizing) {
2549 if (PL_localizing == 1)
7766f137 2550 SAVESPTR(PL_last_in_gv);
748a9306 2551 }
3280af22 2552 else if (SvOK(sv) && GvIO(PL_last_in_gv))
632db599 2553 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
79072805
LW
2554 break;
2555 case '^':
3280af22 2556 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2557 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2558 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2559 break;
2560 case '~':
3280af22 2561 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
e1ec3a88 2562 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
f776e3cd 2563 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
79072805
LW
2564 break;
2565 case '=':
38ab35f8 2566 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2567 break;
2568 case '-':
38ab35f8 2569 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3280af22
NIS
2570 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2571 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
79072805
LW
2572 break;
2573 case '%':
38ab35f8 2574 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
79072805
LW
2575 break;
2576 case '|':
4b65379b 2577 {
8772537c 2578 IO * const io = GvIOp(PL_defoutgv);
720f287d
AB
2579 if(!io)
2580 break;
38ab35f8 2581 if ((SvIV(sv)) == 0)
4b65379b
CS
2582 IoFLAGS(io) &= ~IOf_FLUSH;
2583 else {
2584 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2585 PerlIO *ofp = IoOFP(io);
2586 if (ofp)
2587 (void)PerlIO_flush(ofp);
2588 IoFLAGS(io) |= IOf_FLUSH;
2589 }
2590 }
79072805
LW
2591 }
2592 break;
79072805 2593 case '/':
3280af22 2594 SvREFCNT_dec(PL_rs);
8bfdd7d9 2595 PL_rs = newSVsv(sv);
79072805
LW
2596 break;
2597 case '\\':
7889fe52
NIS
2598 if (PL_ors_sv)
2599 SvREFCNT_dec(PL_ors_sv);
009c130f 2600 if (SvOK(sv) || SvGMAGICAL(sv)) {
7889fe52 2601 PL_ors_sv = newSVsv(sv);
009c130f 2602 }
e3c19b7b 2603 else {
a0714e2c 2604 PL_ors_sv = NULL;
e3c19b7b 2605 }
79072805
LW
2606 break;
2607 case ',':
7889fe52
NIS
2608 if (PL_ofs_sv)
2609 SvREFCNT_dec(PL_ofs_sv);
2610 if (SvOK(sv) || SvGMAGICAL(sv)) {
2611 PL_ofs_sv = newSVsv(sv);
2612 }
2613 else {
a0714e2c 2614 PL_ofs_sv = NULL;
7889fe52 2615 }
79072805 2616 break;
79072805 2617 case '[':
38ab35f8 2618 CopARYBASE_set(&PL_compiling, SvIV(sv));
79072805
LW
2619 break;
2620 case '?':
ff0cee69 2621#ifdef COMPLEX_STATUS
6b88bc9c
GS
2622 if (PL_localizing == 2) {
2623 PL_statusvalue = LvTARGOFF(sv);
2624 PL_statusvalue_vms = LvTARGLEN(sv);
ff0cee69
PP
2625 }
2626 else
2627#endif
2628#ifdef VMSISH_STATUS
2629 if (VMSISH_STATUS)
fb38d079 2630 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
ff0cee69
PP
2631 else
2632#endif
38ab35f8 2633 STATUS_UNIX_EXIT_SET(SvIV(sv));
79072805
LW
2634 break;
2635 case '!':
93189314
JH
2636 {
2637#ifdef VMS
2638# define PERL_VMS_BANG vaxc$errno
2639#else
2640# define PERL_VMS_BANG 0
2641#endif
91487cfc 2642 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
93189314
JH
2643 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2644 }
79072805
LW
2645 break;
2646 case '<':
38ab35f8 2647 PL_uid = SvIV(sv);
3280af22
NIS
2648 if (PL_delaymagic) {
2649 PL_delaymagic |= DM_RUID;
79072805
LW
2650 break; /* don't do magic till later */
2651 }
2652#ifdef HAS_SETRUID
b28d0864 2653 (void)setruid((Uid_t)PL_uid);
79072805
LW
2654#else
2655#ifdef HAS_SETREUID
3280af22 2656 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2657#else
85e6fe83 2658#ifdef HAS_SETRESUID
b28d0864 2659 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2660#else
75870ed3 2661 if (PL_uid == PL_euid) { /* special case $< = $> */
2662#ifdef PERL_DARWIN
2663 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2664 if (PL_uid != 0 && PerlProc_getuid() == 0)
2665 (void)PerlProc_setuid(0);
2666#endif
b28d0864 2667 (void)PerlProc_setuid(PL_uid);
75870ed3 2668 } else {
d8eceb89 2669 PL_uid = PerlProc_getuid();
cea2e8a9 2670 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2671 }
79072805
LW
2672#endif
2673#endif
85e6fe83 2674#endif
d8eceb89 2675 PL_uid = PerlProc_getuid();
3280af22 2676 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2677 break;
2678 case '>':
38ab35f8 2679 PL_euid = SvIV(sv);
3280af22
NIS
2680 if (PL_delaymagic) {
2681 PL_delaymagic |= DM_EUID;
79072805
LW
2682 break; /* don't do magic till later */
2683 }
2684#ifdef HAS_SETEUID
3280af22 2685 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2686#else
2687#ifdef HAS_SETREUID
b28d0864 2688 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2689#else
2690#ifdef HAS_SETRESUID
6b88bc9c 2691 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2692#else
b28d0864
NIS
2693 if (PL_euid == PL_uid) /* special case $> = $< */
2694 PerlProc_setuid(PL_euid);
a0d0e21e 2695 else {
e8ee3774 2696 PL_euid = PerlProc_geteuid();
cea2e8a9 2697 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2698 }
79072805
LW
2699#endif
2700#endif
85e6fe83 2701#endif
d8eceb89 2702 PL_euid = PerlProc_geteuid();
3280af22 2703 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2704 break;
2705 case '(':
38ab35f8 2706 PL_gid = SvIV(sv);
3280af22
NIS
2707 if (PL_delaymagic) {
2708 PL_delaymagic |= DM_RGID;
79072805
LW
2709 break; /* don't do magic till later */
2710 }
2711#ifdef HAS_SETRGID
b28d0864 2712 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2713#else
2714#ifdef HAS_SETREGID
3280af22 2715 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2716#else
2717#ifdef HAS_SETRESGID
b28d0864 2718 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
79072805 2719#else
b28d0864
NIS
2720 if (PL_gid == PL_egid) /* special case $( = $) */
2721 (void)PerlProc_setgid(PL_gid);
748a9306 2722 else {
d8eceb89 2723 PL_gid = PerlProc_getgid();
cea2e8a9 2724 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2725 }
79072805
LW
2726#endif
2727#endif
85e6fe83 2728#endif
d8eceb89 2729 PL_gid = PerlProc_getgid();
3280af22 2730 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2731 break;
2732 case ')':
5cd24f17
PP
2733#ifdef HAS_SETGROUPS
2734 {
b83604b4 2735 const char *p = SvPV_const(sv, len);
757f63d8
SP
2736 Groups_t *gary = NULL;
2737
2738 while (isSPACE(*p))
2739 ++p;
2740 PL_egid = Atol(p);
2741 for (i = 0; i < NGROUPS; ++i) {
2742 while (*p && !isSPACE(*p))
2743 ++p;
2744 while (isSPACE(*p))
2745 ++p;
2746 if (!*p)
2747 break;
2748 if(!gary)
2749 Newx(gary, i + 1, Groups_t);
2750 else
2751 Renew(gary, i + 1, Groups_t);
2752 gary[i] = Atol(p);
2753 }
2754 if (i)
2755 (void)setgroups(i, gary);
f5a63d97 2756 Safefree(gary);
5cd24f17
PP
2757 }
2758#else /* HAS_SETGROUPS */
38ab35f8 2759 PL_egid = SvIV(sv);
5cd24f17 2760#endif /* HAS_SETGROUPS */
3280af22
NIS
2761 if (PL_delaymagic) {
2762 PL_delaymagic |= DM_EGID;
79072805
LW
2763 break; /* don't do magic till later */
2764 }
2765#ifdef HAS_SETEGID
3280af22 2766 (void)setegid((Gid_t)PL_egid);
79072805
LW
2767#else
2768#ifdef HAS_SETREGID
b28d0864 2769 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2770#else
2771#ifdef HAS_SETRESGID
b28d0864 2772 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2773#else
b28d0864
NIS
2774 if (PL_egid == PL_gid) /* special case $) = $( */
2775 (void)PerlProc_setgid(PL_egid);
748a9306 2776 else {
d8eceb89 2777 PL_egid = PerlProc_getegid();
cea2e8a9 2778 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2779 }
79072805
LW
2780#endif
2781#endif
85e6fe83 2782#endif
d8eceb89 2783 PL_egid = PerlProc_getegid();
3280af22 2784 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
79072805
LW
2785 break;
2786 case ':':
2d8e6c8d 2787 PL_chopset = SvPV_force(sv,len);
79072805 2788 break;
cd39f2b6 2789#ifndef MACOS_TRADITIONAL
79072805 2790 case '0':
e2975953 2791 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2792#ifdef HAS_SETPROCTITLE
2793 /* The BSDs don't show the argv[] in ps(1) output, they
2794 * show a string from the process struct and provide
2795 * the setproctitle() routine to manipulate that. */
a2722ac9 2796 if (PL_origalen != 1) {
b83604b4 2797 s = SvPV_const(sv, len);
98b76f99 2798# if __FreeBSD_version > 410001
9aad2c0e 2799 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2800 * but not the "(perl) suffix from the ps(1)
2801 * output, because that's what ps(1) shows if the
2802 * argv[] is modified. */
6f2ad931 2803 setproctitle("-%s", s);
9aad2c0e 2804# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2805 /* This doesn't really work if you assume that
2806 * $0 = 'foobar'; will wipe out 'perl' from the $0
2807 * because in ps(1) output the result will be like
2808 * sprintf("perl: %s (perl)", s)
2809 * I guess this is a security feature:
2810 * one (a user process) cannot get rid of the original name.
2811 * --jhi */
2812 setproctitle("%s", s);
2813# endif
2814 }
9d3968b2 2815#elif defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2816 if (PL_origalen != 1) {
17aa7f3d 2817 union pstun un;
b83604b4 2818 s = SvPV_const(sv, len);
6867be6d 2819 un.pst_command = (char *)s;
17aa7f3d
JH
2820 pstat(PSTAT_SETCMD, un, len, 0, 0);
2821 }
9d3968b2 2822#else
2d2af554
GA
2823 if (PL_origalen > 1) {
2824 /* PL_origalen is set in perl_parse(). */
2825 s = SvPV_force(sv,len);
2826 if (len >= (STRLEN)PL_origalen-1) {
2827 /* Longer than original, will be truncated. We assume that
2828 * PL_origalen bytes are available. */
2829 Copy(s, PL_origargv[0], PL_origalen-1, char);
2830 }
2831 else {
2832 /* Shorter than original, will be padded. */
235ac35d 2833#ifdef PERL_DARWIN
60777a0d
JH
2834 /* Special case for Mac OS X: see [perl #38868] */
2835 const int pad = 0;
235ac35d 2836#else
8a89a4f1
MB
2837 /* Is the space counterintuitive? Yes.
2838 * (You were expecting \0?)
2839 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2840 * --jhi */
60777a0d 2841 const int pad = ' ';
235ac35d 2842#endif
60777a0d
JH
2843 Copy(s, PL_origargv[0], len, char);
2844 PL_origargv[0][len] = 0;
2845 memset(PL_origargv[0] + len + 1,
2846 pad, PL_origalen - len - 1);
2d2af554
GA
2847 }
2848 PL_origargv[0][PL_origalen-1] = 0;
2849 for (i = 1; i < PL_origargc; i++)
2850 PL_origargv[i] = 0;
79072805 2851 }
9d3968b2 2852#endif
e2975953 2853 UNLOCK_DOLLARZERO_MUTEX;
79072805 2854 break;
cd39f2b6 2855#endif
79072805
LW
2856 }
2857 return 0;
2858}
2859
2860I32
35a4481c 2861Perl_whichsig(pTHX_ const char *sig)
79072805 2862{
aadb217d 2863 register char* const* sigv;
7918f24d
NC
2864
2865 PERL_ARGS_ASSERT_WHICHSIG;
96a5add6 2866 PERL_UNUSED_CONTEXT;
79072805 2867
aadb217d 2868 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
79072805 2869 if (strEQ(sig,*sigv))
aadb217d 2870 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805
LW
2871#ifdef SIGCLD
2872 if (strEQ(sig,"CHLD"))
2873 return SIGCLD;
2874#endif
2875#ifdef SIGCHLD
2876 if (strEQ(sig,"CLD"))
2877 return SIGCHLD;
2878#endif
7f1236c0 2879 return -1;
79072805
LW
2880}
2881
ecfc5424 2882Signal_t
1e82f5a6 2883#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b6455c53 2884Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
1e82f5a6
SH
2885#else
2886Perl_sighandler(int sig)
2887#endif
79072805 2888{
1018e26f
NIS
2889#ifdef PERL_GET_SIG_CONTEXT
2890 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 2891#else
cea2e8a9 2892 dTHX;
71d280e3 2893#endif
79072805 2894 dSP;
a0714e2c
SS
2895 GV *gv = NULL;
2896 SV *sv = NULL;
8772537c 2897 SV * const tSv = PL_Sv;
601f1833 2898 CV *cv = NULL;
533c011a 2899 OP *myop = PL_op;
84902520 2900 U32 flags = 0;
8772537c 2901 XPV * const tXpv = PL_Xpv;
71d280e3 2902
3280af22 2903 if (PL_savestack_ix + 15 <= PL_savestack_max)
84902520 2904 flags |= 1;
3280af22 2905 if (PL_markstack_ptr < PL_markstack_max - 2)
84902520 2906 flags |= 4;
3280af22 2907 if (PL_scopestack_ix < PL_scopestack_max - 3)
84902520
TB
2908 flags |= 16;
2909
727405f8 2910 if (!PL_psig_ptr[sig]) {
99ef548b 2911 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
2912 PL_sig_name[sig]);
2913 exit(sig);
2914 }
ff0cee69 2915
84902520
TB
2916 /* Max number of items pushed there is 3*n or 4. We cannot fix
2917 infinity, so we fix 4 (in fact 5): */
2918 if (flags & 1) {
3280af22 2919 PL_savestack_ix += 5; /* Protect save in progress. */
8772537c 2920 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
84902520 2921 }
ac27b0f5 2922 if (flags & 4)
3280af22 2923 PL_markstack_ptr++; /* Protect mark. */
84902520 2924 if (flags & 16)
3280af22 2925 PL_scopestack_ix += 1;
84902520 2926 /* sv_2cv is too complicated, try a simpler variant first: */
ea726b52 2927 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
8772537c
AL
2928 || SvTYPE(cv) != SVt_PVCV) {
2929 HV *st;
f2c0649b 2930 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 2931 }
84902520 2932
a0d0e21e 2933 if (!cv || !CvROOT(cv)) {
599cee73 2934 if (ckWARN(WARN_SIGNAL))
9014280d 2935 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
22c35a8c 2936 PL_sig_name[sig], (gv ? GvENAME(gv)
00d579c5
GS
2937 : ((cv && CvGV(cv))
2938 ? GvENAME(CvGV(cv))
2939 : "__ANON__")));
2940 goto cleanup;
79072805
LW
2941 }
2942
22c35a8c 2943 if(PL_psig_name[sig]) {
b37c2d43 2944 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
84902520 2945 flags |= 64;
df3728a2 2946#if !defined(PERL_IMPLICIT_CONTEXT)
27da23d5 2947 PL_sig_sv = sv;
df3728a2 2948#endif
84902520 2949 } else {
ff0cee69 2950 sv = sv_newmortal();
22c35a8c 2951 sv_setpv(sv,PL_sig_name[sig]);
88e89b8a 2952 }
e336de0d 2953
e788e7d3 2954 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 2955 PUSHMARK(SP);
79072805 2956 PUSHs(sv);
8aad04aa
JH
2957#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2958 {
2959 struct sigaction oact;
2960
2961 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
8aad04aa
JH
2962 if (sip) {
2963 HV *sih = newHV();
ad64d0ec 2964 SV *rv = newRV_noinc(MUTABLE_SV(sih));
8aad04aa
JH
2965 /* The siginfo fields signo, code, errno, pid, uid,
2966 * addr, status, and band are defined by POSIX/SUSv3. */
85771703
NC
2967 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2968 (void)hv_stores(sih, "code", newSViv(sip->si_code));
79dec0f4 2969#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
2970 hv_stores(sih, "errno", newSViv(sip->si_errno));
2971 hv_stores(sih, "status", newSViv(sip->si_status));
2972 hv_stores(sih, "uid", newSViv(sip->si_uid));
2973 hv_stores(sih, "pid", newSViv(sip->si_pid));
2974 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2975 hv_stores(sih, "band", newSViv(sip->si_band));
79dec0f4 2976#endif
8aad04aa 2977 EXTEND(SP, 2);
ad64d0ec 2978 PUSHs(rv);
22f1178f 2979 mPUSHp((char *)sip, sizeof(*sip));
8aad04aa 2980 }
b4552a27 2981
8aad04aa
JH
2982 }
2983 }
2984#endif
79072805 2985 PUTBACK;
a0d0e21e 2986
ad64d0ec 2987 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
79072805 2988
d3acc0f7 2989 POPSTACK;
1b266415 2990 if (SvTRUE(ERRSV)) {
1d615522 2991#ifndef PERL_MICRO
983dbef6 2992#ifdef HAS_SIGPROCMASK
1b266415
NIS
2993 /* Handler "died", for example to get out of a restart-able read().
2994 * Before we re-do that on its behalf re-enable the signal which was
2995 * blocked by the system when we entered.
2996 */
2997 sigset_t set;
2998 sigemptyset(&set);
2999 sigaddset(&set,sig);
3000 sigprocmask(SIG_UNBLOCK, &set, NULL);
3001#else
3002 /* Not clear if this will work */
3003 (void)rsignal(sig, SIG_IGN);
5c1546dc 3004 (void)rsignal(sig, PL_csighandlerp);
1b266415 3005#endif
1d615522 3006#endif /* !PERL_MICRO */
bd61b366 3007 Perl_die(aTHX_ NULL);
1b266415 3008 }
00d579c5 3009cleanup:
84902520 3010 if (flags & 1)
3280af22 3011 PL_savestack_ix -= 8; /* Unprotect save in progress. */
ac27b0f5 3012 if (flags & 4)
3280af22 3013 PL_markstack_ptr--;
84902520 3014 if (flags & 16)
3280af22 3015 PL_scopestack_ix -= 1;
84902520
TB
3016 if (flags & 64)
3017 SvREFCNT_dec(sv);
533c011a 3018 PL_op = myop; /* Apparently not needed... */
ac27b0f5 3019
3280af22
NIS
3020 PL_Sv = tSv; /* Restore global temporaries. */
3021 PL_Xpv = tXpv;
53bb94e2 3022 return;
79072805 3023}
4e35701f
NIS
3024
3025
51371543 3026static void
8772537c 3027S_restore_magic(pTHX_ const void *p)
51371543 3028{
97aff369 3029 dVAR;
8772537c
AL
3030 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3031 SV* const sv = mgs->mgs_sv;
51371543
GS
3032
3033 if (!sv)
3034 return;
3035
3036 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3037 {
f8c7b90f 3038#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
3039 /* While magic was saved (and off) sv_setsv may well have seen
3040 this SV as a prime candidate for COW. */
3041 if (SvIsCOW(sv))
e424a81e 3042 sv_force_normal_flags(sv, 0);
f9701176
NC
3043#endif
3044
51371543
GS
3045 if (mgs->mgs_flags)
3046 SvFLAGS(sv) |= mgs->mgs_flags;
3047 else
3048 mg_magical(sv);
2b77b520
YST
3049 if (SvGMAGICAL(sv)) {
3050 /* downgrade public flags to private,
3051 and discard any other private flags */
3052
10edeb5d
JH
3053 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3054 if (pubflags) {
3055 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3056 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2b77b520
YST
3057 }
3058 }
51371543
GS
3059 }
3060
3061 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3062
3063 /* If we're still on top of the stack, pop us off. (That condition
3064 * will be satisfied if restore_magic was called explicitly, but *not*
3065 * if it's being called via leave_scope.)
3066 * The reason for doing this is that otherwise, things like sv_2cv()
3067 * may leave alloc gunk on the savestack, and some code
3068 * (e.g. sighandler) doesn't expect that...
3069 */
3070 if (PL_savestack_ix == mgs->mgs_ss_ix)
3071 {
3072 I32 popval = SSPOPINT;
c76ac1ee 3073 assert(popval == SAVEt_DESTRUCTOR_X);
51371543
GS
3074 PL_savestack_ix -= 2;
3075 popval = SSPOPINT;
3076 assert(popval == SAVEt_ALLOC);
3077 popval = SSPOPINT;
3078 PL_savestack_ix -= popval;
3079 }
3080
3081}
3082
3083static void
8772537c 3084S_unwind_handler_stack(pTHX_ const void *p)
51371543 3085{
27da23d5 3086 dVAR;
e1ec3a88 3087 const U32 flags = *(const U32*)p;
51371543 3088
7918f24d
NC
3089 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3090
51371543
GS
3091 if (flags & 1)
3092 PL_savestack_ix -= 5; /* Unprotect save in progress. */
df3728a2 3093#if !defined(PERL_IMPLICIT_CONTEXT)
51371543 3094 if (flags & 64)
27da23d5 3095 SvREFCNT_dec(PL_sig_sv);
df3728a2 3096#endif
51371543 3097}
1018e26f 3098
66610fdd 3099/*
b3ca2e83
NC
3100=for apidoc magic_sethint
3101
3102Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC
3103C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3104anything that would need a deep copy. Maybe we should warn if we find a
3105reference.
b3ca2e83
NC
3106
3107=cut
3108*/
3109int
3110Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3111{
3112 dVAR;
ad64d0ec 3113 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
59cd0e26 3114 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
b3ca2e83 3115
7918f24d
NC
3116 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3117
e6e3e454
NC
3118 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3119 an alternative leaf in there, with PL_compiling.cop_hints being used if
3120 it's NULL. If needed for threads, the alternative could lock a mutex,
3121 or take other more complex action. */
3122
5b9c0671
NC
3123 /* Something changed in %^H, so it will need to be restored on scope exit.
3124 Doing this here saves a lot of doing it manually in perl code (and
3125 forgetting to do it, and consequent subtle errors. */
3126 PL_hints |= HINT_LOCALIZE_HH;
c28fe1ec 3127 PL_compiling.cop_hints_hash
fc92a12d 3128 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
b3ca2e83
NC
3129 return 0;
3130}
3131
3132/*
f175cff5 3133=for apidoc magic_clearhint
b3ca2e83 3134
c28fe1ec
NC
3135Triggered by a delete from %^H, records the key to
3136C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC
3137
3138=cut
3139*/
3140int
3141Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3142{
3143 dVAR;
7918f24d
NC
3144
3145 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
f5a63d97
AL
3146 PERL_UNUSED_ARG(sv);
3147
b3ca2e83
NC
3148 assert(mg->mg_len == HEf_SVKEY);
3149
b3f24c00
MHM
3150 PERL_UNUSED_ARG(sv);
3151
5b9c0671 3152 PL_hints |= HINT_LOCALIZE_HH;
c28fe1ec
NC
3153 PL_compiling.cop_hints_hash
3154 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
ad64d0ec 3155 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
b3ca2e83
NC
3156 return 0;
3157}
3158
3159/*
66610fdd
RGS
3160 * Local variables:
3161 * c-indentation-style: bsd
3162 * c-basic-offset: 4
3163 * indent-tabs-mode: t
3164 * End:
3165 *
37442d52
RGS
3166 * ex: set ts=8 sts=4 sw=4 noet:
3167 */