This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add t/porting/pending-author.t, fixing a limitation of t/porting/authors.t
[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 '<':
3280af22 1112 sv_setiv(sv, (IV)PL_uid);
79072805
LW
1113 break;
1114 case '>':
3280af22 1115 sv_setiv(sv, (IV)PL_euid);
79072805
LW
1116 break;
1117 case '(':
3280af22 1118 sv_setiv(sv, (IV)PL_gid);
79072805
LW
1119 goto add_groups;
1120 case ')':
3280af22 1121 sv_setiv(sv, (IV)PL_egid);
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 '<':
38ab35f8 2798 PL_uid = SvIV(sv);
3280af22
NIS
2799 if (PL_delaymagic) {
2800 PL_delaymagic |= DM_RUID;
79072805
LW
2801 break; /* don't do magic till later */
2802 }
2803#ifdef HAS_SETRUID
b28d0864 2804 (void)setruid((Uid_t)PL_uid);
79072805
LW
2805#else
2806#ifdef HAS_SETREUID
3280af22 2807 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
748a9306 2808#else
85e6fe83 2809#ifdef HAS_SETRESUID
b28d0864 2810 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
79072805 2811#else
75870ed3 2812 if (PL_uid == PL_euid) { /* special case $< = $> */
2813#ifdef PERL_DARWIN
2814 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2815 if (PL_uid != 0 && PerlProc_getuid() == 0)
2816 (void)PerlProc_setuid(0);
2817#endif
b28d0864 2818 (void)PerlProc_setuid(PL_uid);
75870ed3 2819 } else {
d8eceb89 2820 PL_uid = PerlProc_getuid();
cea2e8a9 2821 Perl_croak(aTHX_ "setruid() not implemented");
a0d0e21e 2822 }
79072805
LW
2823#endif
2824#endif
85e6fe83 2825#endif
d8eceb89 2826 PL_uid = PerlProc_getuid();
79072805
LW
2827 break;
2828 case '>':
38ab35f8 2829 PL_euid = SvIV(sv);
3280af22
NIS
2830 if (PL_delaymagic) {
2831 PL_delaymagic |= DM_EUID;
79072805
LW
2832 break; /* don't do magic till later */
2833 }
2834#ifdef HAS_SETEUID
3280af22 2835 (void)seteuid((Uid_t)PL_euid);
79072805
LW
2836#else
2837#ifdef HAS_SETREUID
b28d0864 2838 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
85e6fe83
LW
2839#else
2840#ifdef HAS_SETRESUID
6b88bc9c 2841 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
79072805 2842#else
b28d0864
NIS
2843 if (PL_euid == PL_uid) /* special case $> = $< */
2844 PerlProc_setuid(PL_euid);
a0d0e21e 2845 else {
e8ee3774 2846 PL_euid = PerlProc_geteuid();
cea2e8a9 2847 Perl_croak(aTHX_ "seteuid() not implemented");
a0d0e21e 2848 }
79072805
LW
2849#endif
2850#endif
85e6fe83 2851#endif
d8eceb89 2852 PL_euid = PerlProc_geteuid();
79072805
LW
2853 break;
2854 case '(':
38ab35f8 2855 PL_gid = SvIV(sv);
3280af22
NIS
2856 if (PL_delaymagic) {
2857 PL_delaymagic |= DM_RGID;
79072805
LW
2858 break; /* don't do magic till later */
2859 }
2860#ifdef HAS_SETRGID
b28d0864 2861 (void)setrgid((Gid_t)PL_gid);
79072805
LW
2862#else
2863#ifdef HAS_SETREGID
3280af22 2864 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
85e6fe83
LW
2865#else
2866#ifdef HAS_SETRESGID
a058c516 2867 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1);
79072805 2868#else
b28d0864
NIS
2869 if (PL_gid == PL_egid) /* special case $( = $) */
2870 (void)PerlProc_setgid(PL_gid);
748a9306 2871 else {
d8eceb89 2872 PL_gid = PerlProc_getgid();
cea2e8a9 2873 Perl_croak(aTHX_ "setrgid() not implemented");
748a9306 2874 }
79072805
LW
2875#endif
2876#endif
85e6fe83 2877#endif
d8eceb89 2878 PL_gid = PerlProc_getgid();
79072805
LW
2879 break;
2880 case ')':
5cd24f17
PP
2881#ifdef HAS_SETGROUPS
2882 {
b83604b4 2883 const char *p = SvPV_const(sv, len);
757f63d8 2884 Groups_t *gary = NULL;
fb4089e0 2885#ifdef _SC_NGROUPS_MAX
2886 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2887
2888 if (maxgrp < 0)
2889 maxgrp = NGROUPS;
2890#else
2891 int maxgrp = NGROUPS;
2892#endif
757f63d8
SP
2893
2894 while (isSPACE(*p))
2895 ++p;
2896 PL_egid = Atol(p);
fb4089e0 2897 for (i = 0; i < maxgrp; ++i) {
757f63d8
SP
2898 while (*p && !isSPACE(*p))
2899 ++p;
2900 while (isSPACE(*p))
2901 ++p;
2902 if (!*p)
2903 break;
2904 if(!gary)
2905 Newx(gary, i + 1, Groups_t);
2906 else
2907 Renew(gary, i + 1, Groups_t);
2908 gary[i] = Atol(p);
2909 }
2910 if (i)
2911 (void)setgroups(i, gary);
f5a63d97 2912 Safefree(gary);
5cd24f17
PP
2913 }
2914#else /* HAS_SETGROUPS */
38ab35f8 2915 PL_egid = SvIV(sv);
5cd24f17 2916#endif /* HAS_SETGROUPS */
3280af22
NIS
2917 if (PL_delaymagic) {
2918 PL_delaymagic |= DM_EGID;
79072805
LW
2919 break; /* don't do magic till later */
2920 }
2921#ifdef HAS_SETEGID
3280af22 2922 (void)setegid((Gid_t)PL_egid);
79072805
LW
2923#else
2924#ifdef HAS_SETREGID
b28d0864 2925 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
85e6fe83
LW
2926#else
2927#ifdef HAS_SETRESGID
b28d0864 2928 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
79072805 2929#else
b28d0864
NIS
2930 if (PL_egid == PL_gid) /* special case $) = $( */
2931 (void)PerlProc_setgid(PL_egid);
748a9306 2932 else {
d8eceb89 2933 PL_egid = PerlProc_getegid();
cea2e8a9 2934 Perl_croak(aTHX_ "setegid() not implemented");
748a9306 2935 }
79072805
LW
2936#endif
2937#endif
85e6fe83 2938#endif
d8eceb89 2939 PL_egid = PerlProc_getegid();
79072805
LW
2940 break;
2941 case ':':
2d8e6c8d 2942 PL_chopset = SvPV_force(sv,len);
79072805 2943 break;
9cdac2a2
FC
2944 case '$': /* $$ */
2945 /* Store the pid in mg->mg_obj so we can tell when a fork has
2946 occurred. mg->mg_obj points to *$ by default, so clear it. */
2947 if (isGV(mg->mg_obj)) {
2948 if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
2949 SvREFCNT_dec(mg->mg_obj);
2950 mg->mg_flags |= MGf_REFCOUNTED;
2951 mg->mg_obj = newSViv((IV)PerlProc_getpid());
2952 }
2953 else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
2954 break;
79072805 2955 case '0':
e2975953 2956 LOCK_DOLLARZERO_MUTEX;
4bc88a62
PS
2957#ifdef HAS_SETPROCTITLE
2958 /* The BSDs don't show the argv[] in ps(1) output, they
2959 * show a string from the process struct and provide
2960 * the setproctitle() routine to manipulate that. */
a2722ac9 2961 if (PL_origalen != 1) {
b83604b4 2962 s = SvPV_const(sv, len);
98b76f99 2963# if __FreeBSD_version > 410001
9aad2c0e 2964 /* The leading "-" removes the "perl: " prefix,
4bc88a62
PS
2965 * but not the "(perl) suffix from the ps(1)
2966 * output, because that's what ps(1) shows if the
2967 * argv[] is modified. */
6f2ad931 2968 setproctitle("-%s", s);
9aad2c0e 2969# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
4bc88a62
PS
2970 /* This doesn't really work if you assume that
2971 * $0 = 'foobar'; will wipe out 'perl' from the $0
2972 * because in ps(1) output the result will be like
2973 * sprintf("perl: %s (perl)", s)
2974 * I guess this is a security feature:
2975 * one (a user process) cannot get rid of the original name.
2976 * --jhi */
2977 setproctitle("%s", s);
2978# endif
2979 }
9d3968b2 2980#elif defined(__hpux) && defined(PSTAT_SETCMD)
a2722ac9 2981 if (PL_origalen != 1) {
17aa7f3d 2982 union pstun un;
b83604b4 2983 s = SvPV_const(sv, len);
6867be6d 2984 un.pst_command = (char *)s;
17aa7f3d
JH
2985 pstat(PSTAT_SETCMD, un, len, 0, 0);
2986 }
9d3968b2 2987#else
2d2af554
GA
2988 if (PL_origalen > 1) {
2989 /* PL_origalen is set in perl_parse(). */
2990 s = SvPV_force(sv,len);
2991 if (len >= (STRLEN)PL_origalen-1) {
2992 /* Longer than original, will be truncated. We assume that
2993 * PL_origalen bytes are available. */
2994 Copy(s, PL_origargv[0], PL_origalen-1, char);
2995 }
2996 else {
2997 /* Shorter than original, will be padded. */
235ac35d 2998#ifdef PERL_DARWIN
60777a0d
JH
2999 /* Special case for Mac OS X: see [perl #38868] */
3000 const int pad = 0;
235ac35d 3001#else
8a89a4f1
MB
3002 /* Is the space counterintuitive? Yes.
3003 * (You were expecting \0?)
3004 * Does it work? Seems to. (In Linux 2.4.20 at least.)
3005 * --jhi */
60777a0d 3006 const int pad = ' ';
235ac35d 3007#endif
60777a0d
JH
3008 Copy(s, PL_origargv[0], len, char);
3009 PL_origargv[0][len] = 0;
3010 memset(PL_origargv[0] + len + 1,
3011 pad, PL_origalen - len - 1);
2d2af554
GA
3012 }
3013 PL_origargv[0][PL_origalen-1] = 0;
3014 for (i = 1; i < PL_origargc; i++)
3015 PL_origargv[i] = 0;
7636ea95
AB
3016#ifdef HAS_PRCTL_SET_NAME
3017 /* Set the legacy process name in addition to the POSIX name on Linux */
3018 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
3019 /* diag_listed_as: SKIPME */
3020 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
3021 }
3022#endif
79072805 3023 }
9d3968b2 3024#endif
e2975953 3025 UNLOCK_DOLLARZERO_MUTEX;
79072805
LW
3026 break;
3027 }
3028 return 0;
3029}
3030
3031I32
84c7b88c
BF
3032Perl_whichsig_sv(pTHX_ SV *sigsv)
3033{
3034 const char *sigpv;
3035 STRLEN siglen;
3036 PERL_ARGS_ASSERT_WHICHSIG_SV;
3037 PERL_UNUSED_CONTEXT;
3038 sigpv = SvPV_const(sigsv, siglen);
3039 return whichsig_pvn(sigpv, siglen);
3040}
3041
3042I32
3043Perl_whichsig_pv(pTHX_ const char *sig)
3044{
3045 PERL_ARGS_ASSERT_WHICHSIG_PV;
3046 PERL_UNUSED_CONTEXT;
3047 return whichsig_pvn(sig, strlen(sig));
3048}
3049
3050I32
3051Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
79072805 3052{
aadb217d 3053 register char* const* sigv;
7918f24d 3054
84c7b88c 3055 PERL_ARGS_ASSERT_WHICHSIG_PVN;
96a5add6 3056 PERL_UNUSED_CONTEXT;
79072805 3057
aadb217d 3058 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
84c7b88c 3059 if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
aadb217d 3060 return PL_sig_num[sigv - (char* const*)PL_sig_name];
79072805 3061#ifdef SIGCLD
84c7b88c 3062 if (memEQs(sig, len, "CHLD"))
79072805
LW
3063 return SIGCLD;
3064#endif
3065#ifdef SIGCHLD
84c7b88c 3066 if (memEQs(sig, len, "CLD"))
79072805
LW
3067 return SIGCHLD;
3068#endif
7f1236c0 3069 return -1;
79072805
LW
3070}
3071
ecfc5424 3072Signal_t
1e82f5a6 3073#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3074Perl_sighandler(int sig, siginfo_t *sip, void *uap)
1e82f5a6
SH
3075#else
3076Perl_sighandler(int sig)
3077#endif
79072805 3078{
1018e26f
NIS
3079#ifdef PERL_GET_SIG_CONTEXT
3080 dTHXa(PERL_GET_SIG_CONTEXT);
71d280e3 3081#else
cea2e8a9 3082 dTHX;
71d280e3 3083#endif
79072805 3084 dSP;
a0714e2c
SS
3085 GV *gv = NULL;
3086 SV *sv = NULL;
8772537c 3087 SV * const tSv = PL_Sv;
601f1833 3088 CV *cv = NULL;
533c011a 3089 OP *myop = PL_op;
84902520 3090 U32 flags = 0;
8772537c 3091 XPV * const tXpv = PL_Xpv;
0c4d3b5e 3092 I32 old_ss_ix = PL_savestack_ix;
71d280e3 3093
84902520 3094
727405f8 3095 if (!PL_psig_ptr[sig]) {
99ef548b 3096 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
727405f8
NIS
3097 PL_sig_name[sig]);
3098 exit(sig);
3099 }
ff0cee69 3100
a0d63a7b
DM
3101 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3102 /* Max number of items pushed there is 3*n or 4. We cannot fix
3103 infinity, so we fix 4 (in fact 5): */
3104 if (PL_savestack_ix + 15 <= PL_savestack_max) {
3105 flags |= 1;
3106 PL_savestack_ix += 5; /* Protect save in progress. */
3107 SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3108 }
84902520 3109 }
84902520 3110 /* sv_2cv is too complicated, try a simpler variant first: */
ea726b52 3111 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
8772537c
AL
3112 || SvTYPE(cv) != SVt_PVCV) {
3113 HV *st;
f2c0649b 3114 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
8772537c 3115 }
84902520 3116
a0d0e21e 3117 if (!cv || !CvROOT(cv)) {
a2a5de95
NC
3118 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3119 PL_sig_name[sig], (gv ? GvENAME(gv)
3120 : ((cv && CvGV(cv))
3121 ? GvENAME(CvGV(cv))
3122 : "__ANON__")));
00d579c5 3123 goto cleanup;
79072805
LW
3124 }
3125
0c4d3b5e
DM
3126 sv = PL_psig_name[sig]
3127 ? SvREFCNT_inc_NN(PL_psig_name[sig])
3128 : newSVpv(PL_sig_name[sig],0);
72048cfe 3129 flags |= 8;
0c4d3b5e
DM
3130 SAVEFREESV(sv);
3131
a0d63a7b
DM
3132 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
3133 /* make sure our assumption about the size of the SAVEs are correct:
3134 * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3135 assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix);
3136 }
e336de0d 3137
e788e7d3 3138 PUSHSTACKi(PERLSI_SIGNAL);
924508f0 3139 PUSHMARK(SP);
79072805 3140 PUSHs(sv);
8aad04aa
JH
3141#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3142 {
3143 struct sigaction oact;
3144
3145 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
8aad04aa
JH
3146 if (sip) {
3147 HV *sih = newHV();
ad64d0ec 3148 SV *rv = newRV_noinc(MUTABLE_SV(sih));
8aad04aa
JH
3149 /* The siginfo fields signo, code, errno, pid, uid,
3150 * addr, status, and band are defined by POSIX/SUSv3. */
85771703
NC
3151 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3152 (void)hv_stores(sih, "code", newSViv(sip->si_code));
79dec0f4 3153#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
3154 hv_stores(sih, "errno", newSViv(sip->si_errno));
3155 hv_stores(sih, "status", newSViv(sip->si_status));
3156 hv_stores(sih, "uid", newSViv(sip->si_uid));
3157 hv_stores(sih, "pid", newSViv(sip->si_pid));
3158 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
3159 hv_stores(sih, "band", newSViv(sip->si_band));
79dec0f4 3160#endif
8aad04aa 3161 EXTEND(SP, 2);
ad64d0ec 3162 PUSHs(rv);
22f1178f 3163 mPUSHp((char *)sip, sizeof(*sip));
8aad04aa 3164 }
b4552a27 3165
8aad04aa
JH
3166 }
3167 }
3168#endif
79072805 3169 PUTBACK;
a0d0e21e 3170
ad64d0ec 3171 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
79072805 3172
d3acc0f7 3173 POPSTACK;
1b266415 3174 if (SvTRUE(ERRSV)) {
c22d665b 3175#ifndef PERL_MICRO
1b266415
NIS
3176 /* Handler "died", for example to get out of a restart-able read().
3177 * Before we re-do that on its behalf re-enable the signal which was
3178 * blocked by the system when we entered.
3179 */
c22d665b 3180#ifdef HAS_SIGPROCMASK
d488af49 3181#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
b3dbdd48 3182 if (sip || uap)
c22d665b
LT
3183#endif
3184 {
3185 sigset_t set;
3186 sigemptyset(&set);
3187 sigaddset(&set,sig);
3188 sigprocmask(SIG_UNBLOCK, &set, NULL);
3189 }
3190#else
1b266415
NIS
3191 /* Not clear if this will work */
3192 (void)rsignal(sig, SIG_IGN);
5c1546dc 3193 (void)rsignal(sig, PL_csighandlerp);
c22d665b
LT
3194#endif
3195#endif /* !PERL_MICRO */
c5df3096 3196 die_sv(ERRSV);
1b266415 3197 }
00d579c5 3198cleanup:
0c4d3b5e
DM
3199 /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3200 PL_savestack_ix = old_ss_ix;
72048cfe 3201 if (flags & 8)
84902520 3202 SvREFCNT_dec(sv);
533c011a 3203 PL_op = myop; /* Apparently not needed... */
ac27b0f5 3204
3280af22
NIS
3205 PL_Sv = tSv; /* Restore global temporaries. */
3206 PL_Xpv = tXpv;
53bb94e2 3207 return;
79072805 3208}
4e35701f
NIS
3209
3210
51371543 3211static void
8772537c 3212S_restore_magic(pTHX_ const void *p)
51371543 3213{
97aff369 3214 dVAR;
8772537c
AL
3215 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3216 SV* const sv = mgs->mgs_sv;
150b625d 3217 bool bumped;
51371543
GS
3218
3219 if (!sv)
3220 return;
3221
3222 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3223 {
f8c7b90f 3224#ifdef PERL_OLD_COPY_ON_WRITE
f9701176
NC
3225 /* While magic was saved (and off) sv_setsv may well have seen
3226 this SV as a prime candidate for COW. */
3227 if (SvIsCOW(sv))
e424a81e 3228 sv_force_normal_flags(sv, 0);
f9701176
NC
3229#endif
3230
f9c6fee5
CS
3231 if (mgs->mgs_readonly)
3232 SvREADONLY_on(sv);
3233 if (mgs->mgs_magical)
3234 SvFLAGS(sv) |= mgs->mgs_magical;
51371543
GS
3235 else
3236 mg_magical(sv);
2b77b520
YST
3237 if (SvGMAGICAL(sv)) {
3238 /* downgrade public flags to private,
3239 and discard any other private flags */
3240
10edeb5d
JH
3241 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3242 if (pubflags) {
3243 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3244 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2b77b520
YST
3245 }
3246 }
51371543
GS
3247 }
3248
150b625d 3249 bumped = mgs->mgs_bumped;
51371543
GS
3250 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3251
3252 /* If we're still on top of the stack, pop us off. (That condition
3253 * will be satisfied if restore_magic was called explicitly, but *not*
3254 * if it's being called via leave_scope.)
3255 * The reason for doing this is that otherwise, things like sv_2cv()
3256 * may leave alloc gunk on the savestack, and some code
3257 * (e.g. sighandler) doesn't expect that...
3258 */
3259 if (PL_savestack_ix == mgs->mgs_ss_ix)
3260 {
1be36ce0
NC
3261 UV popval = SSPOPUV;
3262 assert(popval == SAVEt_DESTRUCTOR_X);
51371543 3263 PL_savestack_ix -= 2;
1be36ce0
NC
3264 popval = SSPOPUV;
3265 assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3266 PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
51371543 3267 }
150b625d
DM
3268 if (bumped) {
3269 if (SvREFCNT(sv) == 1) {
3270 /* We hold the last reference to this SV, which implies that the
3271 SV was deleted as a side effect of the routines we called.
3272 So artificially keep it alive a bit longer.
3273 We avoid turning on the TEMP flag, which can cause the SV's
3274 buffer to get stolen (and maybe other stuff). */
3275 int was_temp = SvTEMP(sv);
3276 sv_2mortal(sv);
3277 if (!was_temp) {
3278 SvTEMP_off(sv);
3279 }
3280 SvOK_off(sv);
8985fe98 3281 }
150b625d
DM
3282 else
3283 SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
8985fe98 3284 }
51371543
GS
3285}
3286
0c4d3b5e
DM
3287/* clean up the mess created by Perl_sighandler().
3288 * Note that this is only called during an exit in a signal handler;
3289 * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
9a7f166c 3290 * skipped over. */
0c4d3b5e 3291
51371543 3292static void
8772537c 3293S_unwind_handler_stack(pTHX_ const void *p)
51371543 3294{
27da23d5 3295 dVAR;
0c4d3b5e 3296 PERL_UNUSED_ARG(p);
7918f24d 3297
0c4d3b5e 3298 PL_savestack_ix -= 5; /* Unprotect save in progress. */
51371543 3299}
1018e26f 3300
66610fdd 3301/*
b3ca2e83
NC
3302=for apidoc magic_sethint
3303
3304Triggered by a store to %^H, records the key/value pair to
c28fe1ec
NC
3305C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3306anything that would need a deep copy. Maybe we should warn if we find a
3307reference.
b3ca2e83
NC
3308
3309=cut
3310*/
3311int
3312Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3313{
3314 dVAR;
ad64d0ec 3315 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
59cd0e26 3316 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
b3ca2e83 3317
7918f24d
NC
3318 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3319
e6e3e454
NC
3320 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3321 an alternative leaf in there, with PL_compiling.cop_hints being used if
3322 it's NULL. If needed for threads, the alternative could lock a mutex,
3323 or take other more complex action. */
3324
5b9c0671
NC
3325 /* Something changed in %^H, so it will need to be restored on scope exit.
3326 Doing this here saves a lot of doing it manually in perl code (and
3327 forgetting to do it, and consequent subtle errors. */
3328 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z
3329 CopHINTHASH_set(&PL_compiling,
3330 cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
b3ca2e83
NC
3331 return 0;
3332}
3333
3334/*
f175cff5 3335=for apidoc magic_clearhint
b3ca2e83 3336
c28fe1ec
NC
3337Triggered by a delete from %^H, records the key to
3338C<PL_compiling.cop_hints_hash>.
b3ca2e83
NC
3339
3340=cut
3341*/
3342int
3343Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3344{
3345 dVAR;
7918f24d
NC
3346
3347 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
f5a63d97
AL
3348 PERL_UNUSED_ARG(sv);
3349
b3ca2e83
NC
3350 assert(mg->mg_len == HEf_SVKEY);
3351
b3f24c00
MHM
3352 PERL_UNUSED_ARG(sv);
3353
5b9c0671 3354 PL_hints |= HINT_LOCALIZE_HH;
20439bc7
Z
3355 CopHINTHASH_set(&PL_compiling,
3356 cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3357 MUTABLE_SV(mg->mg_ptr), 0, 0));
b3ca2e83
NC
3358 return 0;
3359}
3360
3361/*
f747ebd6
Z
3362=for apidoc magic_clearhints
3363
3364Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3365
3366=cut
3367*/
3368int
3369Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3370{
3371 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3372 PERL_UNUSED_ARG(sv);
3373 PERL_UNUSED_ARG(mg);
20439bc7
Z
3374 cophh_free(CopHINTHASH_get(&PL_compiling));
3375 CopHINTHASH_set(&PL_compiling, cophh_new_empty());
f747ebd6
Z
3376 return 0;
3377}
3378
3379/*
66610fdd
RGS
3380 * Local variables:
3381 * c-indentation-style: bsd
3382 * c-basic-offset: 4
3383 * indent-tabs-mode: t
3384 * End:
3385 *
37442d52
RGS
3386 * ex: set ts=8 sts=4 sw=4 noet:
3387 */