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