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