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