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