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