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