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