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