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