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