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