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