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