Use tempfile() in tests
[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             LvTARGOFF(sv) = PL_statusvalue;
979             LvTARGLEN(sv) = PL_statusvalue_vms;
980 #endif
981         }
982         break;
983     case '^':
984         if (GvIOp(PL_defoutgv))
985             s = IoTOP_NAME(GvIOp(PL_defoutgv));
986         if (s)
987             sv_setpv(sv,s);
988         else {
989             sv_setpv(sv,GvENAME(PL_defoutgv));
990             sv_catpvs(sv,"_TOP");
991         }
992         break;
993     case '~':
994         if (GvIOp(PL_defoutgv))
995             s = IoFMT_NAME(GvIOp(PL_defoutgv));
996         if (!s)
997             s = GvENAME(PL_defoutgv);
998         sv_setpv(sv,s);
999         break;
1000     case '=':
1001         if (GvIOp(PL_defoutgv))
1002             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1003         break;
1004     case '-':
1005         if (GvIOp(PL_defoutgv))
1006             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1007         break;
1008     case '%':
1009         if (GvIOp(PL_defoutgv))
1010             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1011         break;
1012     case ':':
1013         break;
1014     case '/':
1015         break;
1016     case '[':
1017         sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1018         break;
1019     case '|':
1020         if (GvIOp(PL_defoutgv))
1021             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1022         break;
1023     case ',':
1024         break;
1025     case '\\':
1026         if (PL_ors_sv)
1027             sv_copypv(sv, PL_ors_sv);
1028         break;
1029     case '!':
1030 #ifdef VMS
1031         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1032         sv_setpv(sv, errno ? Strerror(errno) : "");
1033 #else
1034         {
1035         dSAVE_ERRNO;
1036         sv_setnv(sv, (NV)errno);
1037 #ifdef OS2
1038         if (errno == errno_isOS2 || errno == errno_isOS2_set)
1039             sv_setpv(sv, os2error(Perl_rc));
1040         else
1041 #endif
1042         sv_setpv(sv, errno ? Strerror(errno) : "");
1043         RESTORE_ERRNO;
1044         }
1045 #endif
1046         SvRTRIM(sv);
1047         SvNOK_on(sv);   /* what a wonderful hack! */
1048         break;
1049     case '<':
1050         sv_setiv(sv, (IV)PL_uid);
1051         break;
1052     case '>':
1053         sv_setiv(sv, (IV)PL_euid);
1054         break;
1055     case '(':
1056         sv_setiv(sv, (IV)PL_gid);
1057         goto add_groups;
1058     case ')':
1059         sv_setiv(sv, (IV)PL_egid);
1060       add_groups:
1061 #ifdef HAS_GETGROUPS
1062         {
1063             Groups_t *gary = NULL;
1064             I32 i, num_groups = getgroups(0, gary);
1065             Newx(gary, num_groups, Groups_t);
1066             num_groups = getgroups(num_groups, gary);
1067             for (i = 0; i < num_groups; i++)
1068                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1069             Safefree(gary);
1070         }
1071         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1072 #endif
1073         break;
1074 #ifndef MACOS_TRADITIONAL
1075     case '0':
1076         break;
1077 #endif
1078     }
1079     return 0;
1080 }
1081
1082 int
1083 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1084 {
1085     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1086
1087     PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1088
1089     if (uf && uf->uf_val)
1090         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1091     return 0;
1092 }
1093
1094 int
1095 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1096 {
1097     dVAR;
1098     STRLEN len = 0, klen;
1099     const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1100     const char * const ptr = MgPV_const(mg,klen);
1101     my_setenv(ptr, s);
1102
1103     PERL_ARGS_ASSERT_MAGIC_SETENV;
1104
1105 #ifdef DYNAMIC_ENV_FETCH
1106      /* We just undefd an environment var.  Is a replacement */
1107      /* waiting in the wings? */
1108     if (!len) {
1109         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1110         if (valp)
1111             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1112     }
1113 #endif
1114
1115 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1116                             /* And you'll never guess what the dog had */
1117                             /*   in its mouth... */
1118     if (PL_tainting) {
1119         MgTAINTEDDIR_off(mg);
1120 #ifdef VMS
1121         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1122             char pathbuf[256], eltbuf[256], *cp, *elt;
1123             Stat_t sbuf;
1124             int i = 0, j = 0;
1125
1126             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1127             elt = eltbuf;
1128             do {          /* DCL$PATH may be a search list */
1129                 while (1) {   /* as may dev portion of any element */
1130                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1131                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1132                              cando_by_name(S_IWUSR,0,elt) ) {
1133                             MgTAINTEDDIR_on(mg);
1134                             return 0;
1135                         }
1136                     }
1137                     if ((cp = strchr(elt, ':')) != NULL)
1138                         *cp = '\0';
1139                     if (my_trnlnm(elt, eltbuf, j++))
1140                         elt = eltbuf;
1141                     else
1142                         break;
1143                 }
1144                 j = 0;
1145             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1146         }
1147 #endif /* VMS */
1148         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1149             const char * const strend = s + len;
1150
1151             while (s < strend) {
1152                 char tmpbuf[256];
1153                 Stat_t st;
1154                 I32 i;
1155 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1156                 const char path_sep = '|';
1157 #else
1158                 const char path_sep = ':';
1159 #endif
1160                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1161                              s, strend, path_sep, &i);
1162                 s++;
1163                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1164 #ifdef VMS
1165                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1166 #else
1167                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1168 #endif
1169                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1170                     MgTAINTEDDIR_on(mg);
1171                     return 0;
1172                 }
1173             }
1174         }
1175     }
1176 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1177
1178     return 0;
1179 }
1180
1181 int
1182 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1183 {
1184     PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1185     PERL_UNUSED_ARG(sv);
1186     my_setenv(MgPV_nolen_const(mg),NULL);
1187     return 0;
1188 }
1189
1190 int
1191 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1192 {
1193     dVAR;
1194     PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1195     PERL_UNUSED_ARG(mg);
1196 #if defined(VMS)
1197     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1198 #else
1199     if (PL_localizing) {
1200         HE* entry;
1201         my_clearenv();
1202         hv_iterinit(MUTABLE_HV(sv));
1203         while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1204             I32 keylen;
1205             my_setenv(hv_iterkey(entry, &keylen),
1206                       SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1207         }
1208     }
1209 #endif
1210     return 0;
1211 }
1212
1213 int
1214 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1215 {
1216     dVAR;
1217     PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1218     PERL_UNUSED_ARG(sv);
1219     PERL_UNUSED_ARG(mg);
1220 #if defined(VMS)
1221     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1222 #else
1223     my_clearenv();
1224 #endif
1225     return 0;
1226 }
1227
1228 #ifndef PERL_MICRO
1229 #ifdef HAS_SIGPROCMASK
1230 static void
1231 restore_sigmask(pTHX_ SV *save_sv)
1232 {
1233     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1234     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1235 }
1236 #endif
1237 int
1238 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1239 {
1240     dVAR;
1241     /* Are we fetching a signal entry? */
1242     const I32 i = whichsig(MgPV_nolen_const(mg));
1243
1244     PERL_ARGS_ASSERT_MAGIC_GETSIG;
1245
1246     if (i > 0) {
1247         if(PL_psig_ptr[i])
1248             sv_setsv(sv,PL_psig_ptr[i]);
1249         else {
1250             Sighandler_t sigstate = rsignal_state(i);
1251 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1252             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1253                 sigstate = SIG_IGN;
1254 #endif
1255 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1256             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1257                 sigstate = SIG_DFL;
1258 #endif
1259             /* cache state so we don't fetch it again */
1260             if(sigstate == (Sighandler_t) SIG_IGN)
1261                 sv_setpvs(sv,"IGNORE");
1262             else
1263                 sv_setsv(sv,&PL_sv_undef);
1264             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1265             SvTEMP_off(sv);
1266         }
1267     }
1268     return 0;
1269 }
1270 int
1271 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1272 {
1273     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1274      * refactoring might be in order.
1275      */
1276     dVAR;
1277     register const char * const s = MgPV_nolen_const(mg);
1278     PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1279     PERL_UNUSED_ARG(sv);
1280     if (*s == '_') {
1281         SV** svp = NULL;
1282         if (strEQ(s,"__DIE__"))
1283             svp = &PL_diehook;
1284         else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1285             svp = &PL_warnhook;
1286         if (svp && *svp) {
1287             SV *const to_dec = *svp;
1288             *svp = NULL;
1289             SvREFCNT_dec(to_dec);
1290         }
1291     }
1292     else {
1293         /* Are we clearing a signal entry? */
1294         const I32 i = whichsig(s);
1295         if (i > 0) {
1296 #ifdef HAS_SIGPROCMASK
1297             sigset_t set, save;
1298             SV* save_sv;
1299             /* Avoid having the signal arrive at a bad time, if possible. */
1300             sigemptyset(&set);
1301             sigaddset(&set,i);
1302             sigprocmask(SIG_BLOCK, &set, &save);
1303             ENTER;
1304             save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1305             SAVEFREESV(save_sv);
1306             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1307 #endif
1308             PERL_ASYNC_CHECK();
1309 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1310             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1311 #endif
1312 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1313             PL_sig_defaulting[i] = 1;
1314             (void)rsignal(i, PL_csighandlerp);
1315 #else
1316             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1317 #endif
1318             if(PL_psig_name[i]) {
1319                 SvREFCNT_dec(PL_psig_name[i]);
1320                 PL_psig_name[i]=0;
1321             }
1322             if(PL_psig_ptr[i]) {
1323                 SV * const to_dec=PL_psig_ptr[i];
1324                 PL_psig_ptr[i]=0;
1325                 LEAVE;
1326                 SvREFCNT_dec(to_dec);
1327             }
1328             else
1329                 LEAVE;
1330         }
1331     }
1332     return 0;
1333 }
1334
1335 Signal_t
1336 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1337 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1338 #else
1339 Perl_csighandler(int sig)
1340 #endif
1341 {
1342 #ifdef PERL_GET_SIG_CONTEXT
1343     dTHXa(PERL_GET_SIG_CONTEXT);
1344 #else
1345     dTHX;
1346 #endif
1347 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1348     (void) rsignal(sig, PL_csighandlerp);
1349     if (PL_sig_ignoring[sig]) return;
1350 #endif
1351 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1352     if (PL_sig_defaulting[sig])
1353 #ifdef KILL_BY_SIGPRC
1354             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1355 #else
1356             exit(1);
1357 #endif
1358 #endif
1359     if (
1360 #ifdef SIGILL
1361            sig == SIGILL ||
1362 #endif
1363 #ifdef SIGBUS
1364            sig == SIGBUS ||
1365 #endif
1366 #ifdef SIGSEGV
1367            sig == SIGSEGV ||
1368 #endif
1369            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1370         /* Call the perl level handler now--
1371          * with risk we may be in malloc() etc. */
1372 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1373         (*PL_sighandlerp)(sig, NULL, NULL);
1374 #else
1375         (*PL_sighandlerp)(sig);
1376 #endif
1377     else {
1378         /* Set a flag to say this signal is pending, that is awaiting delivery after
1379          * the current Perl opcode completes */
1380         PL_psig_pend[sig]++;
1381
1382 #ifndef SIG_PENDING_DIE_COUNT
1383 #  define SIG_PENDING_DIE_COUNT 120
1384 #endif
1385         /* And one to say _a_ signal is pending */
1386         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1387             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1388                        (unsigned long)SIG_PENDING_DIE_COUNT);
1389     }
1390 }
1391
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1393 void
1394 Perl_csighandler_init(void)
1395 {
1396     int sig;
1397     if (PL_sig_handlers_initted) return;
1398
1399     for (sig = 1; sig < SIG_SIZE; sig++) {
1400 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1401         dTHX;
1402         PL_sig_defaulting[sig] = 1;
1403         (void) rsignal(sig, PL_csighandlerp);
1404 #endif
1405 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1406         PL_sig_ignoring[sig] = 0;
1407 #endif
1408     }
1409     PL_sig_handlers_initted = 1;
1410 }
1411 #endif
1412
1413 void
1414 Perl_despatch_signals(pTHX)
1415 {
1416     dVAR;
1417     int sig;
1418     PL_sig_pending = 0;
1419     for (sig = 1; sig < SIG_SIZE; sig++) {
1420         if (PL_psig_pend[sig]) {
1421             PERL_BLOCKSIG_ADD(set, sig);
1422             PL_psig_pend[sig] = 0;
1423             PERL_BLOCKSIG_BLOCK(set);
1424 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1425             (*PL_sighandlerp)(sig, NULL, NULL);
1426 #else
1427             (*PL_sighandlerp)(sig);
1428 #endif
1429             PERL_BLOCKSIG_UNBLOCK(set);
1430         }
1431     }
1432 }
1433
1434 int
1435 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1436 {
1437     dVAR;
1438     I32 i;
1439     SV** svp = NULL;
1440     /* Need to be careful with SvREFCNT_dec(), because that can have side
1441      * effects (due to closures). We must make sure that the new disposition
1442      * is in place before it is called.
1443      */
1444     SV* to_dec = NULL;
1445     STRLEN len;
1446 #ifdef HAS_SIGPROCMASK
1447     sigset_t set, save;
1448     SV* save_sv;
1449 #endif
1450     register const char *s = MgPV_const(mg,len);
1451
1452     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1453
1454     if (*s == '_') {
1455         if (strEQ(s,"__DIE__"))
1456             svp = &PL_diehook;
1457         else if (strEQ(s,"__WARN__"))
1458             svp = &PL_warnhook;
1459         else
1460             Perl_croak(aTHX_ "No such hook: %s", s);
1461         i = 0;
1462         if (*svp) {
1463             if (*svp != PERL_WARNHOOK_FATAL)
1464                 to_dec = *svp;
1465             *svp = NULL;
1466         }
1467     }
1468     else {
1469         i = whichsig(s);        /* ...no, a brick */
1470         if (i <= 0) {
1471             if (ckWARN(WARN_SIGNAL))
1472                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1473             return 0;
1474         }
1475 #ifdef HAS_SIGPROCMASK
1476         /* Avoid having the signal arrive at a bad time, if possible. */
1477         sigemptyset(&set);
1478         sigaddset(&set,i);
1479         sigprocmask(SIG_BLOCK, &set, &save);
1480         ENTER;
1481         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1482         SAVEFREESV(save_sv);
1483         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1484 #endif
1485         PERL_ASYNC_CHECK();
1486 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1487         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1488 #endif
1489 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1490         PL_sig_ignoring[i] = 0;
1491 #endif
1492 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1493         PL_sig_defaulting[i] = 0;
1494 #endif
1495         SvREFCNT_dec(PL_psig_name[i]);
1496         to_dec = PL_psig_ptr[i];
1497         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1498         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1499         PL_psig_name[i] = newSVpvn(s, len);
1500         SvREADONLY_on(PL_psig_name[i]);
1501     }
1502     if (isGV_with_GP(sv) || SvROK(sv)) {
1503         if (i) {
1504             (void)rsignal(i, PL_csighandlerp);
1505 #ifdef HAS_SIGPROCMASK
1506             LEAVE;
1507 #endif
1508         }
1509         else
1510             *svp = SvREFCNT_inc_simple_NN(sv);
1511         if(to_dec)
1512             SvREFCNT_dec(to_dec);
1513         return 0;
1514     }
1515     s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1516     if (strEQ(s,"IGNORE")) {
1517         if (i) {
1518 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1519             PL_sig_ignoring[i] = 1;
1520             (void)rsignal(i, PL_csighandlerp);
1521 #else
1522             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1523 #endif
1524         }
1525     }
1526     else if (strEQ(s,"DEFAULT") || !*s) {
1527         if (i)
1528 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1529           {
1530             PL_sig_defaulting[i] = 1;
1531             (void)rsignal(i, PL_csighandlerp);
1532           }
1533 #else
1534             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1535 #endif
1536     }
1537     else {
1538         /*
1539          * We should warn if HINT_STRICT_REFS, but without
1540          * access to a known hint bit in a known OP, we can't
1541          * tell whether HINT_STRICT_REFS is in force or not.
1542          */
1543         if (!strchr(s,':') && !strchr(s,'\''))
1544             Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1545                                  SV_GMAGIC);
1546         if (i)
1547             (void)rsignal(i, PL_csighandlerp);
1548         else
1549             *svp = SvREFCNT_inc_simple_NN(sv);
1550     }
1551 #ifdef HAS_SIGPROCMASK
1552     if(i)
1553         LEAVE;
1554 #endif
1555     if(to_dec)
1556         SvREFCNT_dec(to_dec);
1557     return 0;
1558 }
1559 #endif /* !PERL_MICRO */
1560
1561 int
1562 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1563 {
1564     dVAR;
1565     HV* stash;
1566
1567     PERL_ARGS_ASSERT_MAGIC_SETISA;
1568     PERL_UNUSED_ARG(sv);
1569
1570     /* Bail out if destruction is going on */
1571     if(PL_dirty) return 0;
1572
1573     /* Skip _isaelem because _isa will handle it shortly */
1574     if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1575         return 0;
1576
1577     /* XXX Once it's possible, we need to
1578        detect that our @ISA is aliased in
1579        other stashes, and act on the stashes
1580        of all of the aliases */
1581
1582     /* The first case occurs via setisa,
1583        the second via setisa_elem, which
1584        calls this same magic */
1585     stash = GvSTASH(
1586         SvTYPE(mg->mg_obj) == SVt_PVGV
1587             ? (const GV *)mg->mg_obj
1588             : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1589     );
1590
1591     if (stash)
1592         mro_isa_changed_in(stash);
1593
1594     return 0;
1595 }
1596
1597 int
1598 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1599 {
1600     dVAR;
1601     HV* stash;
1602
1603     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1604
1605     /* Bail out if destruction is going on */
1606     if(PL_dirty) return 0;
1607
1608     av_clear(MUTABLE_AV(sv));
1609
1610     /* XXX see comments in magic_setisa */
1611     stash = GvSTASH(
1612         SvTYPE(mg->mg_obj) == SVt_PVGV
1613             ? (const GV *)mg->mg_obj
1614             : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1615     );
1616
1617     if (stash)
1618         mro_isa_changed_in(stash);
1619
1620     return 0;
1621 }
1622
1623 int
1624 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1625 {
1626     dVAR;
1627     PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1628     PERL_UNUSED_ARG(sv);
1629     PERL_UNUSED_ARG(mg);
1630     PL_amagic_generation++;
1631
1632     return 0;
1633 }
1634
1635 int
1636 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1637 {
1638     HV * const hv = MUTABLE_HV(LvTARG(sv));
1639     I32 i = 0;
1640
1641     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1642     PERL_UNUSED_ARG(mg);
1643
1644     if (hv) {
1645          (void) hv_iterinit(hv);
1646          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1647              i = HvKEYS(hv);
1648          else {
1649              while (hv_iternext(hv))
1650                  i++;
1651          }
1652     }
1653
1654     sv_setiv(sv, (IV)i);
1655     return 0;
1656 }
1657
1658 int
1659 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1660 {
1661     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1662     PERL_UNUSED_ARG(mg);
1663     if (LvTARG(sv)) {
1664         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1665     }
1666     return 0;
1667 }
1668
1669 /* caller is responsible for stack switching/cleanup */
1670 STATIC int
1671 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1672 {
1673     dVAR;
1674     dSP;
1675
1676     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1677
1678     PUSHMARK(SP);
1679     EXTEND(SP, n);
1680     PUSHs(SvTIED_obj(sv, mg));
1681     if (n > 1) {
1682         if (mg->mg_ptr) {
1683             if (mg->mg_len >= 0)
1684                 mPUSHp(mg->mg_ptr, mg->mg_len);
1685             else if (mg->mg_len == HEf_SVKEY)
1686                 PUSHs(MUTABLE_SV(mg->mg_ptr));
1687         }
1688         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1689             mPUSHi(mg->mg_len);
1690         }
1691     }
1692     if (n > 2) {
1693         PUSHs(val);
1694     }
1695     PUTBACK;
1696
1697     return call_method(meth, flags);
1698 }
1699
1700 STATIC int
1701 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1702 {
1703     dVAR; dSP;
1704
1705     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1706
1707     ENTER;
1708     SAVETMPS;
1709     PUSHSTACKi(PERLSI_MAGIC);
1710
1711     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1712         sv_setsv(sv, *PL_stack_sp--);
1713     }
1714
1715     POPSTACK;
1716     FREETMPS;
1717     LEAVE;
1718     return 0;
1719 }
1720
1721 int
1722 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1723 {
1724     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1725
1726     if (mg->mg_ptr)
1727         mg->mg_flags |= MGf_GSKIP;
1728     magic_methpack(sv,mg,"FETCH");
1729     return 0;
1730 }
1731
1732 int
1733 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1734 {
1735     dVAR; dSP;
1736
1737     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1738
1739     ENTER;
1740     PUSHSTACKi(PERLSI_MAGIC);
1741     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1742     POPSTACK;
1743     LEAVE;
1744     return 0;
1745 }
1746
1747 int
1748 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1749 {
1750     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1751
1752     return magic_methpack(sv,mg,"DELETE");
1753 }
1754
1755
1756 U32
1757 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1758 {
1759     dVAR; dSP;
1760     I32 retval = 0;
1761
1762     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1763
1764     ENTER;
1765     SAVETMPS;
1766     PUSHSTACKi(PERLSI_MAGIC);
1767     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1768         sv = *PL_stack_sp--;
1769         retval = SvIV(sv)-1;
1770         if (retval < -1)
1771             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1772     }
1773     POPSTACK;
1774     FREETMPS;
1775     LEAVE;
1776     return (U32) retval;
1777 }
1778
1779 int
1780 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1781 {
1782     dVAR; dSP;
1783
1784     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1785
1786     ENTER;
1787     PUSHSTACKi(PERLSI_MAGIC);
1788     PUSHMARK(SP);
1789     XPUSHs(SvTIED_obj(sv, mg));
1790     PUTBACK;
1791     call_method("CLEAR", G_SCALAR|G_DISCARD);
1792     POPSTACK;
1793     LEAVE;
1794
1795     return 0;
1796 }
1797
1798 int
1799 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1800 {
1801     dVAR; dSP;
1802     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1803
1804     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1805
1806     ENTER;
1807     SAVETMPS;
1808     PUSHSTACKi(PERLSI_MAGIC);
1809     PUSHMARK(SP);
1810     EXTEND(SP, 2);
1811     PUSHs(SvTIED_obj(sv, mg));
1812     if (SvOK(key))
1813         PUSHs(key);
1814     PUTBACK;
1815
1816     if (call_method(meth, G_SCALAR))
1817         sv_setsv(key, *PL_stack_sp--);
1818
1819     POPSTACK;
1820     FREETMPS;
1821     LEAVE;
1822     return 0;
1823 }
1824
1825 int
1826 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1827 {
1828     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1829
1830     return magic_methpack(sv,mg,"EXISTS");
1831 }
1832
1833 SV *
1834 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1835 {
1836     dVAR; dSP;
1837     SV *retval;
1838     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1839     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1840    
1841     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1842
1843     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1844         SV *key;
1845         if (HvEITER_get(hv))
1846             /* we are in an iteration so the hash cannot be empty */
1847             return &PL_sv_yes;
1848         /* no xhv_eiter so now use FIRSTKEY */
1849         key = sv_newmortal();
1850         magic_nextpack(MUTABLE_SV(hv), mg, key);
1851         HvEITER_set(hv, NULL);     /* need to reset iterator */
1852         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1853     }
1854    
1855     /* there is a SCALAR method that we can call */
1856     ENTER;
1857     PUSHSTACKi(PERLSI_MAGIC);
1858     PUSHMARK(SP);
1859     EXTEND(SP, 1);
1860     PUSHs(tied);
1861     PUTBACK;
1862
1863     if (call_method("SCALAR", G_SCALAR))
1864         retval = *PL_stack_sp--; 
1865     else
1866         retval = &PL_sv_undef;
1867     POPSTACK;
1868     LEAVE;
1869     return retval;
1870 }
1871
1872 int
1873 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1874 {
1875     dVAR;
1876     GV * const gv = PL_DBline;
1877     const I32 i = SvTRUE(sv);
1878     SV ** const svp = av_fetch(GvAV(gv),
1879                      atoi(MgPV_nolen_const(mg)), FALSE);
1880
1881     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1882
1883     if (svp && SvIOKp(*svp)) {
1884         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1885         if (o) {
1886             /* set or clear breakpoint in the relevant control op */
1887             if (i)
1888                 o->op_flags |= OPf_SPECIAL;
1889             else
1890                 o->op_flags &= ~OPf_SPECIAL;
1891         }
1892     }
1893     return 0;
1894 }
1895
1896 int
1897 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1898 {
1899     dVAR;
1900     const AV * const obj = MUTABLE_AV(mg->mg_obj);
1901
1902     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1903
1904     if (obj) {
1905         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1906     } else {
1907         SvOK_off(sv);
1908     }
1909     return 0;
1910 }
1911
1912 int
1913 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1914 {
1915     dVAR;
1916     AV * const obj = MUTABLE_AV(mg->mg_obj);
1917
1918     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1919
1920     if (obj) {
1921         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1922     } else {
1923         if (ckWARN(WARN_MISC))
1924             Perl_warner(aTHX_ packWARN(WARN_MISC),
1925                         "Attempt to set length of freed array");
1926     }
1927     return 0;
1928 }
1929
1930 int
1931 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1932 {
1933     dVAR;
1934
1935     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1936     PERL_UNUSED_ARG(sv);
1937
1938     /* during global destruction, mg_obj may already have been freed */
1939     if (PL_in_clean_all)
1940         return 0;
1941
1942     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1943
1944     if (mg) {
1945         /* arylen scalar holds a pointer back to the array, but doesn't own a
1946            reference. Hence the we (the array) are about to go away with it
1947            still pointing at us. Clear its pointer, else it would be pointing
1948            at free memory. See the comment in sv_magic about reference loops,
1949            and why it can't own a reference to us.  */
1950         mg->mg_obj = 0;
1951     }
1952     return 0;
1953 }
1954
1955 int
1956 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1957 {
1958     dVAR;
1959     SV* const lsv = LvTARG(sv);
1960
1961     PERL_ARGS_ASSERT_MAGIC_GETPOS;
1962     PERL_UNUSED_ARG(mg);
1963
1964     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1965         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1966         if (found && found->mg_len >= 0) {
1967             I32 i = found->mg_len;
1968             if (DO_UTF8(lsv))
1969                 sv_pos_b2u(lsv, &i);
1970             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1971             return 0;
1972         }
1973     }
1974     SvOK_off(sv);
1975     return 0;
1976 }
1977
1978 int
1979 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1980 {
1981     dVAR;
1982     SV* const lsv = LvTARG(sv);
1983     SSize_t pos;
1984     STRLEN len;
1985     STRLEN ulen = 0;
1986     MAGIC* found;
1987
1988     PERL_ARGS_ASSERT_MAGIC_SETPOS;
1989     PERL_UNUSED_ARG(mg);
1990
1991     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1992         found = mg_find(lsv, PERL_MAGIC_regex_global);
1993     else
1994         found = NULL;
1995     if (!found) {
1996         if (!SvOK(sv))
1997             return 0;
1998 #ifdef PERL_OLD_COPY_ON_WRITE
1999     if (SvIsCOW(lsv))
2000         sv_force_normal_flags(lsv, 0);
2001 #endif
2002         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2003                             NULL, 0);
2004     }
2005     else if (!SvOK(sv)) {
2006         found->mg_len = -1;
2007         return 0;
2008     }
2009     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2010
2011     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2012
2013     if (DO_UTF8(lsv)) {
2014         ulen = sv_len_utf8(lsv);
2015         if (ulen)
2016             len = ulen;
2017     }
2018
2019     if (pos < 0) {
2020         pos += len;
2021         if (pos < 0)
2022             pos = 0;
2023     }
2024     else if (pos > (SSize_t)len)
2025         pos = len;
2026
2027     if (ulen) {
2028         I32 p = pos;
2029         sv_pos_u2b(lsv, &p, 0);
2030         pos = p;
2031     }
2032
2033     found->mg_len = pos;
2034     found->mg_flags &= ~MGf_MINMATCH;
2035
2036     return 0;
2037 }
2038
2039 int
2040 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2041 {
2042     STRLEN len;
2043     SV * const lsv = LvTARG(sv);
2044     const char * const tmps = SvPV_const(lsv,len);
2045     I32 offs = LvTARGOFF(sv);
2046     I32 rem = LvTARGLEN(sv);
2047
2048     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2049     PERL_UNUSED_ARG(mg);
2050
2051     if (SvUTF8(lsv))
2052         sv_pos_u2b(lsv, &offs, &rem);
2053     if (offs > (I32)len)
2054         offs = len;
2055     if (rem + offs > (I32)len)
2056         rem = len - offs;
2057     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2058     if (SvUTF8(lsv))
2059         SvUTF8_on(sv);
2060     return 0;
2061 }
2062
2063 int
2064 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2065 {
2066     dVAR;
2067     STRLEN len;
2068     const char * const tmps = SvPV_const(sv, len);
2069     SV * const lsv = LvTARG(sv);
2070     I32 lvoff = LvTARGOFF(sv);
2071     I32 lvlen = LvTARGLEN(sv);
2072
2073     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2074     PERL_UNUSED_ARG(mg);
2075
2076     if (DO_UTF8(sv)) {
2077         sv_utf8_upgrade(lsv);
2078         sv_pos_u2b(lsv, &lvoff, &lvlen);
2079         sv_insert(lsv, lvoff, lvlen, tmps, len);
2080         LvTARGLEN(sv) = sv_len_utf8(sv);
2081         SvUTF8_on(lsv);
2082     }
2083     else if (lsv && SvUTF8(lsv)) {
2084         const char *utf8;
2085         sv_pos_u2b(lsv, &lvoff, &lvlen);
2086         LvTARGLEN(sv) = len;
2087         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2088         sv_insert(lsv, lvoff, lvlen, utf8, len);
2089         Safefree(utf8);
2090     }
2091     else {
2092         sv_insert(lsv, lvoff, lvlen, tmps, len);
2093         LvTARGLEN(sv) = len;
2094     }
2095
2096
2097     return 0;
2098 }
2099
2100 int
2101 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2102 {
2103     dVAR;
2104
2105     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2106     PERL_UNUSED_ARG(sv);
2107
2108     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2109     return 0;
2110 }
2111
2112 int
2113 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2114 {
2115     dVAR;
2116
2117     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2118     PERL_UNUSED_ARG(sv);
2119
2120     /* update taint status */
2121     if (PL_tainted)
2122         mg->mg_len |= 1;
2123     else
2124         mg->mg_len &= ~1;
2125     return 0;
2126 }
2127
2128 int
2129 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2130 {
2131     SV * const lsv = LvTARG(sv);
2132
2133     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2134     PERL_UNUSED_ARG(mg);
2135
2136     if (lsv)
2137         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2138     else
2139         SvOK_off(sv);
2140
2141     return 0;
2142 }
2143
2144 int
2145 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2146 {
2147     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2148     PERL_UNUSED_ARG(mg);
2149     do_vecset(sv);      /* XXX slurp this routine */
2150     return 0;
2151 }
2152
2153 int
2154 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2155 {
2156     dVAR;
2157     SV *targ = NULL;
2158
2159     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2160
2161     if (LvTARGLEN(sv)) {
2162         if (mg->mg_obj) {
2163             SV * const ahv = LvTARG(sv);
2164             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2165             if (he)
2166                 targ = HeVAL(he);
2167         }
2168         else {
2169             AV *const av = MUTABLE_AV(LvTARG(sv));
2170             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2171                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2172         }
2173         if (targ && (targ != &PL_sv_undef)) {
2174             /* somebody else defined it for us */
2175             SvREFCNT_dec(LvTARG(sv));
2176             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2177             LvTARGLEN(sv) = 0;
2178             SvREFCNT_dec(mg->mg_obj);
2179             mg->mg_obj = NULL;
2180             mg->mg_flags &= ~MGf_REFCOUNTED;
2181         }
2182     }
2183     else
2184         targ = LvTARG(sv);
2185     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2186     return 0;
2187 }
2188
2189 int
2190 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2191 {
2192     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2193     PERL_UNUSED_ARG(mg);
2194     if (LvTARGLEN(sv))
2195         vivify_defelem(sv);
2196     if (LvTARG(sv)) {
2197         sv_setsv(LvTARG(sv), sv);
2198         SvSETMAGIC(LvTARG(sv));
2199     }
2200     return 0;
2201 }
2202
2203 void
2204 Perl_vivify_defelem(pTHX_ SV *sv)
2205 {
2206     dVAR;
2207     MAGIC *mg;
2208     SV *value = NULL;
2209
2210     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2211
2212     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2213         return;
2214     if (mg->mg_obj) {
2215         SV * const ahv = LvTARG(sv);
2216         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2217         if (he)
2218             value = HeVAL(he);
2219         if (!value || value == &PL_sv_undef)
2220             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2221     }
2222     else {
2223         AV *const av = MUTABLE_AV(LvTARG(sv));
2224         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2225             LvTARG(sv) = NULL;  /* array can't be extended */
2226         else {
2227             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2228             if (!svp || (value = *svp) == &PL_sv_undef)
2229                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2230         }
2231     }
2232     SvREFCNT_inc_simple_void(value);
2233     SvREFCNT_dec(LvTARG(sv));
2234     LvTARG(sv) = value;
2235     LvTARGLEN(sv) = 0;
2236     SvREFCNT_dec(mg->mg_obj);
2237     mg->mg_obj = NULL;
2238     mg->mg_flags &= ~MGf_REFCOUNTED;
2239 }
2240
2241 int
2242 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2243 {
2244     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2245     return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2246 }
2247
2248 int
2249 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2250 {
2251     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2252     PERL_UNUSED_CONTEXT;
2253     mg->mg_len = -1;
2254     SvSCREAM_off(sv);
2255     return 0;
2256 }
2257
2258 int
2259 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2260 {
2261     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2262
2263     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2264
2265     if (uf && uf->uf_set)
2266         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2267     return 0;
2268 }
2269
2270 int
2271 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2272 {
2273     const char type = mg->mg_type;
2274
2275     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2276
2277     if (type == PERL_MAGIC_qr) {
2278     } else if (type == PERL_MAGIC_bm) {
2279         SvTAIL_off(sv);
2280         SvVALID_off(sv);
2281     } else {
2282         assert(type == PERL_MAGIC_fm);
2283         SvCOMPILED_off(sv);
2284     }
2285     return sv_unmagic(sv, type);
2286 }
2287
2288 int
2289 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2290 {
2291     dVAR;
2292     regexp * const re = (regexp *)mg->mg_obj;
2293     PERL_UNUSED_ARG(sv);
2294
2295     ReREFCNT_dec(re);
2296     return 0;
2297 }
2298
2299 #ifdef USE_LOCALE_COLLATE
2300 int
2301 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2302 {
2303     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2304
2305     /*
2306      * RenE<eacute> Descartes said "I think not."
2307      * and vanished with a faint plop.
2308      */
2309     PERL_UNUSED_CONTEXT;
2310     PERL_UNUSED_ARG(sv);
2311     if (mg->mg_ptr) {
2312         Safefree(mg->mg_ptr);
2313         mg->mg_ptr = NULL;
2314         mg->mg_len = -1;
2315     }
2316     return 0;
2317 }
2318 #endif /* USE_LOCALE_COLLATE */
2319
2320 /* Just clear the UTF-8 cache data. */
2321 int
2322 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2323 {
2324     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2325     PERL_UNUSED_CONTEXT;
2326     PERL_UNUSED_ARG(sv);
2327     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2328     mg->mg_ptr = NULL;
2329     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2330     return 0;
2331 }
2332
2333 int
2334 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2335 {
2336     dVAR;
2337     register const char *s;
2338     register I32 paren;
2339     register const REGEXP * rx;
2340     const char * const remaining = mg->mg_ptr + 1;
2341     I32 i;
2342     STRLEN len;
2343
2344     PERL_ARGS_ASSERT_MAGIC_SET;
2345
2346     switch (*mg->mg_ptr) {
2347     case '\015': /* $^MATCH */
2348       if (strEQ(remaining, "ATCH"))
2349           goto do_match;
2350     case '`': /* ${^PREMATCH} caught below */
2351       do_prematch:
2352       paren = RX_BUFF_IDX_PREMATCH;
2353       goto setparen;
2354     case '\'': /* ${^POSTMATCH} caught below */
2355       do_postmatch:
2356       paren = RX_BUFF_IDX_POSTMATCH;
2357       goto setparen;
2358     case '&':
2359       do_match:
2360       paren = RX_BUFF_IDX_FULLMATCH;
2361       goto setparen;
2362     case '1': case '2': case '3': case '4':
2363     case '5': case '6': case '7': case '8': case '9':
2364       paren = atoi(mg->mg_ptr);
2365       setparen:
2366         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2367             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2368             break;
2369         } else {
2370             /* Croak with a READONLY error when a numbered match var is
2371              * set without a previous pattern match. Unless it's C<local $1>
2372              */
2373             if (!PL_localizing) {
2374                 Perl_croak(aTHX_ "%s", PL_no_modify);
2375             }
2376         }
2377     case '\001':        /* ^A */
2378         sv_setsv(PL_bodytarget, sv);
2379         break;
2380     case '\003':        /* ^C */
2381         PL_minus_c = (bool)SvIV(sv);
2382         break;
2383
2384     case '\004':        /* ^D */
2385 #ifdef DEBUGGING
2386         s = SvPV_nolen_const(sv);
2387         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2388         DEBUG_x(dump_all());
2389 #else
2390         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2391 #endif
2392         break;
2393     case '\005':  /* ^E */
2394         if (*(mg->mg_ptr+1) == '\0') {
2395 #ifdef MACOS_TRADITIONAL
2396             gMacPerl_OSErr = SvIV(sv);
2397 #else
2398 #  ifdef VMS
2399             set_vaxc_errno(SvIV(sv));
2400 #  else
2401 #    ifdef WIN32
2402             SetLastError( SvIV(sv) );
2403 #    else
2404 #      ifdef OS2
2405             os2_setsyserrno(SvIV(sv));
2406 #      else
2407             /* will anyone ever use this? */
2408             SETERRNO(SvIV(sv), 4);
2409 #      endif
2410 #    endif
2411 #  endif
2412 #endif
2413         }
2414         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2415             if (PL_encoding)
2416                 SvREFCNT_dec(PL_encoding);
2417             if (SvOK(sv) || SvGMAGICAL(sv)) {
2418                 PL_encoding = newSVsv(sv);
2419             }
2420             else {
2421                 PL_encoding = NULL;
2422             }
2423         }
2424         break;
2425     case '\006':        /* ^F */
2426         PL_maxsysfd = SvIV(sv);
2427         break;
2428     case '\010':        /* ^H */
2429         PL_hints = SvIV(sv);
2430         break;
2431     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2432         Safefree(PL_inplace);
2433         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2434         break;
2435     case '\017':        /* ^O */
2436         if (*(mg->mg_ptr+1) == '\0') {
2437             Safefree(PL_osname);
2438             PL_osname = NULL;
2439             if (SvOK(sv)) {
2440                 TAINT_PROPER("assigning to $^O");
2441                 PL_osname = savesvpv(sv);
2442             }
2443         }
2444         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2445             STRLEN len;
2446             const char *const start = SvPV(sv, len);
2447             const char *out = (const char*)memchr(start, '\0', len);
2448             SV *tmp;
2449             struct refcounted_he *tmp_he;
2450
2451
2452             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2453             PL_hints
2454                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2455
2456             /* Opening for input is more common than opening for output, so
2457                ensure that hints for input are sooner on linked list.  */
2458             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2459                                        SVs_TEMP | SvUTF8(sv))
2460                 : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
2461
2462             tmp_he
2463                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, 
2464                                          newSVpvs_flags("open>", SVs_TEMP),
2465                                          tmp);
2466
2467             /* The UTF-8 setting is carried over  */
2468             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2469
2470             PL_compiling.cop_hints_hash
2471                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2472                                          newSVpvs_flags("open<", SVs_TEMP),
2473                                          tmp);
2474         }
2475         break;
2476     case '\020':        /* ^P */
2477       if (*remaining == '\0') { /* ^P */
2478           PL_perldb = SvIV(sv);
2479           if (PL_perldb && !PL_DBsingle)
2480               init_debugger();
2481           break;
2482       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2483           goto do_prematch;
2484       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2485           goto do_postmatch;
2486       }
2487     case '\024':        /* ^T */
2488 #ifdef BIG_TIME
2489         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2490 #else
2491         PL_basetime = (Time_t)SvIV(sv);
2492 #endif
2493         break;
2494     case '\025':        /* ^UTF8CACHE */
2495          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2496              PL_utf8cache = (signed char) sv_2iv(sv);
2497          }
2498          break;
2499     case '\027':        /* ^W & $^WARNING_BITS */
2500         if (*(mg->mg_ptr+1) == '\0') {
2501             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2502                 i = SvIV(sv);
2503                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2504                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2505             }
2506         }
2507         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2508             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2509                 if (!SvPOK(sv) && PL_localizing) {
2510                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2511                     PL_compiling.cop_warnings = pWARN_NONE;
2512                     break;
2513                 }
2514                 {
2515                     STRLEN len, i;
2516                     int accumulate = 0 ;
2517                     int any_fatals = 0 ;
2518                     const char * const ptr = SvPV_const(sv, len) ;
2519                     for (i = 0 ; i < len ; ++i) {
2520                         accumulate |= ptr[i] ;
2521                         any_fatals |= (ptr[i] & 0xAA) ;
2522                     }
2523                     if (!accumulate) {
2524                         if (!specialWARN(PL_compiling.cop_warnings))
2525                             PerlMemShared_free(PL_compiling.cop_warnings);
2526                         PL_compiling.cop_warnings = pWARN_NONE;
2527                     }
2528                     /* Yuck. I can't see how to abstract this:  */
2529                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2530                                        WARN_ALL) && !any_fatals) {
2531                         if (!specialWARN(PL_compiling.cop_warnings))
2532                             PerlMemShared_free(PL_compiling.cop_warnings);
2533                         PL_compiling.cop_warnings = pWARN_ALL;
2534                         PL_dowarn |= G_WARN_ONCE ;
2535                     }
2536                     else {
2537                         STRLEN len;
2538                         const char *const p = SvPV_const(sv, len);
2539
2540                         PL_compiling.cop_warnings
2541                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2542                                                          p, len);
2543
2544                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2545                             PL_dowarn |= G_WARN_ONCE ;
2546                     }
2547
2548                 }
2549             }
2550         }
2551         break;
2552     case '.':
2553         if (PL_localizing) {
2554             if (PL_localizing == 1)
2555                 SAVESPTR(PL_last_in_gv);
2556         }
2557         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2558             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2559         break;
2560     case '^':
2561         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2562         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2563         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2564         break;
2565     case '~':
2566         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2567         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2568         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2569         break;
2570     case '=':
2571         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2572         break;
2573     case '-':
2574         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2575         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2576             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2577         break;
2578     case '%':
2579         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2580         break;
2581     case '|':
2582         {
2583             IO * const io = GvIOp(PL_defoutgv);
2584             if(!io)
2585               break;
2586             if ((SvIV(sv)) == 0)
2587                 IoFLAGS(io) &= ~IOf_FLUSH;
2588             else {
2589                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2590                     PerlIO *ofp = IoOFP(io);
2591                     if (ofp)
2592                         (void)PerlIO_flush(ofp);
2593                     IoFLAGS(io) |= IOf_FLUSH;
2594                 }
2595             }
2596         }
2597         break;
2598     case '/':
2599         SvREFCNT_dec(PL_rs);
2600         PL_rs = newSVsv(sv);
2601         break;
2602     case '\\':
2603         if (PL_ors_sv)
2604             SvREFCNT_dec(PL_ors_sv);
2605         if (SvOK(sv) || SvGMAGICAL(sv)) {
2606             PL_ors_sv = newSVsv(sv);
2607         }
2608         else {
2609             PL_ors_sv = NULL;
2610         }
2611         break;
2612     case ',':
2613         if (PL_ofs_sv)
2614             SvREFCNT_dec(PL_ofs_sv);
2615         if (SvOK(sv) || SvGMAGICAL(sv)) {
2616             PL_ofs_sv = newSVsv(sv);
2617         }
2618         else {
2619             PL_ofs_sv = NULL;
2620         }
2621         break;
2622     case '[':
2623         CopARYBASE_set(&PL_compiling, SvIV(sv));
2624         break;
2625     case '?':
2626 #ifdef COMPLEX_STATUS
2627         if (PL_localizing == 2) {
2628             PL_statusvalue = LvTARGOFF(sv);
2629             PL_statusvalue_vms = LvTARGLEN(sv);
2630         }
2631         else
2632 #endif
2633 #ifdef VMSISH_STATUS
2634         if (VMSISH_STATUS)
2635             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2636         else
2637 #endif
2638             STATUS_UNIX_EXIT_SET(SvIV(sv));
2639         break;
2640     case '!':
2641         {
2642 #ifdef VMS
2643 #   define PERL_VMS_BANG vaxc$errno
2644 #else
2645 #   define PERL_VMS_BANG 0
2646 #endif
2647         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2648                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2649         }
2650         break;
2651     case '<':
2652         PL_uid = SvIV(sv);
2653         if (PL_delaymagic) {
2654             PL_delaymagic |= DM_RUID;
2655             break;                              /* don't do magic till later */
2656         }
2657 #ifdef HAS_SETRUID
2658         (void)setruid((Uid_t)PL_uid);
2659 #else
2660 #ifdef HAS_SETREUID
2661         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2662 #else
2663 #ifdef HAS_SETRESUID
2664       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2665 #else
2666         if (PL_uid == PL_euid) {                /* special case $< = $> */
2667 #ifdef PERL_DARWIN
2668             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2669             if (PL_uid != 0 && PerlProc_getuid() == 0)
2670                 (void)PerlProc_setuid(0);
2671 #endif
2672             (void)PerlProc_setuid(PL_uid);
2673         } else {
2674             PL_uid = PerlProc_getuid();
2675             Perl_croak(aTHX_ "setruid() not implemented");
2676         }
2677 #endif
2678 #endif
2679 #endif
2680         PL_uid = PerlProc_getuid();
2681         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2682         break;
2683     case '>':
2684         PL_euid = SvIV(sv);
2685         if (PL_delaymagic) {
2686             PL_delaymagic |= DM_EUID;
2687             break;                              /* don't do magic till later */
2688         }
2689 #ifdef HAS_SETEUID
2690         (void)seteuid((Uid_t)PL_euid);
2691 #else
2692 #ifdef HAS_SETREUID
2693         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2694 #else
2695 #ifdef HAS_SETRESUID
2696         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2697 #else
2698         if (PL_euid == PL_uid)          /* special case $> = $< */
2699             PerlProc_setuid(PL_euid);
2700         else {
2701             PL_euid = PerlProc_geteuid();
2702             Perl_croak(aTHX_ "seteuid() not implemented");
2703         }
2704 #endif
2705 #endif
2706 #endif
2707         PL_euid = PerlProc_geteuid();
2708         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2709         break;
2710     case '(':
2711         PL_gid = SvIV(sv);
2712         if (PL_delaymagic) {
2713             PL_delaymagic |= DM_RGID;
2714             break;                              /* don't do magic till later */
2715         }
2716 #ifdef HAS_SETRGID
2717         (void)setrgid((Gid_t)PL_gid);
2718 #else
2719 #ifdef HAS_SETREGID
2720         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2721 #else
2722 #ifdef HAS_SETRESGID
2723       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2724 #else
2725         if (PL_gid == PL_egid)                  /* special case $( = $) */
2726             (void)PerlProc_setgid(PL_gid);
2727         else {
2728             PL_gid = PerlProc_getgid();
2729             Perl_croak(aTHX_ "setrgid() not implemented");
2730         }
2731 #endif
2732 #endif
2733 #endif
2734         PL_gid = PerlProc_getgid();
2735         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2736         break;
2737     case ')':
2738 #ifdef HAS_SETGROUPS
2739         {
2740             const char *p = SvPV_const(sv, len);
2741             Groups_t *gary = NULL;
2742
2743             while (isSPACE(*p))
2744                 ++p;
2745             PL_egid = Atol(p);
2746             for (i = 0; i < NGROUPS; ++i) {
2747                 while (*p && !isSPACE(*p))
2748                     ++p;
2749                 while (isSPACE(*p))
2750                     ++p;
2751                 if (!*p)
2752                     break;
2753                 if(!gary)
2754                     Newx(gary, i + 1, Groups_t);
2755                 else
2756                     Renew(gary, i + 1, Groups_t);
2757                 gary[i] = Atol(p);
2758             }
2759             if (i)
2760                 (void)setgroups(i, gary);
2761             Safefree(gary);
2762         }
2763 #else  /* HAS_SETGROUPS */
2764         PL_egid = SvIV(sv);
2765 #endif /* HAS_SETGROUPS */
2766         if (PL_delaymagic) {
2767             PL_delaymagic |= DM_EGID;
2768             break;                              /* don't do magic till later */
2769         }
2770 #ifdef HAS_SETEGID
2771         (void)setegid((Gid_t)PL_egid);
2772 #else
2773 #ifdef HAS_SETREGID
2774         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2775 #else
2776 #ifdef HAS_SETRESGID
2777         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2778 #else
2779         if (PL_egid == PL_gid)                  /* special case $) = $( */
2780             (void)PerlProc_setgid(PL_egid);
2781         else {
2782             PL_egid = PerlProc_getegid();
2783             Perl_croak(aTHX_ "setegid() not implemented");
2784         }
2785 #endif
2786 #endif
2787 #endif
2788         PL_egid = PerlProc_getegid();
2789         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2790         break;
2791     case ':':
2792         PL_chopset = SvPV_force(sv,len);
2793         break;
2794 #ifndef MACOS_TRADITIONAL
2795     case '0':
2796         LOCK_DOLLARZERO_MUTEX;
2797 #ifdef HAS_SETPROCTITLE
2798         /* The BSDs don't show the argv[] in ps(1) output, they
2799          * show a string from the process struct and provide
2800          * the setproctitle() routine to manipulate that. */
2801         if (PL_origalen != 1) {
2802             s = SvPV_const(sv, len);
2803 #   if __FreeBSD_version > 410001
2804             /* The leading "-" removes the "perl: " prefix,
2805              * but not the "(perl) suffix from the ps(1)
2806              * output, because that's what ps(1) shows if the
2807              * argv[] is modified. */
2808             setproctitle("-%s", s);
2809 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2810             /* This doesn't really work if you assume that
2811              * $0 = 'foobar'; will wipe out 'perl' from the $0
2812              * because in ps(1) output the result will be like
2813              * sprintf("perl: %s (perl)", s)
2814              * I guess this is a security feature:
2815              * one (a user process) cannot get rid of the original name.
2816              * --jhi */
2817             setproctitle("%s", s);
2818 #   endif
2819         }
2820 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2821         if (PL_origalen != 1) {
2822              union pstun un;
2823              s = SvPV_const(sv, len);
2824              un.pst_command = (char *)s;
2825              pstat(PSTAT_SETCMD, un, len, 0, 0);
2826         }
2827 #else
2828         if (PL_origalen > 1) {
2829             /* PL_origalen is set in perl_parse(). */
2830             s = SvPV_force(sv,len);
2831             if (len >= (STRLEN)PL_origalen-1) {
2832                 /* Longer than original, will be truncated. We assume that
2833                  * PL_origalen bytes are available. */
2834                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2835             }
2836             else {
2837                 /* Shorter than original, will be padded. */
2838 #ifdef PERL_DARWIN
2839                 /* Special case for Mac OS X: see [perl #38868] */
2840                 const int pad = 0;
2841 #else
2842                 /* Is the space counterintuitive?  Yes.
2843                  * (You were expecting \0?)
2844                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2845                  * --jhi */
2846                 const int pad = ' ';
2847 #endif
2848                 Copy(s, PL_origargv[0], len, char);
2849                 PL_origargv[0][len] = 0;
2850                 memset(PL_origargv[0] + len + 1,
2851                        pad,  PL_origalen - len - 1);
2852             }
2853             PL_origargv[0][PL_origalen-1] = 0;
2854             for (i = 1; i < PL_origargc; i++)
2855                 PL_origargv[i] = 0;
2856         }
2857 #endif
2858         UNLOCK_DOLLARZERO_MUTEX;
2859         break;
2860 #endif
2861     }
2862     return 0;
2863 }
2864
2865 I32
2866 Perl_whichsig(pTHX_ const char *sig)
2867 {
2868     register char* const* sigv;
2869
2870     PERL_ARGS_ASSERT_WHICHSIG;
2871     PERL_UNUSED_CONTEXT;
2872
2873     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2874         if (strEQ(sig,*sigv))
2875             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2876 #ifdef SIGCLD
2877     if (strEQ(sig,"CHLD"))
2878         return SIGCLD;
2879 #endif
2880 #ifdef SIGCHLD
2881     if (strEQ(sig,"CLD"))
2882         return SIGCHLD;
2883 #endif
2884     return -1;
2885 }
2886
2887 Signal_t
2888 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2889 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2890 #else
2891 Perl_sighandler(int sig)
2892 #endif
2893 {
2894 #ifdef PERL_GET_SIG_CONTEXT
2895     dTHXa(PERL_GET_SIG_CONTEXT);
2896 #else
2897     dTHX;
2898 #endif
2899     dSP;
2900     GV *gv = NULL;
2901     SV *sv = NULL;
2902     SV * const tSv = PL_Sv;
2903     CV *cv = NULL;
2904     OP *myop = PL_op;
2905     U32 flags = 0;
2906     XPV * const tXpv = PL_Xpv;
2907
2908     if (PL_savestack_ix + 15 <= PL_savestack_max)
2909         flags |= 1;
2910     if (PL_markstack_ptr < PL_markstack_max - 2)
2911         flags |= 4;
2912     if (PL_scopestack_ix < PL_scopestack_max - 3)
2913         flags |= 16;
2914
2915     if (!PL_psig_ptr[sig]) {
2916                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2917                                  PL_sig_name[sig]);
2918                 exit(sig);
2919         }
2920
2921     /* Max number of items pushed there is 3*n or 4. We cannot fix
2922        infinity, so we fix 4 (in fact 5): */
2923     if (flags & 1) {
2924         PL_savestack_ix += 5;           /* Protect save in progress. */
2925         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2926     }
2927     if (flags & 4)
2928         PL_markstack_ptr++;             /* Protect mark. */
2929     if (flags & 16)
2930         PL_scopestack_ix += 1;
2931     /* sv_2cv is too complicated, try a simpler variant first: */
2932     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2933         || SvTYPE(cv) != SVt_PVCV) {
2934         HV *st;
2935         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2936     }
2937
2938     if (!cv || !CvROOT(cv)) {
2939         if (ckWARN(WARN_SIGNAL))
2940             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2941                 PL_sig_name[sig], (gv ? GvENAME(gv)
2942                                 : ((cv && CvGV(cv))
2943                                    ? GvENAME(CvGV(cv))
2944                                    : "__ANON__")));
2945         goto cleanup;
2946     }
2947
2948     if(PL_psig_name[sig]) {
2949         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2950         flags |= 64;
2951 #if !defined(PERL_IMPLICIT_CONTEXT)
2952         PL_sig_sv = sv;
2953 #endif
2954     } else {
2955         sv = sv_newmortal();
2956         sv_setpv(sv,PL_sig_name[sig]);
2957     }
2958
2959     PUSHSTACKi(PERLSI_SIGNAL);
2960     PUSHMARK(SP);
2961     PUSHs(sv);
2962 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2963     {
2964          struct sigaction oact;
2965
2966          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2967               if (sip) {
2968                    HV *sih = newHV();
2969                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
2970                    /* The siginfo fields signo, code, errno, pid, uid,
2971                     * addr, status, and band are defined by POSIX/SUSv3. */
2972                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2973                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2974 #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. */
2975                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2976                    hv_stores(sih, "status",     newSViv(sip->si_status));
2977                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2978                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2979                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2980                    hv_stores(sih, "band",       newSViv(sip->si_band));
2981 #endif
2982                    EXTEND(SP, 2);
2983                    PUSHs(rv);
2984                    mPUSHp((char *)sip, sizeof(*sip));
2985               }
2986
2987          }
2988     }
2989 #endif
2990     PUTBACK;
2991
2992     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2993
2994     POPSTACK;
2995     if (SvTRUE(ERRSV)) {
2996 #ifndef PERL_MICRO
2997 #ifdef HAS_SIGPROCMASK
2998         /* Handler "died", for example to get out of a restart-able read().
2999          * Before we re-do that on its behalf re-enable the signal which was
3000          * blocked by the system when we entered.
3001          */
3002         sigset_t set;
3003         sigemptyset(&set);
3004         sigaddset(&set,sig);
3005         sigprocmask(SIG_UNBLOCK, &set, NULL);
3006 #else
3007         /* Not clear if this will work */
3008         (void)rsignal(sig, SIG_IGN);
3009         (void)rsignal(sig, PL_csighandlerp);
3010 #endif
3011 #endif /* !PERL_MICRO */
3012         Perl_die(aTHX_ NULL);
3013     }
3014 cleanup:
3015     if (flags & 1)
3016         PL_savestack_ix -= 8; /* Unprotect save in progress. */
3017     if (flags & 4)
3018         PL_markstack_ptr--;
3019     if (flags & 16)
3020         PL_scopestack_ix -= 1;
3021     if (flags & 64)
3022         SvREFCNT_dec(sv);
3023     PL_op = myop;                       /* Apparently not needed... */
3024
3025     PL_Sv = tSv;                        /* Restore global temporaries. */
3026     PL_Xpv = tXpv;
3027     return;
3028 }
3029
3030
3031 static void
3032 S_restore_magic(pTHX_ const void *p)
3033 {
3034     dVAR;
3035     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3036     SV* const sv = mgs->mgs_sv;
3037
3038     if (!sv)
3039         return;
3040
3041     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3042     {
3043 #ifdef PERL_OLD_COPY_ON_WRITE
3044         /* While magic was saved (and off) sv_setsv may well have seen
3045            this SV as a prime candidate for COW.  */
3046         if (SvIsCOW(sv))
3047             sv_force_normal_flags(sv, 0);
3048 #endif
3049
3050         if (mgs->mgs_flags)
3051             SvFLAGS(sv) |= mgs->mgs_flags;
3052         else
3053             mg_magical(sv);
3054         if (SvGMAGICAL(sv)) {
3055             /* downgrade public flags to private,
3056                and discard any other private flags */
3057
3058             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3059             if (pubflags) {
3060                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3061                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3062             }
3063         }
3064     }
3065
3066     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3067
3068     /* If we're still on top of the stack, pop us off.  (That condition
3069      * will be satisfied if restore_magic was called explicitly, but *not*
3070      * if it's being called via leave_scope.)
3071      * The reason for doing this is that otherwise, things like sv_2cv()
3072      * may leave alloc gunk on the savestack, and some code
3073      * (e.g. sighandler) doesn't expect that...
3074      */
3075     if (PL_savestack_ix == mgs->mgs_ss_ix)
3076     {
3077         I32 popval = SSPOPINT;
3078         assert(popval == SAVEt_DESTRUCTOR_X);
3079         PL_savestack_ix -= 2;
3080         popval = SSPOPINT;
3081         assert(popval == SAVEt_ALLOC);
3082         popval = SSPOPINT;
3083         PL_savestack_ix -= popval;
3084     }
3085
3086 }
3087
3088 static void
3089 S_unwind_handler_stack(pTHX_ const void *p)
3090 {
3091     dVAR;
3092     const U32 flags = *(const U32*)p;
3093
3094     PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3095
3096     if (flags & 1)
3097         PL_savestack_ix -= 5; /* Unprotect save in progress. */
3098 #if !defined(PERL_IMPLICIT_CONTEXT)
3099     if (flags & 64)
3100         SvREFCNT_dec(PL_sig_sv);
3101 #endif
3102 }
3103
3104 /*
3105 =for apidoc magic_sethint
3106
3107 Triggered by a store to %^H, records the key/value pair to
3108 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3109 anything that would need a deep copy.  Maybe we should warn if we find a
3110 reference.
3111
3112 =cut
3113 */
3114 int
3115 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3116 {
3117     dVAR;
3118     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3119         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3120
3121     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3122
3123     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3124        an alternative leaf in there, with PL_compiling.cop_hints being used if
3125        it's NULL. If needed for threads, the alternative could lock a mutex,
3126        or take other more complex action.  */
3127
3128     /* Something changed in %^H, so it will need to be restored on scope exit.
3129        Doing this here saves a lot of doing it manually in perl code (and
3130        forgetting to do it, and consequent subtle errors.  */
3131     PL_hints |= HINT_LOCALIZE_HH;
3132     PL_compiling.cop_hints_hash
3133         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3134     return 0;
3135 }
3136
3137 /*
3138 =for apidoc magic_clearhint
3139
3140 Triggered by a delete from %^H, records the key to
3141 C<PL_compiling.cop_hints_hash>.
3142
3143 =cut
3144 */
3145 int
3146 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3147 {
3148     dVAR;
3149
3150     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3151     PERL_UNUSED_ARG(sv);
3152
3153     assert(mg->mg_len == HEf_SVKEY);
3154
3155     PERL_UNUSED_ARG(sv);
3156
3157     PL_hints |= HINT_LOCALIZE_HH;
3158     PL_compiling.cop_hints_hash
3159         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3160                                  MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3161     return 0;
3162 }
3163
3164 /*
3165  * Local variables:
3166  * c-indentation-style: bsd
3167  * c-basic-offset: 4
3168  * indent-tabs-mode: t
3169  * End:
3170  *
3171  * ex: set ts=8 sts=4 sw=4 noet:
3172  */