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