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