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