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