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