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