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