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