42a0b10316b2f74300e2ae67a795da99cd0ee886
[perl.git] / mg.c
1 /*    mg.c
2  *
3  *    Copyright (c) 1991-1994, 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 #include "perl.h"
17
18 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
19 #ifdef I_UNISTD
20 # include <unistd.h>
21 #endif
22
23 /*
24  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
25  */
26
27 struct magic_state {
28     SV* mgs_sv;
29     U32 mgs_flags;
30 };
31 typedef struct magic_state MGS;
32
33 static void restore_magic _((void *p));
34
35 static MGS *
36 save_magic(sv)
37 SV* sv;
38 {
39     MGS* mgs;
40
41     assert(SvMAGICAL(sv));
42
43     mgs = (MGS*)safemalloc(sizeof(MGS));
44     mgs->mgs_sv = sv;
45     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
46     SAVEDESTRUCTOR(restore_magic, mgs);
47
48     SvMAGICAL_off(sv);
49     SvREADONLY_off(sv);
50     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
51
52     return mgs;
53 }
54
55 static void
56 restore_magic(p)
57 void* p;
58 {
59     MGS *mgs = (MGS*)p;
60     SV* sv = mgs->mgs_sv;
61
62     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
63     {
64         if (mgs->mgs_flags)
65             SvFLAGS(sv) |= mgs->mgs_flags;
66         else
67             mg_magical(sv);
68         if (SvGMAGICAL(sv))
69             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
70     }
71
72     Safefree(mgs);
73 }
74
75
76 void
77 mg_magical(sv)
78 SV* sv;
79 {
80     MAGIC* mg;
81     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
82         MGVTBL* vtbl = mg->mg_virtual;
83         if (vtbl) {
84             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
85                 SvGMAGICAL_on(sv);
86             if (vtbl->svt_set)
87                 SvSMAGICAL_on(sv);
88             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
89                 SvRMAGICAL_on(sv);
90         }
91     }
92 }
93
94 int
95 mg_get(sv)
96 SV* sv;
97 {
98     MGS* mgs;
99     MAGIC* mg;
100     MAGIC** mgp;
101     int mgp_valid = 0;
102
103     ENTER;
104     mgs = save_magic(sv);
105
106     mgp = &SvMAGIC(sv);
107     while ((mg = *mgp) != 0) {
108         MGVTBL* vtbl = mg->mg_virtual;
109         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
110             (*vtbl->svt_get)(sv, mg);
111             /* Ignore this magic if it's been deleted */
112             if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && (mg->mg_flags & MGf_GSKIP))
113                 mgs->mgs_flags = 0;
114         }
115         /* Advance to next magic (complicated by possible deletion) */
116         if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
117             mgp = &mg->mg_moremagic;
118             mgp_valid = 1;
119         }
120         else
121             mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
122     }
123
124     LEAVE;
125     return 0;
126 }
127
128 int
129 mg_set(sv)
130 SV* sv;
131 {
132     MGS* mgs;
133     MAGIC* mg;
134     MAGIC* nextmg;
135
136     ENTER;
137     mgs = save_magic(sv);
138
139     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
140         MGVTBL* vtbl = mg->mg_virtual;
141         nextmg = mg->mg_moremagic;      /* it may delete itself */
142         if (mg->mg_flags & MGf_GSKIP) {
143             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
144             mgs->mgs_flags = 0;
145         }
146         if (vtbl && vtbl->svt_set)
147             (*vtbl->svt_set)(sv, mg);
148     }
149
150     LEAVE;
151     return 0;
152 }
153
154 U32
155 mg_len(sv)
156 SV* sv;
157 {
158     MAGIC* mg;
159     char *junk;
160     STRLEN len;
161
162     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
163         MGVTBL* vtbl = mg->mg_virtual;
164         if (vtbl && vtbl->svt_len) {
165             ENTER;
166             save_magic(sv);
167             /* omit MGf_GSKIP -- not changed here */
168             len = (*vtbl->svt_len)(sv, mg);
169             LEAVE;
170             return len;
171         }
172     }
173
174     junk = SvPV(sv, len);
175     return len;
176 }
177
178 int
179 mg_clear(sv)
180 SV* sv;
181 {
182     MAGIC* mg;
183
184     ENTER;
185     save_magic(sv);
186
187     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
188         MGVTBL* vtbl = mg->mg_virtual;
189         /* omit GSKIP -- never set here */
190         
191         if (vtbl && vtbl->svt_clear)
192             (*vtbl->svt_clear)(sv, mg);
193     }
194
195     LEAVE;
196     return 0;
197 }
198
199 MAGIC*
200 mg_find(sv, type)
201 SV* sv;
202 int type;
203 {
204     MAGIC* mg;
205     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
206         if (mg->mg_type == type)
207             return mg;
208     }
209     return 0;
210 }
211
212 int
213 mg_copy(sv, nsv, key, klen)
214 SV* sv;
215 SV* nsv;
216 char *key;
217 I32 klen;
218 {
219     int count = 0;
220     MAGIC* mg;
221     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
222         if (isUPPER(mg->mg_type)) {
223             sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
224             count++;
225         }
226     }
227     return count;
228 }
229
230 int
231 mg_free(sv)
232 SV* sv;
233 {
234     MAGIC* mg;
235     MAGIC* moremagic;
236     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
237         MGVTBL* vtbl = mg->mg_virtual;
238         moremagic = mg->mg_moremagic;
239         if (vtbl && vtbl->svt_free)
240             (*vtbl->svt_free)(sv, mg);
241         if (mg->mg_ptr && mg->mg_type != 'g')
242             if (mg->mg_len >= 0)
243                 Safefree(mg->mg_ptr);
244             else if (mg->mg_len == HEf_SVKEY)
245                 SvREFCNT_dec((SV*)mg->mg_ptr);
246         if (mg->mg_flags & MGf_REFCOUNTED)
247             SvREFCNT_dec(mg->mg_obj);
248         Safefree(mg);
249     }
250     SvMAGIC(sv) = 0;
251     return 0;
252 }
253
254 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
255 #include <signal.h>
256 #endif
257
258 U32
259 magic_len(sv, mg)
260 SV *sv;
261 MAGIC *mg;
262 {
263     register I32 paren;
264     register char *s;
265     register I32 i;
266     char *t;
267
268     switch (*mg->mg_ptr) {
269     case '1': case '2': case '3': case '4':
270     case '5': case '6': case '7': case '8': case '9': case '&':
271         if (curpm) {
272             paren = atoi(mg->mg_ptr);
273           getparen:
274             if (curpm->op_pmregexp &&
275               paren <= curpm->op_pmregexp->nparens &&
276               (s = curpm->op_pmregexp->startp[paren]) &&
277               (t = curpm->op_pmregexp->endp[paren]) ) {
278                 i = t - s;
279                 if (i >= 0)
280                     return i;
281             }
282         }
283         return 0;
284         break;
285     case '+':
286         if (curpm) {
287             paren = curpm->op_pmregexp->lastparen;
288             if (!paren)
289                 return 0;
290             goto getparen;
291         }
292         return 0;
293         break;
294     case '`':
295         if (curpm) {
296             if (curpm->op_pmregexp &&
297               (s = curpm->op_pmregexp->subbeg) ) {
298                 i = curpm->op_pmregexp->startp[0] - s;
299                 if (i >= 0)
300                     return i;
301             }
302         }
303         return 0;
304     case '\'':
305         if (curpm) {
306             if (curpm->op_pmregexp &&
307               (s = curpm->op_pmregexp->endp[0]) ) {
308                 return (STRLEN) (curpm->op_pmregexp->subend - s);
309             }
310         }
311         return 0;
312     case ',':
313         return (STRLEN)ofslen;
314     case '\\':
315         return (STRLEN)orslen;
316     }
317     magic_get(sv,mg);
318     if (!SvPOK(sv) && SvNIOK(sv))
319         sv_2pv(sv, &na);
320     if (SvPOK(sv))
321         return SvCUR(sv);
322     return 0;
323 }
324
325 int
326 magic_get(sv, mg)
327 SV *sv;
328 MAGIC *mg;
329 {
330     register I32 paren;
331     register char *s;
332     register I32 i;
333     char *t;
334
335     switch (*mg->mg_ptr) {
336     case '\001':                /* ^A */
337         sv_setsv(sv, bodytarget);
338         break;
339     case '\004':                /* ^D */
340         sv_setiv(sv,(I32)(debug & 32767));
341         break;
342     case '\005':  /* ^E */
343 #ifdef VMS
344         {
345 #           include <descrip.h>
346 #           include <starlet.h>
347             char msg[255];
348             $DESCRIPTOR(msgdsc,msg);
349             sv_setnv(sv,(double)vaxc$errno);
350             if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
351                 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
352             else
353                 sv_setpv(sv,"");
354         }
355 #else
356 #ifdef OS2
357         sv_setnv(sv,(double)Perl_rc);
358         sv_setpv(sv, os2error(Perl_rc));
359 #else
360         sv_setnv(sv,(double)errno);
361         sv_setpv(sv, errno ? Strerror(errno) : "");
362 #endif
363 #endif
364         SvNOK_on(sv);   /* what a wonderful hack! */
365         break;
366     case '\006':                /* ^F */
367         sv_setiv(sv,(I32)maxsysfd);
368         break;
369     case '\010':                /* ^H */
370         sv_setiv(sv,(I32)hints);
371         break;
372     case '\t':                  /* ^I */
373         if (inplace)
374             sv_setpv(sv, inplace);
375         else
376             sv_setsv(sv,&sv_undef);
377         break;
378     case '\017':                /* ^O */
379         sv_setpv(sv,osname);
380         break;
381     case '\020':                /* ^P */
382         sv_setiv(sv,(I32)perldb);
383         break;
384     case '\024':                /* ^T */
385 #ifdef BIG_TIME
386         sv_setnv(sv,basetime);
387 #else
388         sv_setiv(sv,(I32)basetime);
389 #endif
390         break;
391     case '\027':                /* ^W */
392         sv_setiv(sv,(I32)dowarn);
393         break;
394     case '1': case '2': case '3': case '4':
395     case '5': case '6': case '7': case '8': case '9': case '&':
396         if (curpm) {
397             paren = atoi(GvENAME((GV*)mg->mg_obj));
398           getparen:
399             if (curpm->op_pmregexp &&
400               paren <= curpm->op_pmregexp->nparens &&
401               (s = curpm->op_pmregexp->startp[paren]) &&
402               (t = curpm->op_pmregexp->endp[paren]) ) {
403                 i = t - s;
404                 if (i >= 0) {
405                     MAGIC *tmg;
406                     sv_setpvn(sv,s,i);
407                     if (tainting && (tmg = mg_find(sv,'t')))
408                         tmg->mg_len = 0;        /* guarantee $1 untainted */
409                     break;
410                 }
411             }
412         }
413         sv_setsv(sv,&sv_undef);
414         break;
415     case '+':
416         if (curpm) {
417             paren = curpm->op_pmregexp->lastparen;
418             if (paren)
419                 goto getparen;
420         }
421         sv_setsv(sv,&sv_undef);
422         break;
423     case '`':
424         if (curpm) {
425             if (curpm->op_pmregexp &&
426               (s = curpm->op_pmregexp->subbeg) ) {
427                 i = curpm->op_pmregexp->startp[0] - s;
428                 if (i >= 0) {
429                     sv_setpvn(sv,s,i);
430                     break;
431                 }
432             }
433         }
434         sv_setsv(sv,&sv_undef);
435         break;
436     case '\'':
437         if (curpm) {
438             if (curpm->op_pmregexp &&
439               (s = curpm->op_pmregexp->endp[0]) ) {
440                 sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
441                 break;
442             }
443         }
444         sv_setsv(sv,&sv_undef);
445         break;
446     case '.':
447 #ifndef lint
448         if (GvIO(last_in_gv)) {
449             sv_setiv(sv,(I32)IoLINES(GvIO(last_in_gv)));
450         }
451 #endif
452         break;
453     case '?':
454         sv_setiv(sv,(I32)statusvalue);
455         break;
456     case '^':
457         s = IoTOP_NAME(GvIOp(defoutgv));
458         if (s)
459             sv_setpv(sv,s);
460         else {
461             sv_setpv(sv,GvENAME(defoutgv));
462             sv_catpv(sv,"_TOP");
463         }
464         break;
465     case '~':
466         s = IoFMT_NAME(GvIOp(defoutgv));
467         if (!s)
468             s = GvENAME(defoutgv);
469         sv_setpv(sv,s);
470         break;
471 #ifndef lint
472     case '=':
473         sv_setiv(sv,(I32)IoPAGE_LEN(GvIOp(defoutgv)));
474         break;
475     case '-':
476         sv_setiv(sv,(I32)IoLINES_LEFT(GvIOp(defoutgv)));
477         break;
478     case '%':
479         sv_setiv(sv,(I32)IoPAGE(GvIOp(defoutgv)));
480         break;
481 #endif
482     case ':':
483         break;
484     case '/':
485         break;
486     case '[':
487         sv_setiv(sv,(I32)curcop->cop_arybase);
488         break;
489     case '|':
490         sv_setiv(sv, (IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
491         break;
492     case ',':
493         sv_setpvn(sv,ofs,ofslen);
494         break;
495     case '\\':
496         sv_setpvn(sv,ors,orslen);
497         break;
498     case '#':
499         sv_setpv(sv,ofmt);
500         break;
501     case '!':
502 #ifdef VMS
503         sv_setnv(sv,(double)((errno == EVMSERR) ? vaxc$errno : errno));
504         sv_setpv(sv, errno ? Strerror(errno) : "");
505 #else
506         {
507         int saveerrno = errno;
508         sv_setnv(sv,(double)errno);
509 #ifdef OS2
510         if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
511         else
512 #endif
513         sv_setpv(sv, errno ? Strerror(errno) : "");
514         errno = saveerrno;
515         }
516 #endif
517         SvNOK_on(sv);   /* what a wonderful hack! */
518         break;
519     case '<':
520         sv_setiv(sv,(I32)uid);
521         break;
522     case '>':
523         sv_setiv(sv,(I32)euid);
524         break;
525     case '(':
526         s = buf;
527         (void)sprintf(s,"%d",(int)gid);
528         goto add_groups;
529     case ')':
530         s = buf;
531         (void)sprintf(s,"%d",(int)egid);
532       add_groups:
533         while (*s) s++;
534 #ifdef HAS_GETGROUPS
535 #ifndef NGROUPS
536 #define NGROUPS 32
537 #endif
538         {
539             Groups_t gary[NGROUPS];
540
541             i = getgroups(NGROUPS,gary);
542             while (--i >= 0) {
543                 (void)sprintf(s," %ld", (long)gary[i]);
544                 while (*s) s++;
545             }
546         }
547 #endif
548         sv_setpv(sv,buf);
549         break;
550     case '*':
551         break;
552     case '0':
553         break;
554     }
555     return 0;
556 }
557
558 int
559 magic_getuvar(sv, mg)
560 SV *sv;
561 MAGIC *mg;
562 {
563     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
564
565     if (uf && uf->uf_val)
566         (*uf->uf_val)(uf->uf_index, sv);
567     return 0;
568 }
569
570 int
571 magic_setenv(sv,mg)
572 SV* sv;
573 MAGIC* mg;
574 {
575     register char *s;
576     char *ptr;
577     STRLEN len;
578     I32 i;
579     s = SvPV(sv,len);
580     ptr = (mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr;
581     my_setenv(ptr, s);
582 #ifdef DYNAMIC_ENV_FETCH
583      /* We just undefd an environment var.  Is a replacement */
584      /* waiting in the wings? */
585     if (!len) {
586         HE *envhe;
587         if (envhe = hv_fetch_ent(GvHVn(envgv),HeSVKEY((HE*)(mg->mg_ptr)),FALSE,0))
588             s = SvPV(HeVAL(envhe),len);
589     }
590 #endif
591                             /* And you'll never guess what the dog had */
592                             /*   in its mouth... */
593     if (tainting) {
594         if (s && strEQ(ptr,"PATH")) {
595             char *strend = s + len;
596
597             while (s < strend) {
598                 s = cpytill(tokenbuf,s,strend,':',&i);
599                 s++;
600                 if (*tokenbuf != '/'
601                   || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
602                     MgTAINTEDDIR_on(mg);
603             }
604         }
605     }
606     return 0;
607 }
608
609 int
610 magic_clearenv(sv,mg)
611 SV* sv;
612 MAGIC* mg;
613 {
614     my_setenv(((mg->mg_len == HEf_SVKEY) ?
615                SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr),Nullch);
616     return 0;
617 }
618
619 #ifdef HAS_SIGACTION
620 /* set up reliable signal() clone */
621
622 typedef void (*Sigfunc) _((int));
623
624 static
625 Sigfunc rsignal(signo,handler)
626 int signo;
627 Sigfunc handler;
628 {
629     struct sigaction act,oact;
630     
631     act.sa_handler = handler;
632     sigemptyset(&act.sa_mask);
633     act.sa_flags = 0;
634 #ifdef SA_RESTART
635     act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
636 #endif
637     if (sigaction(signo, &act, &oact) < 0)
638         return(SIG_ERR);
639     else
640         return(oact.sa_handler);
641 }
642
643 #else
644
645 /* ah well, so much for reliability */
646
647 #define rsignal(x,y) signal(x,y)
648
649 #endif
650
651 static sig_trapped;
652 static
653 Signal_t
654 sig_trap(signo)
655 int signo;
656 {
657     sig_trapped++;
658 }
659 int
660 magic_getsig(sv,mg)
661 SV* sv;
662 MAGIC* mg;
663 {
664     I32 i;
665     /* Are we fetching a signal entry? */
666     i = whichsig((mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr);
667     if (i) {
668         if(psig_ptr[i])
669             sv_setsv(sv,psig_ptr[i]);
670         else {
671             void (*origsig) _((int));
672             /* get signal state without losing signals */
673             sig_trapped=0;
674             origsig = rsignal(i,sig_trap);
675             rsignal(i,origsig);
676             if(sig_trapped)
677                 kill(getpid(),i);
678             /* cache state so we don't fetch it again */
679             if(origsig == SIG_IGN)
680                 sv_setpv(sv,"IGNORE");
681             else
682                 sv_setsv(sv,&sv_undef);
683             psig_ptr[i] = SvREFCNT_inc(sv);
684             SvTEMP_off(sv);
685         }
686     }
687     return 0;
688 }
689 int
690 magic_clearsig(sv,mg)
691 SV* sv;
692 MAGIC* mg;
693 {
694     I32 i;
695     /* Are we clearing a signal entry? */
696     i = whichsig((mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr);
697     if (i) {
698         if(psig_ptr[i]) {
699             SvREFCNT_dec(psig_ptr[i]);
700             psig_ptr[i]=0;
701         }
702         if(psig_name[i]) {
703             SvREFCNT_dec(psig_name[i]);
704             psig_name[i]=0;
705         }
706     }
707     return 0;
708 }
709
710 int
711 magic_setsig(sv,mg)
712 SV* sv;
713 MAGIC* mg;
714 {
715     register char *s;
716     I32 i;
717     SV** svp;
718
719     s = (mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr;
720     if (*s == '_') {
721         if (strEQ(s,"__DIE__"))
722             svp = &diehook;
723         else if (strEQ(s,"__WARN__"))
724             svp = &warnhook;
725         else if (strEQ(s,"__PARSE__"))
726             svp = &parsehook;
727         else
728             croak("No such hook: %s", s);
729         i = 0;
730         if (*svp) {
731             SvREFCNT_dec(*svp);
732             *svp = 0;
733         }
734     }
735     else {
736         i = whichsig(s);        /* ...no, a brick */
737         if (!i) {
738             if (dowarn || strEQ(s,"ALARM"))
739                 warn("No such signal: SIG%s", s);
740             return 0;
741         }
742         if(psig_ptr[i])
743             SvREFCNT_dec(psig_ptr[i]);
744         psig_ptr[i] = SvREFCNT_inc(sv);
745         if(psig_name[i])
746             SvREFCNT_dec(psig_name[i]);
747         psig_name[i] = newSVpv(s,strlen(s));
748         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
749         SvREADONLY_on(psig_name[i]);
750     }
751     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
752         if (i)
753             (void)rsignal(i,sighandler);
754         else
755             *svp = SvREFCNT_inc(sv);
756         return 0;
757     }
758     s = SvPV_force(sv,na);
759     if (strEQ(s,"IGNORE")) {
760         if (i)
761             (void)rsignal(i,SIG_IGN);
762         else
763             *svp = 0;
764     }
765     else if (strEQ(s,"DEFAULT") || !*s) {
766         if (i)
767             (void)rsignal(i,SIG_DFL);
768         else
769             *svp = 0;
770     }
771     else {
772         if(hints & HINT_STRICT_REFS)
773                 die(no_symref,s,"a subroutine");
774         if (!strchr(s,':') && !strchr(s,'\'')) {
775             sprintf(tokenbuf, "main::%s",s);
776             sv_setpv(sv,tokenbuf);
777         }
778         if (i)
779             (void)rsignal(i,sighandler);
780         else
781             *svp = SvREFCNT_inc(sv);
782     }
783     return 0;
784 }
785
786 int
787 magic_setisa(sv,mg)
788 SV* sv;
789 MAGIC* mg;
790 {
791     sub_generation++;
792     return 0;
793 }
794
795 #ifdef OVERLOAD
796
797 int
798 magic_setamagic(sv,mg)
799 SV* sv;
800 MAGIC* mg;
801 {
802     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
803     amagic_generation++;
804
805     return 0;
806 }
807 #endif /* OVERLOAD */
808
809 static int
810 magic_methpack(sv,mg,meth)
811 SV* sv;
812 MAGIC* mg;
813 char *meth;
814 {
815     dSP;
816
817     ENTER;
818     SAVETMPS;
819     PUSHMARK(sp);
820     EXTEND(sp, 2);
821     PUSHs(mg->mg_obj);
822     if (mg->mg_ptr) {
823         if (mg->mg_len >= 0)
824             PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
825         else if (mg->mg_len == HEf_SVKEY)
826             PUSHs((SV*)mg->mg_ptr);
827     }
828     else if (mg->mg_type == 'p')
829         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
830     PUTBACK;
831
832     if (perl_call_method(meth, G_SCALAR))
833         sv_setsv(sv, *stack_sp--);
834
835     FREETMPS;
836     LEAVE;
837     return 0;
838 }
839
840 int
841 magic_getpack(sv,mg)
842 SV* sv;
843 MAGIC* mg;
844 {
845     magic_methpack(sv,mg,"FETCH");
846     if (mg->mg_ptr)
847         mg->mg_flags |= MGf_GSKIP;
848     return 0;
849 }
850
851 int
852 magic_setpack(sv,mg)
853 SV* sv;
854 MAGIC* mg;
855 {
856     dSP;
857
858     PUSHMARK(sp);
859     EXTEND(sp, 3);
860     PUSHs(mg->mg_obj);
861     if (mg->mg_ptr) {
862         if (mg->mg_len >= 0)
863             PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
864         else if (mg->mg_len == HEf_SVKEY)
865             PUSHs((SV*)mg->mg_ptr);
866     }
867     else if (mg->mg_type == 'p')
868         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
869     PUSHs(sv);
870     PUTBACK;
871
872     perl_call_method("STORE", G_SCALAR|G_DISCARD);
873
874     return 0;
875 }
876
877 int
878 magic_clearpack(sv,mg)
879 SV* sv;
880 MAGIC* mg;
881 {
882     return magic_methpack(sv,mg,"DELETE");
883 }
884
885 int magic_wipepack(sv,mg)
886 SV* sv;
887 MAGIC* mg;
888 {
889     dSP;
890
891     PUSHMARK(sp);
892     XPUSHs(mg->mg_obj);
893     PUTBACK;
894
895     perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
896
897     return 0;
898 }
899
900 int
901 magic_nextpack(sv,mg,key)
902 SV* sv;
903 MAGIC* mg;
904 SV* key;
905 {
906     dSP;
907     char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
908
909     ENTER;
910     SAVETMPS;
911     PUSHMARK(sp);
912     EXTEND(sp, 2);
913     PUSHs(mg->mg_obj);
914     if (SvOK(key))
915         PUSHs(key);
916     PUTBACK;
917
918     if (perl_call_method(meth, G_SCALAR))
919         sv_setsv(key, *stack_sp--);
920
921     FREETMPS;
922     LEAVE;
923     return 0;
924 }
925
926 int
927 magic_existspack(sv,mg)
928 SV* sv;
929 MAGIC* mg;
930 {
931     return magic_methpack(sv,mg,"EXISTS");
932
933
934 int
935 magic_setdbline(sv,mg)
936 SV* sv;
937 MAGIC* mg;
938 {
939     OP *o;
940     I32 i;
941     GV* gv;
942     SV** svp;
943
944     gv = DBline;
945     i = SvTRUE(sv);
946     svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
947     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
948         o->op_private = i;
949     else
950         warn("Can't break at that line\n");
951     return 0;
952 }
953
954 int
955 magic_getarylen(sv,mg)
956 SV* sv;
957 MAGIC* mg;
958 {
959     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
960     return 0;
961 }
962
963 int
964 magic_setarylen(sv,mg)
965 SV* sv;
966 MAGIC* mg;
967 {
968     av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
969     return 0;
970 }
971
972 int
973 magic_getpos(sv,mg)
974 SV* sv;
975 MAGIC* mg;
976 {
977     SV* lsv = LvTARG(sv);
978     
979     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
980         mg = mg_find(lsv, 'g');
981         if (mg && mg->mg_len >= 0) {
982             sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
983             return 0;
984         }
985     }
986     (void)SvOK_off(sv);
987     return 0;
988 }
989
990 int
991 magic_setpos(sv,mg)
992 SV* sv;
993 MAGIC* mg;
994 {
995     SV* lsv = LvTARG(sv);
996     SSize_t pos;
997     STRLEN len;
998
999     mg = 0;
1000     
1001     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1002         mg = mg_find(lsv, 'g');
1003     if (!mg) {
1004         if (!SvOK(sv))
1005             return 0;
1006         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1007         mg = mg_find(lsv, 'g');
1008     }
1009     else if (!SvOK(sv)) {
1010         mg->mg_len = -1;
1011         return 0;
1012     }
1013     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1014
1015     pos = SvIV(sv) - curcop->cop_arybase;
1016     if (pos < 0) {
1017         pos += len;
1018         if (pos < 0)
1019             pos = 0;
1020     }
1021     else if (pos > len)
1022         pos = len;
1023     mg->mg_len = pos;
1024
1025     return 0;
1026 }
1027
1028 int
1029 magic_getglob(sv,mg)
1030 SV* sv;
1031 MAGIC* mg;
1032 {
1033     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1034         SvFAKE_off(sv);
1035         gv_efullname(sv,((GV*)sv), "*");
1036         SvFAKE_on(sv);
1037     }
1038     else
1039         gv_efullname(sv,((GV*)sv), "*");        /* a gv value, be nice */
1040     return 0;
1041 }
1042
1043 int
1044 magic_setglob(sv,mg)
1045 SV* sv;
1046 MAGIC* mg;
1047 {
1048     register char *s;
1049     GV* gv;
1050
1051     if (!SvOK(sv))
1052         return 0;
1053     s = SvPV(sv, na);
1054     if (*s == '*' && s[1])
1055         s++;
1056     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1057     if (sv == (SV*)gv)
1058         return 0;
1059     if (GvGP(sv))
1060         gp_free((GV*)sv);
1061     GvGP(sv) = gp_ref(GvGP(gv));
1062     if (!GvAV(gv))
1063         gv_AVadd(gv);
1064     if (!GvHV(gv))
1065         gv_HVadd(gv);
1066     if (!GvIOp(gv))
1067         GvIOp(gv) = newIO();
1068     return 0;
1069 }
1070
1071 int
1072 magic_setsubstr(sv,mg)
1073 SV* sv;
1074 MAGIC* mg;
1075 {
1076     STRLEN len;
1077     char *tmps = SvPV(sv,len);
1078     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
1079     return 0;
1080 }
1081
1082 int
1083 magic_gettaint(sv,mg)
1084 SV* sv;
1085 MAGIC* mg;
1086 {
1087     if (mg->mg_len & 1)
1088         tainted = TRUE;
1089     else if (mg->mg_len & 2 && mg->mg_obj == sv)        /* kludge */
1090         tainted = TRUE;
1091     return 0;
1092 }
1093
1094 int
1095 magic_settaint(sv,mg)
1096 SV* sv;
1097 MAGIC* mg;
1098 {
1099     if (localizing) {
1100         if (localizing == 1)
1101             mg->mg_len <<= 1;
1102         else
1103             mg->mg_len >>= 1;
1104     }
1105     else if (tainted)
1106         mg->mg_len |= 1;
1107     else
1108         mg->mg_len &= ~1;
1109     return 0;
1110 }
1111
1112 int
1113 magic_setvec(sv,mg)
1114 SV* sv;
1115 MAGIC* mg;
1116 {
1117     do_vecset(sv);      /* XXX slurp this routine */
1118     return 0;
1119 }
1120
1121 int
1122 magic_setmglob(sv,mg)
1123 SV* sv;
1124 MAGIC* mg;
1125 {
1126     mg->mg_len = -1;
1127     SvSCREAM_off(sv);
1128     return 0;
1129 }
1130
1131 int
1132 magic_setbm(sv,mg)
1133 SV* sv;
1134 MAGIC* mg;
1135 {
1136     sv_unmagic(sv, 'B');
1137     SvVALID_off(sv);
1138     return 0;
1139 }
1140
1141 int
1142 magic_setuvar(sv,mg)
1143 SV* sv;
1144 MAGIC* mg;
1145 {
1146     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1147
1148     if (uf && uf->uf_set)
1149         (*uf->uf_set)(uf->uf_index, sv);
1150     return 0;
1151 }
1152
1153 int
1154 magic_set(sv,mg)
1155 SV* sv;
1156 MAGIC* mg;
1157 {
1158     register char *s;
1159     I32 i;
1160     STRLEN len;
1161     switch (*mg->mg_ptr) {
1162     case '\001':        /* ^A */
1163         sv_setsv(bodytarget, sv);
1164         break;
1165     case '\004':        /* ^D */
1166         debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
1167         DEBUG_x(dump_all());
1168         break;
1169     case '\005':  /* ^E */
1170 #ifdef VMS
1171         set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1172 #else
1173         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),4);         /* will anyone ever use this? */
1174 #endif
1175         break;
1176     case '\006':        /* ^F */
1177         maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1178         break;
1179     case '\010':        /* ^H */
1180         hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1181         break;
1182     case '\t':  /* ^I */
1183         if (inplace)
1184             Safefree(inplace);
1185         if (SvOK(sv))
1186             inplace = savepv(SvPV(sv,na));
1187         else
1188             inplace = Nullch;
1189         break;
1190     case '\017':        /* ^O */
1191         if (osname)
1192             Safefree(osname);
1193         if (SvOK(sv))
1194             osname = savepv(SvPV(sv,na));
1195         else
1196             osname = Nullch;
1197         break;
1198     case '\020':        /* ^P */
1199         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1200         if (i != perldb) {
1201             if (perldb)
1202                 oldlastpm = curpm;
1203             else
1204                 curpm = oldlastpm;
1205         }
1206         perldb = i;
1207         break;
1208     case '\024':        /* ^T */
1209 #ifdef BIG_TIME
1210         basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1211 #else
1212         basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1213 #endif
1214         break;
1215     case '\027':        /* ^W */
1216         dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1217         break;
1218     case '.':
1219         if (localizing) {
1220             if (localizing == 1)
1221                 save_sptr((SV**)&last_in_gv);
1222         }
1223         else if (SvOK(sv) && GvIO(last_in_gv))
1224             IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1225         break;
1226     case '^':
1227         Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1228         IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1229         IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1230         break;
1231     case '~':
1232         Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1233         IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1234         IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1235         break;
1236     case '=':
1237         IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1238         break;
1239     case '-':
1240         IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1241         if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1242             IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1243         break;
1244     case '%':
1245         IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1246         break;
1247     case '|':
1248         IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
1249         if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
1250             IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
1251         }
1252         break;
1253     case '*':
1254         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1255         multiline = (i != 0);
1256         break;
1257     case '/':
1258         SvREFCNT_dec(nrs);
1259         nrs = newSVsv(sv);
1260         SvREFCNT_dec(rs);
1261         rs = SvREFCNT_inc(nrs);
1262         break;
1263     case '\\':
1264         if (ors)
1265             Safefree(ors);
1266         ors = savepv(SvPV(sv,orslen));
1267         break;
1268     case ',':
1269         if (ofs)
1270             Safefree(ofs);
1271         ofs = savepv(SvPV(sv, ofslen));
1272         break;
1273     case '#':
1274         if (ofmt)
1275             Safefree(ofmt);
1276         ofmt = savepv(SvPV(sv,na));
1277         break;
1278     case '[':
1279         compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1280         break;
1281     case '?':
1282         statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1283         break;
1284     case '!':
1285         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SvIV(sv) == EVMSERR ? 4 : vaxc$errno);              /* will anyone ever use this? */
1286         break;
1287     case '<':
1288         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1289         if (delaymagic) {
1290             delaymagic |= DM_RUID;
1291             break;                              /* don't do magic till later */
1292         }
1293 #ifdef HAS_SETRUID
1294         (void)setruid((Uid_t)uid);
1295 #else
1296 #ifdef HAS_SETREUID
1297         (void)setreuid((Uid_t)uid, (Uid_t)-1);
1298 #else
1299 #ifdef HAS_SETRESUID
1300       (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1301 #else
1302         if (uid == euid)                /* special case $< = $> */
1303             (void)setuid(uid);
1304         else {
1305             uid = (I32)getuid();
1306             croak("setruid() not implemented");
1307         }
1308 #endif
1309 #endif
1310 #endif
1311         uid = (I32)getuid();
1312         tainting |= (uid && (euid != uid || egid != gid));
1313         break;
1314     case '>':
1315         euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1316         if (delaymagic) {
1317             delaymagic |= DM_EUID;
1318             break;                              /* don't do magic till later */
1319         }
1320 #ifdef HAS_SETEUID
1321         (void)seteuid((Uid_t)euid);
1322 #else
1323 #ifdef HAS_SETREUID
1324         (void)setreuid((Uid_t)-1, (Uid_t)euid);
1325 #else
1326 #ifdef HAS_SETRESUID
1327         (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1328 #else
1329         if (euid == uid)                /* special case $> = $< */
1330             setuid(euid);
1331         else {
1332             euid = (I32)geteuid();
1333             croak("seteuid() not implemented");
1334         }
1335 #endif
1336 #endif
1337 #endif
1338         euid = (I32)geteuid();
1339         tainting |= (uid && (euid != uid || egid != gid));
1340         break;
1341     case '(':
1342         gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1343         if (delaymagic) {
1344             delaymagic |= DM_RGID;
1345             break;                              /* don't do magic till later */
1346         }
1347 #ifdef HAS_SETRGID
1348         (void)setrgid((Gid_t)gid);
1349 #else
1350 #ifdef HAS_SETREGID
1351         (void)setregid((Gid_t)gid, (Gid_t)-1);
1352 #else
1353 #ifdef HAS_SETRESGID
1354       (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1355 #else
1356         if (gid == egid)                        /* special case $( = $) */
1357             (void)setgid(gid);
1358         else {
1359             gid = (I32)getgid();
1360             croak("setrgid() not implemented");
1361         }
1362 #endif
1363 #endif
1364 #endif
1365         gid = (I32)getgid();
1366         tainting |= (uid && (euid != uid || egid != gid));
1367         break;
1368     case ')':
1369         egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1370         if (delaymagic) {
1371             delaymagic |= DM_EGID;
1372             break;                              /* don't do magic till later */
1373         }
1374 #ifdef HAS_SETEGID
1375         (void)setegid((Gid_t)egid);
1376 #else
1377 #ifdef HAS_SETREGID
1378         (void)setregid((Gid_t)-1, (Gid_t)egid);
1379 #else
1380 #ifdef HAS_SETRESGID
1381         (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1382 #else
1383         if (egid == gid)                        /* special case $) = $( */
1384             (void)setgid(egid);
1385         else {
1386             egid = (I32)getegid();
1387             croak("setegid() not implemented");
1388         }
1389 #endif
1390 #endif
1391 #endif
1392         egid = (I32)getegid();
1393         tainting |= (uid && (euid != uid || egid != gid));
1394         break;
1395     case ':':
1396         chopset = SvPV_force(sv,na);
1397         break;
1398     case '0':
1399         if (!origalen) {
1400             s = origargv[0];
1401             s += strlen(s);
1402             /* See if all the arguments are contiguous in memory */
1403             for (i = 1; i < origargc; i++) {
1404                 if (origargv[i] == s + 1)
1405                     s += strlen(++s);   /* this one is ok too */
1406             }
1407             if (origenviron[0] == s + 1) {      /* can grab env area too? */
1408                 my_setenv("NoNeSuCh", Nullch);
1409                                             /* force copy of environment */
1410                 for (i = 0; origenviron[i]; i++)
1411                     if (origenviron[i] == s + 1)
1412                         s += strlen(++s);
1413             }
1414             origalen = s - origargv[0];
1415         }
1416         s = SvPV_force(sv,len);
1417         i = len;
1418         if (i >= origalen) {
1419             i = origalen;
1420             SvCUR_set(sv, i);
1421             *SvEND(sv) = '\0';
1422             Copy(s, origargv[0], i, char);
1423         }
1424         else {
1425             Copy(s, origargv[0], i, char);
1426             s = origargv[0]+i;
1427             *s++ = '\0';
1428             while (++i < origalen)
1429                 *s++ = ' ';
1430             s = origargv[0]+i;
1431             for (i = 1; i < origargc; i++)
1432                 origargv[i] = Nullch;
1433         }
1434         break;
1435     }
1436     return 0;
1437 }
1438
1439 I32
1440 whichsig(sig)
1441 char *sig;
1442 {
1443     register char **sigv;
1444
1445     for (sigv = sig_name+1; *sigv; sigv++)
1446         if (strEQ(sig,*sigv))
1447             return sig_num[sigv - sig_name];
1448 #ifdef SIGCLD
1449     if (strEQ(sig,"CHLD"))
1450         return SIGCLD;
1451 #endif
1452 #ifdef SIGCHLD
1453     if (strEQ(sig,"CLD"))
1454         return SIGCHLD;
1455 #endif
1456     return 0;
1457 }
1458
1459 Signal_t
1460 sighandler(sig)
1461 int sig;
1462 {
1463     dSP;
1464     GV *gv;
1465     HV *st;
1466     SV *sv;
1467     CV *cv;
1468     AV *oldstack;
1469     
1470     if(!psig_ptr[sig])
1471         die("Signal SIG%s received, but no signal handler set.\n",
1472         sig_name[sig]);
1473
1474     cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
1475     if (!cv || !CvROOT(cv)) {
1476         if (dowarn)
1477             warn("SIG%s handler \"%s\" not defined.\n",
1478                 sig_name[sig], GvENAME(gv) );
1479         return;
1480     }
1481
1482     oldstack = curstack;
1483     if (curstack != signalstack)
1484         AvFILL(signalstack) = 0;
1485     SWITCHSTACK(curstack, signalstack);
1486
1487     if(psig_name[sig])
1488         sv = SvREFCNT_inc(psig_name[sig]);
1489     else {
1490         sv = sv_newmortal();
1491         sv_setpv(sv,sig_name[sig]);
1492     }
1493     PUSHMARK(sp);
1494     PUSHs(sv);
1495     PUTBACK;
1496
1497     perl_call_sv((SV*)cv, G_DISCARD);
1498
1499     SWITCHSTACK(signalstack, oldstack);
1500
1501     return;
1502 }