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