perl 5.003_04: lib/Test/Harness.pm
[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_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_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(mg->mg_ptr,strlen(mg->mg_ptr));
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     gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
1034     return 0;
1035 }
1036
1037 int
1038 magic_setglob(sv,mg)
1039 SV* sv;
1040 MAGIC* mg;
1041 {
1042     register char *s;
1043     GV* gv;
1044
1045     if (!SvOK(sv))
1046         return 0;
1047     s = SvPV(sv, na);
1048     if (*s == '*' && s[1])
1049         s++;
1050     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1051     if (sv == (SV*)gv)
1052         return 0;
1053     if (GvGP(sv))
1054         gp_free((GV*)sv);
1055     GvGP(sv) = gp_ref(GvGP(gv));
1056     if (!GvAV(gv))
1057         gv_AVadd(gv);
1058     if (!GvHV(gv))
1059         gv_HVadd(gv);
1060     if (!GvIOp(gv))
1061         GvIOp(gv) = newIO();
1062     return 0;
1063 }
1064
1065 int
1066 magic_setsubstr(sv,mg)
1067 SV* sv;
1068 MAGIC* mg;
1069 {
1070     STRLEN len;
1071     char *tmps = SvPV(sv,len);
1072     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
1073     return 0;
1074 }
1075
1076 int
1077 magic_gettaint(sv,mg)
1078 SV* sv;
1079 MAGIC* mg;
1080 {
1081     if (mg->mg_len & 1)
1082         tainted = TRUE;
1083     else if (mg->mg_len & 2 && mg->mg_obj == sv)        /* kludge */
1084         tainted = TRUE;
1085     return 0;
1086 }
1087
1088 int
1089 magic_settaint(sv,mg)
1090 SV* sv;
1091 MAGIC* mg;
1092 {
1093     if (localizing) {
1094         if (localizing == 1)
1095             mg->mg_len <<= 1;
1096         else
1097             mg->mg_len >>= 1;
1098     }
1099     else if (tainted)
1100         mg->mg_len |= 1;
1101     else
1102         mg->mg_len &= ~1;
1103     return 0;
1104 }
1105
1106 int
1107 magic_setvec(sv,mg)
1108 SV* sv;
1109 MAGIC* mg;
1110 {
1111     do_vecset(sv);      /* XXX slurp this routine */
1112     return 0;
1113 }
1114
1115 int
1116 magic_setmglob(sv,mg)
1117 SV* sv;
1118 MAGIC* mg;
1119 {
1120     mg->mg_len = -1;
1121     SvSCREAM_off(sv);
1122     return 0;
1123 }
1124
1125 int
1126 magic_setbm(sv,mg)
1127 SV* sv;
1128 MAGIC* mg;
1129 {
1130     sv_unmagic(sv, 'B');
1131     SvVALID_off(sv);
1132     return 0;
1133 }
1134
1135 int
1136 magic_setuvar(sv,mg)
1137 SV* sv;
1138 MAGIC* mg;
1139 {
1140     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1141
1142     if (uf && uf->uf_set)
1143         (*uf->uf_set)(uf->uf_index, sv);
1144     return 0;
1145 }
1146
1147 int
1148 magic_set(sv,mg)
1149 SV* sv;
1150 MAGIC* mg;
1151 {
1152     register char *s;
1153     I32 i;
1154     STRLEN len;
1155     switch (*mg->mg_ptr) {
1156     case '\001':        /* ^A */
1157         sv_setsv(bodytarget, sv);
1158         break;
1159     case '\004':        /* ^D */
1160         debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
1161         DEBUG_x(dump_all());
1162         break;
1163     case '\005':  /* ^E */
1164 #ifdef VMS
1165         set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1166 #else
1167         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),4);         /* will anyone ever use this? */
1168 #endif
1169         break;
1170     case '\006':        /* ^F */
1171         maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1172         break;
1173     case '\010':        /* ^H */
1174         hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1175         break;
1176     case '\t':  /* ^I */
1177         if (inplace)
1178             Safefree(inplace);
1179         if (SvOK(sv))
1180             inplace = savepv(SvPV(sv,na));
1181         else
1182             inplace = Nullch;
1183         break;
1184     case '\017':        /* ^O */
1185         if (osname)
1186             Safefree(osname);
1187         if (SvOK(sv))
1188             osname = savepv(SvPV(sv,na));
1189         else
1190             osname = Nullch;
1191         break;
1192     case '\020':        /* ^P */
1193         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1194         if (i != perldb) {
1195             if (perldb)
1196                 oldlastpm = curpm;
1197             else
1198                 curpm = oldlastpm;
1199         }
1200         perldb = i;
1201         break;
1202     case '\024':        /* ^T */
1203 #ifdef BIG_TIME
1204         basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1205 #else
1206         basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1207 #endif
1208         break;
1209     case '\027':        /* ^W */
1210         dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1211         break;
1212     case '.':
1213         if (localizing) {
1214             if (localizing == 1)
1215                 save_sptr((SV**)&last_in_gv);
1216         }
1217         else if (SvOK(sv) && GvIO(last_in_gv))
1218             IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1219         break;
1220     case '^':
1221         Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1222         IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1223         IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1224         break;
1225     case '~':
1226         Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1227         IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1228         IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1229         break;
1230     case '=':
1231         IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1232         break;
1233     case '-':
1234         IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1235         if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1236             IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1237         break;
1238     case '%':
1239         IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1240         break;
1241     case '|':
1242         IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
1243         if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
1244             IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
1245         }
1246         break;
1247     case '*':
1248         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1249         multiline = (i != 0);
1250         break;
1251     case '/':
1252         SvREFCNT_dec(nrs);
1253         nrs = newSVsv(sv);
1254         SvREFCNT_dec(rs);
1255         rs = SvREFCNT_inc(nrs);
1256         break;
1257     case '\\':
1258         if (ors)
1259             Safefree(ors);
1260         ors = savepv(SvPV(sv,orslen));
1261         break;
1262     case ',':
1263         if (ofs)
1264             Safefree(ofs);
1265         ofs = savepv(SvPV(sv, ofslen));
1266         break;
1267     case '#':
1268         if (ofmt)
1269             Safefree(ofmt);
1270         ofmt = savepv(SvPV(sv,na));
1271         break;
1272     case '[':
1273         compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1274         break;
1275     case '?':
1276         statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1277         break;
1278     case '!':
1279         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SvIV(sv) == EVMSERR ? 4 : vaxc$errno);              /* will anyone ever use this? */
1280         break;
1281     case '<':
1282         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1283         if (delaymagic) {
1284             delaymagic |= DM_RUID;
1285             break;                              /* don't do magic till later */
1286         }
1287 #ifdef HAS_SETRUID
1288         (void)setruid((Uid_t)uid);
1289 #else
1290 #ifdef HAS_SETREUID
1291         (void)setreuid((Uid_t)uid, (Uid_t)-1);
1292 #else
1293 #ifdef HAS_SETRESUID
1294       (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1295 #else
1296         if (uid == euid)                /* special case $< = $> */
1297             (void)setuid(uid);
1298         else {
1299             uid = (I32)getuid();
1300             croak("setruid() not implemented");
1301         }
1302 #endif
1303 #endif
1304 #endif
1305         uid = (I32)getuid();
1306         tainting |= (uid && (euid != uid || egid != gid));
1307         break;
1308     case '>':
1309         euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1310         if (delaymagic) {
1311             delaymagic |= DM_EUID;
1312             break;                              /* don't do magic till later */
1313         }
1314 #ifdef HAS_SETEUID
1315         (void)seteuid((Uid_t)euid);
1316 #else
1317 #ifdef HAS_SETREUID
1318         (void)setreuid((Uid_t)-1, (Uid_t)euid);
1319 #else
1320 #ifdef HAS_SETRESUID
1321         (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1322 #else
1323         if (euid == uid)                /* special case $> = $< */
1324             setuid(euid);
1325         else {
1326             euid = (I32)geteuid();
1327             croak("seteuid() not implemented");
1328         }
1329 #endif
1330 #endif
1331 #endif
1332         euid = (I32)geteuid();
1333         tainting |= (uid && (euid != uid || egid != gid));
1334         break;
1335     case '(':
1336         gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1337         if (delaymagic) {
1338             delaymagic |= DM_RGID;
1339             break;                              /* don't do magic till later */
1340         }
1341 #ifdef HAS_SETRGID
1342         (void)setrgid((Gid_t)gid);
1343 #else
1344 #ifdef HAS_SETREGID
1345         (void)setregid((Gid_t)gid, (Gid_t)-1);
1346 #else
1347 #ifdef HAS_SETRESGID
1348       (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1349 #else
1350         if (gid == egid)                        /* special case $( = $) */
1351             (void)setgid(gid);
1352         else {
1353             gid = (I32)getgid();
1354             croak("setrgid() not implemented");
1355         }
1356 #endif
1357 #endif
1358 #endif
1359         gid = (I32)getgid();
1360         tainting |= (uid && (euid != uid || egid != gid));
1361         break;
1362     case ')':
1363         egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1364         if (delaymagic) {
1365             delaymagic |= DM_EGID;
1366             break;                              /* don't do magic till later */
1367         }
1368 #ifdef HAS_SETEGID
1369         (void)setegid((Gid_t)egid);
1370 #else
1371 #ifdef HAS_SETREGID
1372         (void)setregid((Gid_t)-1, (Gid_t)egid);
1373 #else
1374 #ifdef HAS_SETRESGID
1375         (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1376 #else
1377         if (egid == gid)                        /* special case $) = $( */
1378             (void)setgid(egid);
1379         else {
1380             egid = (I32)getegid();
1381             croak("setegid() not implemented");
1382         }
1383 #endif
1384 #endif
1385 #endif
1386         egid = (I32)getegid();
1387         tainting |= (uid && (euid != uid || egid != gid));
1388         break;
1389     case ':':
1390         chopset = SvPV_force(sv,na);
1391         break;
1392     case '0':
1393         if (!origalen) {
1394             s = origargv[0];
1395             s += strlen(s);
1396             /* See if all the arguments are contiguous in memory */
1397             for (i = 1; i < origargc; i++) {
1398                 if (origargv[i] == s + 1)
1399                     s += strlen(++s);   /* this one is ok too */
1400             }
1401             if (origenviron[0] == s + 1) {      /* can grab env area too? */
1402                 my_setenv("NoNeSuCh", Nullch);
1403                                             /* force copy of environment */
1404                 for (i = 0; origenviron[i]; i++)
1405                     if (origenviron[i] == s + 1)
1406                         s += strlen(++s);
1407             }
1408             origalen = s - origargv[0];
1409         }
1410         s = SvPV_force(sv,len);
1411         i = len;
1412         if (i >= origalen) {
1413             i = origalen;
1414             SvCUR_set(sv, i);
1415             *SvEND(sv) = '\0';
1416             Copy(s, origargv[0], i, char);
1417         }
1418         else {
1419             Copy(s, origargv[0], i, char);
1420             s = origargv[0]+i;
1421             *s++ = '\0';
1422             while (++i < origalen)
1423                 *s++ = ' ';
1424             s = origargv[0]+i;
1425             for (i = 1; i < origargc; i++)
1426                 origargv[i] = Nullch;
1427         }
1428         break;
1429     }
1430     return 0;
1431 }
1432
1433 I32
1434 whichsig(sig)
1435 char *sig;
1436 {
1437     register char **sigv;
1438
1439     for (sigv = sig_name+1; *sigv; sigv++)
1440         if (strEQ(sig,*sigv))
1441             return sig_num[sigv - sig_name];
1442 #ifdef SIGCLD
1443     if (strEQ(sig,"CHLD"))
1444         return SIGCLD;
1445 #endif
1446 #ifdef SIGCHLD
1447     if (strEQ(sig,"CLD"))
1448         return SIGCHLD;
1449 #endif
1450     return 0;
1451 }
1452
1453 Signal_t
1454 sighandler(sig)
1455 int sig;
1456 {
1457     dSP;
1458     GV *gv;
1459     HV *st;
1460     SV *sv;
1461     CV *cv;
1462     AV *oldstack;
1463     
1464     if(!psig_ptr[sig])
1465         die("Signal SIG%s received, but no signal handler set.\n",
1466         sig_name[sig]);
1467
1468     cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
1469     if (!cv || !CvROOT(cv)) {
1470         if (dowarn)
1471             warn("SIG%s handler \"%s\" not defined.\n",
1472                 sig_name[sig], GvENAME(gv) );
1473         return;
1474     }
1475
1476     oldstack = curstack;
1477     if (curstack != signalstack)
1478         AvFILL(signalstack) = 0;
1479     SWITCHSTACK(curstack, signalstack);
1480
1481     if(psig_name[sig])
1482         sv = SvREFCNT_inc(psig_name[sig]);
1483     else {
1484         sv = sv_newmortal();
1485         sv_setpv(sv,sig_name[sig]);
1486     }
1487     PUSHMARK(sp);
1488     PUSHs(sv);
1489     PUTBACK;
1490
1491     perl_call_sv((SV*)cv, G_DISCARD);
1492
1493     SWITCHSTACK(signalstack, oldstack);
1494
1495     return;
1496 }