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
updateAUTHORS.pl - split into module Porting/updateAUTHORS.pm
[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 18/*
51b56f5c 19=head1 Magic
166f8a29
DM		 20"Magic" is special data attached to SV structures in order to give them
21"magical" properties. When any Perl code tries to read from, or assign to,
22an SV marked as magical, it calls the 'get' or 'set' function associated
154e47c8 23with that SV's magic. A get is called prior to reading an SV, in order to
ddfa107c 24give it a chance to update its internal value (get on $. writes the line
b53c43bf 25number of the last read filehandle into the SV's IV slot), while
166f8a29 26set is called after an SV has been written to, in order to allow it to make
ddfa107c 27use of its changed value (set on $/ copies the SV's new value to the
166f8a29
DM		 28PL_rs global variable).
29
30Magic is implemented as a linked list of MAGIC structures attached to the
154e47c8 31SV. Each MAGIC struct holds the type of the magic, a pointer to an array
166f8a29 32of functions that implement the get(), set(), length() etc functions,
154e47c8 33plus space for some flags and pointers. For example, a tied variable has
166f8a29
DM		 34a MAGIC structure that contains a pointer to the object associated with the
35tie.
36
19851e27
KW		 37=for apidoc Ayh||MAGIC
38
7fefc6c1
KW		 39=cut
40
ccfc67b7
JH		 41*/
42
79072805 43#include "EXTERN.h"
864dbfa3 44#define PERL_IN_MG_C
79072805 45#include "perl.h"
b34c1a7e 46#include "feature.h"
79072805 47
5cd24f17 48#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
b7953727
JH		 49# ifdef I_GRP
50# include <grp.h>
51# endif
188ea221
CS		 52#endif
53
757f63d8
SP		 54#if defined(HAS_SETGROUPS)
55# ifndef NGROUPS
56# define NGROUPS 32
57# endif
58#endif
59
17aa7f3d
JH		 60#ifdef __hpux
61# include <sys/pstat.h>
62#endif
63
7636ea95
AB		 64#ifdef HAS_PRCTL_SET_NAME
65# include <sys/prctl.h>
66#endif
67
9cffb111
OS		 68#ifdef __Lynx__
69/* Missing protos on LynxOS */
70void setruid(uid_t id);
71void seteuid(uid_t id);
72void setrgid(uid_t id);
73void setegid(uid_t id);
74#endif
75
c07a80fd 76/*
4bac9ae4 77 * Pre-magic setup and post-magic takedown.
c07a80fd 78 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
79 */
80
81struct magic_state {
82 SV* mgs_sv;
455ece5e 83 I32 mgs_ss_ix;
a623f893 84 U32 mgs_flags;
150b625d 85 bool mgs_bumped;
c07a80fd 86};
455ece5e 87/* MGS is typedef'ed to struct magic_state in perl.h */
76e3520e
GS		 88
89STATIC void
ff44333e 90S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
c07a80fd 91{
455ece5e 92 MGS* mgs;
150b625d 93 bool bumped = FALSE;
7918f24d 94
ff44333e 95 PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
7918f24d 96
4bac9ae4
CS		 97 assert(SvMAGICAL(sv));
98
150b625d
DM		 99 /* we shouldn't really be called here with RC==0, but it can sometimes
100 * happen via mg_clear() (which also shouldn't be called when RC==0,
101 * but it can happen). Handle this case gracefully(ish) by not RC++
102 * and thus avoiding the resultant double free */
103 if (SvREFCNT(sv) > 0) {
104 /* guard against sv getting freed midway through the mg clearing,
105 * by holding a private reference for the duration. */
1604cfb0
MS		 106 SvREFCNT_inc_simple_void_NN(sv);
107 bumped = TRUE;
150b625d 108 }
8985fe98 109
8772537c 110 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
455ece5e
AD		 111
112 mgs = SSPTR(mgs_ix, MGS*);
c07a80fd 113 mgs->mgs_sv = sv;
a623f893 114 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
455ece5e 115 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
150b625d 116 mgs->mgs_bumped = bumped;
c07a80fd 117
ff44333e 118 SvFLAGS(sv) &= ~flags;
3805b5fb 119 SvREADONLY_off(sv);
c07a80fd 120}
121
ff44333e
FC		 122#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
123
954c1994
GS		 124/*
125=for apidoc mg_magical
126
fbe13c60 127Turns on the magical status of an SV. See C<L</sv_magic>>.
954c1994
GS		 128
129=cut
130*/
131
8990e307 132void
ddeaf645 133Perl_mg_magical(SV *sv)
8990e307 134{
e1ec3a88 135 const MAGIC* mg;
7918f24d 136 PERL_ARGS_ASSERT_MG_MAGICAL;
f9c6fee5
CS		 137
138 SvMAGICAL_off(sv);
218787bd 139 if ((mg = SvMAGIC(sv))) {
1604cfb0
MS		 140 do {
141 const MGVTBL* const vtbl = mg->mg_virtual;
142 if (vtbl) {
143 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
144 SvGMAGICAL_on(sv);
145 if (vtbl->svt_set)
146 SvSMAGICAL_on(sv);
147 if (vtbl->svt_clear)
148 SvRMAGICAL_on(sv);
149 }
150 } while ((mg = mg->mg_moremagic));
151 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
152 SvRMAGICAL_on(sv);
8990e307
LW		 153 }
154}
155
954c1994
GS		 156/*
157=for apidoc mg_get
158
4b1e7f06 159Do magic before a value is retrieved from the SV. The type of SV must
796b6530 160be >= C<SVt_PVMG>. See C<L</sv_magic>>.
954c1994
GS		 161
162=cut
163*/
164
79072805 165int
864dbfa3 166Perl_mg_get(pTHX_ SV *sv)
79072805 167{
35a4481c 168 const I32 mgs_ix = SSNEW(sizeof(MGS));
a9844598 169 bool saved = FALSE;
f9c6fee5 170 bool have_new = 0;
b949b68f 171 bool taint_only = TRUE; /* the only get method seen is taint */
ff76feab 172 MAGIC *newmg, *head, *cur, *mg;
6683b158 173
7918f24d
NC		 174 PERL_ARGS_ASSERT_MG_GET;
175
407287f9
FC		 176 if (PL_localizing == 1 && sv == DEFSV) return 0;
177
ff76feab
AMS		 178 /* We must call svt_get(sv, mg) for each valid entry in the linked
179 list of magic. svt_get() may delete the current entry, add new
180 magic to the head of the list, or upgrade the SV. AMS 20010810 */
181
182 newmg = cur = head = mg = SvMAGIC(sv);
183 while (mg) {
1604cfb0
MS		 184 const MGVTBL * const vtbl = mg->mg_virtual;
185 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
ff76feab 186
1604cfb0 187 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
a9844598 188
1604cfb0
MS		 189 /* taint's mg get is so dumb it doesn't need flag saving */
190 if (mg->mg_type != PERL_MAGIC_taint) {
b949b68f
DM		 191 taint_only = FALSE;
192 if (!saved) {
193 save_magic(mgs_ix, sv);
194 saved = TRUE;
195 }
196 }
a9844598 197
1604cfb0
MS		 198 vtbl->svt_get(aTHX_ sv, mg);
199
200 /* guard against magic having been deleted - eg FETCH calling
201 * untie */
202 if (!SvMAGIC(sv)) {
203 /* recalculate flags */
204 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
205 break;
206 }
207
208 /* recalculate flags if this entry was deleted. */
209 if (mg->mg_flags & MGf_GSKIP)
210 (SSPTR(mgs_ix, MGS *))->mgs_flags &=
211 ~(SVs_GMG|SVs_SMG|SVs_RMG);
212 }
213 else if (vtbl == &PL_vtbl_utf8) {
214 /* get-magic can reallocate the PV, unless there's only taint
b949b68f
DM		 215 * magic */
216 if (taint_only) {
217 MAGIC *mg2;
218 for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
219 if ( mg2->mg_type != PERL_MAGIC_taint
220 && !(mg2->mg_flags & MGf_GSKIP)
221 && mg2->mg_virtual
222 && mg2->mg_virtual->svt_get
223 ) {
224 taint_only = FALSE;
225 break;
226 }
227 }
228 }
229 if (!taint_only)
230 magic_setutf8(sv, mg);
1604cfb0
MS		 231 }
232
233 mg = nextmg;
234
235 if (have_new) {
236 /* Have we finished with the new entries we saw? Start again
237 where we left off (unless there are more new entries). */
238 if (mg == head) {
239 have_new = 0;
240 mg = cur;
241 head = newmg;
242 }
243 }
244
245 /* Were any new entries added? */
246 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
247 have_new = 1;
248 cur = mg;
249 mg = newmg;
250 /* recalculate flags */
251 (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
252 }
79072805 253 }
463ee0b2 254
a9844598 255 if (saved)
1604cfb0 256 restore_magic(INT2PTR(void *, (IV)mgs_ix));
a9844598 257
79072805
LW		 258 return 0;
259}
260
954c1994
GS		 261/*
262=for apidoc mg_set
263
fbe13c60 264Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
954c1994
GS		 265
266=cut
267*/
268
79072805 269int
864dbfa3 270Perl_mg_set(pTHX_ SV *sv)
79072805 271{
35a4481c 272 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 273 MAGIC* mg;
463ee0b2
LW		 274 MAGIC* nextmg;
275
7918f24d
NC		 276 PERL_ARGS_ASSERT_MG_SET;
277
b5ed8c44
FC		 278 if (PL_localizing == 2 && sv == DEFSV) return 0;
279
ff44333e 280 save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
463ee0b2
LW		 281
282 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
e1ec3a88 283 const MGVTBL* vtbl = mg->mg_virtual;
1604cfb0
MS		 284 nextmg = mg->mg_moremagic; /* it may delete itself */
285 if (mg->mg_flags & MGf_GSKIP) {
286 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
287 (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
288 }
289 if (PL_localizing == 2
290 && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
291 continue;
292 if (vtbl && vtbl->svt_set)
293 vtbl->svt_set(aTHX_ sv, mg);
79072805 294 }
463ee0b2 295
8772537c 296 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW		 297 return 0;
298}
299
8fb26106 300I32
864dbfa3 301Perl_mg_size(pTHX_ SV *sv)
93965878
NIS		 302{
303 MAGIC* mg;
ac27b0f5 304
7918f24d
NC		 305 PERL_ARGS_ASSERT_MG_SIZE;
306
93965878 307 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 308 const MGVTBL* const vtbl = mg->mg_virtual;
1604cfb0 309 if (vtbl && vtbl->svt_len) {
35a4481c
AL		 310 const I32 mgs_ix = SSNEW(sizeof(MGS));
311 I32 len;
1604cfb0
MS		 312 save_magic(mgs_ix, sv);
313 /* omit MGf_GSKIP -- not changed here */
314 len = vtbl->svt_len(aTHX_ sv, mg);
315 restore_magic(INT2PTR(void*, (IV)mgs_ix));
316 return len;
317 }
93965878
NIS		 318 }
319
320 switch(SvTYPE(sv)) {
1604cfb0
MS		 321 case SVt_PVAV:
322 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
323 case SVt_PVHV:
324 /* FIXME */
325 default:
326 Perl_croak(aTHX_ "Size magic not implemented");
81d52ecd 327
93965878 328 }
a25b5927 329 NOT_REACHED; /* NOTREACHED */
93965878
NIS		 330}
331
954c1994
GS		 332/*
333=for apidoc mg_clear
334
fbe13c60 335Clear something magical that the SV represents. See C<L</sv_magic>>.
954c1994
GS		 336
337=cut
338*/
339
79072805 340int
864dbfa3 341Perl_mg_clear(pTHX_ SV *sv)
79072805 342{
35a4481c 343 const I32 mgs_ix = SSNEW(sizeof(MGS));
79072805 344 MAGIC* mg;
8ac77ac9 345 MAGIC *nextmg;
463ee0b2 346
7918f24d
NC		 347 PERL_ARGS_ASSERT_MG_CLEAR;
348
455ece5e 349 save_magic(mgs_ix, sv);
463ee0b2 350
8ac77ac9 351 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
35a4481c 352 const MGVTBL* const vtbl = mg->mg_virtual;
1604cfb0 353 /* omit GSKIP -- never set here */
727405f8 354
1604cfb0 355 nextmg = mg->mg_moremagic; /* it may delete itself */
8ac77ac9 356
1604cfb0
MS		 357 if (vtbl && vtbl->svt_clear)
358 vtbl->svt_clear(aTHX_ sv, mg);
79072805 359 }
463ee0b2 360
8772537c 361 restore_magic(INT2PTR(void*, (IV)mgs_ix));
79072805
LW		 362 return 0;
363}
364
ed624ca8 365static MAGIC*
ddeaf645 366S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
39de7f53 367{
39de7f53
FR		 368 assert(flags <= 1);
369
370 if (sv) {
1604cfb0 371 MAGIC *mg;
39de7f53 372
1604cfb0
MS		 373 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
374 if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
375 return mg;
376 }
377 }
39de7f53
FR		 378 }
379
380 return NULL;
381}
382
954c1994
GS		 383/*
384=for apidoc mg_find
385
796b6530 386Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
954c1994
GS		 387
388=cut
389*/
390
93a17b20 391MAGIC*
ddeaf645 392Perl_mg_find(const SV *sv, int type)
93a17b20 393{
ddeaf645 394 return S_mg_findext_flags(sv, type, NULL, 0);
39de7f53
FR		 395}
396
397/*
398=for apidoc mg_findext
399
400Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
fbe13c60 401C<L</sv_magicext>>.
39de7f53
FR		 402
403=cut
404*/
405
406MAGIC*
ddeaf645 407Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
39de7f53 408{
ddeaf645 409 return S_mg_findext_flags(sv, type, vtbl, 1);
93a17b20
LW		 410}
411
96c2a8ff
FC		 412MAGIC *
413Perl_mg_find_mglob(pTHX_ SV *sv)
414{
415 PERL_ARGS_ASSERT_MG_FIND_MGLOB;
416 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
417 /* This sv is only a delegate. //g magic must be attached to
418 its target. */
419 vivify_defelem(sv);
420 sv = LvTARG(sv);
421 }
422 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
ddeaf645 423 return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
96c2a8ff
FC		 424 return NULL;
425}
426
954c1994
GS		 427/*
428=for apidoc mg_copy
429
fbe13c60 430Copies the magic from one SV to another. See C<L</sv_magic>>.
954c1994
GS		 431
432=cut
433*/
434
79072805 435int
864dbfa3 436Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
79072805 437{
463ee0b2 438 int count = 0;
79072805 439 MAGIC* mg;
7918f24d
NC		 440
441 PERL_ARGS_ASSERT_MG_COPY;
442
463ee0b2 443 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
35a4481c 444 const MGVTBL* const vtbl = mg->mg_virtual;
1604cfb0
MS		 445 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
446 count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen);
447 }
448 else {
449 const char type = mg->mg_type;
450 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
451 sv_magic(nsv,
452 (type == PERL_MAGIC_tied)
453 ? SvTIED_obj(sv, mg)
27deb0cf 454 : mg->mg_obj,
1604cfb0
MS		 455 toLOWER(type), key, klen);
456 count++;
457 }
458 }
79072805 459 }
463ee0b2 460 return count;
79072805
LW		 461}
462
954c1994 463/*
0cbee0a4
DM		 464=for apidoc mg_localize
465
9711599e 466Copy some of the magic from an existing SV to new localized version of that
dfcfced8
KW		 467SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
468gets copied, value magic doesn't (I<e.g.>,
796b6530 469C<taint>, C<pos>).
9711599e 470
796b6530 471If C<setmagic> is false then no set magic will be called on the new (empty) SV.
61b16eb9 472This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
9711599e 473and that will handle the magic.
0cbee0a4
DM		 474
475=cut
476*/
477
478void
af7df257 479Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
0cbee0a4
DM		 480{
481 MAGIC *mg;
7918f24d
NC		 482
483 PERL_ARGS_ASSERT_MG_LOCALIZE;
484
658a9f31 485 if (nsv == DEFSV)
1604cfb0 486 return;
658a9f31 487
0cbee0a4 488 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
1604cfb0
MS		 489 const MGVTBL* const vtbl = mg->mg_virtual;
490 if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
491 continue;
492
493 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
494 (void)vtbl->svt_local(aTHX_ nsv, mg);
495 else
496 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
497 mg->mg_ptr, mg->mg_len);
a5063e7c 498
1604cfb0
MS		 499 /* container types should remain read-only across localization */
500 SvFLAGS(nsv) |= SvREADONLY(sv);
0cbee0a4
DM		 501 }
502
503 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
1604cfb0
MS		 504 SvFLAGS(nsv) |= SvMAGICAL(sv);
505 if (setmagic) {
506 PL_localizing = 1;
507 SvSETMAGIC(nsv);
508 PL_localizing = 0;
509 }
0cbee0a4
DM		 510 }
511}
512
d9088386
Z		 513#define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg)
514static void
515S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
516{
517 const MGVTBL* const vtbl = mg->mg_virtual;
518 if (vtbl && vtbl->svt_free)
1604cfb0 519 vtbl->svt_free(aTHX_ sv, mg);
44955e7d 520
02a48966
DM		 521 if (mg->mg_len > 0)
522 Safefree(mg->mg_ptr);
523 else if (mg->mg_len == HEf_SVKEY)
524 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
44955e7d 525
d9088386 526 if (mg->mg_flags & MGf_REFCOUNTED)
1604cfb0 527 SvREFCNT_dec(mg->mg_obj);
d9088386
Z		 528 Safefree(mg);
529}
530
0cbee0a4 531/*
954c1994
GS		 532=for apidoc mg_free
533
fbe13c60 534Free any magic storage used by the SV. See C<L</sv_magic>>.
954c1994
GS		 535
536=cut
537*/
538
79072805 539int
864dbfa3 540Perl_mg_free(pTHX_ SV *sv)
79072805
LW		 541{
542 MAGIC* mg;
543 MAGIC* moremagic;
7918f24d
NC		 544
545 PERL_ARGS_ASSERT_MG_FREE;
546
79072805 547 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
1604cfb0
MS		 548 moremagic = mg->mg_moremagic;
549 mg_free_struct(sv, mg);
550 SvMAGIC_set(sv, moremagic);
79072805 551 }
b162af07 552 SvMAGIC_set(sv, NULL);
68f8932e 553 SvMAGICAL_off(sv);
79072805
LW		 554 return 0;
555}
556
d9088386 557/*
44170c9a 558=for apidoc mg_free_type
d9088386 559
2d7f6611 560Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
d9088386
Z		 561
562=cut
563*/
564
565void
566Perl_mg_free_type(pTHX_ SV *sv, int how)
567{
568 MAGIC *mg, *prevmg, *moremg;
569 PERL_ARGS_ASSERT_MG_FREE_TYPE;
570 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
1604cfb0
MS		 571 moremg = mg->mg_moremagic;
572 if (mg->mg_type == how) {
19742f39 573 MAGIC *newhead;
1604cfb0
MS		 574 /* temporarily move to the head of the magic chain, in case
575 custom free code relies on this historical aspect of mg_free */
576 if (prevmg) {
577 prevmg->mg_moremagic = moremg;
578 mg->mg_moremagic = SvMAGIC(sv);
579 SvMAGIC_set(sv, mg);
580 }
581 newhead = mg->mg_moremagic;
582 mg_free_struct(sv, mg);
583 SvMAGIC_set(sv, newhead);
584 mg = prevmg;
585 }
d9088386
Z		 586 }
587 mg_magical(sv);
588}
589
e0d4aead
TC		 590/*
591=for apidoc mg_freeext
592
593Remove any magic of type C<how> using virtual table C<vtbl> from the
594SV C<sv>. See L</sv_magic>.
595
596C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
597
598=cut
599*/
600
601void
602Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
603{
604 MAGIC *mg, *prevmg, *moremg;
605 PERL_ARGS_ASSERT_MG_FREEEXT;
606 for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
1604cfb0
MS		 607 MAGIC *newhead;
608 moremg = mg->mg_moremagic;
609 if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
610 /* temporarily move to the head of the magic chain, in case
611 custom free code relies on this historical aspect of mg_free */
612 if (prevmg) {
613 prevmg->mg_moremagic = moremg;
614 mg->mg_moremagic = SvMAGIC(sv);
615 SvMAGIC_set(sv, mg);
616 }
617 newhead = mg->mg_moremagic;
618 mg_free_struct(sv, mg);
619 SvMAGIC_set(sv, newhead);
620 mg = prevmg;
621 }
e0d4aead
TC		 622 }
623 mg_magical(sv);
624}
625
79072805 626#include <signal.h>
79072805 627
942e002e 628U32
864dbfa3 629Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 630{
8772537c 631 PERL_UNUSED_ARG(sv);
6cef1e77 632
7918f24d
NC		 633 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
634
0bd48802 635 if (PL_curpm) {
27deb0cf 636 REGEXP * const rx = PM_GETRE(PL_curpm);
1604cfb0 637 if (rx) {
fa531f32
DM		 638 const SSize_t n = (SSize_t)mg->mg_obj;
639 if (n == '+') { /* @+ */
1604cfb0
MS		 640 /* return the number possible */
641 return RX_NPARENS(rx);
27deb0cf 642 } else { /* @- @^CAPTURE @{^CAPTURE} */
1604cfb0 643 I32 paren = RX_LASTPAREN(rx);
a678b0e4 644
1604cfb0
MS		 645 /* return the last filled */
646 while ( paren >= 0
647 && (RX_OFFS(rx)[paren].start == -1
648 || RX_OFFS(rx)[paren].end == -1) )
649 paren--;
fa531f32 650 if (n == '-') {
27deb0cf
YO		 651 /* @- */
652 return (U32)paren;
653 } else {
654 /* @^CAPTURE @{^CAPTURE} */
655 return paren >= 0 ? (U32)(paren-1) : (U32)-1;
656 }
657 }
1604cfb0 658 }
8f580fb8 659 }
ac27b0f5 660
942e002e 661 return (U32)-1;
6cef1e77
IZ		 662}
663
6502e081
DM		 664/* @-, @+ */
665
6cef1e77 666int
864dbfa3 667Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
6cef1e77 668{
7918f24d
NC		 669 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
670
0bd48802 671 if (PL_curpm) {
27deb0cf 672 REGEXP * const rx = PM_GETRE(PL_curpm);
1604cfb0 673 if (rx) {
fa531f32 674 const SSize_t n = (SSize_t)mg->mg_obj;
27deb0cf
YO		 675 /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
676 const I32 paren = mg->mg_len
fa531f32 677 + (n == '\003' ? 1 : 0);
1604cfb0
MS		 678 SSize_t s;
679 SSize_t t;
680 if (paren < 0)
681 return 0;
682 if (paren <= (I32)RX_NPARENS(rx) &&
683 (s = RX_OFFS(rx)[paren].start) != -1 &&
684 (t = RX_OFFS(rx)[paren].end) != -1)
685 {
686 SSize_t i;
27deb0cf 687
fa531f32 688 if (n == '+') /* @+ */
1604cfb0 689 i = t;
fa531f32 690 else if (n == '-') /* @- */
1604cfb0 691 i = s;
27deb0cf
YO		 692 else { /* @^CAPTURE @{^CAPTURE} */
693 CALLREG_NUMBUF_FETCH(rx,paren,sv);
694 return 0;
695 }
0bd48802 696
1604cfb0
MS		 697 if (RX_MATCH_UTF8(rx)) {
698 const char * const b = RX_SUBBEG(rx);
699 if (b)
700 i = RX_SUBCOFFSET(rx) +
6502e081
DM		 701 utf8_length((U8*)b,
702 (U8*)(b-RX_SUBOFFSET(rx)+i));
1604cfb0 703 }
727405f8 704
1604cfb0
MS		 705 sv_setuv(sv, i);
706 return 0;
707 }
708 }
6cef1e77 709 }
3773545d 710 sv_set_undef(sv);
6cef1e77
IZ		 711 return 0;
712}
713
6502e081
DM		 714/* @-, @+ */
715
e4b89193 716int
a29d06ed
MG		 717Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
718{
7918f24d 719 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
dc3bf405 720 PERL_UNUSED_CONTEXT;
d4c19fe8
AL		 721 PERL_UNUSED_ARG(sv);
722 PERL_UNUSED_ARG(mg);
cb077ed2 723 Perl_croak_no_modify();
0dbb1585 724 NORETURN_FUNCTION_END;
a29d06ed
MG		 725}
726
34e6ab8f
KW		 727#define SvRTRIM(sv) STMT_START { \
728 SV * sv_ = sv; \
729 if (SvPOK(sv_)) { \
730 STRLEN len = SvCUR(sv_); \
731 char * const p = SvPVX(sv_); \
732 while (len > 0 && isSPACE(p[len-1])) \
733 --len; \
734 SvCUR_set(sv_, len); \
735 p[len] = '\0'; \
736 } \
ad3296c6
SH		 737} STMT_END
738
8b850bd5
NC		 739void
740Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
741{
7918f24d
NC		 742 PERL_ARGS_ASSERT_EMULATE_COP_IO;
743
8b850bd5 744 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
1604cfb0 745 sv_set_undef(sv);
8b850bd5 746 else {
b2aed775 747 SvPVCLEAR(sv);
1604cfb0
MS		 748 SvUTF8_off(sv);
749 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
750 SV *const value = cop_hints_fetch_pvs(c, "open<", 0);
751 assert(value);
752 sv_catsv(sv, value);
753 }
754 sv_catpvs(sv, "\0");
755 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
756 SV *const value = cop_hints_fetch_pvs(c, "open>", 0);
757 assert(value);
758 sv_catsv(sv, value);
759 }
8b850bd5
NC		 760 }
761}
762
d9fe7d23
KW		 763STATIC void
764S_fixup_errno_string(pTHX_ SV* sv)
765{
766 /* Do what is necessary to fixup the non-empty string in 'sv' for return to
767 * Perl space. */
768
769 PERL_ARGS_ASSERT_FIXUP_ERRNO_STRING;
770
771 assert(SvOK(sv));
b35e4f8b
KW		 772
773 if(strEQ(SvPVX(sv), "")) {
1604cfb0 774 sv_catpv(sv, UNKNOWN_ERRNO_MSG);
b35e4f8b
KW		 775 }
776 else {
d9fe7d23 777
d3c0b317
KW		 778 /* In some locales the error string may come back as UTF-8, in which
779 * case we should turn on that flag. This didn't use to happen, and to
5320b60d
KW		 780 * avoid as many possible backward compatibility issues as possible, we
781 * don't turn on the flag unless we have to. So the flag stays off for
9f10db87 782 * an entirely invariant string. We assume that if the string looks
fab19207
KW		 783 * like UTF-8 in a single script, it really is UTF-8: "text in any
784 * other encoding that uses bytes with the high bit set is extremely
785 * unlikely to pass a UTF-8 validity test"
9f10db87
KW		 786 * (http://en.wikipedia.org/wiki/Charset_detection). There is a
787 * potential that we will get it wrong however, especially on short
a8f4b0c6 788 * error message text, so do an additional check. */
027a0d26
KW		 789 if ( ! IN_BYTES /* respect 'use bytes' */
790 && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
a8f4b0c6
KW		 791
792#ifdef USE_LOCALE_MESSAGES
793
61520eee 794 && _is_cur_LC_category_utf8(LC_MESSAGES)
a8f4b0c6 795
fab19207
KW		 796#else /* If can't check directly, at least can see if script is consistent,
797 under UTF-8, which gives us an extra measure of confidence. */
798
799 && isSCRIPT_RUN((const U8 *) SvPVX_const(sv), (U8 *) SvEND(sv),
8c53dada 800 TRUE) /* Means assume UTF-8 */
a8f4b0c6
KW		 801#endif
802
803 ) {
d3c0b317
KW		 804 SvUTF8_on(sv);
805 }
b35e4f8b 806 }
d9fe7d23
KW		 807}
808
658db622 809/*
3f620621 810=for apidoc_section $errno
44170c9a 811=for apidoc sv_string_from_errnum
658db622
Z		 812
813Generates the message string describing an OS error and returns it as
814an SV. C<errnum> must be a value that C<errno> could take, identifying
815the type of error.
816
817If C<tgtsv> is non-null then the string will be written into that SV
818(overwriting existing content) and it will be returned. If C<tgtsv>
819is a null pointer then the string will be written into a new mortal SV
820which will be returned.
821
822The message will be taken from whatever locale would be used by C<$!>,
823and will be encoded in the SV in whatever manner would be used by C<$!>.
824The details of this process are subject to future change. Currently,
825the message is taken from the C locale by default (usually producing an
826English message), and from the currently selected locale when in the scope
827of the C<use locale> pragma. A heuristic attempt is made to decode the
828message from the locale's character encoding, but it will only be decoded
829as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
830locale, usually in an ISO-8859-1 locale, and never in any other locale.
831
832The SV is always returned containing an actual string, and with no other
833OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
834(meaning success), and if no useful message is available then a useless
835string (currently empty) is returned.
836
837=cut
838*/
839
840SV *
841Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
842{
843 char const *errstr;
844 if(!tgtsv)
7ea8b04b 845 tgtsv = newSV_type_mortal(SVt_PV);
658db622
Z		 846 errstr = my_strerror(errnum);
847 if(errstr) {
1604cfb0
MS		 848 sv_setpv(tgtsv, errstr);
849 fixup_errno_string(tgtsv);
658db622 850 } else {
1604cfb0 851 SvPVCLEAR(tgtsv);
658db622
Z		 852 }
853 return tgtsv;
854}
855
25bbd826
CB		 856#ifdef VMS
857#include <descrip.h>
858#include <starlet.h>
859#endif
860
79072805 861int
864dbfa3 862Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
79072805 863{
eb578fdb
KW		 864 I32 paren;
865 const char *s = NULL;
866 REGEXP *rx;
e91d8259 867 char nextchar;
79072805 868
7918f24d
NC		 869 PERL_ARGS_ASSERT_MAGIC_GET;
870
12865d70
KW		 871 const char * const remaining = (mg->mg_ptr)
872 ? mg->mg_ptr + 1
873 : NULL;
874
e91d8259 875 if (!mg->mg_ptr) {
e91d8259 876 paren = mg->mg_len;
e91d8259 877 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
a6d0b1b5 878 do_numbuf_fetch:
e91d8259 879 CALLREG_NUMBUF_FETCH(rx,paren,sv);
e91d8259 880 }
e03e82a0
DM		 881 else
882 goto set_undef;
e91d8259
NC		 883 return 0;
884 }
885
886 nextchar = *remaining;
79072805 887 switch (*mg->mg_ptr) {
748a9306 888 case '\001': /* ^A */
1604cfb0
MS		 889 if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget);
890 else
e03e82a0 891 sv_set_undef(sv);
1604cfb0
MS		 892 if (SvTAINTED(PL_bodytarget))
893 SvTAINTED_on(sv);
894 break;
e5218da5 895 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
1604cfb0
MS		 896 if (nextchar == '\0') {
897 sv_setiv(sv, (IV)PL_minus_c);
898 }
899 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
900 sv_setiv(sv, (IV)STATUS_NATIVE);
e5218da5 901 }
1604cfb0 902 break;
49460fe6 903
79072805 904 case '\004': /* ^D */
1604cfb0
MS		 905 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
906 break;
28f23441 907 case '\005': /* ^E */
1604cfb0 908 if (nextchar != '\0') {
6c6eab55 909 if (strEQ(remaining, "NCODING"))
3773545d 910 sv_set_undef(sv);
4f4ff3a7 911 break;
6c6eab55 912 }
4f4ff3a7
KW		 913
914#if defined(VMS) || defined(OS2) || defined(WIN32)
915# if defined(VMS)
2a99ff86
KW		 916 {
917 char msg[255];
918 $DESCRIPTOR(msgdsc,msg);
919 sv_setnv(sv,(NV) vaxc$errno);
920 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
921 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
922 else
b2aed775 923 SvPVCLEAR(sv);
2a99ff86 924 }
4b645107 925#elif defined(OS2)
2a99ff86
KW		 926 if (!(_emx_env & 0x200)) { /* Under DOS */
927 sv_setnv(sv, (NV)errno);
2c6ee1a7 928 sv_setpv(sv, errno ? my_strerror(errno) : "");
2a99ff86
KW		 929 } else {
930 if (errno != errno_isOS2) {
931 const int tmp = _syserrno();
932 if (tmp) /* 2nd call to _syserrno() makes it 0 */
933 Perl_rc = tmp;
934 }
935 sv_setnv(sv, (NV)Perl_rc);
936 sv_setpv(sv, os2error(Perl_rc));
937 }
1534c6f5 938 if (SvOK(sv) && strNE(SvPVX(sv), "")) {
99461a73
KW		 939 fixup_errno_string(sv);
940 }
4f4ff3a7 941# elif defined(WIN32)
2a99ff86
KW		 942 {
943 const DWORD dwErr = GetLastError();
944 sv_setnv(sv, (NV)dwErr);
945 if (dwErr) {
946 PerlProc_GetOSError(sv, dwErr);
2efab60d 947 fixup_errno_string(sv);
2a99ff86
KW		 948 }
949 else
b2aed775 950 SvPVCLEAR(sv);
2a99ff86
KW		 951 SetLastError(dwErr);
952 }
4f4ff3a7
KW		 953# else
954# error Missing code for platform
955# endif
2a99ff86
KW		 956 SvRTRIM(sv);
957 SvNOK_on(sv); /* what a wonderful hack! */
1604cfb0 958 break;
4f4ff3a7
KW		 959#endif /* End of platforms with special handling for $^E; others just fall
960 through to $! */
2165bd23 961 /* FALLTHROUGH */
46f3e16c
KW		 962
963 case '!':
1604cfb0 964 {
5f1b979d 965 dSAVE_ERRNO;
46f3e16c 966#ifdef VMS
5f1b979d 967 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
46f3e16c 968#else
5f1b979d 969 sv_setnv(sv, (NV)errno);
46f3e16c
KW		 970#endif
971#ifdef OS2
5f1b979d
KW		 972 if (errno == errno_isOS2 || errno == errno_isOS2_set)
973 sv_setpv(sv, os2error(Perl_rc));
974 else
46f3e16c 975#endif
5f1b979d 976 if (! errno) {
b2aed775 977 SvPVCLEAR(sv);
46f3e16c 978 }
5f1b979d 979 else {
658db622
Z		 980 sv_string_from_errnum(errno, sv);
981 /* If no useful string is available, don't
982 * claim to have a string part. The SvNOK_on()
5f1b979d 983 * below will cause just the number part to be valid */
658db622
Z		 984 if (!SvCUR(sv))
985 SvPOK_off(sv);
5f1b979d
KW		 986 }
987 RESTORE_ERRNO;
1604cfb0 988 }
46f3e16c 989
1604cfb0
MS		 990 SvRTRIM(sv);
991 SvNOK_on(sv); /* what a wonderful hack! */
992 break;
46f3e16c 993
79072805 994 case '\006': /* ^F */
9f601cf3
TC		 995 if (nextchar == '\0') {
996 sv_setiv(sv, (IV)PL_maxsysfd);
997 }
1604cfb0 998 break;
9ebf26ad 999 case '\007': /* ^GLOBAL_PHASE */
1604cfb0
MS		 1000 if (strEQ(remaining, "LOBAL_PHASE")) {
1001 sv_setpvn(sv, PL_phase_names[PL_phase],
1002 strlen(PL_phase_names[PL_phase]));
1003 }
1004 break;
a0d0e21e 1005 case '\010': /* ^H */
1604cfb0
MS		 1006 sv_setuv(sv, PL_hints);
1007 break;
9d116dd7 1008 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1604cfb0
MS		 1009 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
1010 break;
8561ea1d 1011 case '\014': /* ^LAST_FH */
1604cfb0
MS		 1012 if (strEQ(remaining, "AST_FH")) {
1013 if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
1014 assert(isGV_with_GP(PL_last_in_gv));
972c8f20 1015 sv_setrv_inc(sv, MUTABLE_SV(PL_last_in_gv));
1604cfb0
MS		 1016 sv_rvweaken(sv);
1017 }
1018 else
3773545d 1019 sv_set_undef(sv);
1604cfb0
MS		 1020 }
1021 break;
ac27b0f5 1022 case '\017': /* ^O & ^OPEN */
1604cfb0
MS		 1023 if (nextchar == '\0') {
1024 sv_setpv(sv, PL_osname);
1025 SvTAINTED_off(sv);
1026 }
1027 else if (strEQ(remaining, "PEN")) {
1028 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
1029 }
1030 break;
9ebf26ad 1031 case '\020':
a6d0b1b5 1032 sv_setiv(sv, (IV)PL_perldb);
1604cfb0 1033 break;
fb73857a 1034 case '\023': /* ^S */
1604cfb0
MS		 1035 if (nextchar == '\0') {
1036 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
1037 SvOK_off(sv);
1038 else if (PL_in_eval)
1039 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
1040 else
1041 sv_setiv(sv, 0);
1042 }
1043 else if (strEQ(remaining, "AFE_LOCALES")) {
f512d242
KW		 1044
1045#if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE)
1046
1604cfb0 1047 sv_setuv(sv, (UV) 1);
f512d242
KW		 1048
1049#else
1604cfb0 1050 sv_setuv(sv, (UV) 0);
f512d242
KW		 1051
1052#endif
1053
1054 }
1604cfb0 1055 break;
79072805 1056 case '\024': /* ^T */
1604cfb0 1057 if (nextchar == '\0') {
88e89b8a 1058#ifdef BIG_TIME
7c36658b 1059 sv_setnv(sv, PL_basetime);
88e89b8a 1060#else
7c36658b 1061 sv_setiv(sv, (IV)PL_basetime);
88e89b8a 1062#endif
7c36658b 1063 }
1604cfb0 1064 else if (strEQ(remaining, "AINT"))
284167a5 1065 sv_setiv(sv, TAINTING_get
1604cfb0
MS		 1066 ? (TAINT_WARN_get || PL_unsafe ? -1 : 1)
1067 : 0);
7c36658b 1068 break;
e07ea26a 1069 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
1604cfb0
MS		 1070 if (strEQ(remaining, "NICODE"))
1071 sv_setuv(sv, (UV) PL_unicode);
1072 else if (strEQ(remaining, "TF8LOCALE"))
1073 sv_setuv(sv, (UV) PL_utf8locale);
1074 else if (strEQ(remaining, "TF8CACHE"))
1075 sv_setiv(sv, (IV) PL_utf8cache);
fde18df1
JH		 1076 break;
1077 case '\027': /* ^W & $^WARNING_BITS */
1604cfb0
MS		 1078 if (nextchar == '\0')
1079 sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
1080 else if (strEQ(remaining, "ARNING_BITS")) {
1081 if (PL_compiling.cop_warnings == pWARN_NONE) {
1082 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
1083 }
1084 else if (PL_compiling.cop_warnings == pWARN_STD) {
e03e82a0 1085 goto set_undef;
1604cfb0 1086 }
d3a7d8c7 1087 else if (PL_compiling.cop_warnings == pWARN_ALL) {
1604cfb0
MS		 1088 sv_setpvn(sv, WARN_ALLstring, WARNsize);
1089 }
4438c4b7 1090 else {
1604cfb0
MS		 1091 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
1092 *PL_compiling.cop_warnings);
1093 }
1094 }
1095 break;
79072805 1096 case '+':
1604cfb0
MS		 1097 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1098 paren = RX_LASTPAREN(rx);
1099 if (paren)
2c7b5d76 1100 goto do_numbuf_fetch;
1604cfb0 1101 }
e03e82a0 1102 goto set_undef;
a01268b5 1103 case '\016': /* ^N */
1604cfb0
MS		 1104 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1105 paren = RX_LASTCLOSEPAREN(rx);
1106 if (paren)
2c7b5d76 1107 goto do_numbuf_fetch;
1604cfb0 1108 }
e03e82a0 1109 goto set_undef;
79072805 1110 case '.':
1604cfb0
MS		 1111 if (GvIO(PL_last_in_gv)) {
1112 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1113 }
1114 break;
79072805 1115 case '?':
1604cfb0
MS		 1116 {
1117 sv_setiv(sv, (IV)STATUS_CURRENT);
ff0cee69 1118#ifdef COMPLEX_STATUS
1604cfb0
MS		 1119 SvUPGRADE(sv, SVt_PVLV);
1120 LvTARGOFF(sv) = PL_statusvalue;
1121 LvTARGLEN(sv) = PL_statusvalue_vms;
ff0cee69 1122#endif
1604cfb0
MS		 1123 }
1124 break;
79072805 1125 case '^':
1604cfb0
MS		 1126 if (GvIOp(PL_defoutgv))
1127 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1128 if (s)
1129 sv_setpv(sv,s);
1130 else {
1131 sv_setpv(sv,GvENAME(PL_defoutgv));
1132 sv_catpvs(sv,"_TOP");
1133 }
1134 break;
79072805 1135 case '~':
1604cfb0
MS		 1136 if (GvIOp(PL_defoutgv))
1137 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1138 if (!s)
1139 s = GvENAME(PL_defoutgv);
1140 sv_setpv(sv,s);
1141 break;
79072805 1142 case '=':
1604cfb0
MS		 1143 if (GvIO(PL_defoutgv))
1144 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1145 break;
79072805 1146 case '-':
1604cfb0
MS		 1147 if (GvIO(PL_defoutgv))
1148 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1149 break;
79072805 1150 case '%':
1604cfb0
MS		 1151 if (GvIO(PL_defoutgv))
1152 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1153 break;
79072805 1154 case ':':
79072805 1155 case '/':
1604cfb0 1156 break;
79072805 1157 case '[':
1604cfb0
MS		 1158 sv_setiv(sv, 0);
1159 break;
79072805 1160 case '|':
1604cfb0
MS		 1161 if (GvIO(PL_defoutgv))
1162 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1163 break;
79072805 1164 case '\\':
1604cfb0
MS		 1165 if (PL_ors_sv)
1166 sv_copypv(sv, PL_ors_sv);
1167 else
e03e82a0 1168 goto set_undef;
1604cfb0 1169 break;
0e219455 1170 case '$': /* $$ */
1604cfb0
MS		 1171 {
1172 IV const pid = (IV)PerlProc_getpid();
1173 if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1174 /* never set manually, or at least not since last fork */
1175 sv_setiv(sv, pid);
1176 /* never unsafe, even if reading in a tainted expression */
1177 SvTAINTED_off(sv);
1178 }
1179 /* else a value has been assigned manually, so do nothing */
1180 }
1181 break;
79072805 1182 case '<':
dfff4baf 1183 sv_setuid(sv, PerlProc_getuid());
1604cfb0 1184 break;
79072805 1185 case '>':
dfff4baf 1186 sv_setuid(sv, PerlProc_geteuid());
1604cfb0 1187 break;
79072805 1188 case '(':
dfff4baf 1189 sv_setgid(sv, PerlProc_getgid());
1604cfb0 1190 goto add_groups;
79072805 1191 case ')':
dfff4baf 1192 sv_setgid(sv, PerlProc_getegid());
79072805 1193 add_groups:
79072805 1194#ifdef HAS_GETGROUPS
1604cfb0
MS		 1195 {
1196 Groups_t *gary = NULL;
375ed12a
JH		 1197 I32 num_groups = getgroups(0, gary);
1198 if (num_groups > 0) {
19742f39 1199 I32 i;
375ed12a
JH		 1200 Newx(gary, num_groups, Groups_t);
1201 num_groups = getgroups(num_groups, gary);
1202 for (i = 0; i < num_groups; i++)
147e3846 1203 Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
375ed12a
JH		 1204 Safefree(gary);
1205 }
1604cfb0 1206 }
1a93d8df
FG		 1207
1208 /*
1209 Set this to avoid warnings when the SV is used as a number.
1210 Avoid setting the public IOK flag so that serializers will
1211 use the PV.
1212 */
1213 (void)SvIOKp_on(sv); /* what a wonderful hack! */
cd70abae 1214#endif
1604cfb0 1215 break;
79072805 1216 case '0':
1604cfb0 1217 break;
79072805 1218 }
a0d0e21e 1219 return 0;
e03e82a0
DM		 1220
1221 set_undef:
1222 sv_set_undef(sv);
1223 return 0;
79072805
LW		 1224}
1225
1226int
864dbfa3 1227Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 1228{
8772537c 1229 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 1230
7918f24d
NC		 1231 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1232
79072805 1233 if (uf && uf->uf_val)
1604cfb0 1234 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
79072805
LW		 1235 return 0;
1236}
1237
1238int
864dbfa3 1239Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
79072805 1240{
9ae3433d 1241 STRLEN len = 0, klen;
50352f16
FG		 1242
1243 const char *key;
888a67f6 1244 const char *s = "";
1e422769 1245
50352f16
FG		 1246 SV *keysv = MgSV(mg);
1247
1248 if (keysv == NULL) {
1249 key = mg->mg_ptr;
1250 klen = mg->mg_len;
1251 }
1252 else {
1253 if (!sv_utf8_downgrade(keysv, /* fail_ok */ TRUE)) {
1254 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv key (encoding to utf8)");
1255 }
1256
1257 key = SvPV_const(keysv,klen);
1258 }
1259
7918f24d
NC		 1260 PERL_ARGS_ASSERT_MAGIC_SETENV;
1261
613c63b4 1262 SvGETMAGIC(sv);
12033064 1263 if (SvOK(sv)) {
613c63b4
CS		 1264 /* defined environment variables are byte strings; unfortunately
1265 there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1266 (void)SvPV_force_nomg_nolen(sv);
90eef0af 1267 (void)sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
613c63b4
CS		 1268 if (SvUTF8(sv)) {
1269 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1270 SvUTF8_off(sv);
1271 }
1272 s = SvPVX(sv);
1273 len = SvCUR(sv);
12033064
CS		 1274 }
1275 my_setenv(key, s); /* does the deed */
1276
a0d0e21e
LW		 1277#ifdef DYNAMIC_ENV_FETCH
1278 /* We just undefd an environment var. Is a replacement */
1279 /* waiting in the wings? */
1280 if (!len) {
1604cfb0
MS		 1281 SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1282 if (valp)
1283 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
a0d0e21e
LW		 1284 }
1285#endif
1e422769 1286
4457f3fc 1287#if !defined(OS2) && !defined(WIN32)
1604cfb0
MS		 1288 /* And you'll never guess what the dog had */
1289 /* in its mouth... */
284167a5 1290 if (TAINTING_get) {
1604cfb0 1291 MgTAINTEDDIR_off(mg);
1e422769 1292#ifdef VMS
1604cfb0
MS		 1293 if (s && memEQs(key, klen, "DCL$PATH")) {
1294 char pathbuf[256], eltbuf[256], *cp, *elt;
1295 int i = 0, j = 0;
1296
1297 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1298 elt = eltbuf;
1299 do { /* DCL$PATH may be a search list */
1300 while (1) { /* as may dev portion of any element */
1301 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1302 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1303 cando_by_name(S_IWUSR,0,elt) ) {
1304 MgTAINTEDDIR_on(mg);
1305 return 0;
1306 }
1307 }
1308 if ((cp = strchr(elt, ':')) != NULL)
1309 *cp = '\0';
1310 if (my_trnlnm(elt, eltbuf, j++))
1311 elt = eltbuf;
1312 else
1313 break;
1314 }
1315 j = 0;
1316 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1317 }
1e422769 1318#endif /* VMS */
1604cfb0
MS		 1319 if (s && memEQs(key, klen, "PATH")) {
1320 const char * const strend = s + len;
1c9a202f
YO		 1321#ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */
1322 const char path_sep = PL_perllib_sep;
1323#else
1324 const char path_sep = ':';
1325#endif
463ee0b2 1326
92ec2fce
YO		 1327#ifndef __VMS
1328 /* Does this apply for VMS?
1329 * Empty PATH on linux is treated same as ".", which is forbidden
1330 * under taint. So check if the PATH variable is empty. */
1331 if (!len) {
1332 MgTAINTEDDIR_on(mg);
1333 return 0;
1334 }
1335#endif
70b484a8
DM		 1336 /* set MGf_TAINTEDDIR if any component of the new path is
1337 * relative or world-writeable */
1604cfb0
MS		 1338 while (s < strend) {
1339 char tmpbuf[256];
1340 Stat_t st;
1341 I32 i;
1604cfb0
MS		 1342 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1343 s, strend, path_sep, &i);
1344 s++;
1345 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
83269ced 1346#ifdef __VMS
1604cfb0
MS		 1347 /* no colon thus no device name -- assume relative path */
1348 || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1349 /* Using Unix separator, e.g. under bash, so act line Unix */
1350 || (PL_perllib_sep == ':' && *tmpbuf != '/')
326b5008 1351#else
92ec2fce
YO		 1352 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1353 || s == strend /* trailing empty component -- same as "." */
326b5008 1354#endif
1604cfb0
MS		 1355 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1356 MgTAINTEDDIR_on(mg);
1357 return 0;
1358 }
1359 }
1360 }
79072805 1361 }
4457f3fc 1362#endif /* neither OS2 nor WIN32 */
1e422769 1363
79072805
LW		 1364 return 0;
1365}
1366
1367int
864dbfa3 1368Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
85e6fe83 1369{
7918f24d 1370 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
8772537c 1371 PERL_UNUSED_ARG(sv);
bd61b366 1372 my_setenv(MgPV_nolen_const(mg),NULL);
85e6fe83
LW		 1373 return 0;
1374}
1375
88e89b8a 1376int
864dbfa3 1377Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
fb73857a 1378{
7918f24d 1379 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
65e66c80 1380 PERL_UNUSED_ARG(mg);
b0269e46 1381#if defined(VMS)
cea2e8a9 1382 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
fb73857a 1383#else
3280af22 1384 if (PL_localizing) {
1604cfb0
MS		 1385 HE* entry;
1386 my_clearenv();
1387 hv_iterinit(MUTABLE_HV(sv));
1388 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1389 I32 keylen;
1390 my_setenv(hv_iterkey(entry, &keylen),
1391 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1392 }
fb73857a 1393 }
1394#endif
1395 return 0;
1396}
1397
1398int
864dbfa3 1399Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
66b1d557 1400{
7918f24d 1401 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
8772537c
AL		 1402 PERL_UNUSED_ARG(sv);
1403 PERL_UNUSED_ARG(mg);
b0269e46
AB		 1404#if defined(VMS)
1405 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1406#else
1407 my_clearenv();
1408#endif
3e3baf6d 1409 return 0;
66b1d557
HM		 1410}
1411
64ca3a65 1412#ifndef PERL_MICRO
2d4fcd5e
AJ		 1413#ifdef HAS_SIGPROCMASK
1414static void
1415restore_sigmask(pTHX_ SV *save_sv)
1416{
0bd48802 1417 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
f5a63d97 1418 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
2d4fcd5e
AJ		 1419}
1420#endif
66b1d557 1421int
864dbfa3 1422Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1423{
88e89b8a 1424 /* Are we fetching a signal entry? */
708854f2 1425 int i = (I16)mg->mg_private;
7918f24d
NC		 1426
1427 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1428
708854f2 1429 if (!i) {
84c7b88c
BF		 1430 STRLEN siglen;
1431 const char * sig = MgPV_const(mg, siglen);
1432 mg->mg_private = i = whichsig_pvn(sig, siglen);
708854f2
NC		 1433 }
1434
e02bfb16 1435 if (i > 0) {
1604cfb0
MS		 1436 if(PL_psig_ptr[i])
1437 sv_setsv(sv,PL_psig_ptr[i]);
1438 else {
1439 Sighandler_t sigstate = rsignal_state(i);
23ada85b 1440#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1604cfb0
MS		 1441 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1442 sigstate = SIG_IGN;
2e34cc90
CL		 1443#endif
1444#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1604cfb0
MS		 1445 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1446 sigstate = SIG_DFL;
85b332e2 1447#endif
1604cfb0
MS		 1448 /* cache state so we don't fetch it again */
1449 if(sigstate == (Sighandler_t) SIG_IGN)
1450 sv_setpvs(sv,"IGNORE");
1451 else
e03e82a0 1452 sv_set_undef(sv);
1604cfb0
MS		 1453 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1454 SvTEMP_off(sv);
1455 }
88e89b8a 1456 }
1457 return 0;
1458}
1459int
864dbfa3 1460Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
88e89b8a 1461{
7918f24d 1462 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
179c85a2 1463
38a124f0 1464 magic_setsig(NULL, mg);
179c85a2 1465 return sv_unmagic(sv, mg->mg_type);
88e89b8a 1466}
3d37d572 1467
dc37125b 1468
5e7940ce 1469#ifdef PERL_USE_3ARG_SIGHANDLER
dc37125b
DM		 1470Signal_t
1471Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
1472{
1473 Perl_csighandler3(sig, sip, uap);
1474}
8aad04aa 1475#else
dc37125b 1476Signal_t
0a8e0eff 1477Perl_csighandler(int sig)
dc37125b
DM		 1478{
1479 Perl_csighandler3(sig, NULL, NULL);
1480}
8aad04aa 1481#endif
dc37125b
DM		 1482
1483Signal_t
1484Perl_csighandler1(int sig)
1485{
1486 Perl_csighandler3(sig, NULL, NULL);
1487}
1488
1489/* Handler intended to directly handle signal calls from the kernel.
1490 * (Depending on configuration, the kernel may actually call one of the
1491 * wrappers csighandler() or csighandler1() instead.)
1492 * It either queues up the signal or dispatches it immediately depending
1493 * on whether safe signals are enabled and whether the signal is capable
1494 * of being deferred (e.g. SEGV isn't).
1495 */
1496
1497Signal_t
1498Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
0a8e0eff 1499{
1018e26f
NIS		 1500#ifdef PERL_GET_SIG_CONTEXT
1501 dTHXa(PERL_GET_SIG_CONTEXT);
1502#else
85b332e2
CL		 1503 dTHX;
1504#endif
5e7940ce
DM		 1505
1506#ifdef PERL_USE_3ARG_SIGHANDLER
ffb6256b
JH		 1507#if defined(__cplusplus) && defined(__GNUC__)
1508 /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1509 * parameters would be warned about. */
1510 PERL_UNUSED_ARG(sip);
1511 PERL_UNUSED_ARG(uap);
1512#endif
1271a1be 1513#endif
5e7940ce 1514
23ada85b 1515#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
5c1546dc 1516 (void) rsignal(sig, PL_csighandlerp);
27da23d5 1517 if (PL_sig_ignoring[sig]) return;
85b332e2 1518#endif
2e34cc90 1519#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
27da23d5 1520 if (PL_sig_defaulting[sig])
2e34cc90
CL		 1521#ifdef KILL_BY_SIGPRC
1522 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1523#else
1524 exit(1);
1525#endif
1526#endif
406878dd 1527 if (
853d2c32 1528#ifdef SIGILL
1604cfb0 1529 sig == SIGILL ||
853d2c32
RGS		 1530#endif
1531#ifdef SIGBUS
1604cfb0 1532 sig == SIGBUS ||
853d2c32
RGS		 1533#endif
1534#ifdef SIGSEGV
1604cfb0 1535 sig == SIGSEGV ||
5892d8f5
HS		 1536#endif
1537#ifdef SIGFPE
1538 sig == SIGFPE ||
853d2c32 1539#endif
1604cfb0
MS		 1540 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1541 /* Call the perl level handler now--
1542 * with risk we may be in malloc() or being destructed etc. */
8a5e470b
DM		 1543 {
1544 if (PL_sighandlerp == Perl_sighandler)
1545 /* default handler, so can call perly_sighandler() directly
1546 * rather than via Perl_sighandler, passing the extra
1547 * 'safe = false' arg
1548 */
ddb513d5 1549 Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
8a5e470b 1550 else
5e7940ce 1551#ifdef PERL_USE_3ARG_SIGHANDLER
8a5e470b 1552 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09 1553#else
8a5e470b 1554 (*PL_sighandlerp)(sig);
92807b6d 1555#endif
8a5e470b 1556 }
406878dd 1557 else {
1604cfb0
MS		 1558 if (!PL_psig_pend) return;
1559 /* Set a flag to say this signal is pending, that is awaiting delivery after
1560 * the current Perl opcode completes */
1561 PL_psig_pend[sig]++;
406878dd
GA		 1562
1563#ifndef SIG_PENDING_DIE_COUNT
1564# define SIG_PENDING_DIE_COUNT 120
1565#endif
1604cfb0
MS		 1566 /* Add one to say _a_ signal is pending */
1567 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1568 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1569 (unsigned long)SIG_PENDING_DIE_COUNT);
406878dd 1570 }
0a8e0eff
NIS		 1571}
1572
2e34cc90
CL		 1573#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1574void
1575Perl_csighandler_init(void)
1576{
1577 int sig;
27da23d5 1578 if (PL_sig_handlers_initted) return;
2e34cc90
CL		 1579
1580 for (sig = 1; sig < SIG_SIZE; sig++) {
1581#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
218fdd94 1582 dTHX;
27da23d5 1583 PL_sig_defaulting[sig] = 1;
5c1546dc 1584 (void) rsignal(sig, PL_csighandlerp);
2e34cc90
CL		 1585#endif
1586#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
27da23d5 1587 PL_sig_ignoring[sig] = 0;
2e34cc90
CL		 1588#endif
1589 }
27da23d5 1590 PL_sig_handlers_initted = 1;
2e34cc90
CL		 1591}
1592#endif
1593
7fe50b8b
LT		 1594#if defined HAS_SIGPROCMASK
1595static void
1596unblock_sigmask(pTHX_ void* newset)
1597{
dc3bf405 1598 PERL_UNUSED_CONTEXT;
7fe50b8b
LT		 1599 sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1600}
1601#endif
1602
0a8e0eff
NIS		 1603void
1604Perl_despatch_signals(pTHX)
1605{
1606 int sig;
1607 PL_sig_pending = 0;
1608 for (sig = 1; sig < SIG_SIZE; sig++) {
1604cfb0
MS		 1609 if (PL_psig_pend[sig]) {
1610 dSAVE_ERRNO;
7fe50b8b 1611#ifdef HAS_SIGPROCMASK
1604cfb0
MS		 1612 /* From sigaction(2) (FreeBSD man page):
1613 * | Signal routines normally execute with the signal that
1614 * | caused their invocation blocked, but other signals may
1615 * | yet occur.
1616 * Emulation of this behavior (from within Perl) is enabled
1617 * using sigprocmask
1618 */
1619 int was_blocked;
1620 sigset_t newset, oldset;
1621
1622 sigemptyset(&newset);
1623 sigaddset(&newset, sig);
1624 sigprocmask(SIG_BLOCK, &newset, &oldset);
1625 was_blocked = sigismember(&oldset, sig);
1626 if (!was_blocked) {
1627 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1628 ENTER;
1629 SAVEFREESV(save_sv);
1630 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1631 }
1632#endif
1633 PL_psig_pend[sig] = 0;
8a5e470b
DM		 1634 if (PL_sighandlerp == Perl_sighandler)
1635 /* default handler, so can call perly_sighandler() directly
1636 * rather than via Perl_sighandler, passing the extra
1637 * 'safe = true' arg
1638 */
1639 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
1640 else
5e7940ce 1641#ifdef PERL_USE_3ARG_SIGHANDLER
8a5e470b 1642 (*PL_sighandlerp)(sig, NULL, NULL);
6e324d09 1643#else
8a5e470b 1644 (*PL_sighandlerp)(sig);
92807b6d 1645#endif
8a5e470b 1646
7fe50b8b 1647#ifdef HAS_SIGPROCMASK
1604cfb0
MS		 1648 if (!was_blocked)
1649 LEAVE;
55534442 1650#endif
1604cfb0
MS		 1651 RESTORE_ERRNO;
1652 }
0a8e0eff
NIS		 1653 }
1654}
1655
38a124f0 1656/* sv of NULL signifies that we're acting as magic_clearsig. */
85e6fe83 1657int
864dbfa3 1658Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
79072805 1659{
79072805 1660 I32 i;
cbbf8932 1661 SV** svp = NULL;
2d4fcd5e
AJ		 1662 /* Need to be careful with SvREFCNT_dec(), because that can have side
1663 * effects (due to closures). We must make sure that the new disposition
1664 * is in place before it is called.
1665 */
cbbf8932 1666 SV* to_dec = NULL;
e72dc28c 1667 STRLEN len;
2d4fcd5e
AJ		 1668#ifdef HAS_SIGPROCMASK
1669 sigset_t set, save;
1670 SV* save_sv;
1671#endif
eb578fdb 1672 const char *s = MgPV_const(mg,len);
7918f24d
NC		 1673
1674 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1675
748a9306 1676 if (*s == '_') {
84c7b88c 1677 if (memEQs(s, len, "__DIE__"))
1604cfb0
MS		 1678 svp = &PL_diehook;
1679 else if (memEQs(s, len, "__WARN__")
1680 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1681 /* Merge the existing behaviours, which are as follows:
1682 magic_setsig, we always set svp to &PL_warnhook
1683 (hence we always change the warnings handler)
1684 For magic_clearsig, we don't change the warnings handler if it's
1685 set to the &PL_warnhook. */
1686 svp = &PL_warnhook;
84c7b88c
BF		 1687 } else if (sv) {
1688 SV *tmp = sv_newmortal();
1689 Perl_croak(aTHX_ "No such hook: %s",
1690 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1691 }
1604cfb0
MS		 1692 i = 0;
1693 if (svp && *svp) {
1694 if (*svp != PERL_WARNHOOK_FATAL)
1695 to_dec = *svp;
1696 *svp = NULL;
1697 }
748a9306
LW		 1698 }
1699 else {
1604cfb0
MS		 1700 i = (I16)mg->mg_private;
1701 if (!i) {
1702 i = whichsig_pvn(s, len); /* ...no, a brick */
1703 mg->mg_private = (U16)i;
1704 }
1705 if (i <= 0) {
1706 if (sv) {
84c7b88c 1707 SV *tmp = sv_newmortal();
1604cfb0 1708 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
84c7b88c
BF		 1709 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1710 }
1604cfb0
MS		 1711 return 0;
1712 }
2d4fcd5e 1713#ifdef HAS_SIGPROCMASK
1604cfb0
MS		 1714 /* Avoid having the signal arrive at a bad time, if possible. */
1715 sigemptyset(&set);
1716 sigaddset(&set,i);
1717 sigprocmask(SIG_BLOCK, &set, &save);
1718 ENTER;
1719 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1720 SAVEFREESV(save_sv);
1721 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1722#endif
1723 PERL_ASYNC_CHECK();
2e34cc90 1724#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1604cfb0 1725 if (!PL_sig_handlers_initted) Perl_csighandler_init();
2e34cc90 1726#endif
23ada85b 1727#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1604cfb0 1728 PL_sig_ignoring[i] = 0;
85b332e2 1729#endif
2e34cc90 1730#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1604cfb0
MS		 1731 PL_sig_defaulting[i] = 0;
1732#endif
1733 to_dec = PL_psig_ptr[i];
1734 if (sv) {
1735 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1736 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1737
1738 /* Signals don't change name during the program's execution, so once
1739 they're cached in the appropriate slot of PL_psig_name, they can
1740 stay there.
1741
1742 Ideally we'd find some way of making SVs at (C) compile time, or
1743 at least, doing most of the work. */
1744 if (!PL_psig_name[i]) {
1745 const char* name = PL_sig_name[i];
1746 PL_psig_name[i] = newSVpvn(name, strlen(name));
1747 SvREADONLY_on(PL_psig_name[i]);
1748 }
1749 } else {
1750 SvREFCNT_dec(PL_psig_name[i]);
1751 PL_psig_name[i] = NULL;
1752 PL_psig_ptr[i] = NULL;
1753 }
748a9306 1754 }
38a124f0 1755 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1604cfb0
MS		 1756 if (i) {
1757 (void)rsignal(i, PL_csighandlerp);
1758 }
1759 else
1760 *svp = SvREFCNT_inc_simple_NN(sv);
38a124f0 1761 } else {
1604cfb0
MS		 1762 if (sv && SvOK(sv)) {
1763 s = SvPV_force(sv, len);
1764 } else {
1765 sv = NULL;
1766 }
1767 if (sv && memEQs(s, len,"IGNORE")) {
1768 if (i) {
23ada85b 1769#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1604cfb0
MS		 1770 PL_sig_ignoring[i] = 1;
1771 (void)rsignal(i, PL_csighandlerp);
85b332e2 1772#else
1604cfb0 1773 (void)rsignal(i, (Sighandler_t) SIG_IGN);
85b332e2 1774#endif
1604cfb0
MS		 1775 }
1776 }
1777 else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1778 if (i) {
2e34cc90 1779#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1604cfb0
MS		 1780 PL_sig_defaulting[i] = 1;
1781 (void)rsignal(i, PL_csighandlerp);
2e34cc90 1782#else
1604cfb0
MS		 1783 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1784#endif
1785 }
1786 }
1787 else {
1788 /*
1789 * We should warn if HINT_STRICT_REFS, but without
1790 * access to a known hint bit in a known OP, we can't
1791 * tell whether HINT_STRICT_REFS is in force or not.
1792 */
1793 if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1794 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1795 SV_GMAGIC);
1796 if (i)
1797 (void)rsignal(i, PL_csighandlerp);
1798 else
1799 *svp = SvREFCNT_inc_simple_NN(sv);
1800 }
748a9306 1801 }
9dfa190b 1802
2d4fcd5e
AJ		 1803#ifdef HAS_SIGPROCMASK
1804 if(i)
1604cfb0 1805 LEAVE;
2d4fcd5e 1806#endif
ef8d46e8 1807 SvREFCNT_dec(to_dec);
79072805
LW		 1808 return 0;
1809}
64ca3a65 1810#endif /* !PERL_MICRO */
79072805
LW		 1811
1812int
55f5e765
LT		 1813Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg)
1814{
1815 PERL_ARGS_ASSERT_MAGIC_SETSIGALL;
1816 PERL_UNUSED_ARG(mg);
1817
1818 if (PL_localizing == 2) {
1819 HV* hv = (HV*)sv;
1820 HE* current;
1821 hv_iterinit(hv);
1822 while ((current = hv_iternext(hv))) {
1823 SV* sigelem = hv_iterval(hv, current);
1824 mg_set(sigelem);
1825 }
1826 }
1827 return 0;
1828}
1829
1830int
864dbfa3 1831Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
79072805 1832{
7918f24d 1833 PERL_ARGS_ASSERT_MAGIC_SETISA;
8772537c 1834 PERL_UNUSED_ARG(sv);
e1a479c5 1835
89c14e2e 1836 /* Skip _isaelem because _isa will handle it shortly */
354b0578 1837 if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1604cfb0 1838 return 0;
89c14e2e 1839
0e446081 1840 return magic_clearisa(NULL, mg);
463ee0b2
LW		 1841}
1842
0e446081 1843/* sv of NULL signifies that we're acting as magic_setisa. */
463ee0b2 1844int
52b45067
RD		 1845Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1846{
52b45067 1847 HV* stash;
7918f24d
NC		 1848 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1849
52b45067 1850 /* Bail out if destruction is going on */
627364f1 1851 if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
52b45067 1852
0e446081 1853 if (sv)
1604cfb0 1854 av_clear(MUTABLE_AV(sv));
52b45067 1855
6624142a 1856 if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1604cfb0
MS		 1857 /* This occurs with setisa_elem magic, which calls this
1858 same function. */
1859 mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
6624142a 1860
316ebaf2 1861 assert(mg);
6624142a 1862 if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1604cfb0
MS		 1863 SV **svp = AvARRAY((AV *)mg->mg_obj);
1864 I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1865 while (items--) {
1866 stash = GvSTASH((GV *)*svp++);
1867 if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1868 }
6624142a 1869
1604cfb0 1870 return 0;
6624142a
FC		 1871 }
1872
52b45067 1873 stash = GvSTASH(
6624142a 1874 (const GV *)mg->mg_obj
52b45067
RD		 1875 );
1876
00169e2c
FC		 1877 /* The stash may have been detached from the symbol table, so check its
1878 name before doing anything. */
1879 if (stash && HvENAME_get(stash))
1604cfb0 1880 mro_isa_changed_in(stash);
52b45067
RD		 1881
1882 return 0;
1883}
1884
1885int
864dbfa3 1886Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
6ff81951 1887{
85fbaab2 1888 HV * const hv = MUTABLE_HV(LvTARG(sv));
6ff81951 1889 I32 i = 0;
7918f24d
NC		 1890
1891 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
8772537c 1892 PERL_UNUSED_ARG(mg);
7719e241 1893
6ff81951 1894 if (hv) {
497b47a8 1895 (void) hv_iterinit(hv);
ad64d0ec 1896 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1604cfb0 1897 i = HvUSEDKEYS(hv);
497b47a8 1898 else {
1604cfb0
MS		 1899 while (hv_iternext(hv))
1900 i++;
497b47a8 1901 }
6ff81951
GS		 1902 }
1903
1904 sv_setiv(sv, (IV)i);
1905 return 0;
1906}
1907
1908int
864dbfa3 1909Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
946ec16e 1910{
7918f24d 1911 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
8772537c 1912 PERL_UNUSED_ARG(mg);
946ec16e 1913 if (LvTARG(sv)) {
1604cfb0 1914 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
946ec16e 1915 }
1916 return 0;
ac27b0f5 1917}
946ec16e 1918
efaf3674 1919/*
3f620621 1920=for apidoc_section $magic
efaf3674
DM		 1921=for apidoc magic_methcall
1922
1923Invoke a magic method (like FETCH).
1924
2baee27b
FC		 1925C<sv> and C<mg> are the tied thingy and the tie magic.
1926
1927C<meth> is the name of the method to call.
1928
1929C<argc> is the number of args (in addition to $self) to pass to the method.
1930
1931The C<flags> can be:
1932
1933 G_DISCARD invoke method with G_DISCARD flag and don't
1934 return a value
1935 G_UNDEF_FILL fill the stack with argc pointers to
1936 PL_sv_undef
1937
1938The arguments themselves are any values following the C<flags> argument.
efaf3674 1939
796b6530 1940Returns the SV (if any) returned by the method, or C<NULL> on failure.
efaf3674
DM		 1941
1942
1943=cut
1944*/
1945
1946SV*
36925d9e 1947Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1604cfb0 1948 U32 argc, ...)
a0d0e21e
LW		 1949{
1950 dSP;
efaf3674 1951 SV* ret = NULL;
463ee0b2 1952
7918f24d
NC		 1953 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1954
efaf3674 1955 ENTER;
d1d7a15d
NC		 1956
1957 if (flags & G_WRITING_TO_STDERR) {
1604cfb0 1958 SAVETMPS;
d1d7a15d 1959
1604cfb0
MS		 1960 save_re_context();
1961 SAVESPTR(PL_stderrgv);
1962 PL_stderrgv = NULL;
d1d7a15d
NC		 1963 }
1964
efaf3674 1965 PUSHSTACKi(PERLSI_MAGIC);
924508f0 1966 PUSHMARK(SP);
efaf3674 1967
052a7c76
DM		 1968 /* EXTEND() expects a signed argc; don't wrap when casting */
1969 assert(argc <= I32_MAX);
1970 EXTEND(SP, (I32)argc+1);
67549bd2
NC		 1971 PUSHs(SvTIED_obj(sv, mg));
1972 if (flags & G_UNDEF_FILL) {
1604cfb0
MS		 1973 while (argc--) {
1974 PUSHs(&PL_sv_undef);
1975 }
67549bd2 1976 } else if (argc > 0) {
1604cfb0
MS		 1977 va_list args;
1978 va_start(args, argc);
046b0c7d 1979
1604cfb0
MS		 1980 do {
1981 SV *const this_sv = va_arg(args, SV *);
1982 PUSHs(this_sv);
1983 } while (--argc);
046b0c7d 1984
1604cfb0 1985 va_end(args);
88e89b8a 1986 }
463ee0b2 1987 PUTBACK;
efaf3674 1988 if (flags & G_DISCARD) {
1604cfb0 1989 call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
efaf3674
DM		 1990 }
1991 else {
1604cfb0
MS		 1992 if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1993 ret = *PL_stack_sp--;
efaf3674
DM		 1994 }
1995 POPSTACK;
d1d7a15d 1996 if (flags & G_WRITING_TO_STDERR)
1604cfb0 1997 FREETMPS;
efaf3674
DM		 1998 LEAVE;
1999 return ret;
2000}
2001
efaf3674 2002/* wrapper for magic_methcall that creates the first arg */
463ee0b2 2003
efaf3674 2004STATIC SV*
36925d9e 2005S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
efaf3674
DM		 2006 int n, SV *val)
2007{
efaf3674
DM		 2008 SV* arg1 = NULL;
2009
2010 PERL_ARGS_ASSERT_MAGIC_METHCALL1;
2011
2012 if (mg->mg_ptr) {
1604cfb0
MS		 2013 if (mg->mg_len >= 0) {
2014 arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2015 }
2016 else if (mg->mg_len == HEf_SVKEY)
2017 arg1 = MUTABLE_SV(mg->mg_ptr);
efaf3674
DM		 2018 }
2019 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1604cfb0
MS		 2020 arg1 = newSViv((IV)(mg->mg_len));
2021 sv_2mortal(arg1);
efaf3674
DM		 2022 }
2023 if (!arg1) {
1604cfb0 2024 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
efaf3674 2025 }
046b0c7d 2026 return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
946ec16e 2027}
2028
76e3520e 2029STATIC int
36925d9e 2030S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
a0d0e21e 2031{
efaf3674 2032 SV* ret;
463ee0b2 2033
7918f24d
NC		 2034 PERL_ARGS_ASSERT_MAGIC_METHPACK;
2035
efaf3674
DM		 2036 ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
2037 if (ret)
1604cfb0 2038 sv_setsv(sv, ret);
a0d0e21e
LW		 2039 return 0;
2040}
463ee0b2 2041
a0d0e21e 2042int
864dbfa3 2043Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2044{
7918f24d
NC		 2045 PERL_ARGS_ASSERT_MAGIC_GETPACK;
2046
fd69380d 2047 if (mg->mg_type == PERL_MAGIC_tiedelem)
1604cfb0 2048 mg->mg_flags |= MGf_GSKIP;
36925d9e 2049 magic_methpack(sv,mg,SV_CONST(FETCH));
463ee0b2
LW		 2050 return 0;
2051}
2052
2053int
864dbfa3 2054Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
e336de0d 2055{
b112cff9
DM		 2056 MAGIC *tmg;
2057 SV *val;
7918f24d
NC		 2058
2059 PERL_ARGS_ASSERT_MAGIC_SETPACK;
2060
b112cff9
DM		 2061 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2062 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2063 * public flags indicate its value based on copying from $val. Doing
2064 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2065 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2066 * wrong if $val happened to be tainted, as sv hasn't got magic
2067 * enabled, even though taint magic is in the chain. In which case,
2068 * fake up a temporary tainted value (this is easier than temporarily
2069 * re-enabling magic on sv). */
2070
284167a5 2071 if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
1604cfb0 2072 && (tmg->mg_len & 1))
b112cff9 2073 {
1604cfb0
MS		 2074 val = sv_mortalcopy(sv);
2075 SvTAINTED_on(val);
b112cff9
DM		 2076 }
2077 else
1604cfb0 2078 val = sv;
b112cff9 2079
36925d9e 2080 magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
463ee0b2
LW		 2081 return 0;
2082}
2083
2084int
864dbfa3 2085Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2086{
7918f24d
NC		 2087 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2088
4c13be3f 2089 if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
36925d9e 2090 return magic_methpack(sv,mg,SV_CONST(DELETE));
a0d0e21e 2091}
463ee0b2 2092
93965878
NIS		 2093
2094U32
864dbfa3 2095Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
ac27b0f5 2096{
22846ab4 2097 I32 retval = 0;
efaf3674 2098 SV* retsv;
93965878 2099
7918f24d
NC		 2100 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2101
36925d9e 2102 retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
efaf3674 2103 if (retsv) {
1604cfb0
MS		 2104 retval = SvIV(retsv)-1;
2105 if (retval < -1)
2106 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
93965878 2107 }
22846ab4 2108 return (U32) retval;
93965878
NIS		 2109}
2110
cea2e8a9
GS		 2111int
2112Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2113{
7918f24d
NC		 2114 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2115
36925d9e 2116 Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
463ee0b2
LW		 2117 return 0;
2118}
2119
2120int
864dbfa3 2121Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
463ee0b2 2122{
efaf3674 2123 SV* ret;
463ee0b2 2124
7918f24d
NC		 2125 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2126
36925d9e 2127 ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
1604cfb0 2128 : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
efaf3674 2129 if (ret)
1604cfb0 2130 sv_setsv(key,ret);
79072805
LW		 2131 return 0;
2132}
2133
2134int
1146e912 2135Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
a0d0e21e 2136{
7918f24d
NC		 2137 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2138
36925d9e 2139 return magic_methpack(sv,mg,SV_CONST(EXISTS));
ac27b0f5 2140}
a0d0e21e 2141
a3bcc51e
TP		 2142SV *
2143Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2144{
5fcbf73d 2145 SV *retval;
ad64d0ec
NC		 2146 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2147 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
a3bcc51e 2148
7918f24d
NC		 2149 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2150
a3bcc51e
TP		 2151 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2152 SV *key;
bfcb3514 2153 if (HvEITER_get(hv))
a3bcc51e
TP		 2154 /* we are in an iteration so the hash cannot be empty */
2155 return &PL_sv_yes;
2156 /* no xhv_eiter so now use FIRSTKEY */
2157 key = sv_newmortal();
ad64d0ec 2158 magic_nextpack(MUTABLE_SV(hv), mg, key);
bfcb3514 2159 HvEITER_set(hv, NULL); /* need to reset iterator */
a3bcc51e
TP		 2160 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2161 }
2162
2163 /* there is a SCALAR method that we can call */
36925d9e 2164 retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
efaf3674 2165 if (!retval)
1604cfb0 2166 retval = &PL_sv_undef;
a3bcc51e
TP		 2167 return retval;
2168}
2169
a0d0e21e 2170int
864dbfa3 2171Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
79072805 2172{
089b5c60 2173 SV **svp;
7918f24d
NC		 2174
2175 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2176
089b5c60
NC		 2177 /* The magic ptr/len for the debugger's hash should always be an SV. */
2178 if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
147e3846 2179 Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
7b0eb0b8 2180 (IV)mg->mg_len, mg->mg_ptr);
089b5c60
NC		 2181 }
2182
2183 /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2184 setting/clearing debugger breakpoints is not a hot path. */
43e4250a 2185 svp = av_fetch(MUTABLE_AV(mg->mg_obj),
1604cfb0 2186 sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
089b5c60 2187
8772537c 2188 if (svp && SvIOKp(*svp)) {
1604cfb0
MS		 2189 OP * const o = INT2PTR(OP*,SvIVX(*svp));
2190 if (o) {
88df5f01 2191#ifdef PERL_DEBUG_READONLY_OPS
1604cfb0 2192 Slab_to_rw(OpSLAB(o));
88df5f01 2193#endif
1604cfb0
MS		 2194 /* set or clear breakpoint in the relevant control op */
2195 if (SvTRUE(sv))
2196 o->op_flags |= OPf_SPECIAL;
2197 else
2198 o->op_flags &= ~OPf_SPECIAL;
88df5f01 2199#ifdef PERL_DEBUG_READONLY_OPS
1604cfb0 2200 Slab_to_ro(OpSLAB(o));
88df5f01 2201#endif
1604cfb0 2202 }
5df8de69 2203 }
79072805
LW		 2204 return 0;
2205}
2206
2207int
8772537c 2208Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
79072805 2209{
502c6561 2210 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC		 2211
2212 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2213
83bf042f 2214 if (obj) {
1604cfb0 2215 sv_setiv(sv, AvFILL(obj));
83bf042f 2216 } else {
3773545d 2217 sv_set_undef(sv);
83bf042f 2218 }
79072805
LW		 2219 return 0;
2220}
2221
2222int
864dbfa3 2223Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
79072805 2224{
502c6561 2225 AV * const obj = MUTABLE_AV(mg->mg_obj);
7918f24d
NC		 2226
2227 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2228
83bf042f 2229 if (obj) {
1604cfb0 2230 av_fill(obj, SvIV(sv));
83bf042f 2231 } else {
1604cfb0
MS		 2232 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2233 "Attempt to set length of freed array");
83bf042f
NC		 2234 }
2235 return 0;
2236}
2237
2238int
83f29afa
VP		 2239Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2240{
83f29afa
VP		 2241 PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2242 PERL_UNUSED_ARG(sv);
dc3bf405 2243 PERL_UNUSED_CONTEXT;
83f29afa
VP		 2244
2245 /* Reset the iterator when the array is cleared */
4803e7f7 2246 if (sizeof(IV) == sizeof(SSize_t)) {
1604cfb0 2247 *((IV *) &(mg->mg_len)) = 0;
4803e7f7 2248 } else {
1604cfb0
MS		 2249 if (mg->mg_ptr)
2250 *((IV *) mg->mg_ptr) = 0;
4803e7f7 2251 }
83f29afa
VP		 2252
2253 return 0;
2254}
2255
2256int
83bf042f
NC		 2257Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2258{
7918f24d 2259 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
53c1dcc0 2260 PERL_UNUSED_ARG(sv);
7918f24d 2261
94f3782b
DM		 2262 /* during global destruction, mg_obj may already have been freed */
2263 if (PL_in_clean_all)
1604cfb0 2264 return 0;
94f3782b 2265
83bf042f
NC		 2266 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2267
2268 if (mg) {
1604cfb0
MS		 2269 /* arylen scalar holds a pointer back to the array, but doesn't own a
2270 reference. Hence the we (the array) are about to go away with it
2271 still pointing at us. Clear its pointer, else it would be pointing
2272 at free memory. See the comment in sv_magic about reference loops,
2273 and why it can't own a reference to us. */
2274 mg->mg_obj = 0;
83bf042f 2275 }
a0d0e21e
LW		 2276 return 0;
2277}
2278
2279int
864dbfa3 2280Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2281{
16eb5365 2282 SV* const lsv = LvTARG(sv);
96c2a8ff 2283 MAGIC * const found = mg_find_mglob(lsv);
7918f24d
NC		 2284
2285 PERL_ARGS_ASSERT_MAGIC_GETPOS;
16eb5365 2286 PERL_UNUSED_ARG(mg);
ac27b0f5 2287
6174b39a 2288 if (found && found->mg_len != -1) {
1604cfb0
MS		 2289 STRLEN i = found->mg_len;
2290 if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2291 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2292 sv_setuv(sv, i);
2293 return 0;
a0d0e21e 2294 }
3773545d 2295 sv_set_undef(sv);
a0d0e21e
LW		 2296 return 0;
2297}
2298
2299int
864dbfa3 2300Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
a0d0e21e 2301{
16eb5365 2302 SV* const lsv = LvTARG(sv);
a0d0e21e
LW		 2303 SSize_t pos;
2304 STRLEN len;
53d44271 2305 MAGIC* found;
aec43834 2306 const char *s;
a0d0e21e 2307
7918f24d 2308 PERL_ARGS_ASSERT_MAGIC_SETPOS;
16eb5365 2309 PERL_UNUSED_ARG(mg);
ac27b0f5 2310
96c2a8ff 2311 found = mg_find_mglob(lsv);
3881461a 2312 if (!found) {
1604cfb0
MS		 2313 if (!SvOK(sv))
2314 return 0;
2315 found = sv_magicext_mglob(lsv);
a0d0e21e
LW		 2316 }
2317 else if (!SvOK(sv)) {
1604cfb0
MS		 2318 found->mg_len = -1;
2319 return 0;
a0d0e21e 2320 }
aec43834 2321 s = SvPV_const(lsv, len);
a0d0e21e 2322
e1dccc0d 2323 pos = SvIV(sv);
a0ed51b3 2324
7e2040f0 2325 if (DO_UTF8(lsv)) {
19742f39 2326 const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
1604cfb0
MS		 2327 if (ulen)
2328 len = ulen;
a0ed51b3
LW		 2329 }
2330
a0d0e21e 2331 if (pos < 0) {
1604cfb0
MS		 2332 pos += len;
2333 if (pos < 0)
2334 pos = 0;
a0d0e21e 2335 }
eb160463 2336 else if (pos > (SSize_t)len)
1604cfb0 2337 pos = len;
a0ed51b3 2338
3881461a 2339 found->mg_len = pos;
25fdce4a 2340 found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
a0d0e21e 2341
79072805
LW		 2342 return 0;
2343}
2344
2345int
864dbfa3 2346Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
6ff81951
GS		 2347{
2348 STRLEN len;
35a4481c 2349 SV * const lsv = LvTARG(sv);
b83604b4 2350 const char * const tmps = SvPV_const(lsv,len);
777f7c56
EB		 2351 STRLEN offs = LvTARGOFF(sv);
2352 STRLEN rem = LvTARGLEN(sv);
b063b0a8
DIM		 2353 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2354 const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
7918f24d
NC		 2355
2356 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
8772537c 2357 PERL_UNUSED_ARG(mg);
6ff81951 2358
83f78d1a 2359 if (!translate_substr_offsets(
1604cfb0
MS		 2360 SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2361 negoff ? -(IV)offs : (IV)offs, !negoff,
2362 negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem
83f78d1a 2363 )) {
1604cfb0 2364 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
e03e82a0 2365 sv_set_undef(sv);
1604cfb0 2366 return 0;
83f78d1a
FC		 2367 }
2368
9aa983d2 2369 if (SvUTF8(lsv))
1604cfb0 2370 offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
1c900557 2371 sv_setpvn(sv, tmps + offs, rem);
9aa983d2 2372 if (SvUTF8(lsv))
2ef4b674 2373 SvUTF8_on(sv);
6ff81951
GS		 2374 return 0;
2375}
2376
2377int
864dbfa3 2378Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
79072805 2379{
83f78d1a 2380 STRLEN len, lsv_len, oldtarglen, newtarglen;
5fcbf73d 2381 const char * const tmps = SvPV_const(sv, len);
dd374669 2382 SV * const lsv = LvTARG(sv);
777f7c56
EB		 2383 STRLEN lvoff = LvTARGOFF(sv);
2384 STRLEN lvlen = LvTARGLEN(sv);
b063b0a8
DIM		 2385 const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2386 const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
7918f24d
NC		 2387
2388 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
8772537c 2389 PERL_UNUSED_ARG(mg);
075a4a2b 2390
a74fb2cd
FC		 2391 SvGETMAGIC(lsv);
2392 if (SvROK(lsv))
1604cfb0
MS		 2393 Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2394 "Attempt to use reference as lvalue in substr"
2395 );
fc061ed8
FC		 2396 SvPV_force_nomg(lsv,lsv_len);
2397 if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
83f78d1a 2398 if (!translate_substr_offsets(
1604cfb0
MS		 2399 lsv_len,
2400 negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2401 neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
83f78d1a 2402 ))
1604cfb0 2403 Perl_croak(aTHX_ "substr outside of string");
83f78d1a 2404 oldtarglen = lvlen;
1aa99e6b 2405 if (DO_UTF8(sv)) {
1604cfb0
MS		 2406 sv_utf8_upgrade_nomg(lsv);
2407 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2408 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2409 newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2410 SvUTF8_on(lsv);
9aa983d2 2411 }
0d336106 2412 else if (SvUTF8(lsv)) {
1604cfb0
MS		 2413 const char *utf8;
2414 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2415 newtarglen = len;
2416 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2417 sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2418 Safefree(utf8);
1aa99e6b 2419 }
b76f3ce2 2420 else {
1604cfb0
MS		 2421 sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2422 newtarglen = len;
b76f3ce2 2423 }
83f78d1a
FC		 2424 if (!neglen) LvTARGLEN(sv) = newtarglen;
2425 if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen;
b76f3ce2 2426
79072805
LW		 2427 return 0;
2428}
2429
2430int
864dbfa3 2431Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2432{
7918f24d 2433 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
8772537c 2434 PERL_UNUSED_ARG(sv);
9a9b5ec9
DM		 2435#ifdef NO_TAINT_SUPPORT
2436 PERL_UNUSED_ARG(mg);
2437#endif
7918f24d 2438
64ff300b 2439 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
463ee0b2
LW		 2440 return 0;
2441}
2442
2443int
864dbfa3 2444Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
463ee0b2 2445{
7918f24d 2446 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
8772537c 2447 PERL_UNUSED_ARG(sv);
7918f24d 2448
b01e650a 2449 /* update taint status */
284167a5 2450 if (TAINT_get)
1604cfb0 2451 mg->mg_len |= 1;
b01e650a 2452 else
1604cfb0 2453 mg->mg_len &= ~1;
463ee0b2
LW		 2454 return 0;
2455}
2456
2457int
864dbfa3 2458Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
6ff81951 2459{
35a4481c 2460 SV * const lsv = LvTARG(sv);
1b92e694 2461 char errflags = LvFLAGS(sv);
7918f24d
NC		 2462
2463 PERL_ARGS_ASSERT_MAGIC_GETVEC;
8772537c 2464 PERL_UNUSED_ARG(mg);
6ff81951 2465
1b92e694 2466 /* non-zero errflags implies deferred out-of-range condition */
b063b0a8 2467 assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
1b92e694 2468 sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
6ff81951 2469
6ff81951
GS		 2470 return 0;
2471}
2472
2473int
864dbfa3 2474Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
79072805 2475{
7918f24d 2476 PERL_ARGS_ASSERT_MAGIC_SETVEC;
8772537c 2477 PERL_UNUSED_ARG(mg);
79072805
LW		 2478 do_vecset(sv); /* XXX slurp this routine */
2479 return 0;
2480}
2481
13733cde
FC		 2482SV *
2483Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
5f05dabc 2484{
a0714e2c 2485 SV *targ = NULL;
13733cde
FC		 2486 PERL_ARGS_ASSERT_DEFELEM_TARGET;
2487 if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2488 assert(mg);
5f05dabc 2489 if (LvTARGLEN(sv)) {
1604cfb0
MS		 2490 if (mg->mg_obj) {
2491 SV * const ahv = LvTARG(sv);
2492 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
6d822dc4
MS		 2493 if (he)
2494 targ = HeVAL(he);
1604cfb0
MS		 2495 }
2496 else if (LvSTARGOFF(sv) >= 0) {
2497 AV *const av = MUTABLE_AV(LvTARG(sv));
2498 if (LvSTARGOFF(sv) <= AvFILL(av))
2499 {
2500 if (SvRMAGICAL(av)) {
2501 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2502 targ = svp ? *svp : NULL;
2503 }
2504 else
2505 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2506 }
2507 }
2508 if (targ && (targ != &PL_sv_undef)) {
2509 /* somebody else defined it for us */
2510 SvREFCNT_dec(LvTARG(sv));
2511 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2512 LvTARGLEN(sv) = 0;
2513 SvREFCNT_dec(mg->mg_obj);
2514 mg->mg_obj = NULL;
2515 mg->mg_flags &= ~MGf_REFCOUNTED;
2516 }
2517 return targ;
5f05dabc 2518 }
71be2cbc 2519 else
1604cfb0 2520 return LvTARG(sv);
13733cde
FC		 2521}
2522
2523int
2524Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2525{
2526 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2527
2528 sv_setsv(sv, defelem_target(sv, mg));
71be2cbc 2529 return 0;
2530}
2531
2532int
864dbfa3 2533Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
71be2cbc 2534{
7918f24d 2535 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
8772537c 2536 PERL_UNUSED_ARG(mg);
71be2cbc 2537 if (LvTARGLEN(sv))
1604cfb0 2538 vivify_defelem(sv);
68dc0745 2539 if (LvTARG(sv)) {
1604cfb0
MS		 2540 sv_setsv(LvTARG(sv), sv);
2541 SvSETMAGIC(LvTARG(sv));
68dc0745 2542 }
5f05dabc 2543 return 0;
2544}
2545
71be2cbc 2546void
864dbfa3 2547Perl_vivify_defelem(pTHX_ SV *sv)
71be2cbc 2548{
74e13ce4 2549 MAGIC *mg;
a0714e2c 2550 SV *value = NULL;
71be2cbc 2551
7918f24d
NC		 2552 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2553
14befaf4 2554 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1604cfb0 2555 return;
68dc0745 2556 if (mg->mg_obj) {
1604cfb0
MS		 2557 SV * const ahv = LvTARG(sv);
2558 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
6d822dc4
MS		 2559 if (he)
2560 value = HeVAL(he);
1604cfb0
MS		 2561 if (!value || value == &PL_sv_undef)
2562 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
71be2cbc 2563 }
bbfdc870 2564 else if (LvSTARGOFF(sv) < 0)
1604cfb0 2565 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
68dc0745 2566 else {
1604cfb0
MS		 2567 AV *const av = MUTABLE_AV(LvTARG(sv));
2568 if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2569 LvTARG(sv) = NULL; /* array can't be extended */
2570 else {
2571 SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2572 if (!svp || !(value = *svp))
2573 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2574 }
68dc0745 2575 }
b37c2d43 2576 SvREFCNT_inc_simple_void(value);
68dc0745 2577 SvREFCNT_dec(LvTARG(sv));
2578 LvTARG(sv) = value;
71be2cbc 2579 LvTARGLEN(sv) = 0;
68dc0745 2580 SvREFCNT_dec(mg->mg_obj);
a0714e2c 2581 mg->mg_obj = NULL;
68dc0745 2582 mg->mg_flags &= ~MGf_REFCOUNTED;
5f05dabc 2583}
2584
2585int
1f1dcfb5
FC		 2586Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2587{
2588 PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2589 PERL_UNUSED_ARG(mg);
2590 sv_unmagic(sv, PERL_MAGIC_nonelem);
2591 return 0;
2592}
2593
2594int
864dbfa3 2595Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
810b8aa5 2596{
7918f24d 2597 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
5648c0ae
DM		 2598 Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2599 return 0;
810b8aa5
GS		 2600}
2601
2602int
864dbfa3 2603Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
93a17b20 2604{
7918f24d 2605 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
96a5add6 2606 PERL_UNUSED_CONTEXT;
0177730e 2607 PERL_UNUSED_ARG(sv);
565764a8 2608 mg->mg_len = -1;
93a17b20
LW		 2609 return 0;
2610}
2611
02a48966
DM		 2612
2613int
2614Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
2615{
2616 PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
2617 PERL_UNUSED_ARG(sv);
2618
5d273abb
DM		 2619 /* pos() magic uses mg_len as a string position rather than a buffer
2620 * length, and mg_ptr is currently unused, so skip freeing.
2621 */
02a48966 2622 assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
02a48966
DM		 2623 mg->mg_ptr = NULL;
2624 return 0;
2625}
2626
2627
93a17b20 2628int
864dbfa3 2629Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
79072805 2630{
35a4481c 2631 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
79072805 2632
7918f24d
NC		 2633 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2634
79072805 2635 if (uf && uf->uf_set)
1604cfb0 2636 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
79072805
LW		 2637 return 0;
2638}
2639
c277df42 2640int
faf82a0b
AE		 2641Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2642{
488344d2 2643 const char type = mg->mg_type;
7918f24d
NC		 2644
2645 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2646
a5c7cb08
DM		 2647 assert( type == PERL_MAGIC_fm
2648 || type == PERL_MAGIC_qr
2649 || type == PERL_MAGIC_bm);
488344d2 2650 return sv_unmagic(sv, type);
faf82a0b
AE		 2651}
2652
7a4c00b4 2653#ifdef USE_LOCALE_COLLATE
79072805 2654int
864dbfa3 2655Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
bbce6d69 2656{
7918f24d
NC		 2657 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2658
bbce6d69 2659 /*
838b5b74 2660 * RenE<eacute> Descartes said "I think not."
bbce6d69 2661 * and vanished with a faint plop.
2662 */
96a5add6 2663 PERL_UNUSED_CONTEXT;
8772537c 2664 PERL_UNUSED_ARG(sv);
7a4c00b4 2665 if (mg->mg_ptr) {
1604cfb0
MS		 2666 Safefree(mg->mg_ptr);
2667 mg->mg_ptr = NULL;
2668 mg->mg_len = -1;
7a4c00b4 2669 }
bbce6d69 2670 return 0;
2671}
a457b73c
DM		 2672
2673int
2674Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg)
2675{
2676 PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM;
2677 PERL_UNUSED_ARG(sv);
2678
2679 /* Collate magic uses mg_len as a string length rather than a buffer
2680 * length, so we need to free even with mg_len == 0: hence we can't
2681 * rely on standard magic free handling */
fb072d00
TC		 2682 if (mg->mg_len >= 0) {
2683 assert(mg->mg_type == PERL_MAGIC_collxfrm);
2684 Safefree(mg->mg_ptr);
2685 mg->mg_ptr = NULL;
2686 }
2687
a457b73c
DM		 2688 return 0;
2689}
7a4c00b4 2690#endif /* USE_LOCALE_COLLATE */
bbce6d69 2691
7e8c5dac
HS		 2692/* Just clear the UTF-8 cache data. */
2693int
2694Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2695{
7918f24d 2696 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
96a5add6 2697 PERL_UNUSED_CONTEXT;
8772537c 2698 PERL_UNUSED_ARG(sv);
7e8c5dac 2699 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
3881461a 2700 mg->mg_ptr = NULL;
7e8c5dac
HS		 2701 mg->mg_len = -1; /* The mg_len holds the len cache. */
2702 return 0;
2703}
2704
bbce6d69 2705int
032a4919
DM		 2706Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg)
2707{
2708 PERL_ARGS_ASSERT_MAGIC_FREEUTF8;
2709 PERL_UNUSED_ARG(sv);
2710
2711 /* utf8 magic uses mg_len as a string length rather than a buffer
2712 * length, so we need to free even with mg_len == 0: hence we can't
2713 * rely on standard magic free handling */
2714 assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1);
2715 Safefree(mg->mg_ptr);
2716 mg->mg_ptr = NULL;
2717 return 0;
2718}
2719
2720
2721int
9cce4f9a
FC		 2722Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2723{
9782ce69 2724 const char *bad = NULL;
9cce4f9a 2725 PERL_ARGS_ASSERT_MAGIC_SETLVREF;
26a50d99 2726 if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
9782ce69
FC		 2727 switch (mg->mg_private & OPpLVREF_TYPE) {
2728 case OPpLVREF_SV:
1604cfb0
MS		 2729 if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2730 bad = " SCALAR";
2731 break;
9782ce69 2732 case OPpLVREF_AV:
1604cfb0
MS		 2733 if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2734 bad = "n ARRAY";
2735 break;
9782ce69 2736 case OPpLVREF_HV:
1604cfb0
MS		 2737 if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2738 bad = " HASH";
2739 break;
9782ce69 2740 case OPpLVREF_CV:
1604cfb0
MS		 2741 if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2742 bad = " CODE";
9782ce69
FC		 2743 }
2744 if (bad)
1604cfb0
MS		 2745 /* diag_listed_as: Assigned value is not %s reference */
2746 Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
c146a62a
FC		 2747 switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2748 case 0:
2749 {
1604cfb0
MS		 2750 SV * const old = PAD_SV(mg->mg_len);
2751 PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2752 SvREFCNT_dec(old);
2753 break;
c146a62a
FC		 2754 }
2755 case SVt_PVGV:
1604cfb0
MS		 2756 gv_setref(mg->mg_obj, sv);
2757 SvSETMAGIC(mg->mg_obj);
2758 break;
6102323a 2759 case SVt_PVAV:
1604cfb0
MS		 2760 av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2761 SvREFCNT_inc_simple_NN(SvRV(sv)));
2762 break;
5f94141d 2763 case SVt_PVHV:
1604cfb0 2764 (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
7fcb36d5 2765 SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
c146a62a 2766 }
d39c26a6 2767 if (mg->mg_flags & MGf_PERSIST)
1604cfb0
MS		 2768 NOOP; /* This sv is in use as an iterator var and will be reused,
2769 so we must leave the magic. */
d39c26a6 2770 else
1604cfb0
MS		 2771 /* This sv could be returned by the assignment op, so clear the
2772 magic, as lvrefs are an implementation detail that must not be
2773 leaked to the user. */
2774 sv_unmagic(sv, PERL_MAGIC_lvref);
9cce4f9a
FC		 2775 return 0;
2776}
2777
f1540bed
JH		 2778static void
2779S_set_dollarzero(pTHX_ SV *sv)
2780 PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2781{
f1540bed
JH		 2782 const char *s;
2783 STRLEN len;
f1540bed
JH		 2784#ifdef HAS_SETPROCTITLE
2785 /* The BSDs don't show the argv[] in ps(1) output, they
2786 * show a string from the process struct and provide
2787 * the setproctitle() routine to manipulate that. */
2788 if (PL_origalen != 1) {
2789 s = SvPV_const(sv, len);
38626956 2790# if __FreeBSD_version > 410001 || defined(__DragonFly__)
f1540bed
JH		 2791 /* The leading "-" removes the "perl: " prefix,
2792 * but not the "(perl) suffix from the ps(1)
2793 * output, because that's what ps(1) shows if the
2794 * argv[] is modified. */
2795 setproctitle("-%s", s);
2796# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2797 /* This doesn't really work if you assume that
2798 * $0 = 'foobar'; will wipe out 'perl' from the $0
2799 * because in ps(1) output the result will be like
2800 * sprintf("perl: %s (perl)", s)
2801 * I guess this is a security feature:
2802 * one (a user process) cannot get rid of the original name.
2803 * --jhi */
2804 setproctitle("%s", s);
2805# endif
2806 }
2807#elif defined(__hpux) && defined(PSTAT_SETCMD)
2808 if (PL_origalen != 1) {
2809 union pstun un;
2810 s = SvPV_const(sv, len);
2811 un.pst_command = (char *)s;
2812 pstat(PSTAT_SETCMD, un, len, 0, 0);
2813 }
2814#else
2815 if (PL_origalen > 1) {
4f3e04fd 2816 I32 i;
f1540bed
JH		 2817 /* PL_origalen is set in perl_parse(). */
2818 s = SvPV_force(sv,len);
2819 if (len >= (STRLEN)PL_origalen-1) {
2820 /* Longer than original, will be truncated. We assume that
2821 * PL_origalen bytes are available. */
2822 Copy(s, PL_origargv[0], PL_origalen-1, char);
2823 }
2824 else {
2825 /* Shorter than original, will be padded. */
2826#ifdef PERL_DARWIN
2827 /* Special case for Mac OS X: see [perl #38868] */
2828 const int pad = 0;
2829#else
2830 /* Is the space counterintuitive? Yes.
2831 * (You were expecting \0?)
2832 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2833 * --jhi */
2834 const int pad = ' ';
2835#endif
2836 Copy(s, PL_origargv[0], len, char);
2837 PL_origargv[0][len] = 0;
2838 memset(PL_origargv[0] + len + 1,
2839 pad, PL_origalen - len - 1);
2840 }
2841 PL_origargv[0][PL_origalen-1] = 0;
2842 for (i = 1; i < PL_origargc; i++)
2843 PL_origargv[i] = 0;
2844#ifdef HAS_PRCTL_SET_NAME
2845 /* Set the legacy process name in addition to the POSIX name on Linux */
2846 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2847 /* diag_listed_as: SKIPME */
2848 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2849 }
2850#endif
2851 }
2852#endif
2853}
2854
9cce4f9a 2855int
864dbfa3 2856Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
79072805 2857{
eb578fdb
KW		 2858 I32 paren;
2859 const REGEXP * rx;
79072805 2860 I32 i;
8990e307 2861 STRLEN len;
125b9982 2862 MAGIC *tmg;
2fdbfb4d 2863
7918f24d
NC		 2864 PERL_ARGS_ASSERT_MAGIC_SET;
2865
e91d8259 2866 if (!mg->mg_ptr) {
960b831f 2867 paren = mg->mg_len;
1604cfb0 2868 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
e91d8259 2869 setparen_got_rx:
fb15da9c 2870 CALLREG_NUMBUF_STORE((REGEXP *)rx,paren,sv);
1604cfb0 2871 } else {
2fdbfb4d
AB		 2872 /* Croak with a READONLY error when a numbered match var is
2873 * set without a previous pattern match. Unless it's C<local $1>
2874 */
e91d8259 2875 croakparen:
2fdbfb4d 2876 if (!PL_localizing) {
cb077ed2 2877 Perl_croak_no_modify();
2fdbfb4d
AB		 2878 }
2879 }
e91d8259
NC		 2880 return 0;
2881 }
2882
2883 switch (*mg->mg_ptr) {
748a9306 2884 case '\001': /* ^A */
1604cfb0
MS		 2885 if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2886 else SvOK_off(PL_bodytarget);
2887 FmLINES(PL_bodytarget) = 0;
2888 if (SvPOK(PL_bodytarget)) {
2889 char *s = SvPVX(PL_bodytarget);
0687887e 2890 char *e = SvEND(PL_bodytarget);
1604cfb0
MS		 2891 while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2892 FmLINES(PL_bodytarget)++;
2893 s++;
2894 }
2895 }
2896 /* mg_set() has temporarily made sv non-magical */
2897 if (TAINTING_get) {
2898 if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2899 SvTAINTED_on(PL_bodytarget);
2900 else
2901 SvTAINTED_off(PL_bodytarget);
2902 }
2903 break;
49460fe6 2904 case '\003': /* ^C */
1604cfb0
MS		 2905 PL_minus_c = cBOOL(SvIV(sv));
2906 break;
49460fe6 2907
79072805 2908 case '\004': /* ^D */
b4ab917c 2909#ifdef DEBUGGING
a9e2d2bf
DM		 2910 {
2911 const char *s = SvPV_nolen_const(sv);
2912 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2913 if (DEBUG_x_TEST || DEBUG_B_TEST)
2914 dump_all_perl(!DEBUG_B_TEST);
2915 }
b4ab917c 2916#else
1604cfb0 2917 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
b4ab917c 2918#endif
1604cfb0 2919 break;
28f23441 2920 case '\005': /* ^E */
1604cfb0 2921 if (*(mg->mg_ptr+1) == '\0') {
e37778c2 2922#ifdef VMS
1604cfb0 2923 set_vaxc_errno(SvIV(sv));
2abc681d 2924#elif defined(WIN32)
1604cfb0 2925 SetLastError( SvIV(sv) );
2abc681d 2926#elif defined(OS2)
1604cfb0 2927 os2_setsyserrno(SvIV(sv));
2abc681d 2928#else
1604cfb0
MS		 2929 /* will anyone ever use this? */
2930 SETERRNO(SvIV(sv), 4);
22fae026 2931#endif
1604cfb0
MS		 2932 }
2933 else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
fd503f5c 2934 Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
1604cfb0 2935 break;
79072805 2936 case '\006': /* ^F */
9f601cf3
TC		 2937 if (mg->mg_ptr[1] == '\0') {
2938 PL_maxsysfd = SvIV(sv);
2939 }
1604cfb0 2940 break;
a0d0e21e 2941 case '\010': /* ^H */
efa571ab
KW		 2942 {
2943 U32 save_hints = PL_hints;
5d382c25 2944 PL_hints = SvUV(sv);
efa571ab
KW		 2945
2946 /* If wasn't UTF-8, and now is, notify the parser */
2947 if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2948 notify_parser_that_changed_to_utf8();
2949 }
2950 }
1604cfb0 2951 break;
9d116dd7 2952 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1604cfb0
MS		 2953 Safefree(PL_inplace);
2954 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2955 break;
d9bad346 2956 case '\016': /* ^N */
1604cfb0
MS		 2957 if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2958 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2959 goto croakparen;
28f23441 2960 case '\017': /* ^O */
1604cfb0
MS		 2961 if (*(mg->mg_ptr+1) == '\0') {
2962 Safefree(PL_osname);
2963 PL_osname = NULL;
2964 if (SvOK(sv)) {
2965 TAINT_PROPER("assigning to $^O");
2966 PL_osname = savesvpv(sv);
2967 }
2968 }
2969 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2970 STRLEN len;
2971 const char *const start = SvPV(sv, len);
2972 const char *out = (const char*)memchr(start, '\0', len);
2973 SV *tmp;
2974
2975
2976 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2977 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2978
2979 /* Opening for input is more common than opening for output, so
2980 ensure that hints for input are sooner on linked list. */
2981 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2982 SvUTF8(sv))
2983 : newSVpvs_flags("", SvUTF8(sv));
2984 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2985 mg_set(tmp);
2986
2987 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2988 SvUTF8(sv));
2989 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2990 mg_set(tmp);
2991 }
2992 break;
79072805 2993 case '\020': /* ^P */
2fdbfb4d
AB		 2994 PL_perldb = SvIV(sv);
2995 if (PL_perldb && !PL_DBsingle)
2996 init_debugger();
9b9e0be4 2997 break;
79072805 2998 case '\024': /* ^T */
88e89b8a 2999#ifdef BIG_TIME
1604cfb0 3000 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
88e89b8a 3001#else
1604cfb0 3002 PL_basetime = (Time_t)SvIV(sv);
88e89b8a 3003#endif
1604cfb0 3004 break;
e07ea26a 3005 case '\025': /* ^UTF8CACHE */
1604cfb0
MS		 3006 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
3007 PL_utf8cache = (signed char) sv_2iv(sv);
3008 }
3009 break;
fde18df1 3010 case '\027': /* ^W & $^WARNING_BITS */
1604cfb0
MS		 3011 if (*(mg->mg_ptr+1) == '\0') {
3012 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3013 i = SvIV(sv);
3014 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
3015 | (i ? G_WARN_ON : G_WARN_OFF) ;
3016 }
3017 }
3018 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
3019 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3020 if (!SvPOK(sv)) {
1943af61 3021 free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
1604cfb0
MS		 3022 break;
3023 }
3024 {
3025 STRLEN len, i;
3026 int not_none = 0, not_all = 0;
3027 const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
3028 for (i = 0 ; i < len ; ++i) {
3029 not_none |= ptr[i];
3030 not_all |= ptr[i] ^ 0x55;
3031 }
3032 if (!not_none) {
1943af61 3033 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
1604cfb0 3034 } else if (len >= WARNsize && !not_all) {
1943af61 3035 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
1604cfb0
MS		 3036 PL_dowarn |= G_WARN_ONCE ;
3037 }
94c8b9c1 3038 else {
1604cfb0
MS		 3039 STRLEN len;
3040 const char *const p = SvPV_const(sv, len);
94c8b9c1 3041
1604cfb0
MS		 3042 PL_compiling.cop_warnings
3043 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
3044 p, len);
72dc9ed5 3045
1604cfb0
MS		 3046 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
3047 PL_dowarn |= G_WARN_ONCE ;
3048 }
f4fc7782 3049
1604cfb0
MS		 3050 }
3051 }
3052 }
3053 break;
79072805 3054 case '.':
1604cfb0
MS		 3055 if (PL_localizing) {
3056 if (PL_localizing == 1)
3057 SAVESPTR(PL_last_in_gv);
3058 }
3059 else if (SvOK(sv) && GvIO(PL_last_in_gv))
3060 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
3061 break;
79072805 3062 case '^':
1604cfb0
MS		 3063 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
3064 IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3065 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3066 break;
79072805 3067 case '~':
1604cfb0
MS		 3068 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
3069 IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3070 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3071 break;
79072805 3072 case '=':
1604cfb0
MS		 3073 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
3074 break;
79072805 3075 case '-':
1604cfb0
MS		 3076 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3077 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
3078 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
3079 break;
79072805 3080 case '%':
1604cfb0
MS		 3081 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
3082 break;
79072805 3083 case '|':
1604cfb0
MS		 3084 {
3085 IO * const io = GvIO(PL_defoutgv);
3086 if(!io)
3087 break;
3088 if ((SvIV(sv)) == 0)
3089 IoFLAGS(io) &= ~IOf_FLUSH;
3090 else {
3091 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3092 PerlIO *ofp = IoOFP(io);
3093 if (ofp)
3094 (void)PerlIO_flush(ofp);
3095 IoFLAGS(io) |= IOf_FLUSH;
3096 }
3097 }
3098 }
3099 break;
79072805 3100 case '/':
1ab48e3a 3101 {
1ab48e3a 3102 if (SvROK(sv)) {
8d37cdf7
DIM		 3103 SV *referent = SvRV(sv);
3104 const char *reftype = sv_reftype(referent, 0);
d239bea0
A		 3105 /* XXX: dodgy type check: This leaves me feeling dirty, but
3106 * the alternative is to copy pretty much the entire
3107 * sv_reftype() into this routine, or to do a full string
3108 * comparison on the return of sv_reftype() both of which
3109 * make me feel worse! NOTE, do not modify this comment
3110 * without reviewing the corresponding comment in
3111 * sv_reftype(). - Yves */
1ab48e3a 3112 if (reftype[0] == 'S' || reftype[0] == 'L') {
8d37cdf7 3113 IV val = SvIV(referent);
1ab48e3a 3114 if (val <= 0) {
520b6fb6
DIM		 3115 sv_setsv(sv, PL_rs);
3116 Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3117 val < 0 ? "a negative integer" : "zero");
1ab48e3a
YO		 3118 }
3119 } else {
ddce084a 3120 sv_setsv(sv, PL_rs);
8d37cdf7 3121 /* diag_listed_as: Setting $/ to %s reference is forbidden */
a48e4205
FC		 3122 Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3123 *reftype == 'A' ? "n" : "", reftype);
1ab48e3a
YO		 3124 }
3125 }
b3a2acfa 3126 SvREFCNT_dec(PL_rs);
520b6fb6 3127 PL_rs = newSVsv(sv);
b3a2acfa 3128 }
1604cfb0 3129 break;
79072805 3130 case '\\':
1604cfb0
MS		 3131 SvREFCNT_dec(PL_ors_sv);
3132 if (SvOK(sv)) {
3133 PL_ors_sv = newSVsv(sv);
3134 }
3135 else {
3136 PL_ors_sv = NULL;
3137 }
3138 break;
7d69d4a6 3139 case '[':
1604cfb0
MS		 3140 if (SvIV(sv) != 0)
3141 Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3142 break;
79072805 3143 case '?':
ff0cee69 3144#ifdef COMPLEX_STATUS
1604cfb0
MS		 3145 if (PL_localizing == 2) {
3146 SvUPGRADE(sv, SVt_PVLV);
3147 PL_statusvalue = LvTARGOFF(sv);
3148 PL_statusvalue_vms = LvTARGLEN(sv);
3149 }
3150 else
ff0cee69 3151#endif
3152#ifdef VMSISH_STATUS
1604cfb0
MS		 3153 if (VMSISH_STATUS)
3154 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3155 else
ff0cee69 3156#endif
1604cfb0
MS		 3157 STATUS_UNIX_EXIT_SET(SvIV(sv));
3158 break;
79072805 3159 case '!':
93189314
JH		 3160 {
3161#ifdef VMS
3162# define PERL_VMS_BANG vaxc$errno
3163#else
3164# define PERL_VMS_BANG 0
3165#endif
79c32fc2 3166#if defined(WIN32)
1604cfb0
MS		 3167 SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3168 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
c9beaf97 3169#else
1604cfb0
MS		 3170 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3171 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
c9beaf97 3172#endif
1604cfb0
MS		 3173 }
3174 break;
79072805 3175 case '<':
1604cfb0 3176 {
b469f1e0 3177 /* XXX $< currently silently ignores failures */
1604cfb0
MS		 3178 const Uid_t new_uid = SvUID(sv);
3179 PL_delaymagic_uid = new_uid;
3180 if (PL_delaymagic) {
3181 PL_delaymagic |= DM_RUID;
3182 break; /* don't do magic till later */
3183 }
79072805 3184#ifdef HAS_SETRUID
1604cfb0 3185 PERL_UNUSED_RESULT(setruid(new_uid));
2abc681d 3186#elif defined(HAS_SETREUID)
b469f1e0 3187 PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
2abc681d 3188#elif defined(HAS_SETRESUID)
b469f1e0 3189 PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
79072805 3190#else
1604cfb0 3191 if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
2abc681d 3192# ifdef PERL_DARWIN
1604cfb0
MS		 3193 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3194 if (new_uid != 0 && PerlProc_getuid() == 0)
b469f1e0 3195 PERL_UNUSED_RESULT(PerlProc_setuid(0));
2abc681d 3196# endif
b469f1e0 3197 PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
1604cfb0
MS		 3198 } else {
3199 Perl_croak(aTHX_ "setruid() not implemented");
3200 }
79072805 3201#endif
1604cfb0
MS		 3202 break;
3203 }
79072805 3204 case '>':
1604cfb0 3205 {
b469f1e0 3206 /* XXX $> currently silently ignores failures */
1604cfb0
MS		 3207 const Uid_t new_euid = SvUID(sv);
3208 PL_delaymagic_euid = new_euid;
3209 if (PL_delaymagic) {
3210 PL_delaymagic |= DM_EUID;
3211 break; /* don't do magic till later */
3212 }
79072805 3213#ifdef HAS_SETEUID
1604cfb0 3214 PERL_UNUSED_RESULT(seteuid(new_euid));
2abc681d 3215#elif defined(HAS_SETREUID)
1604cfb0 3216 PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
2abc681d 3217#elif defined(HAS_SETRESUID)
1604cfb0 3218 PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
79072805 3219#else
1604cfb0
MS		 3220 if (new_euid == PerlProc_getuid()) /* special case $> = $< */
3221 PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3222 else {
3223 Perl_croak(aTHX_ "seteuid() not implemented");
3224 }
3225#endif
3226 break;
3227 }
79072805 3228 case '(':
1604cfb0 3229 {
b469f1e0 3230 /* XXX $( currently silently ignores failures */
1604cfb0
MS		 3231 const Gid_t new_gid = SvGID(sv);
3232 PL_delaymagic_gid = new_gid;
3233 if (PL_delaymagic) {
3234 PL_delaymagic |= DM_RGID;
3235 break; /* don't do magic till later */
3236 }
79072805 3237#ifdef HAS_SETRGID
1604cfb0 3238 PERL_UNUSED_RESULT(setrgid(new_gid));
2abc681d 3239#elif defined(HAS_SETREGID)
1604cfb0 3240 PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
2abc681d 3241#elif defined(HAS_SETRESGID)
b469f1e0 3242 PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
79072805 3243#else
1604cfb0
MS		 3244 if (new_gid == PerlProc_getegid()) /* special case $( = $) */
3245 PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3246 else {
3247 Perl_croak(aTHX_ "setrgid() not implemented");
3248 }
3249#endif
3250 break;
3251 }
79072805 3252 case ')':
1604cfb0 3253 {
0635704a
HS		 3254/* (hv) best guess: maybe we'll need configure probes to do a better job,
3255 * but you can override it if you need to.
3256 */
3257#ifndef INVALID_GID
3258#define INVALID_GID ((Gid_t)-1)
3259#endif
b469f1e0 3260 /* XXX $) currently silently ignores failures */
1604cfb0 3261 Gid_t new_egid;
5cd24f17 3262#ifdef HAS_SETGROUPS
1604cfb0
MS		 3263 {
3264 const char *p = SvPV_const(sv, len);
757f63d8 3265 Groups_t *gary = NULL;
79e302e6
MM		 3266 const char* p_end = p + len;
3267 const char* endptr = p_end;
22ff3130 3268 UV uv;
fb4089e0 3269#ifdef _SC_NGROUPS_MAX
3270 int maxgrp = sysconf(_SC_NGROUPS_MAX);
3271
3272 if (maxgrp < 0)
3273 maxgrp = NGROUPS;
3274#else
3275 int maxgrp = NGROUPS;
3276#endif
757f63d8
SP		 3277
3278 while (isSPACE(*p))
3279 ++p;
22ff3130
HS		 3280 if (grok_atoUV(p, &uv, &endptr))
3281 new_egid = (Gid_t)uv;
3282 else {
0635704a 3283 new_egid = INVALID_GID;
22ff3130
HS		 3284 endptr = NULL;
3285 }
fb4089e0 3286 for (i = 0; i < maxgrp; ++i) {
fdadaf77
JH		 3287 if (endptr == NULL)
3288 break;
3289 p = endptr;
79e302e6 3290 endptr = p_end;
757f63d8
SP		 3291 while (isSPACE(*p))
3292 ++p;
3293 if (!*p)
3294 break;
fdadaf77 3295 if (!gary)
757f63d8
SP		 3296 Newx(gary, i + 1, Groups_t);
3297 else
3298 Renew(gary, i + 1, Groups_t);
22ff3130
HS		 3299 if (grok_atoUV(p, &uv, &endptr))
3300 gary[i] = (Groups_t)uv;
3301 else {
0635704a 3302 gary[i] = INVALID_GID;
22ff3130
HS		 3303 endptr = NULL;
3304 }
757f63d8
SP		 3305 }
3306 if (i)
b469f1e0 3307 PERL_UNUSED_RESULT(setgroups(i, gary));
1604cfb0
MS		 3308 Safefree(gary);
3309 }
5cd24f17 3310#else /* HAS_SETGROUPS */
dfff4baf 3311 new_egid = SvGID(sv);
5cd24f17 3312#endif /* HAS_SETGROUPS */
1604cfb0
MS		 3313 PL_delaymagic_egid = new_egid;
3314 if (PL_delaymagic) {
3315 PL_delaymagic |= DM_EGID;
3316 break; /* don't do magic till later */
3317 }
79072805 3318#ifdef HAS_SETEGID
1604cfb0 3319 PERL_UNUSED_RESULT(setegid(new_egid));
2abc681d 3320#elif defined(HAS_SETREGID)
1604cfb0 3321 PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
2abc681d 3322#elif defined(HAS_SETRESGID)
1604cfb0 3323 PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
79072805 3324#else
1604cfb0
MS		 3325 if (new_egid == PerlProc_getgid()) /* special case $) = $( */
3326 PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3327 else {
3328 Perl_croak(aTHX_ "setegid() not implemented");
3329 }
3330#endif
3331 break;
3332 }
79072805 3333 case ':':
1604cfb0
MS		 3334 PL_chopset = SvPV_force(sv,len);
3335 break;
9cdac2a2 3336 case '$': /* $$ */
1604cfb0
MS		 3337 /* Store the pid in mg->mg_obj so we can tell when a fork has
3338 occurred. mg->mg_obj points to *$ by default, so clear it. */
3339 if (isGV(mg->mg_obj)) {
3340 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3341 SvREFCNT_dec(mg->mg_obj);
3342 mg->mg_flags |= MGf_REFCOUNTED;
3343 mg->mg_obj = newSViv((IV)PerlProc_getpid());
3344 }
3345 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3346 break;
79072805 3347 case '0':
2d3b3561
FG		 3348 if (!sv_utf8_downgrade(sv, /* fail_ok */ TRUE)) {
3349
3350 /* Since we are going to set the string's UTF8-encoded form
3351 as the process name we should update $0 itself to contain
3352 that same (UTF8-encoded) value. */
3353 sv_utf8_encode(GvSV(mg->mg_obj));
3354
3355 Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "$0");
3356 }
3357
1604cfb0 3358 LOCK_DOLLARZERO_MUTEX;
f1540bed 3359 S_set_dollarzero(aTHX_ sv);
1604cfb0
MS		 3360 UNLOCK_DOLLARZERO_MUTEX;
3361 break;
79072805
LW		 3362 }
3363 return 0;
3364}
3365
ea81552b 3366/*
3f620621 3367=for apidoc_section $signals
ea81552b
KW		 3368=for apidoc whichsig
3369=for apidoc_item whichsig_pv
3370=for apidoc_item whichsig_pvn
3371=for apidoc_item whichsig_sv
3372
3373These all convert a signal name into its corresponding signal number;
3374returning -1 if no corresponding number was found.
3375
3376They differ only in the source of the signal name:
3377
3378C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at
3379C<sig>.
3380
3381C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>.
3382
3383C<whichsig_pvn> takes the name from the string starting at C<sig>, with length
3384C<len> bytes.
3385
3386C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>.
3387
3388=cut
3389*/
3390
79072805 3391I32
84c7b88c
BF		 3392Perl_whichsig_sv(pTHX_ SV *sigsv)
3393{
3394 const char *sigpv;
3395 STRLEN siglen;
3396 PERL_ARGS_ASSERT_WHICHSIG_SV;
84c7b88c
BF		 3397 sigpv = SvPV_const(sigsv, siglen);
3398 return whichsig_pvn(sigpv, siglen);
3399}
3400
3401I32
3402Perl_whichsig_pv(pTHX_ const char *sig)
3403{
3404 PERL_ARGS_ASSERT_WHICHSIG_PV;
84c7b88c
BF		 3405 return whichsig_pvn(sig, strlen(sig));
3406}
3407
3408I32
3409Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
79072805 3410{
eb578fdb 3411 char* const* sigv;
7918f24d 3412
84c7b88c 3413 PERL_ARGS_ASSERT_WHICHSIG_PVN;
96a5add6 3414 PERL_UNUSED_CONTEXT;
79072805 3415
aadb217d 3416 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
1604cfb0
MS		 3417 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3418 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805 3419#ifdef SIGCLD
84c7b88c 3420 if (memEQs(sig, len, "CHLD"))
1604cfb0 3421 return SIGCLD;
79072805
LW		 3422#endif
3423#ifdef SIGCHLD
84c7b88c 3424 if (memEQs(sig, len, "CLD"))
1604cfb0 3425 return SIGCHLD;
79072805 3426#endif
7f1236c0 3427 return -1;
79072805
LW		 3428}
3429
dc37125b
DM		 3430
3431/* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
3432 * these three function are intended to be called by the OS as 'C' level
3433 * signal handler functions in the case where unsafe signals are being
3434 * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
3435 * perl-level sighandler, rather than deferring.
3436 * In fact, the core itself will normally use Perl_csighandler as the
3437 * OS-level handler; that function will then decide whether to queue the
3438 * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
3439 * functions are more useful for e.g. POSIX.xs when it wants explicit
3440 * control of what's happening.
3441 */
3442
3443
5e7940ce 3444#ifdef PERL_USE_3ARG_SIGHANDLER
8a5e470b
DM		 3445
3446Signal_t
e7124897 3447Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
8a5e470b
DM		 3448{
3449 Perl_perly_sighandler(sig, sip, uap, 0);
3450}
3451
1e82f5a6 3452#else
8a5e470b
DM		 3453
3454Signal_t
1e82f5a6 3455Perl_sighandler(int sig)
8a5e470b
DM		 3456{
3457 Perl_perly_sighandler(sig, NULL, NULL, 0);
3458}
3459
1e82f5a6 3460#endif
8a5e470b 3461
dc37125b
DM		 3462Signal_t
3463Perl_sighandler1(int sig)
3464{
3465 Perl_perly_sighandler(sig, NULL, NULL, 0);
3466}
3467
3468Signal_t
3469Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
3470{
3471 Perl_perly_sighandler(sig, sip, uap, 0);
3472}
3473
3474
8a5e470b
DM		 3475/* Invoke the perl-level signal handler. This function is called either
3476 * directly from one of the C-level signals handlers (Perl_sighandler or
3477 * Perl_csighandler), or for safe signals, later from
3478 * Perl_despatch_signals() at a suitable safe point during execution.
3479 *
3480 * 'safe' is a boolean indicating the latter call path.
3481 */
3482
3483Signal_t
3484Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
3485 void *uap PERL_UNUSED_DECL, bool safe)
79072805 3486{
1018e26f
NIS		 3487#ifdef PERL_GET_SIG_CONTEXT
3488 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 3489#else
cea2e8a9 3490 dTHX;
71d280e3 3491#endif
79072805 3492 dSP;
a0714e2c
SS		 3493 GV *gv = NULL;
3494 SV *sv = NULL;
8772537c 3495 SV * const tSv = PL_Sv;
601f1833 3496 CV *cv = NULL;
533c011a 3497 OP *myop = PL_op;
84902520 3498 U32 flags = 0;
8772537c 3499 XPV * const tXpv = PL_Xpv;
0c4d3b5e 3500 I32 old_ss_ix = PL_savestack_ix;
100c03aa 3501 SV *errsv_save = NULL;
71d280e3 3502
84902520 3503
727405f8 3504 if (!PL_psig_ptr[sig]) {
1604cfb0
MS		 3505 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3506 PL_sig_name[sig]);
3507 exit(sig);
3508 }
ff0cee69 3509
a0d63a7b 3510 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
1604cfb0
MS		 3511 /* Max number of items pushed there is 3*n or 4. We cannot fix
3512 infinity, so we fix 4 (in fact 5): */
3513 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3514 flags |= 1;
3515 PL_savestack_ix += 5; /* Protect save in progress. */
3516 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3517 }
84902520 3518 }
84902520 3519 /* sv_2cv is too complicated, try a simpler variant first: */
ea726b52 3520 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
1604cfb0
MS		 3521 || SvTYPE(cv) != SVt_PVCV) {
3522 HV *st;
3523 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 3524 }
84902520 3525
a0d0e21e 3526 if (!cv || !CvROOT(cv)) {
1604cfb0
MS		 3527 const HEK * const hek = gv
3528 ? GvENAME_HEK(gv)
3529 : cv && CvNAMED(cv)
3530 ? CvNAME_HEK(cv)
3531 : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3532 if (hek)
3533 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3534 "SIG%s handler \"%" HEKf "\" not defined.\n",
3535 PL_sig_name[sig], HEKfARG(hek));
3536 /* diag_listed_as: SIG%s handler "%s" not defined */
3537 else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3538 "SIG%s handler \"__ANON__\" not defined.\n",
3539 PL_sig_name[sig]);
3540 goto cleanup;
79072805
LW		 3541 }
3542
0c4d3b5e 3543 sv = PL_psig_name[sig]
1604cfb0
MS		 3544 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3545 : newSVpv(PL_sig_name[sig],0);
72048cfe 3546 flags |= 8;
0c4d3b5e
DM		 3547 SAVEFREESV(sv);
3548
a0d63a7b 3549 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
1604cfb0
MS		 3550 /* make sure our assumption about the size of the SAVEs are correct:
3551 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3552 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
a0d63a7b 3553 }
e336de0d 3554
e788e7d3 3555 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 3556 PUSHMARK(SP);
79072805 3557 PUSHs(sv);
dc43527e 3558
8aad04aa
JH		 3559#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3560 {
1604cfb0 3561 struct sigaction oact;
8aad04aa 3562
1604cfb0 3563 if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
dc43527e
DM		 3564 HV *sih = newHV();
3565 SV *rv = newRV_noinc(MUTABLE_SV(sih));
3566 /* The siginfo fields signo, code, errno, pid, uid,
3567 * addr, status, and band are defined by POSIX/SUSv3. */
3568 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3569 (void)hv_stores(sih, "code", newSViv(sip->si_code));
3570# ifdef HAS_SIGINFO_SI_ERRNO
3571 (void)hv_stores(sih, "errno", newSViv(sip->si_errno));
3572# endif
3573# ifdef HAS_SIGINFO_SI_STATUS
3574 (void)hv_stores(sih, "status", newSViv(sip->si_status));
3575# endif
3576# ifdef HAS_SIGINFO_SI_UID
3577 {
3578 SV *uid = newSV(0);
3579 sv_setuid(uid, sip->si_uid);
3580 (void)hv_stores(sih, "uid", uid);
3581 }
3582# endif
3583# ifdef HAS_SIGINFO_SI_PID
3584 (void)hv_stores(sih, "pid", newSViv(sip->si_pid));
3585# endif
3586# ifdef HAS_SIGINFO_SI_ADDR
3587 (void)hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3588# endif
3589# ifdef HAS_SIGINFO_SI_BAND
3590 (void)hv_stores(sih, "band", newSViv(sip->si_band));
3591# endif
3592 EXTEND(SP, 2);
3593 PUSHs(rv);
3594 mPUSHp((char *)sip, sizeof(*sip));
b4552a27 3595
1604cfb0 3596 }
8aad04aa
JH		 3597 }
3598#endif
dc43527e 3599
79072805 3600 PUTBACK;
a0d0e21e 3601
100c03aa
JL		 3602 errsv_save = newSVsv(ERRSV);
3603
ad64d0ec 3604 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
79072805 3605
d3acc0f7 3606 POPSTACK;
eed484f9 3607 {
1604cfb0
MS		 3608 SV * const errsv = ERRSV;
3609 if (SvTRUE_NN(errsv)) {
3610 SvREFCNT_dec(errsv_save);
dc43527e 3611
c22d665b 3612#ifndef PERL_MICRO
dc43527e
DM		 3613 /* Handler "died", for example to get out of a restart-able read().
3614 * Before we re-do that on its behalf re-enable the signal which was
3615 * blocked by the system when we entered.
3616 */
3617# ifdef HAS_SIGPROCMASK
1604cfb0 3618 if (!safe) {
8a5e470b
DM		 3619 /* safe signals called via dispatch_signals() set up a
3620 * savestack destructor, unblock_sigmask(), to
3621 * automatically unblock the handler at the end. If
3622 * instead we get here directly, we have to do it
3623 * ourselves
3624 */
1604cfb0
MS		 3625 sigset_t set;
3626 sigemptyset(&set);
3627 sigaddset(&set,sig);
3628 sigprocmask(SIG_UNBLOCK, &set, NULL);
3629 }
dc43527e 3630# else
1604cfb0 3631 /* Not clear if this will work */
8a5e470b
DM		 3632 /* XXX not clear if this should be protected by 'if (safe)'
3633 * too */
3634
1604cfb0
MS		 3635 (void)rsignal(sig, SIG_IGN);
3636 (void)rsignal(sig, PL_csighandlerp);
dc43527e 3637# endif
c22d665b 3638#endif /* !PERL_MICRO */
dc43527e 3639
1604cfb0
MS		 3640 die_sv(errsv);
3641 }
3642 else {
3643 sv_setsv(errsv, errsv_save);
3644 SvREFCNT_dec(errsv_save);
3645 }
100c03aa
JL		 3646 }
3647
7b52d656 3648 cleanup:
0c4d3b5e
DM		 3649 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3650 PL_savestack_ix = old_ss_ix;
72048cfe 3651 if (flags & 8)
1604cfb0 3652 SvREFCNT_dec_NN(sv);
533c011a 3653 PL_op = myop; /* Apparently not needed... */
ac27b0f5 3654
3280af22
NIS		 3655 PL_Sv = tSv; /* Restore global temporaries. */
3656 PL_Xpv = tXpv;
53bb94e2 3657 return;
79072805 3658}
4e35701f
NIS		 3659
3660
51371543 3661static void
8772537c 3662S_restore_magic(pTHX_ const void *p)
51371543 3663{
8772537c
AL		 3664 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3665 SV* const sv = mgs->mgs_sv;
150b625d 3666 bool bumped;
51371543
GS		 3667
3668 if (!sv)
3669 return;
3670
4bac9ae4 3671 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
1604cfb0
MS		 3672 SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3673 if (mgs->mgs_flags)
3674 SvFLAGS(sv) |= mgs->mgs_flags;
3675 else
3676 mg_magical(sv);
51371543
GS		 3677 }
3678
150b625d 3679 bumped = mgs->mgs_bumped;
51371543
GS		 3680 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3681
3682 /* If we're still on top of the stack, pop us off. (That condition
3683 * will be satisfied if restore_magic was called explicitly, but *not*
3684 * if it's being called via leave_scope.)
3685 * The reason for doing this is that otherwise, things like sv_2cv()
3686 * may leave alloc gunk on the savestack, and some code
3687 * (e.g. sighandler) doesn't expect that...
3688 */
3689 if (PL_savestack_ix == mgs->mgs_ss_ix)
3690 {
1604cfb0 3691 UV popval = SSPOPUV;
1be36ce0 3692 assert(popval == SAVEt_DESTRUCTOR_X);
51371543 3693 PL_savestack_ix -= 2;
1604cfb0 3694 popval = SSPOPUV;
1be36ce0
NC		 3695 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3696 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
51371543 3697 }
150b625d 3698 if (bumped) {
1604cfb0
MS		 3699 if (SvREFCNT(sv) == 1) {
3700 /* We hold the last reference to this SV, which implies that the
3701 SV was deleted as a side effect of the routines we called.
3702 So artificially keep it alive a bit longer.
3703 We avoid turning on the TEMP flag, which can cause the SV's
3704 buffer to get stolen (and maybe other stuff). */
3705 sv_2mortal(sv);
3706 SvTEMP_off(sv);
3707 }
3708 else
3709 SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
8985fe98 3710 }
51371543
GS		 3711}
3712
0c4d3b5e
DM		 3713/* clean up the mess created by Perl_sighandler().
3714 * Note that this is only called during an exit in a signal handler;
3715 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
9a7f166c 3716 * skipped over. */
0c4d3b5e 3717
51371543 3718static void
8772537c 3719S_unwind_handler_stack(pTHX_ const void *p)
51371543 3720{
0c4d3b5e 3721 PERL_UNUSED_ARG(p);
7918f24d 3722
0c4d3b5e 3723 PL_savestack_ix -= 5; /* Unprotect save in progress. */
51371543 3724}
1018e26f 3725
66610fdd 3726/*
3f620621 3727=for apidoc_section $magic
b3ca2e83
NC		 3728=for apidoc magic_sethint
3729
796b6530 3730Triggered by a store to C<%^H>, records the key/value pair to
c28fe1ec
NC		 3731C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3732anything that would need a deep copy. Maybe we should warn if we find a
3733reference.
b3ca2e83
NC		 3734
3735=cut
3736*/
3737int
3738Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3739{
ad64d0ec 3740 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
1604cfb0 3741 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
b3ca2e83 3742
7918f24d
NC		 3743 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3744
e6e3e454
NC		 3745 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3746 an alternative leaf in there, with PL_compiling.cop_hints being used if
3747 it's NULL. If needed for threads, the alternative could lock a mutex,
3748 or take other more complex action. */
3749
5b9c0671
NC		 3750 /* Something changed in %^H, so it will need to be restored on scope exit.
3751 Doing this here saves a lot of doing it manually in perl code (and
3752 forgetting to do it, and consequent subtle errors. */
3753 PL_hints |= HINT_LOCALIZE_HH;
20439bc7 3754 CopHINTHASH_set(&PL_compiling,
1604cfb0 3755 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
b34c1a7e 3756 magic_sethint_feature(key, NULL, 0, sv, 0);
b3ca2e83
NC		 3757 return 0;
3758}
3759
3760/*
f175cff5 3761=for apidoc magic_clearhint
b3ca2e83 3762
796b6530 3763Triggered by a delete from C<%^H>, records the key to
c28fe1ec 3764C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC		 3765
3766=cut
3767*/
3768int
3769Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3770{
7918f24d 3771 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
f5a63d97
AL		 3772 PERL_UNUSED_ARG(sv);
3773
5b9c0671 3774 PL_hints |= HINT_LOCALIZE_HH;
20439bc7 3775 CopHINTHASH_set(&PL_compiling,
1604cfb0
MS		 3776 mg->mg_len == HEf_SVKEY
3777 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3778 MUTABLE_SV(mg->mg_ptr), 0, 0)
3779 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3780 mg->mg_ptr, mg->mg_len, 0, 0));
b34c1a7e
TC		 3781 if (mg->mg_len == HEf_SVKEY)
3782 magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
3783 else
3784 magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
b3ca2e83
NC		 3785 return 0;
3786}
3787
3788/*
f747ebd6
Z		 3789=for apidoc magic_clearhints
3790
796b6530 3791Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
f747ebd6
Z		 3792
3793=cut
3794*/
3795int
3796Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3797{
3798 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3799 PERL_UNUSED_ARG(sv);
3800 PERL_UNUSED_ARG(mg);
20439bc7
Z		 3801 cophh_free(CopHINTHASH_get(&PL_compiling));
3802 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
b34c1a7e 3803 CLEARFEATUREBITS();
f747ebd6
Z		 3804 return 0;
3805}
3806
09fb282d
FC		 3807int
3808Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
1604cfb0 3809 const char *name, I32 namlen)
09fb282d
FC		 3810{
3811 MAGIC *nmg;
3812
3813 PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
4f8dbb2d 3814 PERL_UNUSED_ARG(sv);
09fb282d
FC		 3815 PERL_UNUSED_ARG(name);
3816 PERL_UNUSED_ARG(namlen);
3817
3818 sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3819 nmg = mg_find(nsv, mg->mg_type);
316ebaf2 3820 assert(nmg);
09fb282d
FC		 3821 if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3822 nmg->mg_ptr = mg->mg_ptr;
3823 nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3824 nmg->mg_flags |= MGf_REFCOUNTED;
3825 return 1;
3826}
3827
a6d69523
TC		 3828int
3829Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3830 PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3831
23270f96
DM		 3832#if DBVARMG_SINGLE != 0
3833 assert(mg->mg_private >= DBVARMG_SINGLE);
3834#endif
3835 assert(mg->mg_private < DBVARMG_COUNT);
a6d69523
TC		 3836
3837 PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3838
3839 return 1;
3840}
3841
3842int
3843Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3844 PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3845
23270f96
DM		 3846#if DBVARMG_SINGLE != 0
3847 assert(mg->mg_private >= DBVARMG_SINGLE);
3848#endif
3849 assert(mg->mg_private < DBVARMG_COUNT);
a6d69523
TC		 3850 sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3851
3852 return 0;
3853}
3854
f747ebd6 3855/*
14d04a33 3856 * ex: set ts=8 sts=4 sw=4 et:
37442d52 3857 */
Unnamed repository; edit this file 'description' to name the repository.