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