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