Patch for Term::Cap
[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_setiv(sv, (IV)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_setiv(sv, (IV)Perl_rc);
364         sv_setpv(sv, os2error(Perl_rc));
365 #else
366         sv_setiv(sv, (IV)errno);
367         sv_setpv(sv, errno ? Strerror(errno) : "");
368 #endif
369 #endif
370         SvIOK_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_setiv(sv, (IV)((errno == EVMSERR) ? vaxc$errno : errno));
510         sv_setpv(sv, errno ? Strerror(errno) : "");
511 #else
512         {
513         int saveerrno = errno;
514         sv_setiv(sv, (IV)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         SvIOK_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         SvIOK_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 static int
819 magic_methpack(sv,mg,meth)
820 SV* sv;
821 MAGIC* mg;
822 char *meth;
823 {
824     dSP;
825
826     ENTER;
827     SAVETMPS;
828     PUSHMARK(sp);
829     EXTEND(sp, 2);
830     PUSHs(mg->mg_obj);
831     if (mg->mg_ptr) {
832         if (mg->mg_len >= 0)
833             PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
834         else if (mg->mg_len == HEf_SVKEY)
835             PUSHs((SV*)mg->mg_ptr);
836     }
837     else if (mg->mg_type == 'p')
838         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
839     PUTBACK;
840
841     if (perl_call_method(meth, G_SCALAR))
842         sv_setsv(sv, *stack_sp--);
843
844     FREETMPS;
845     LEAVE;
846     return 0;
847 }
848
849 int
850 magic_getpack(sv,mg)
851 SV* sv;
852 MAGIC* mg;
853 {
854     magic_methpack(sv,mg,"FETCH");
855     if (mg->mg_ptr)
856         mg->mg_flags |= MGf_GSKIP;
857     return 0;
858 }
859
860 int
861 magic_setpack(sv,mg)
862 SV* sv;
863 MAGIC* mg;
864 {
865     dSP;
866
867     PUSHMARK(sp);
868     EXTEND(sp, 3);
869     PUSHs(mg->mg_obj);
870     if (mg->mg_ptr) {
871         if (mg->mg_len >= 0)
872             PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
873         else if (mg->mg_len == HEf_SVKEY)
874             PUSHs((SV*)mg->mg_ptr);
875     }
876     else if (mg->mg_type == 'p')
877         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
878     PUSHs(sv);
879     PUTBACK;
880
881     perl_call_method("STORE", G_SCALAR|G_DISCARD);
882
883     return 0;
884 }
885
886 int
887 magic_clearpack(sv,mg)
888 SV* sv;
889 MAGIC* mg;
890 {
891     return magic_methpack(sv,mg,"DELETE");
892 }
893
894 int magic_wipepack(sv,mg)
895 SV* sv;
896 MAGIC* mg;
897 {
898     dSP;
899
900     PUSHMARK(sp);
901     XPUSHs(mg->mg_obj);
902     PUTBACK;
903
904     perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
905
906     return 0;
907 }
908
909 int
910 magic_nextpack(sv,mg,key)
911 SV* sv;
912 MAGIC* mg;
913 SV* key;
914 {
915     dSP;
916     char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
917
918     ENTER;
919     SAVETMPS;
920     PUSHMARK(sp);
921     EXTEND(sp, 2);
922     PUSHs(mg->mg_obj);
923     if (SvOK(key))
924         PUSHs(key);
925     PUTBACK;
926
927     if (perl_call_method(meth, G_SCALAR))
928         sv_setsv(key, *stack_sp--);
929
930     FREETMPS;
931     LEAVE;
932     return 0;
933 }
934
935 int
936 magic_existspack(sv,mg)
937 SV* sv;
938 MAGIC* mg;
939 {
940     return magic_methpack(sv,mg,"EXISTS");
941
942
943 int
944 magic_setdbline(sv,mg)
945 SV* sv;
946 MAGIC* mg;
947 {
948     OP *o;
949     I32 i;
950     GV* gv;
951     SV** svp;
952
953     gv = DBline;
954     i = SvTRUE(sv);
955     svp = av_fetch(GvAV(gv),
956                      atoi(MgPV(mg)), FALSE);
957     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
958         o->op_private = i;
959     else
960         warn("Can't break at that line\n");
961     return 0;
962 }
963
964 int
965 magic_getarylen(sv,mg)
966 SV* sv;
967 MAGIC* mg;
968 {
969     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
970     return 0;
971 }
972
973 int
974 magic_setarylen(sv,mg)
975 SV* sv;
976 MAGIC* mg;
977 {
978     av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
979     return 0;
980 }
981
982 int
983 magic_getpos(sv,mg)
984 SV* sv;
985 MAGIC* mg;
986 {
987     SV* lsv = LvTARG(sv);
988     
989     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
990         mg = mg_find(lsv, 'g');
991         if (mg && mg->mg_len >= 0) {
992             sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
993             return 0;
994         }
995     }
996     (void)SvOK_off(sv);
997     return 0;
998 }
999
1000 int
1001 magic_setpos(sv,mg)
1002 SV* sv;
1003 MAGIC* mg;
1004 {
1005     SV* lsv = LvTARG(sv);
1006     SSize_t pos;
1007     STRLEN len;
1008
1009     mg = 0;
1010     
1011     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1012         mg = mg_find(lsv, 'g');
1013     if (!mg) {
1014         if (!SvOK(sv))
1015             return 0;
1016         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1017         mg = mg_find(lsv, 'g');
1018     }
1019     else if (!SvOK(sv)) {
1020         mg->mg_len = -1;
1021         return 0;
1022     }
1023     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1024
1025     pos = SvIV(sv) - curcop->cop_arybase;
1026     if (pos < 0) {
1027         pos += len;
1028         if (pos < 0)
1029             pos = 0;
1030     }
1031     else if (pos > len)
1032         pos = len;
1033     mg->mg_len = pos;
1034
1035     return 0;
1036 }
1037
1038 int
1039 magic_getglob(sv,mg)
1040 SV* sv;
1041 MAGIC* mg;
1042 {
1043     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1044         SvFAKE_off(sv);
1045         gv_efullname(sv,((GV*)sv), "*");
1046         SvFAKE_on(sv);
1047     }
1048     else
1049         gv_efullname(sv,((GV*)sv), "*");        /* a gv value, be nice */
1050     return 0;
1051 }
1052
1053 int
1054 magic_setglob(sv,mg)
1055 SV* sv;
1056 MAGIC* mg;
1057 {
1058     register char *s;
1059     GV* gv;
1060
1061     if (!SvOK(sv))
1062         return 0;
1063     s = SvPV(sv, na);
1064     if (*s == '*' && s[1])
1065         s++;
1066     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1067     if (sv == (SV*)gv)
1068         return 0;
1069     if (GvGP(sv))
1070         gp_free((GV*)sv);
1071     GvGP(sv) = gp_ref(GvGP(gv));
1072     if (!GvAV(gv))
1073         gv_AVadd(gv);
1074     if (!GvHV(gv))
1075         gv_HVadd(gv);
1076     if (!GvIOp(gv))
1077         GvIOp(gv) = newIO();
1078     return 0;
1079 }
1080
1081 int
1082 magic_setsubstr(sv,mg)
1083 SV* sv;
1084 MAGIC* mg;
1085 {
1086     STRLEN len;
1087     char *tmps = SvPV(sv,len);
1088     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
1089     return 0;
1090 }
1091
1092 int
1093 magic_gettaint(sv,mg)
1094 SV* sv;
1095 MAGIC* mg;
1096 {
1097     if (mg->mg_len & 1)
1098         tainted = TRUE;
1099     else if (mg->mg_len & 2 && mg->mg_obj == sv)        /* kludge */
1100         tainted = TRUE;
1101     return 0;
1102 }
1103
1104 int
1105 magic_settaint(sv,mg)
1106 SV* sv;
1107 MAGIC* mg;
1108 {
1109     if (localizing) {
1110         if (localizing == 1)
1111             mg->mg_len <<= 1;
1112         else
1113             mg->mg_len >>= 1;
1114     }
1115     else if (tainted)
1116         mg->mg_len |= 1;
1117     else
1118         mg->mg_len &= ~1;
1119     return 0;
1120 }
1121
1122 int
1123 magic_setvec(sv,mg)
1124 SV* sv;
1125 MAGIC* mg;
1126 {
1127     do_vecset(sv);      /* XXX slurp this routine */
1128     return 0;
1129 }
1130
1131 int
1132 magic_setmglob(sv,mg)
1133 SV* sv;
1134 MAGIC* mg;
1135 {
1136     mg->mg_len = -1;
1137     SvSCREAM_off(sv);
1138     return 0;
1139 }
1140
1141 int
1142 magic_setbm(sv,mg)
1143 SV* sv;
1144 MAGIC* mg;
1145 {
1146     sv_unmagic(sv, 'B');
1147     SvVALID_off(sv);
1148     return 0;
1149 }
1150
1151 int
1152 magic_setuvar(sv,mg)
1153 SV* sv;
1154 MAGIC* mg;
1155 {
1156     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1157
1158     if (uf && uf->uf_set)
1159         (*uf->uf_set)(uf->uf_index, sv);
1160     return 0;
1161 }
1162
1163 int
1164 magic_set(sv,mg)
1165 SV* sv;
1166 MAGIC* mg;
1167 {
1168     register char *s;
1169     I32 i;
1170     STRLEN len;
1171     switch (*mg->mg_ptr) {
1172     case '\001':        /* ^A */
1173         sv_setsv(bodytarget, sv);
1174         break;
1175     case '\004':        /* ^D */
1176         debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
1177         DEBUG_x(dump_all());
1178         break;
1179     case '\005':  /* ^E */
1180 #ifdef VMS
1181         set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1182 #else
1183         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),4);         /* will anyone ever use this? */
1184 #endif
1185         break;
1186     case '\006':        /* ^F */
1187         maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1188         break;
1189     case '\010':        /* ^H */
1190         hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1191         break;
1192     case '\t':  /* ^I */
1193         if (inplace)
1194             Safefree(inplace);
1195         if (SvOK(sv))
1196             inplace = savepv(SvPV(sv,na));
1197         else
1198             inplace = Nullch;
1199         break;
1200     case '\017':        /* ^O */
1201         if (osname)
1202             Safefree(osname);
1203         if (SvOK(sv))
1204             osname = savepv(SvPV(sv,na));
1205         else
1206             osname = Nullch;
1207         break;
1208     case '\020':        /* ^P */
1209         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1210         if (i != perldb) {
1211             if (perldb)
1212                 oldlastpm = curpm;
1213             else
1214                 curpm = oldlastpm;
1215         }
1216         perldb = i;
1217         break;
1218     case '\024':        /* ^T */
1219 #ifdef BIG_TIME
1220         basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1221 #else
1222         basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1223 #endif
1224         break;
1225     case '\027':        /* ^W */
1226         dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1227         break;
1228     case '.':
1229         if (localizing) {
1230             if (localizing == 1)
1231                 save_sptr((SV**)&last_in_gv);
1232         }
1233         else if (SvOK(sv) && GvIO(last_in_gv))
1234             IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1235         break;
1236     case '^':
1237         Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1238         IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1239         IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1240         break;
1241     case '~':
1242         Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1243         IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1244         IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1245         break;
1246     case '=':
1247         IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1248         break;
1249     case '-':
1250         IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1251         if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1252             IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1253         break;
1254     case '%':
1255         IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1256         break;
1257     case '|':
1258         IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
1259         if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
1260             IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
1261         }
1262         break;
1263     case '*':
1264         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1265         multiline = (i != 0);
1266         break;
1267     case '/':
1268         SvREFCNT_dec(nrs);
1269         nrs = newSVsv(sv);
1270         SvREFCNT_dec(rs);
1271         rs = SvREFCNT_inc(nrs);
1272         break;
1273     case '\\':
1274         if (ors)
1275             Safefree(ors);
1276         ors = savepv(SvPV(sv,orslen));
1277         break;
1278     case ',':
1279         if (ofs)
1280             Safefree(ofs);
1281         ofs = savepv(SvPV(sv, ofslen));
1282         break;
1283     case '#':
1284         if (ofmt)
1285             Safefree(ofmt);
1286         ofmt = savepv(SvPV(sv,na));
1287         break;
1288     case '[':
1289         compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1290         break;
1291     case '?':
1292         statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1293         break;
1294     case '!':
1295         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SvIV(sv) == EVMSERR ? 4 : vaxc$errno);              /* will anyone ever use this? */
1296         break;
1297     case '<':
1298         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1299         if (delaymagic) {
1300             delaymagic |= DM_RUID;
1301             break;                              /* don't do magic till later */
1302         }
1303 #ifdef HAS_SETRUID
1304         (void)setruid((Uid_t)uid);
1305 #else
1306 #ifdef HAS_SETREUID
1307         (void)setreuid((Uid_t)uid, (Uid_t)-1);
1308 #else
1309 #ifdef HAS_SETRESUID
1310       (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1311 #else
1312         if (uid == euid)                /* special case $< = $> */
1313             (void)setuid(uid);
1314         else {
1315             uid = (I32)getuid();
1316             croak("setruid() not implemented");
1317         }
1318 #endif
1319 #endif
1320 #endif
1321         uid = (I32)getuid();
1322         tainting |= (uid && (euid != uid || egid != gid));
1323         break;
1324     case '>':
1325         euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1326         if (delaymagic) {
1327             delaymagic |= DM_EUID;
1328             break;                              /* don't do magic till later */
1329         }
1330 #ifdef HAS_SETEUID
1331         (void)seteuid((Uid_t)euid);
1332 #else
1333 #ifdef HAS_SETREUID
1334         (void)setreuid((Uid_t)-1, (Uid_t)euid);
1335 #else
1336 #ifdef HAS_SETRESUID
1337         (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1338 #else
1339         if (euid == uid)                /* special case $> = $< */
1340             setuid(euid);
1341         else {
1342             euid = (I32)geteuid();
1343             croak("seteuid() not implemented");
1344         }
1345 #endif
1346 #endif
1347 #endif
1348         euid = (I32)geteuid();
1349         tainting |= (uid && (euid != uid || egid != gid));
1350         break;
1351     case '(':
1352         gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1353         if (delaymagic) {
1354             delaymagic |= DM_RGID;
1355             break;                              /* don't do magic till later */
1356         }
1357 #ifdef HAS_SETRGID
1358         (void)setrgid((Gid_t)gid);
1359 #else
1360 #ifdef HAS_SETREGID
1361         (void)setregid((Gid_t)gid, (Gid_t)-1);
1362 #else
1363 #ifdef HAS_SETRESGID
1364       (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1365 #else
1366         if (gid == egid)                        /* special case $( = $) */
1367             (void)setgid(gid);
1368         else {
1369             gid = (I32)getgid();
1370             croak("setrgid() not implemented");
1371         }
1372 #endif
1373 #endif
1374 #endif
1375         gid = (I32)getgid();
1376         tainting |= (uid && (euid != uid || egid != gid));
1377         break;
1378     case ')':
1379         egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1380         if (delaymagic) {
1381             delaymagic |= DM_EGID;
1382             break;                              /* don't do magic till later */
1383         }
1384 #ifdef HAS_SETEGID
1385         (void)setegid((Gid_t)egid);
1386 #else
1387 #ifdef HAS_SETREGID
1388         (void)setregid((Gid_t)-1, (Gid_t)egid);
1389 #else
1390 #ifdef HAS_SETRESGID
1391         (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1392 #else
1393         if (egid == gid)                        /* special case $) = $( */
1394             (void)setgid(egid);
1395         else {
1396             egid = (I32)getegid();
1397             croak("setegid() not implemented");
1398         }
1399 #endif
1400 #endif
1401 #endif
1402         egid = (I32)getegid();
1403         tainting |= (uid && (euid != uid || egid != gid));
1404         break;
1405     case ':':
1406         chopset = SvPV_force(sv,na);
1407         break;
1408     case '0':
1409         if (!origalen) {
1410             s = origargv[0];
1411             s += strlen(s);
1412             /* See if all the arguments are contiguous in memory */
1413             for (i = 1; i < origargc; i++) {
1414                 if (origargv[i] == s + 1)
1415                     s += strlen(++s);   /* this one is ok too */
1416             }
1417             if (origenviron[0] == s + 1) {      /* can grab env area too? */
1418                 my_setenv("NoNeSuCh", Nullch);
1419                                             /* force copy of environment */
1420                 for (i = 0; origenviron[i]; i++)
1421                     if (origenviron[i] == s + 1)
1422                         s += strlen(++s);
1423             }
1424             origalen = s - origargv[0];
1425         }
1426         s = SvPV_force(sv,len);
1427         i = len;
1428         if (i >= origalen) {
1429             i = origalen;
1430             SvCUR_set(sv, i);
1431             *SvEND(sv) = '\0';
1432             Copy(s, origargv[0], i, char);
1433         }
1434         else {
1435             Copy(s, origargv[0], i, char);
1436             s = origargv[0]+i;
1437             *s++ = '\0';
1438             while (++i < origalen)
1439                 *s++ = ' ';
1440             s = origargv[0]+i;
1441             for (i = 1; i < origargc; i++)
1442                 origargv[i] = Nullch;
1443         }
1444         break;
1445     }
1446     return 0;
1447 }
1448
1449 I32
1450 whichsig(sig)
1451 char *sig;
1452 {
1453     register char **sigv;
1454
1455     for (sigv = sig_name+1; *sigv; sigv++)
1456         if (strEQ(sig,*sigv))
1457             return sig_num[sigv - sig_name];
1458 #ifdef SIGCLD
1459     if (strEQ(sig,"CHLD"))
1460         return SIGCLD;
1461 #endif
1462 #ifdef SIGCHLD
1463     if (strEQ(sig,"CLD"))
1464         return SIGCHLD;
1465 #endif
1466     return 0;
1467 }
1468
1469 Signal_t
1470 sighandler(sig)
1471 int sig;
1472 {
1473     dSP;
1474     GV *gv;
1475     HV *st;
1476     SV *sv;
1477     CV *cv;
1478     AV *oldstack;
1479     
1480     if(!psig_ptr[sig])
1481         die("Signal SIG%s received, but no signal handler set.\n",
1482         sig_name[sig]);
1483
1484     cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
1485     if (!cv || !CvROOT(cv)) {
1486         if (dowarn)
1487             warn("SIG%s handler \"%s\" not defined.\n",
1488                 sig_name[sig], GvENAME(gv) );
1489         return;
1490     }
1491
1492     oldstack = curstack;
1493     if (curstack != signalstack)
1494         AvFILL(signalstack) = 0;
1495     SWITCHSTACK(curstack, signalstack);
1496
1497     if(psig_name[sig])
1498         sv = SvREFCNT_inc(psig_name[sig]);
1499     else {
1500         sv = sv_newmortal();
1501         sv_setpv(sv,sig_name[sig]);
1502     }
1503     PUSHMARK(sp);
1504     PUSHs(sv);
1505     PUTBACK;
1506
1507     perl_call_sv((SV*)cv, G_DISCARD);
1508
1509     SWITCHSTACK(signalstack, oldstack);
1510
1511     return;
1512 }