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