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