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