This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f51cd47990d8ab3102631b8a5b7c4544a6c1f7e3
[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 #if defined(HAS_SIGPROCMASK)
1447             /* From sigaction(2) (FreeBSD man page):
1448              * | Signal routines normally execute with the signal that
1449              * | caused their invocation blocked, but other signals may
1450              * | yet occur.
1451              * Emulation of this behavior (from within Perl) is enabled
1452              * using sigprocmask
1453              */
1454             int was_blocked;
1455             sigset_t newset, oldset;
1456
1457             sigemptyset(&newset);
1458             sigaddset(&newset, sig);
1459             sigprocmask(SIG_BLOCK, &newset, &oldset);
1460             was_blocked = sigismember(&oldset, sig);
1461 #endif
1462             PL_psig_pend[sig] = 0;
1463 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1464             (*PL_sighandlerp)(sig, NULL, NULL);
1465 #else
1466             (*PL_sighandlerp)(sig);
1467 #endif
1468 #if defined(HAS_SIGPROCMASK)
1469             if (!was_blocked)
1470                 sigprocmask(SIG_UNBLOCK, &newset, NULL);
1471 #endif
1472             RESTORE_ERRNO;
1473         }
1474     }
1475 }
1476
1477 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1478 int
1479 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1480 {
1481     dVAR;
1482     I32 i;
1483     SV** svp = NULL;
1484     /* Need to be careful with SvREFCNT_dec(), because that can have side
1485      * effects (due to closures). We must make sure that the new disposition
1486      * is in place before it is called.
1487      */
1488     SV* to_dec = NULL;
1489     STRLEN len;
1490 #ifdef HAS_SIGPROCMASK
1491     sigset_t set, save;
1492     SV* save_sv;
1493 #endif
1494     register const char *s = MgPV_const(mg,len);
1495
1496     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1497
1498     if (*s == '_') {
1499         if (strEQ(s,"__DIE__"))
1500             svp = &PL_diehook;
1501         else if (strEQ(s,"__WARN__")
1502                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1503             /* Merge the existing behaviours, which are as follows:
1504                magic_setsig, we always set svp to &PL_warnhook
1505                (hence we always change the warnings handler)
1506                For magic_clearsig, we don't change the warnings handler if it's
1507                set to the &PL_warnhook.  */
1508             svp = &PL_warnhook;
1509         } else if (sv)
1510             Perl_croak(aTHX_ "No such hook: %s", s);
1511         i = 0;
1512         if (svp && *svp) {
1513             if (*svp != PERL_WARNHOOK_FATAL)
1514                 to_dec = *svp;
1515             *svp = NULL;
1516         }
1517     }
1518     else {
1519         i = (I16)mg->mg_private;
1520         if (!i) {
1521             i = whichsig(s);    /* ...no, a brick */
1522             mg->mg_private = (U16)i;
1523         }
1524         if (i <= 0) {
1525             if (sv)
1526                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1527             return 0;
1528         }
1529 #ifdef HAS_SIGPROCMASK
1530         /* Avoid having the signal arrive at a bad time, if possible. */
1531         sigemptyset(&set);
1532         sigaddset(&set,i);
1533         sigprocmask(SIG_BLOCK, &set, &save);
1534         ENTER;
1535         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1536         SAVEFREESV(save_sv);
1537         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1538 #endif
1539         PERL_ASYNC_CHECK();
1540 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1541         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1542 #endif
1543 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1544         PL_sig_ignoring[i] = 0;
1545 #endif
1546 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1547         PL_sig_defaulting[i] = 0;
1548 #endif
1549         to_dec = PL_psig_ptr[i];
1550         if (sv) {
1551             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1552             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1553
1554             /* Signals don't change name during the program's execution, so once
1555                they're cached in the appropriate slot of PL_psig_name, they can
1556                stay there.
1557
1558                Ideally we'd find some way of making SVs at (C) compile time, or
1559                at least, doing most of the work.  */
1560             if (!PL_psig_name[i]) {
1561                 PL_psig_name[i] = newSVpvn(s, len);
1562                 SvREADONLY_on(PL_psig_name[i]);
1563             }
1564         } else {
1565             SvREFCNT_dec(PL_psig_name[i]);
1566             PL_psig_name[i] = NULL;
1567             PL_psig_ptr[i] = NULL;
1568         }
1569     }
1570     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1571         if (i) {
1572             (void)rsignal(i, PL_csighandlerp);
1573         }
1574         else
1575             *svp = SvREFCNT_inc_simple_NN(sv);
1576     } else {
1577         if (sv && SvOK(sv)) {
1578             s = SvPV_force(sv, len);
1579         } else {
1580             sv = NULL;
1581         }
1582         if (sv && strEQ(s,"IGNORE")) {
1583             if (i) {
1584 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1585                 PL_sig_ignoring[i] = 1;
1586                 (void)rsignal(i, PL_csighandlerp);
1587 #else
1588                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1589 #endif
1590             }
1591         }
1592         else if (!sv || strEQ(s,"DEFAULT") || !len) {
1593             if (i) {
1594 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1595                 PL_sig_defaulting[i] = 1;
1596                 (void)rsignal(i, PL_csighandlerp);
1597 #else
1598                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1599 #endif
1600             }
1601         }
1602         else {
1603             /*
1604              * We should warn if HINT_STRICT_REFS, but without
1605              * access to a known hint bit in a known OP, we can't
1606              * tell whether HINT_STRICT_REFS is in force or not.
1607              */
1608             if (!strchr(s,':') && !strchr(s,'\''))
1609                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1610                                      SV_GMAGIC);
1611             if (i)
1612                 (void)rsignal(i, PL_csighandlerp);
1613             else
1614                 *svp = SvREFCNT_inc_simple_NN(sv);
1615         }
1616     }
1617
1618 #ifdef HAS_SIGPROCMASK
1619     if(i)
1620         LEAVE;
1621 #endif
1622     SvREFCNT_dec(to_dec);
1623     return 0;
1624 }
1625 #endif /* !PERL_MICRO */
1626
1627 int
1628 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1629 {
1630     dVAR;
1631     PERL_ARGS_ASSERT_MAGIC_SETISA;
1632     PERL_UNUSED_ARG(sv);
1633
1634     /* Skip _isaelem because _isa will handle it shortly */
1635     if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1636         return 0;
1637
1638     return magic_clearisa(NULL, mg);
1639 }
1640
1641 /* sv of NULL signifies that we're acting as magic_setisa.  */
1642 int
1643 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1644 {
1645     dVAR;
1646     HV* stash;
1647
1648     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1649
1650     /* Bail out if destruction is going on */
1651     if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1652
1653     if (sv)
1654         av_clear(MUTABLE_AV(sv));
1655
1656     if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1657         /* This occurs with setisa_elem magic, which calls this
1658            same function. */
1659         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1660
1661     if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1662         SV **svp = AvARRAY((AV *)mg->mg_obj);
1663         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1664         while (items--) {
1665             stash = GvSTASH((GV *)*svp++);
1666             if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1667         }
1668
1669         return 0;
1670     }
1671
1672     stash = GvSTASH(
1673         (const GV *)mg->mg_obj
1674     );
1675
1676     /* The stash may have been detached from the symbol table, so check its
1677        name before doing anything. */
1678     if (stash && HvENAME_get(stash))
1679         mro_isa_changed_in(stash);
1680
1681     return 0;
1682 }
1683
1684 int
1685 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1686 {
1687     dVAR;
1688     PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1689     PERL_UNUSED_ARG(sv);
1690     PERL_UNUSED_ARG(mg);
1691     PL_amagic_generation++;
1692
1693     return 0;
1694 }
1695
1696 int
1697 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1698 {
1699     HV * const hv = MUTABLE_HV(LvTARG(sv));
1700     I32 i = 0;
1701
1702     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1703     PERL_UNUSED_ARG(mg);
1704
1705     if (hv) {
1706          (void) hv_iterinit(hv);
1707          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1708              i = HvKEYS(hv);
1709          else {
1710              while (hv_iternext(hv))
1711                  i++;
1712          }
1713     }
1714
1715     sv_setiv(sv, (IV)i);
1716     return 0;
1717 }
1718
1719 int
1720 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1721 {
1722     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1723     PERL_UNUSED_ARG(mg);
1724     if (LvTARG(sv)) {
1725         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1726     }
1727     return 0;
1728 }
1729
1730 /*
1731 =for apidoc magic_methcall
1732
1733 Invoke a magic method (like FETCH).
1734
1735 * sv and mg are the tied thinggy and the tie magic;
1736 * meth is the name of the method to call;
1737 * argc is the number of args (in addition to $self) to pass to the method;
1738        the args themselves are any values following the argc argument.
1739 * flags:
1740     G_DISCARD:     invoke method with G_DISCARD flag and don't return a value
1741     G_UNDEF_FILL:  fill the stack with argc pointers to PL_sv_undef.
1742
1743 Returns the SV (if any) returned by the method, or NULL on failure.
1744
1745
1746 =cut
1747 */
1748
1749 SV*
1750 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1751                     U32 argc, ...)
1752 {
1753     dVAR;
1754     dSP;
1755     SV* ret = NULL;
1756
1757     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1758
1759     ENTER;
1760
1761     if (flags & G_WRITING_TO_STDERR) {
1762         SAVETMPS;
1763
1764         save_re_context();
1765         SAVESPTR(PL_stderrgv);
1766         PL_stderrgv = NULL;
1767     }
1768
1769     PUSHSTACKi(PERLSI_MAGIC);
1770     PUSHMARK(SP);
1771
1772     EXTEND(SP, argc+1);
1773     PUSHs(SvTIED_obj(sv, mg));
1774     if (flags & G_UNDEF_FILL) {
1775         while (argc--) {
1776             PUSHs(&PL_sv_undef);
1777         }
1778     } else if (argc > 0) {
1779         va_list args;
1780         va_start(args, argc);
1781
1782         do {
1783             SV *const sv = va_arg(args, SV *);
1784             PUSHs(sv);
1785         } while (--argc);
1786
1787         va_end(args);
1788     }
1789     PUTBACK;
1790     if (flags & G_DISCARD) {
1791         call_method(meth, G_SCALAR|G_DISCARD);
1792     }
1793     else {
1794         if (call_method(meth, G_SCALAR))
1795             ret = *PL_stack_sp--;
1796     }
1797     POPSTACK;
1798     if (flags & G_WRITING_TO_STDERR)
1799         FREETMPS;
1800     LEAVE;
1801     return ret;
1802 }
1803
1804
1805 /* wrapper for magic_methcall that creates the first arg */
1806
1807 STATIC SV*
1808 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
1809     int n, SV *val)
1810 {
1811     dVAR;
1812     SV* arg1 = NULL;
1813
1814     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1815
1816     if (mg->mg_ptr) {
1817         if (mg->mg_len >= 0) {
1818             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1819         }
1820         else if (mg->mg_len == HEf_SVKEY)
1821             arg1 = MUTABLE_SV(mg->mg_ptr);
1822     }
1823     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1824         arg1 = newSViv((IV)(mg->mg_len));
1825         sv_2mortal(arg1);
1826     }
1827     if (!arg1) {
1828         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
1829     }
1830     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
1831 }
1832
1833 STATIC int
1834 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1835 {
1836     dVAR;
1837     SV* ret;
1838
1839     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1840
1841     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
1842     if (ret)
1843         sv_setsv(sv, ret);
1844     return 0;
1845 }
1846
1847 int
1848 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1849 {
1850     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1851
1852     if (mg->mg_type == PERL_MAGIC_tiedelem)
1853         mg->mg_flags |= MGf_GSKIP;
1854     magic_methpack(sv,mg,"FETCH");
1855     return 0;
1856 }
1857
1858 int
1859 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1860 {
1861     dVAR;
1862     MAGIC *tmg;
1863     SV    *val;
1864
1865     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1866
1867     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1868      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1869      * public flags indicate its value based on copying from $val. Doing
1870      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1871      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1872      * wrong if $val happened to be tainted, as sv hasn't got magic
1873      * enabled, even though taint magic is in the chain. In which case,
1874      * fake up a temporary tainted value (this is easier than temporarily
1875      * re-enabling magic on sv). */
1876
1877     if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1878         && (tmg->mg_len & 1))
1879     {
1880         val = sv_mortalcopy(sv);
1881         SvTAINTED_on(val);
1882     }
1883     else
1884         val = sv;
1885
1886     magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
1887     return 0;
1888 }
1889
1890 int
1891 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1892 {
1893     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1894
1895     return magic_methpack(sv,mg,"DELETE");
1896 }
1897
1898
1899 U32
1900 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1901 {
1902     dVAR;
1903     I32 retval = 0;
1904     SV* retsv;
1905
1906     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1907
1908     retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
1909     if (retsv) {
1910         retval = SvIV(retsv)-1;
1911         if (retval < -1)
1912             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1913     }
1914     return (U32) retval;
1915 }
1916
1917 int
1918 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1919 {
1920     dVAR;
1921
1922     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1923
1924     Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0);
1925     return 0;
1926 }
1927
1928 int
1929 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1930 {
1931     dVAR;
1932     SV* ret;
1933
1934     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1935
1936     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key)
1937         : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0);
1938     if (ret)
1939         sv_setsv(key,ret);
1940     return 0;
1941 }
1942
1943 int
1944 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1945 {
1946     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1947
1948     return magic_methpack(sv,mg,"EXISTS");
1949 }
1950
1951 SV *
1952 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1953 {
1954     dVAR;
1955     SV *retval;
1956     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1957     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1958    
1959     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1960
1961     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1962         SV *key;
1963         if (HvEITER_get(hv))
1964             /* we are in an iteration so the hash cannot be empty */
1965             return &PL_sv_yes;
1966         /* no xhv_eiter so now use FIRSTKEY */
1967         key = sv_newmortal();
1968         magic_nextpack(MUTABLE_SV(hv), mg, key);
1969         HvEITER_set(hv, NULL);     /* need to reset iterator */
1970         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1971     }
1972    
1973     /* there is a SCALAR method that we can call */
1974     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0);
1975     if (!retval)
1976         retval = &PL_sv_undef;
1977     return retval;
1978 }
1979
1980 int
1981 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1982 {
1983     dVAR;
1984     GV * const gv = PL_DBline;
1985     const I32 i = SvTRUE(sv);
1986     SV ** const svp = av_fetch(GvAV(gv),
1987                      atoi(MgPV_nolen_const(mg)), FALSE);
1988
1989     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1990
1991     if (svp && SvIOKp(*svp)) {
1992         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1993         if (o) {
1994             /* set or clear breakpoint in the relevant control op */
1995             if (i)
1996                 o->op_flags |= OPf_SPECIAL;
1997             else
1998                 o->op_flags &= ~OPf_SPECIAL;
1999         }
2000     }
2001     return 0;
2002 }
2003
2004 int
2005 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2006 {
2007     dVAR;
2008     AV * const obj = MUTABLE_AV(mg->mg_obj);
2009
2010     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2011
2012     if (obj) {
2013         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
2014     } else {
2015         SvOK_off(sv);
2016     }
2017     return 0;
2018 }
2019
2020 int
2021 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2022 {
2023     dVAR;
2024     AV * const obj = MUTABLE_AV(mg->mg_obj);
2025
2026     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2027
2028     if (obj) {
2029         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
2030     } else {
2031         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2032                        "Attempt to set length of freed array");
2033     }
2034     return 0;
2035 }
2036
2037 int
2038 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2039 {
2040     dVAR;
2041
2042     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2043     PERL_UNUSED_ARG(sv);
2044
2045     /* during global destruction, mg_obj may already have been freed */
2046     if (PL_in_clean_all)
2047         return 0;
2048
2049     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2050
2051     if (mg) {
2052         /* arylen scalar holds a pointer back to the array, but doesn't own a
2053            reference. Hence the we (the array) are about to go away with it
2054            still pointing at us. Clear its pointer, else it would be pointing
2055            at free memory. See the comment in sv_magic about reference loops,
2056            and why it can't own a reference to us.  */
2057         mg->mg_obj = 0;
2058     }
2059     return 0;
2060 }
2061
2062 int
2063 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2064 {
2065     dVAR;
2066     SV* const lsv = LvTARG(sv);
2067
2068     PERL_ARGS_ASSERT_MAGIC_GETPOS;
2069     PERL_UNUSED_ARG(mg);
2070
2071     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
2072         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
2073         if (found && found->mg_len >= 0) {
2074             I32 i = found->mg_len;
2075             if (DO_UTF8(lsv))
2076                 sv_pos_b2u(lsv, &i);
2077             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
2078             return 0;
2079         }
2080     }
2081     SvOK_off(sv);
2082     return 0;
2083 }
2084
2085 int
2086 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2087 {
2088     dVAR;
2089     SV* const lsv = LvTARG(sv);
2090     SSize_t pos;
2091     STRLEN len;
2092     STRLEN ulen = 0;
2093     MAGIC* found;
2094
2095     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2096     PERL_UNUSED_ARG(mg);
2097
2098     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2099         found = mg_find(lsv, PERL_MAGIC_regex_global);
2100     else
2101         found = NULL;
2102     if (!found) {
2103         if (!SvOK(sv))
2104             return 0;
2105 #ifdef PERL_OLD_COPY_ON_WRITE
2106     if (SvIsCOW(lsv))
2107         sv_force_normal_flags(lsv, 0);
2108 #endif
2109         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2110                             NULL, 0);
2111     }
2112     else if (!SvOK(sv)) {
2113         found->mg_len = -1;
2114         return 0;
2115     }
2116     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2117
2118     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2119
2120     if (DO_UTF8(lsv)) {
2121         ulen = sv_len_utf8(lsv);
2122         if (ulen)
2123             len = ulen;
2124     }
2125
2126     if (pos < 0) {
2127         pos += len;
2128         if (pos < 0)
2129             pos = 0;
2130     }
2131     else if (pos > (SSize_t)len)
2132         pos = len;
2133
2134     if (ulen) {
2135         I32 p = pos;
2136         sv_pos_u2b(lsv, &p, 0);
2137         pos = p;
2138     }
2139
2140     found->mg_len = pos;
2141     found->mg_flags &= ~MGf_MINMATCH;
2142
2143     return 0;
2144 }
2145
2146 int
2147 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2148 {
2149     STRLEN len;
2150     SV * const lsv = LvTARG(sv);
2151     const char * const tmps = SvPV_const(lsv,len);
2152     STRLEN offs = LvTARGOFF(sv);
2153     STRLEN rem = LvTARGLEN(sv);
2154
2155     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2156     PERL_UNUSED_ARG(mg);
2157
2158     if (SvUTF8(lsv))
2159         offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2160     if (offs > len)
2161         offs = len;
2162     if (rem > len - offs)
2163         rem = len - offs;
2164     sv_setpvn(sv, tmps + offs, rem);
2165     if (SvUTF8(lsv))
2166         SvUTF8_on(sv);
2167     return 0;
2168 }
2169
2170 int
2171 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2172 {
2173     dVAR;
2174     STRLEN len;
2175     const char * const tmps = SvPV_const(sv, len);
2176     SV * const lsv = LvTARG(sv);
2177     STRLEN lvoff = LvTARGOFF(sv);
2178     STRLEN lvlen = LvTARGLEN(sv);
2179
2180     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2181     PERL_UNUSED_ARG(mg);
2182
2183     if (DO_UTF8(sv)) {
2184         sv_utf8_upgrade(lsv);
2185         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2186         sv_insert(lsv, lvoff, lvlen, tmps, len);
2187         LvTARGLEN(sv) = sv_len_utf8(sv);
2188         SvUTF8_on(lsv);
2189     }
2190     else if (lsv && SvUTF8(lsv)) {
2191         const char *utf8;
2192         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2193         LvTARGLEN(sv) = len;
2194         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2195         sv_insert(lsv, lvoff, lvlen, utf8, len);
2196         Safefree(utf8);
2197     }
2198     else {
2199         sv_insert(lsv, lvoff, lvlen, tmps, len);
2200         LvTARGLEN(sv) = len;
2201     }
2202
2203     return 0;
2204 }
2205
2206 int
2207 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2208 {
2209     dVAR;
2210
2211     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2212     PERL_UNUSED_ARG(sv);
2213
2214     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2215     return 0;
2216 }
2217
2218 int
2219 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2220 {
2221     dVAR;
2222
2223     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2224     PERL_UNUSED_ARG(sv);
2225
2226     /* update taint status */
2227     if (PL_tainted)
2228         mg->mg_len |= 1;
2229     else
2230         mg->mg_len &= ~1;
2231     return 0;
2232 }
2233
2234 int
2235 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2236 {
2237     SV * const lsv = LvTARG(sv);
2238
2239     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2240     PERL_UNUSED_ARG(mg);
2241
2242     if (lsv)
2243         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2244     else
2245         SvOK_off(sv);
2246
2247     return 0;
2248 }
2249
2250 int
2251 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2252 {
2253     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2254     PERL_UNUSED_ARG(mg);
2255     do_vecset(sv);      /* XXX slurp this routine */
2256     return 0;
2257 }
2258
2259 int
2260 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2261 {
2262     dVAR;
2263     SV *targ = NULL;
2264
2265     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2266
2267     if (LvTARGLEN(sv)) {
2268         if (mg->mg_obj) {
2269             SV * const ahv = LvTARG(sv);
2270             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2271             if (he)
2272                 targ = HeVAL(he);
2273         }
2274         else {
2275             AV *const av = MUTABLE_AV(LvTARG(sv));
2276             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2277                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2278         }
2279         if (targ && (targ != &PL_sv_undef)) {
2280             /* somebody else defined it for us */
2281             SvREFCNT_dec(LvTARG(sv));
2282             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2283             LvTARGLEN(sv) = 0;
2284             SvREFCNT_dec(mg->mg_obj);
2285             mg->mg_obj = NULL;
2286             mg->mg_flags &= ~MGf_REFCOUNTED;
2287         }
2288     }
2289     else
2290         targ = LvTARG(sv);
2291     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2292     return 0;
2293 }
2294
2295 int
2296 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2297 {
2298     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2299     PERL_UNUSED_ARG(mg);
2300     if (LvTARGLEN(sv))
2301         vivify_defelem(sv);
2302     if (LvTARG(sv)) {
2303         sv_setsv(LvTARG(sv), sv);
2304         SvSETMAGIC(LvTARG(sv));
2305     }
2306     return 0;
2307 }
2308
2309 void
2310 Perl_vivify_defelem(pTHX_ SV *sv)
2311 {
2312     dVAR;
2313     MAGIC *mg;
2314     SV *value = NULL;
2315
2316     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2317
2318     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2319         return;
2320     if (mg->mg_obj) {
2321         SV * const ahv = LvTARG(sv);
2322         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2323         if (he)
2324             value = HeVAL(he);
2325         if (!value || value == &PL_sv_undef)
2326             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2327     }
2328     else {
2329         AV *const av = MUTABLE_AV(LvTARG(sv));
2330         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2331             LvTARG(sv) = NULL;  /* array can't be extended */
2332         else {
2333             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2334             if (!svp || (value = *svp) == &PL_sv_undef)
2335                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2336         }
2337     }
2338     SvREFCNT_inc_simple_void(value);
2339     SvREFCNT_dec(LvTARG(sv));
2340     LvTARG(sv) = value;
2341     LvTARGLEN(sv) = 0;
2342     SvREFCNT_dec(mg->mg_obj);
2343     mg->mg_obj = NULL;
2344     mg->mg_flags &= ~MGf_REFCOUNTED;
2345 }
2346
2347 int
2348 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2349 {
2350     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2351     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2352     return 0;
2353 }
2354
2355 int
2356 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2357 {
2358     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2359     PERL_UNUSED_CONTEXT;
2360     mg->mg_len = -1;
2361     if (!isGV_with_GP(sv))
2362         SvSCREAM_off(sv);
2363     return 0;
2364 }
2365
2366 int
2367 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2368 {
2369     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2370
2371     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2372
2373     if (uf && uf->uf_set)
2374         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2375     return 0;
2376 }
2377
2378 int
2379 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2380 {
2381     const char type = mg->mg_type;
2382
2383     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2384
2385     if (type == PERL_MAGIC_qr) {
2386     } else if (type == PERL_MAGIC_bm) {
2387         SvTAIL_off(sv);
2388         SvVALID_off(sv);
2389     } else {
2390         assert(type == PERL_MAGIC_fm);
2391         SvCOMPILED_off(sv);
2392     }
2393     return sv_unmagic(sv, type);
2394 }
2395
2396 #ifdef USE_LOCALE_COLLATE
2397 int
2398 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2399 {
2400     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2401
2402     /*
2403      * RenE<eacute> Descartes said "I think not."
2404      * and vanished with a faint plop.
2405      */
2406     PERL_UNUSED_CONTEXT;
2407     PERL_UNUSED_ARG(sv);
2408     if (mg->mg_ptr) {
2409         Safefree(mg->mg_ptr);
2410         mg->mg_ptr = NULL;
2411         mg->mg_len = -1;
2412     }
2413     return 0;
2414 }
2415 #endif /* USE_LOCALE_COLLATE */
2416
2417 /* Just clear the UTF-8 cache data. */
2418 int
2419 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2420 {
2421     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2422     PERL_UNUSED_CONTEXT;
2423     PERL_UNUSED_ARG(sv);
2424     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2425     mg->mg_ptr = NULL;
2426     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2427     return 0;
2428 }
2429
2430 int
2431 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2432 {
2433     dVAR;
2434     register const char *s;
2435     register I32 paren;
2436     register const REGEXP * rx;
2437     const char * const remaining = mg->mg_ptr + 1;
2438     I32 i;
2439     STRLEN len;
2440     MAGIC *tmg;
2441
2442     PERL_ARGS_ASSERT_MAGIC_SET;
2443
2444     switch (*mg->mg_ptr) {
2445     case '\015': /* $^MATCH */
2446       if (strEQ(remaining, "ATCH"))
2447           goto do_match;
2448     case '`': /* ${^PREMATCH} caught below */
2449       do_prematch:
2450       paren = RX_BUFF_IDX_PREMATCH;
2451       goto setparen;
2452     case '\'': /* ${^POSTMATCH} caught below */
2453       do_postmatch:
2454       paren = RX_BUFF_IDX_POSTMATCH;
2455       goto setparen;
2456     case '&':
2457       do_match:
2458       paren = RX_BUFF_IDX_FULLMATCH;
2459       goto setparen;
2460     case '1': case '2': case '3': case '4':
2461     case '5': case '6': case '7': case '8': case '9':
2462       paren = atoi(mg->mg_ptr);
2463       setparen:
2464         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2465             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2466         } else {
2467             /* Croak with a READONLY error when a numbered match var is
2468              * set without a previous pattern match. Unless it's C<local $1>
2469              */
2470             if (!PL_localizing) {
2471                 Perl_croak_no_modify(aTHX);
2472             }
2473         }
2474         break;
2475     case '\001':        /* ^A */
2476         sv_setsv(PL_bodytarget, sv);
2477         /* mg_set() has temporarily made sv non-magical */
2478         if (PL_tainting) {
2479             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2480                 SvTAINTED_on(PL_bodytarget);
2481             else
2482                 SvTAINTED_off(PL_bodytarget);
2483         }
2484         break;
2485     case '\003':        /* ^C */
2486         PL_minus_c = cBOOL(SvIV(sv));
2487         break;
2488
2489     case '\004':        /* ^D */
2490 #ifdef DEBUGGING
2491         s = SvPV_nolen_const(sv);
2492         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2493         if (DEBUG_x_TEST || DEBUG_B_TEST)
2494             dump_all_perl(!DEBUG_B_TEST);
2495 #else
2496         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2497 #endif
2498         break;
2499     case '\005':  /* ^E */
2500         if (*(mg->mg_ptr+1) == '\0') {
2501 #ifdef VMS
2502             set_vaxc_errno(SvIV(sv));
2503 #else
2504 #  ifdef WIN32
2505             SetLastError( SvIV(sv) );
2506 #  else
2507 #    ifdef OS2
2508             os2_setsyserrno(SvIV(sv));
2509 #    else
2510             /* will anyone ever use this? */
2511             SETERRNO(SvIV(sv), 4);
2512 #    endif
2513 #  endif
2514 #endif
2515         }
2516         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2517             SvREFCNT_dec(PL_encoding);
2518             if (SvOK(sv) || SvGMAGICAL(sv)) {
2519                 PL_encoding = newSVsv(sv);
2520             }
2521             else {
2522                 PL_encoding = NULL;
2523             }
2524         }
2525         break;
2526     case '\006':        /* ^F */
2527         PL_maxsysfd = SvIV(sv);
2528         break;
2529     case '\010':        /* ^H */
2530         PL_hints = SvIV(sv);
2531         break;
2532     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2533         Safefree(PL_inplace);
2534         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2535         break;
2536     case '\017':        /* ^O */
2537         if (*(mg->mg_ptr+1) == '\0') {
2538             Safefree(PL_osname);
2539             PL_osname = NULL;
2540             if (SvOK(sv)) {
2541                 TAINT_PROPER("assigning to $^O");
2542                 PL_osname = savesvpv(sv);
2543             }
2544         }
2545         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2546             STRLEN len;
2547             const char *const start = SvPV(sv, len);
2548             const char *out = (const char*)memchr(start, '\0', len);
2549             SV *tmp;
2550
2551
2552             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2553             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2554
2555             /* Opening for input is more common than opening for output, so
2556                ensure that hints for input are sooner on linked list.  */
2557             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2558                                        SvUTF8(sv))
2559                 : newSVpvs_flags("", SvUTF8(sv));
2560             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2561             mg_set(tmp);
2562
2563             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2564                                         SvUTF8(sv));
2565             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2566             mg_set(tmp);
2567         }
2568         break;
2569     case '\020':        /* ^P */
2570       if (*remaining == '\0') { /* ^P */
2571           PL_perldb = SvIV(sv);
2572           if (PL_perldb && !PL_DBsingle)
2573               init_debugger();
2574           break;
2575       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2576           goto do_prematch;
2577       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2578           goto do_postmatch;
2579       }
2580       break;
2581     case '\024':        /* ^T */
2582 #ifdef BIG_TIME
2583         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2584 #else
2585         PL_basetime = (Time_t)SvIV(sv);
2586 #endif
2587         break;
2588     case '\025':        /* ^UTF8CACHE */
2589          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2590              PL_utf8cache = (signed char) sv_2iv(sv);
2591          }
2592          break;
2593     case '\027':        /* ^W & $^WARNING_BITS */
2594         if (*(mg->mg_ptr+1) == '\0') {
2595             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2596                 i = SvIV(sv);
2597                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2598                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2599             }
2600         }
2601         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2602             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2603                 if (!SvPOK(sv) && PL_localizing) {
2604                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2605                     PL_compiling.cop_warnings = pWARN_NONE;
2606                     break;
2607                 }
2608                 {
2609                     STRLEN len, i;
2610                     int accumulate = 0 ;
2611                     int any_fatals = 0 ;
2612                     const char * const ptr = SvPV_const(sv, len) ;
2613                     for (i = 0 ; i < len ; ++i) {
2614                         accumulate |= ptr[i] ;
2615                         any_fatals |= (ptr[i] & 0xAA) ;
2616                     }
2617                     if (!accumulate) {
2618                         if (!specialWARN(PL_compiling.cop_warnings))
2619                             PerlMemShared_free(PL_compiling.cop_warnings);
2620                         PL_compiling.cop_warnings = pWARN_NONE;
2621                     }
2622                     /* Yuck. I can't see how to abstract this:  */
2623                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2624                                        WARN_ALL) && !any_fatals) {
2625                         if (!specialWARN(PL_compiling.cop_warnings))
2626                             PerlMemShared_free(PL_compiling.cop_warnings);
2627                         PL_compiling.cop_warnings = pWARN_ALL;
2628                         PL_dowarn |= G_WARN_ONCE ;
2629                     }
2630                     else {
2631                         STRLEN len;
2632                         const char *const p = SvPV_const(sv, len);
2633
2634                         PL_compiling.cop_warnings
2635                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2636                                                          p, len);
2637
2638                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2639                             PL_dowarn |= G_WARN_ONCE ;
2640                     }
2641
2642                 }
2643             }
2644         }
2645         break;
2646     case '.':
2647         if (PL_localizing) {
2648             if (PL_localizing == 1)
2649                 SAVESPTR(PL_last_in_gv);
2650         }
2651         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2652             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2653         break;
2654     case '^':
2655         if (isGV_with_GP(PL_defoutgv)) {
2656             Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2657             s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2658             IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2659         }
2660         break;
2661     case '~':
2662         if (isGV_with_GP(PL_defoutgv)) {
2663             Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2664             s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2665             IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2666         }
2667         break;
2668     case '=':
2669         if (isGV_with_GP(PL_defoutgv))
2670             IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2671         break;
2672     case '-':
2673         if (isGV_with_GP(PL_defoutgv)) {
2674             IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2675             if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2676                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2677         }
2678         break;
2679     case '%':
2680         if (isGV_with_GP(PL_defoutgv))
2681             IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2682         break;
2683     case '|':
2684         {
2685             IO * const io = GvIO(PL_defoutgv);
2686             if(!io)
2687               break;
2688             if ((SvIV(sv)) == 0)
2689                 IoFLAGS(io) &= ~IOf_FLUSH;
2690             else {
2691                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2692                     PerlIO *ofp = IoOFP(io);
2693                     if (ofp)
2694                         (void)PerlIO_flush(ofp);
2695                     IoFLAGS(io) |= IOf_FLUSH;
2696                 }
2697             }
2698         }
2699         break;
2700     case '/':
2701         SvREFCNT_dec(PL_rs);
2702         PL_rs = newSVsv(sv);
2703         break;
2704     case '\\':
2705         SvREFCNT_dec(PL_ors_sv);
2706         if (SvOK(sv) || SvGMAGICAL(sv)) {
2707             PL_ors_sv = newSVsv(sv);
2708         }
2709         else {
2710             PL_ors_sv = NULL;
2711         }
2712         break;
2713     case '[':
2714         CopARYBASE_set(&PL_compiling, SvIV(sv));
2715         break;
2716     case '?':
2717 #ifdef COMPLEX_STATUS
2718         if (PL_localizing == 2) {
2719             SvUPGRADE(sv, SVt_PVLV);
2720             PL_statusvalue = LvTARGOFF(sv);
2721             PL_statusvalue_vms = LvTARGLEN(sv);
2722         }
2723         else
2724 #endif
2725 #ifdef VMSISH_STATUS
2726         if (VMSISH_STATUS)
2727             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2728         else
2729 #endif
2730             STATUS_UNIX_EXIT_SET(SvIV(sv));
2731         break;
2732     case '!':
2733         {
2734 #ifdef VMS
2735 #   define PERL_VMS_BANG vaxc$errno
2736 #else
2737 #   define PERL_VMS_BANG 0
2738 #endif
2739         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2740                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2741         }
2742         break;
2743     case '<':
2744         PL_uid = SvIV(sv);
2745         if (PL_delaymagic) {
2746             PL_delaymagic |= DM_RUID;
2747             break;                              /* don't do magic till later */
2748         }
2749 #ifdef HAS_SETRUID
2750         (void)setruid((Uid_t)PL_uid);
2751 #else
2752 #ifdef HAS_SETREUID
2753         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2754 #else
2755 #ifdef HAS_SETRESUID
2756       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2757 #else
2758         if (PL_uid == PL_euid) {                /* special case $< = $> */
2759 #ifdef PERL_DARWIN
2760             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2761             if (PL_uid != 0 && PerlProc_getuid() == 0)
2762                 (void)PerlProc_setuid(0);
2763 #endif
2764             (void)PerlProc_setuid(PL_uid);
2765         } else {
2766             PL_uid = PerlProc_getuid();
2767             Perl_croak(aTHX_ "setruid() not implemented");
2768         }
2769 #endif
2770 #endif
2771 #endif
2772         PL_uid = PerlProc_getuid();
2773         break;
2774     case '>':
2775         PL_euid = SvIV(sv);
2776         if (PL_delaymagic) {
2777             PL_delaymagic |= DM_EUID;
2778             break;                              /* don't do magic till later */
2779         }
2780 #ifdef HAS_SETEUID
2781         (void)seteuid((Uid_t)PL_euid);
2782 #else
2783 #ifdef HAS_SETREUID
2784         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2785 #else
2786 #ifdef HAS_SETRESUID
2787         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2788 #else
2789         if (PL_euid == PL_uid)          /* special case $> = $< */
2790             PerlProc_setuid(PL_euid);
2791         else {
2792             PL_euid = PerlProc_geteuid();
2793             Perl_croak(aTHX_ "seteuid() not implemented");
2794         }
2795 #endif
2796 #endif
2797 #endif
2798         PL_euid = PerlProc_geteuid();
2799         break;
2800     case '(':
2801         PL_gid = SvIV(sv);
2802         if (PL_delaymagic) {
2803             PL_delaymagic |= DM_RGID;
2804             break;                              /* don't do magic till later */
2805         }
2806 #ifdef HAS_SETRGID
2807         (void)setrgid((Gid_t)PL_gid);
2808 #else
2809 #ifdef HAS_SETREGID
2810         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2811 #else
2812 #ifdef HAS_SETRESGID
2813       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2814 #else
2815         if (PL_gid == PL_egid)                  /* special case $( = $) */
2816             (void)PerlProc_setgid(PL_gid);
2817         else {
2818             PL_gid = PerlProc_getgid();
2819             Perl_croak(aTHX_ "setrgid() not implemented");
2820         }
2821 #endif
2822 #endif
2823 #endif
2824         PL_gid = PerlProc_getgid();
2825         break;
2826     case ')':
2827 #ifdef HAS_SETGROUPS
2828         {
2829             const char *p = SvPV_const(sv, len);
2830             Groups_t *gary = NULL;
2831 #ifdef _SC_NGROUPS_MAX
2832            int maxgrp = sysconf(_SC_NGROUPS_MAX);
2833
2834            if (maxgrp < 0)
2835                maxgrp = NGROUPS;
2836 #else
2837            int maxgrp = NGROUPS;
2838 #endif
2839
2840             while (isSPACE(*p))
2841                 ++p;
2842             PL_egid = Atol(p);
2843             for (i = 0; i < maxgrp; ++i) {
2844                 while (*p && !isSPACE(*p))
2845                     ++p;
2846                 while (isSPACE(*p))
2847                     ++p;
2848                 if (!*p)
2849                     break;
2850                 if(!gary)
2851                     Newx(gary, i + 1, Groups_t);
2852                 else
2853                     Renew(gary, i + 1, Groups_t);
2854                 gary[i] = Atol(p);
2855             }
2856             if (i)
2857                 (void)setgroups(i, gary);
2858             Safefree(gary);
2859         }
2860 #else  /* HAS_SETGROUPS */
2861         PL_egid = SvIV(sv);
2862 #endif /* HAS_SETGROUPS */
2863         if (PL_delaymagic) {
2864             PL_delaymagic |= DM_EGID;
2865             break;                              /* don't do magic till later */
2866         }
2867 #ifdef HAS_SETEGID
2868         (void)setegid((Gid_t)PL_egid);
2869 #else
2870 #ifdef HAS_SETREGID
2871         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2872 #else
2873 #ifdef HAS_SETRESGID
2874         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2875 #else
2876         if (PL_egid == PL_gid)                  /* special case $) = $( */
2877             (void)PerlProc_setgid(PL_egid);
2878         else {
2879             PL_egid = PerlProc_getegid();
2880             Perl_croak(aTHX_ "setegid() not implemented");
2881         }
2882 #endif
2883 #endif
2884 #endif
2885         PL_egid = PerlProc_getegid();
2886         break;
2887     case ':':
2888         PL_chopset = SvPV_force(sv,len);
2889         break;
2890     case '0':
2891         LOCK_DOLLARZERO_MUTEX;
2892 #ifdef HAS_SETPROCTITLE
2893         /* The BSDs don't show the argv[] in ps(1) output, they
2894          * show a string from the process struct and provide
2895          * the setproctitle() routine to manipulate that. */
2896         if (PL_origalen != 1) {
2897             s = SvPV_const(sv, len);
2898 #   if __FreeBSD_version > 410001
2899             /* The leading "-" removes the "perl: " prefix,
2900              * but not the "(perl) suffix from the ps(1)
2901              * output, because that's what ps(1) shows if the
2902              * argv[] is modified. */
2903             setproctitle("-%s", s);
2904 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2905             /* This doesn't really work if you assume that
2906              * $0 = 'foobar'; will wipe out 'perl' from the $0
2907              * because in ps(1) output the result will be like
2908              * sprintf("perl: %s (perl)", s)
2909              * I guess this is a security feature:
2910              * one (a user process) cannot get rid of the original name.
2911              * --jhi */
2912             setproctitle("%s", s);
2913 #   endif
2914         }
2915 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2916         if (PL_origalen != 1) {
2917              union pstun un;
2918              s = SvPV_const(sv, len);
2919              un.pst_command = (char *)s;
2920              pstat(PSTAT_SETCMD, un, len, 0, 0);
2921         }
2922 #else
2923         if (PL_origalen > 1) {
2924             /* PL_origalen is set in perl_parse(). */
2925             s = SvPV_force(sv,len);
2926             if (len >= (STRLEN)PL_origalen-1) {
2927                 /* Longer than original, will be truncated. We assume that
2928                  * PL_origalen bytes are available. */
2929                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2930             }
2931             else {
2932                 /* Shorter than original, will be padded. */
2933 #ifdef PERL_DARWIN
2934                 /* Special case for Mac OS X: see [perl #38868] */
2935                 const int pad = 0;
2936 #else
2937                 /* Is the space counterintuitive?  Yes.
2938                  * (You were expecting \0?)
2939                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2940                  * --jhi */
2941                 const int pad = ' ';
2942 #endif
2943                 Copy(s, PL_origargv[0], len, char);
2944                 PL_origargv[0][len] = 0;
2945                 memset(PL_origargv[0] + len + 1,
2946                        pad,  PL_origalen - len - 1);
2947             }
2948             PL_origargv[0][PL_origalen-1] = 0;
2949             for (i = 1; i < PL_origargc; i++)
2950                 PL_origargv[i] = 0;
2951 #ifdef HAS_PRCTL_SET_NAME
2952             /* Set the legacy process name in addition to the POSIX name on Linux */
2953             if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2954                 /* diag_listed_as: SKIPME */
2955                 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2956             }
2957 #endif
2958         }
2959 #endif
2960         UNLOCK_DOLLARZERO_MUTEX;
2961         break;
2962     }
2963     return 0;
2964 }
2965
2966 I32
2967 Perl_whichsig(pTHX_ const char *sig)
2968 {
2969     register char* const* sigv;
2970
2971     PERL_ARGS_ASSERT_WHICHSIG;
2972     PERL_UNUSED_CONTEXT;
2973
2974     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2975         if (strEQ(sig,*sigv))
2976             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2977 #ifdef SIGCLD
2978     if (strEQ(sig,"CHLD"))
2979         return SIGCLD;
2980 #endif
2981 #ifdef SIGCHLD
2982     if (strEQ(sig,"CLD"))
2983         return SIGCHLD;
2984 #endif
2985     return -1;
2986 }
2987
2988 Signal_t
2989 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2990 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2991 #else
2992 Perl_sighandler(int sig)
2993 #endif
2994 {
2995 #ifdef PERL_GET_SIG_CONTEXT
2996     dTHXa(PERL_GET_SIG_CONTEXT);
2997 #else
2998     dTHX;
2999 #endif
3000     dSP;
3001     GV *gv = NULL;
3002     SV *sv = NULL;
3003     SV * const tSv = PL_Sv;
3004     CV *cv = NULL;
3005     OP *myop = PL_op;
3006     U32 flags = 0;
3007     XPV * const tXpv = PL_Xpv;
3008     I32 old_ss_ix = PL_savestack_ix;
3009
3010
3011     if (!PL_psig_ptr[sig]) {
3012                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3013                                  PL_sig_name[sig]);
3014                 exit(sig);
3015         }
3016
3017     /* Max number of items pushed there is 3*n or 4. We cannot fix
3018        infinity, so we fix 4 (in fact 5): */
3019     if (PL_savestack_ix + 15 <= PL_savestack_max) {
3020         flags |= 1;
3021         PL_savestack_ix += 5;           /* Protect save in progress. */
3022         SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3023     }
3024     if (PL_markstack_ptr < PL_markstack_max - 2) {
3025         flags |= 2;
3026         PL_markstack_ptr++;             /* Protect mark. */
3027     }
3028     if (PL_scopestack_ix < PL_scopestack_max - 3) {
3029         flags |= 4;
3030         PL_scopestack_ix++;
3031     }
3032     /* sv_2cv is too complicated, try a simpler variant first: */
3033     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3034         || SvTYPE(cv) != SVt_PVCV) {
3035         HV *st;
3036         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3037     }
3038
3039     if (!cv || !CvROOT(cv)) {
3040         Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
3041                        PL_sig_name[sig], (gv ? GvENAME(gv)
3042                                           : ((cv && CvGV(cv))
3043                                              ? GvENAME(CvGV(cv))
3044                                              : "__ANON__")));
3045         goto cleanup;
3046     }
3047
3048     sv = PL_psig_name[sig]
3049             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3050             : newSVpv(PL_sig_name[sig],0);
3051     flags |= 8;
3052     SAVEFREESV(sv);
3053
3054     /* make sure our assumption about the size of the SAVEs are correct:
3055      * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3056     assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3057
3058     PUSHSTACKi(PERLSI_SIGNAL);
3059     PUSHMARK(SP);
3060     PUSHs(sv);
3061 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3062     {
3063          struct sigaction oact;
3064
3065          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3066               if (sip) {
3067                    HV *sih = newHV();
3068                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3069                    /* The siginfo fields signo, code, errno, pid, uid,
3070                     * addr, status, and band are defined by POSIX/SUSv3. */
3071                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3072                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
3073 #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. */
3074                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
3075                    hv_stores(sih, "status",     newSViv(sip->si_status));
3076                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
3077                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
3078                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3079                    hv_stores(sih, "band",       newSViv(sip->si_band));
3080 #endif
3081                    EXTEND(SP, 2);
3082                    PUSHs(rv);
3083                    mPUSHp((char *)sip, sizeof(*sip));
3084               }
3085
3086          }
3087     }
3088 #endif
3089     PUTBACK;
3090
3091     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3092
3093     POPSTACK;
3094     if (SvTRUE(ERRSV)) {
3095 #ifndef PERL_MICRO
3096 #ifdef HAS_SIGPROCMASK
3097         /* Handler "died", for example to get out of a restart-able read().
3098          * Before we re-do that on its behalf re-enable the signal which was
3099          * blocked by the system when we entered.
3100          */
3101         sigset_t set;
3102         sigemptyset(&set);
3103         sigaddset(&set,sig);
3104         sigprocmask(SIG_UNBLOCK, &set, NULL);
3105 #else
3106         /* Not clear if this will work */
3107         (void)rsignal(sig, SIG_IGN);
3108         (void)rsignal(sig, PL_csighandlerp);
3109 #endif
3110 #endif /* !PERL_MICRO */
3111         die_sv(ERRSV);
3112     }
3113 cleanup:
3114     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3115     PL_savestack_ix = old_ss_ix;
3116     if (flags & 2)
3117         PL_markstack_ptr--;
3118     if (flags & 4)
3119         PL_scopestack_ix -= 1;
3120     if (flags & 8)
3121         SvREFCNT_dec(sv);
3122     PL_op = myop;                       /* Apparently not needed... */
3123
3124     PL_Sv = tSv;                        /* Restore global temporaries. */
3125     PL_Xpv = tXpv;
3126     return;
3127 }
3128
3129
3130 static void
3131 S_restore_magic(pTHX_ const void *p)
3132 {
3133     dVAR;
3134     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3135     SV* const sv = mgs->mgs_sv;
3136
3137     if (!sv)
3138         return;
3139
3140     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3141     {
3142 #ifdef PERL_OLD_COPY_ON_WRITE
3143         /* While magic was saved (and off) sv_setsv may well have seen
3144            this SV as a prime candidate for COW.  */
3145         if (SvIsCOW(sv))
3146             sv_force_normal_flags(sv, 0);
3147 #endif
3148
3149         if (mgs->mgs_readonly)
3150             SvREADONLY_on(sv);
3151         if (mgs->mgs_magical)
3152             SvFLAGS(sv) |= mgs->mgs_magical;
3153         else
3154             mg_magical(sv);
3155         if (SvGMAGICAL(sv)) {
3156             /* downgrade public flags to private,
3157                and discard any other private flags */
3158
3159             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3160             if (pubflags) {
3161                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3162                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3163             }
3164         }
3165     }
3166
3167     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3168
3169     /* If we're still on top of the stack, pop us off.  (That condition
3170      * will be satisfied if restore_magic was called explicitly, but *not*
3171      * if it's being called via leave_scope.)
3172      * The reason for doing this is that otherwise, things like sv_2cv()
3173      * may leave alloc gunk on the savestack, and some code
3174      * (e.g. sighandler) doesn't expect that...
3175      */
3176     if (PL_savestack_ix == mgs->mgs_ss_ix)
3177     {
3178         UV popval = SSPOPUV;
3179         assert(popval == SAVEt_DESTRUCTOR_X);
3180         PL_savestack_ix -= 2;
3181         popval = SSPOPUV;
3182         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3183         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3184     }
3185     if (SvREFCNT(sv) == 1) {
3186         /* We hold the last reference to this SV, which implies that the
3187            SV was deleted as a side effect of the routines we called.
3188            So artificially keep it alive a bit longer.
3189            We avoid turning on the TEMP flag, which can cause the SV's
3190            buffer to get stolen (and maybe other stuff). */
3191         int was_temp = SvTEMP(sv);
3192         sv_2mortal(sv);
3193         if (!was_temp) {
3194             SvTEMP_off(sv);
3195         }
3196         SvOK_off(sv);
3197     }
3198     else
3199         SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
3200 }
3201
3202 /* clean up the mess created by Perl_sighandler().
3203  * Note that this is only called during an exit in a signal handler;
3204  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3205  * skipped over. This is why we don't need to fix up the markstack and
3206  * scopestack - they're going to be set to 0 anyway */
3207
3208 static void
3209 S_unwind_handler_stack(pTHX_ const void *p)
3210 {
3211     dVAR;
3212     PERL_UNUSED_ARG(p);
3213
3214     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3215 }
3216
3217 /*
3218 =for apidoc magic_sethint
3219
3220 Triggered by a store to %^H, records the key/value pair to
3221 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3222 anything that would need a deep copy.  Maybe we should warn if we find a
3223 reference.
3224
3225 =cut
3226 */
3227 int
3228 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3229 {
3230     dVAR;
3231     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3232         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3233
3234     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3235
3236     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3237        an alternative leaf in there, with PL_compiling.cop_hints being used if
3238        it's NULL. If needed for threads, the alternative could lock a mutex,
3239        or take other more complex action.  */
3240
3241     /* Something changed in %^H, so it will need to be restored on scope exit.
3242        Doing this here saves a lot of doing it manually in perl code (and
3243        forgetting to do it, and consequent subtle errors.  */
3244     PL_hints |= HINT_LOCALIZE_HH;
3245     CopHINTHASH_set(&PL_compiling,
3246         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3247     return 0;
3248 }
3249
3250 /*
3251 =for apidoc magic_clearhint
3252
3253 Triggered by a delete from %^H, records the key to
3254 C<PL_compiling.cop_hints_hash>.
3255
3256 =cut
3257 */
3258 int
3259 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3260 {
3261     dVAR;
3262
3263     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3264     PERL_UNUSED_ARG(sv);
3265
3266     assert(mg->mg_len == HEf_SVKEY);
3267
3268     PERL_UNUSED_ARG(sv);
3269
3270     PL_hints |= HINT_LOCALIZE_HH;
3271     CopHINTHASH_set(&PL_compiling,
3272         cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3273                                  MUTABLE_SV(mg->mg_ptr), 0, 0));
3274     return 0;
3275 }
3276
3277 /*
3278 =for apidoc magic_clearhints
3279
3280 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3281
3282 =cut
3283 */
3284 int
3285 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3286 {
3287     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3288     PERL_UNUSED_ARG(sv);
3289     PERL_UNUSED_ARG(mg);
3290     cophh_free(CopHINTHASH_get(&PL_compiling));
3291     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3292     return 0;
3293 }
3294
3295 /*
3296  * Local variables:
3297  * c-indentation-style: bsd
3298  * c-basic-offset: 4
3299  * indent-tabs-mode: t
3300  * End:
3301  *
3302  * ex: set ts=8 sts=4 sw=4 noet:
3303  */