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