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