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