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