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