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