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