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