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