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