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