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