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