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