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