This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[perl5.git] / mg.c
1 /* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:21:48 $
2  *
3  *    Copyright (c) 1993, 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  * $Log:        hash.c,v $
9  */
10
11 #include "EXTERN.h"
12 #include "perl.h"
13
14 int
15 mg_get(sv)
16 SV* sv;
17 {
18     MAGIC* mg;
19
20     SvMAGICAL_off(sv);
21     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
22     SvFLAGS(sv) |= SvPRIVATE(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
23     SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
24
25     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
26         MGVTBL* vtbl = mg->mg_virtual;
27         if (vtbl && vtbl->svt_get)
28             (*vtbl->svt_get)(sv, mg);
29     }
30
31     SvMAGICAL_on(sv);
32     SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
33     SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
34     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
35
36     return 0;
37 }
38
39 int
40 mg_set(sv)
41 SV* sv;
42 {
43     MAGIC* mg;
44     MAGIC* nextmg;
45
46     SvMAGICAL_off(sv);
47
48     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
49         MGVTBL* vtbl = mg->mg_virtual;
50         nextmg = mg->mg_moremagic;      /* it may delete itself */
51         if (vtbl && vtbl->svt_set)
52             (*vtbl->svt_set)(sv, mg);
53     }
54
55     if (SvMAGIC(sv)) {
56         SvMAGICAL_on(sv);
57 /*      SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);  */
58         SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
59         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
60     }
61
62     return 0;
63 }
64
65 U32
66 mg_len(sv)
67 SV* sv;
68 {
69     MAGIC* mg;
70     char *s;
71     STRLEN len;
72
73     SvMAGICAL_off(sv);
74     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
75     SvFLAGS(sv) |= SvPRIVATE(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
76     SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
77
78     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
79         MGVTBL* vtbl = mg->mg_virtual;
80         if (vtbl && vtbl->svt_len)
81             return (*vtbl->svt_len)(sv, mg);
82     }
83     mg_get(sv);
84     s = SvPV(sv, len);
85
86     SvMAGICAL_on(sv);
87     SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
88     SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
89     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
90
91     return len;
92 }
93
94 int
95 mg_clear(sv)
96 SV* sv;
97 {
98     MAGIC* mg;
99
100     SvMAGICAL_off(sv);
101     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
102     SvFLAGS(sv) |= SvPRIVATE(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
103     SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
104
105     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
106         MGVTBL* vtbl = mg->mg_virtual;
107         if (vtbl && vtbl->svt_clear)
108             (*vtbl->svt_clear)(sv, mg);
109     }
110
111     SvMAGICAL_on(sv);
112     SvPRIVATE(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
113     SvPRIVATE(sv) |= SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
114     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
115
116     return 0;
117 }
118
119 MAGIC*
120 mg_find(sv, type)
121 SV* sv;
122 char type;
123 {
124     MAGIC* mg;
125     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
126         if (mg->mg_type == type)
127             return mg;
128     }
129     return 0;
130 }
131
132 int
133 mg_copy(sv, nsv, key, klen)
134 SV* sv;
135 SV* nsv;
136 char *key;
137 STRLEN klen;
138 {
139     int count = 0;
140     MAGIC* mg;
141     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
142         if (isUPPER(mg->mg_type)) {
143             sv_magic(nsv, mg->mg_obj, tolower(mg->mg_type), key, klen);
144             count++;
145         }
146     }
147     return count;
148 }
149
150 int
151 mg_free(sv)
152 SV* sv;
153 {
154     MAGIC* mg;
155     MAGIC* moremagic;
156     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
157         MGVTBL* vtbl = mg->mg_virtual;
158         moremagic = mg->mg_moremagic;
159         if (vtbl && vtbl->svt_free)
160             (*vtbl->svt_free)(sv, mg);
161         if (mg->mg_ptr && mg->mg_type != 'g')
162             Safefree(mg->mg_ptr);
163         sv_free(mg->mg_obj);
164         Safefree(mg);
165     }
166     SvMAGIC(sv) = 0;
167     return 0;
168 }
169
170 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
171 #include <signal.h>
172 #endif
173
174 #ifdef VOIDSIG
175 #define handlertype void
176 #else
177 #define handlertype int
178 #endif
179
180 static handlertype sighandler();
181
182 U32
183 magic_len(sv, mg)
184 SV *sv;
185 MAGIC *mg;
186 {
187     register I32 paren;
188     register char *s;
189     register I32 i;
190
191     switch (*mg->mg_ptr) {
192     case '1': case '2': case '3': case '4':
193     case '5': case '6': case '7': case '8': case '9': case '&':
194         if (curpm) {
195             paren = atoi(mg->mg_ptr);
196           getparen:
197             if (curpm->op_pmregexp &&
198               paren <= curpm->op_pmregexp->nparens &&
199               (s = curpm->op_pmregexp->startp[paren]) ) {
200                 i = curpm->op_pmregexp->endp[paren] - s;
201                 if (i >= 0)
202                     return i;
203                 else
204                     return 0;
205             }
206             else
207                 return 0;
208         }
209         break;
210     case '+':
211         if (curpm) {
212             paren = curpm->op_pmregexp->lastparen;
213             goto getparen;
214         }
215         break;
216     case '`':
217         if (curpm) {
218             if (curpm->op_pmregexp &&
219               (s = curpm->op_pmregexp->subbeg) ) {
220                 i = curpm->op_pmregexp->startp[0] - s;
221                 if (i >= 0)
222                     return i;
223                 else
224                     return 0;
225             }
226             else
227                 return 0;
228         }
229         break;
230     case '\'':
231         if (curpm) {
232             if (curpm->op_pmregexp &&
233               (s = curpm->op_pmregexp->endp[0]) ) {
234                 return (STRLEN) (curpm->op_pmregexp->subend - s);
235             }
236             else
237                 return 0;
238         }
239         break;
240     case ',':
241         return (STRLEN)ofslen;
242     case '\\':
243         return (STRLEN)orslen;
244     }
245     magic_get(sv,mg);
246     if (!SvPOK(sv) && SvNIOK(sv))
247         sv_2pv(sv, &na);
248     if (SvPOK(sv))
249         return SvCUR(sv);
250     return 0;
251 }
252
253 int
254 magic_get(sv, mg)
255 SV *sv;
256 MAGIC *mg;
257 {
258     register I32 paren;
259     register char *s;
260     register I32 i;
261
262     switch (*mg->mg_ptr) {
263     case '\004':                /* ^D */
264         sv_setiv(sv,(I32)(debug & 32767));
265         break;
266     case '\006':                /* ^F */
267         sv_setiv(sv,(I32)maxsysfd);
268         break;
269     case '\t':                  /* ^I */
270         if (inplace)
271             sv_setpv(sv, inplace);
272         else
273             sv_setsv(sv,&sv_undef);
274         break;
275     case '\020':                /* ^P */
276         sv_setiv(sv,(I32)perldb);
277         break;
278     case '\024':                /* ^T */
279         sv_setiv(sv,(I32)basetime);
280         break;
281     case '\027':                /* ^W */
282         sv_setiv(sv,(I32)dowarn);
283         break;
284     case '1': case '2': case '3': case '4':
285     case '5': case '6': case '7': case '8': case '9': case '&':
286         if (curpm) {
287             paren = atoi(GvENAME(mg->mg_obj));
288           getparen:
289             if (curpm->op_pmregexp &&
290               paren <= curpm->op_pmregexp->nparens &&
291               (s = curpm->op_pmregexp->startp[paren]) ) {
292                 i = curpm->op_pmregexp->endp[paren] - s;
293                 if (i >= 0)
294                     sv_setpvn(sv,s,i);
295                 else
296                     sv_setsv(sv,&sv_undef);
297             }
298             else
299                 sv_setsv(sv,&sv_undef);
300         }
301         break;
302     case '+':
303         if (curpm) {
304             paren = curpm->op_pmregexp->lastparen;
305             goto getparen;
306         }
307         break;
308     case '`':
309         if (curpm) {
310             if (curpm->op_pmregexp &&
311               (s = curpm->op_pmregexp->subbeg) ) {
312                 i = curpm->op_pmregexp->startp[0] - s;
313                 if (i >= 0)
314                     sv_setpvn(sv,s,i);
315                 else
316                     sv_setpvn(sv,"",0);
317             }
318             else
319                 sv_setpvn(sv,"",0);
320         }
321         break;
322     case '\'':
323         if (curpm) {
324             if (curpm->op_pmregexp &&
325               (s = curpm->op_pmregexp->endp[0]) ) {
326                 sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
327             }
328             else
329                 sv_setpvn(sv,"",0);
330         }
331         break;
332     case '.':
333 #ifndef lint
334         if (last_in_gv && GvIO(last_in_gv)) {
335             sv_setiv(sv,(I32)GvIO(last_in_gv)->lines);
336         }
337 #endif
338         break;
339     case '?':
340         sv_setiv(sv,(I32)statusvalue);
341         break;
342     case '^':
343         s = GvIO(defoutgv)->top_name;
344         if (s)
345             sv_setpv(sv,s);
346         else {
347             sv_setpv(sv,GvENAME(defoutgv));
348             sv_catpv(sv,"_TOP");
349         }
350         break;
351     case '~':
352         s = GvIO(defoutgv)->fmt_name;
353         if (!s)
354             s = GvENAME(defoutgv);
355         sv_setpv(sv,s);
356         break;
357 #ifndef lint
358     case '=':
359         sv_setiv(sv,(I32)GvIO(defoutgv)->page_len);
360         break;
361     case '-':
362         sv_setiv(sv,(I32)GvIO(defoutgv)->lines_left);
363         break;
364     case '%':
365         sv_setiv(sv,(I32)GvIO(defoutgv)->page);
366         break;
367 #endif
368     case ':':
369         break;
370     case '/':
371         break;
372     case '[':
373         sv_setiv(sv,(I32)arybase);
374         break;
375     case '|':
376         if (!GvIO(defoutgv))
377             GvIO(defoutgv) = newIO();
378         sv_setiv(sv, (GvIO(defoutgv)->flags & IOf_FLUSH) != 0 );
379         break;
380     case ',':
381         sv_setpvn(sv,ofs,ofslen);
382         break;
383     case '\\':
384         sv_setpvn(sv,ors,orslen);
385         break;
386     case '#':
387         sv_setpv(sv,ofmt);
388         break;
389     case '!':
390         sv_setnv(sv,(double)errno);
391         sv_setpv(sv, errno ? strerror(errno) : "");
392         SvNOK_on(sv);   /* what a wonderful hack! */
393         break;
394     case '<':
395         sv_setiv(sv,(I32)uid);
396         break;
397     case '>':
398         sv_setiv(sv,(I32)euid);
399         break;
400     case '(':
401         s = buf;
402         (void)sprintf(s,"%d",(int)gid);
403         goto add_groups;
404     case ')':
405         s = buf;
406         (void)sprintf(s,"%d",(int)egid);
407       add_groups:
408         while (*s) s++;
409 #ifdef HAS_GETGROUPS
410 #ifndef NGROUPS
411 #define NGROUPS 32
412 #endif
413         {
414             GROUPSTYPE gary[NGROUPS];
415
416             i = getgroups(NGROUPS,gary);
417             while (--i >= 0) {
418                 (void)sprintf(s," %ld", (long)gary[i]);
419                 while (*s) s++;
420             }
421         }
422 #endif
423         sv_setpv(sv,buf);
424         break;
425     case '*':
426         break;
427     case '0':
428         break;
429     }
430 }
431
432 int
433 magic_getuvar(sv, mg)
434 SV *sv;
435 MAGIC *mg;
436 {
437     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
438
439     if (uf && uf->uf_val)
440         (*uf->uf_val)(uf->uf_index, sv);
441     return 0;
442 }
443
444 int
445 magic_setenv(sv,mg)
446 SV* sv;
447 MAGIC* mg;
448 {
449     register char *s;
450     I32 i;
451     s = SvPVX(sv);
452     my_setenv(mg->mg_ptr,s);
453                             /* And you'll never guess what the dog had */
454                             /*   in its mouth... */
455     if (tainting) {
456         if (s && strEQ(mg->mg_ptr,"PATH")) {
457             char *strend = SvEND(sv);
458
459             while (s < strend) {
460                 s = cpytill(tokenbuf,s,strend,':',&i);
461                 s++;
462                 if (*tokenbuf != '/'
463                   || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
464                     SvPRIVATE(sv) |= SVp_TAINTEDDIR;
465             }
466         }
467     }
468     return 0;
469 }
470
471 int
472 magic_setsig(sv,mg)
473 SV* sv;
474 MAGIC* mg;
475 {
476     register char *s;
477     I32 i;
478     s = SvPVX(sv);
479     i = whichsig(mg->mg_ptr);   /* ...no, a brick */
480     if (!i && (dowarn || strEQ(mg->mg_ptr,"ALARM")))
481         warn("No such signal: SIG%s", mg->mg_ptr);
482     if (strEQ(s,"IGNORE"))
483 #ifndef lint
484         (void)signal(i,SIG_IGN);
485 #else
486         ;
487 #endif
488     else if (strEQ(s,"DEFAULT") || !*s)
489         (void)signal(i,SIG_DFL);
490     else {
491         (void)signal(i,sighandler);
492         if (!strchr(s,'\'')) {
493             sprintf(tokenbuf, "main'%s",s);
494             sv_setpv(sv,tokenbuf);
495         }
496     }
497     return 0;
498 }
499
500 int
501 magic_setisa(sv,mg)
502 SV* sv;
503 MAGIC* mg;
504 {
505     sub_generation++;
506     return 0;
507 }
508
509 int
510 magic_getpack(sv,mg)
511 SV* sv;
512 MAGIC* mg;
513 {
514     SV* rv = mg->mg_obj;
515     HV* stash = SvSTASH(SvRV(rv));
516     GV* gv = gv_fetchmethod(stash, "fetch");
517     dSP;
518     BINOP myop;
519
520     if (!gv || !GvCV(gv)) {
521         croak("No fetch method for magical variable in package \"%s\"",
522             HvNAME(stash));
523     }
524     Zero(&myop, 1, BINOP);
525     myop.op_last = (OP *) &myop;
526     myop.op_next = Nullop;
527     myop.op_flags = OPf_STACKED;
528
529     ENTER;
530     SAVESPTR(op);
531     op = (OP *) &myop;
532     PUTBACK;
533     pp_pushmark();
534
535     EXTEND(sp, 4);
536     PUSHs(gv);
537     PUSHs(rv);
538     if (mg->mg_ptr)
539         PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len)));
540     else if (mg->mg_len >= 0)
541         PUSHs(sv_mortalcopy(newSViv(mg->mg_len)));
542     PUTBACK;
543
544     if (op = pp_entersubr())
545         run();
546     LEAVE;
547     SPAGAIN;
548
549     sv_setsv(sv, POPs);
550     PUTBACK;
551
552     return 0;
553 }
554
555 int
556 magic_setpack(sv,mg)
557 SV* sv;
558 MAGIC* mg;
559 {
560     SV* rv = mg->mg_obj;
561     HV* stash = SvSTASH(SvRV(rv));
562     GV* gv = gv_fetchmethod(stash, "store");
563     dSP;
564     BINOP myop;
565
566     if (!gv || !GvCV(gv)) {
567         croak("No store method for magical variable in package \"%s\"",
568             HvNAME(stash));
569     }
570     Zero(&myop, 1, BINOP);
571     myop.op_last = (OP *) &myop;
572     myop.op_next = Nullop;
573     myop.op_flags = OPf_STACKED;
574
575     ENTER;
576     SAVESPTR(op);
577     op = (OP *) &myop;
578     PUTBACK;
579     pp_pushmark();
580
581     EXTEND(sp, 4);
582     PUSHs(gv);
583     PUSHs(rv);
584     if (mg->mg_ptr)
585         PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len)));
586     else if (mg->mg_len >= 0)
587         PUSHs(sv_mortalcopy(newSViv(mg->mg_len)));
588     PUSHs(sv);
589     PUTBACK;
590
591     if (op = pp_entersubr())
592         run();
593     LEAVE;
594     SPAGAIN;
595
596     POPs;
597     PUTBACK;
598
599     return 0;
600 }
601
602 int
603 magic_clearpack(sv,mg)
604 SV* sv;
605 MAGIC* mg;
606 {
607     SV* rv = mg->mg_obj;
608     HV* stash = SvSTASH(SvRV(rv));
609     GV* gv = gv_fetchmethod(stash, "delete");
610     dSP;
611     BINOP myop;
612
613     if (!gv || !GvCV(gv)) {
614         croak("No delete method for magical variable in package \"%s\"",
615             HvNAME(stash));
616     }
617     Zero(&myop, 1, BINOP);
618     myop.op_last = (OP *) &myop;
619     myop.op_next = Nullop;
620     myop.op_flags = OPf_STACKED;
621
622     ENTER;
623     SAVESPTR(op);
624     op = (OP *) &myop;
625     PUTBACK;
626     pp_pushmark();
627
628     EXTEND(sp, 4);
629     PUSHs(gv);
630     PUSHs(rv);
631     if (mg->mg_ptr)
632         PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len)));
633     else
634         PUSHs(sv_mortalcopy(newSViv(mg->mg_len)));
635     PUTBACK;
636
637     if (op = pp_entersubr())
638         run();
639     LEAVE;
640     SPAGAIN;
641
642     sv_setsv(sv, POPs);
643     PUTBACK;
644
645     return 0;
646 }
647
648 int
649 magic_nextpack(sv,mg,key)
650 SV* sv;
651 MAGIC* mg;
652 SV* key;
653 {
654     SV* rv = mg->mg_obj;
655     HV* stash = SvSTASH(SvRV(rv));
656     GV* gv = gv_fetchmethod(stash, SvOK(key) ? "nextkey" : "firstkey");
657     dSP;
658     BINOP myop;
659
660     if (!gv || !GvCV(gv)) {
661         croak("No fetch method for magical variable in package \"%s\"",
662             HvNAME(stash));
663     }
664     Zero(&myop, 1, BINOP);
665     myop.op_last = (OP *) &myop;
666     myop.op_next = Nullop;
667     myop.op_flags = OPf_STACKED;
668
669     ENTER;
670     SAVESPTR(op);
671     op = (OP *) &myop;
672     PUTBACK;
673     pp_pushmark();
674
675     EXTEND(sp, 4);
676     PUSHs(gv);
677     PUSHs(rv);
678     if (SvOK(key))
679         PUSHs(key);
680     PUTBACK;
681
682     if (op = pp_entersubr())
683         run();
684     LEAVE;
685     SPAGAIN;
686
687     sv_setsv(key, POPs);
688     PUTBACK;
689
690     return 0;
691 }
692
693 int
694 magic_setdbline(sv,mg)
695 SV* sv;
696 MAGIC* mg;
697 {
698     OP *o;
699     I32 i;
700     GV* gv;
701     SV** svp;
702
703     gv = DBline;
704     i = SvTRUE(sv);
705     svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
706     if (svp && SvIOK(*svp) && (o = (OP*)SvSTASH(*svp)))
707         o->op_private = i;
708     else
709         warn("Can't break at that line\n");
710     return 0;
711 }
712
713 int
714 magic_getarylen(sv,mg)
715 SV* sv;
716 MAGIC* mg;
717 {
718     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + arybase);
719     return 0;
720 }
721
722 int
723 magic_setarylen(sv,mg)
724 SV* sv;
725 MAGIC* mg;
726 {
727     av_fill((AV*)mg->mg_obj, (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) - arybase);
728     return 0;
729 }
730
731 int
732 magic_getglob(sv,mg)
733 SV* sv;
734 MAGIC* mg;
735 {
736     gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
737     return 0;
738 }
739
740 int
741 magic_setglob(sv,mg)
742 SV* sv;
743 MAGIC* mg;
744 {
745     register char *s;
746     GV* gv;
747
748     if (!SvOK(sv))
749         return 0;
750     s = SvPV(sv, na);
751     if (*s == '*' && s[1])
752         s++;
753     gv = gv_fetchpv(s,TRUE);
754     if (sv == (SV*)gv)
755         return 0;
756     if (GvGP(sv))
757         gp_free(sv);
758     GvGP(sv) = gp_ref(GvGP(gv));
759     if (!GvAV(gv))
760         gv_AVadd(gv);
761     if (!GvHV(gv))
762         gv_HVadd(gv);
763     if (!GvIO(gv))
764         GvIO(gv) = newIO();
765     return 0;
766 }
767
768 int
769 magic_setsubstr(sv,mg)
770 SV* sv;
771 MAGIC* mg;
772 {
773     char *tmps = SvPVX(sv);
774     if (!tmps)
775         tmps = "";
776     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps,SvCUR(sv));
777     return 0;
778 }
779
780 int
781 magic_gettaint(sv,mg)
782 SV* sv;
783 MAGIC* mg;
784 {
785     tainted = TRUE;
786     return 0;
787 }
788
789 int
790 magic_settaint(sv,mg)
791 SV* sv;
792 MAGIC* mg;
793 {
794     if (!tainted)
795         sv_unmagic(sv, 't');
796     return 0;
797 }
798
799 int
800 magic_setvec(sv,mg)
801 SV* sv;
802 MAGIC* mg;
803 {
804     do_vecset(sv);      /* XXX slurp this routine */
805     return 0;
806 }
807
808 int
809 magic_setmglob(sv,mg)
810 SV* sv;
811 MAGIC* mg;
812 {
813     mg->mg_ptr = 0;
814     mg->mg_len = 0;
815     return 0;
816 }
817
818 int
819 magic_setbm(sv,mg)
820 SV* sv;
821 MAGIC* mg;
822 {
823     sv_unmagic(sv, 'B');
824     SvVALID_off(sv);
825     return 0;
826 }
827
828 int
829 magic_setuvar(sv,mg)
830 SV* sv;
831 MAGIC* mg;
832 {
833     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
834
835     if (uf && uf->uf_set)
836         (*uf->uf_set)(uf->uf_index, sv);
837     return 0;
838 }
839
840 int
841 magic_set(sv,mg)
842 SV* sv;
843 MAGIC* mg;
844 {
845     register char *s;
846     I32 i;
847     switch (*mg->mg_ptr) {
848     case '\004':        /* ^D */
849         debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 32768;
850         DEBUG_x(dump_all());
851         break;
852     case '\006':        /* ^F */
853         maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
854         break;
855     case '\t':  /* ^I */
856         if (inplace)
857             Safefree(inplace);
858         if (SvOK(sv))
859             inplace = savestr(SvPVX(sv));
860         else
861             inplace = Nullch;
862         break;
863     case '\020':        /* ^P */
864         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
865         if (i != perldb) {
866             if (perldb)
867                 oldlastpm = curpm;
868             else
869                 curpm = oldlastpm;
870         }
871         perldb = i;
872         break;
873     case '\024':        /* ^T */
874         basetime = (time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
875         break;
876     case '\027':        /* ^W */
877         dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
878         break;
879     case '.':
880         if (localizing)
881             save_sptr((SV**)&last_in_gv);
882         break;
883     case '^':
884         Safefree(GvIO(defoutgv)->top_name);
885         GvIO(defoutgv)->top_name = s = savestr(SvPVX(sv));
886         GvIO(defoutgv)->top_gv = gv_fetchpv(s,TRUE);
887         break;
888     case '~':
889         Safefree(GvIO(defoutgv)->fmt_name);
890         GvIO(defoutgv)->fmt_name = s = savestr(SvPVX(sv));
891         GvIO(defoutgv)->fmt_gv = gv_fetchpv(s,TRUE);
892         break;
893     case '=':
894         GvIO(defoutgv)->page_len = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
895         break;
896     case '-':
897         GvIO(defoutgv)->lines_left = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
898         if (GvIO(defoutgv)->lines_left < 0L)
899             GvIO(defoutgv)->lines_left = 0L;
900         break;
901     case '%':
902         GvIO(defoutgv)->page = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
903         break;
904     case '|':
905         if (!GvIO(defoutgv))
906             GvIO(defoutgv) = newIO();
907         GvIO(defoutgv)->flags &= ~IOf_FLUSH;
908         if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
909             GvIO(defoutgv)->flags |= IOf_FLUSH;
910         }
911         break;
912     case '*':
913         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
914         multiline = (i != 0);
915         break;
916     case '/':
917         if (SvPOK(sv)) {
918             nrs = rs = SvPVX(sv);
919             nrslen = rslen = SvCUR(sv);
920             if (rspara = !rslen) {
921                 nrs = rs = "\n\n";
922                 nrslen = rslen = 2;
923             }
924             nrschar = rschar = rs[rslen - 1];
925         }
926         else {
927             nrschar = rschar = 0777;    /* fake a non-existent char */
928             nrslen = rslen = 1;
929         }
930         break;
931     case '\\':
932         if (ors)
933             Safefree(ors);
934         ors = savestr(SvPVX(sv));
935         orslen = SvCUR(sv);
936         break;
937     case ',':
938         if (ofs)
939             Safefree(ofs);
940         ofs = savestr(SvPVX(sv));
941         ofslen = SvCUR(sv);
942         break;
943     case '#':
944         if (ofmt)
945             Safefree(ofmt);
946         ofmt = savestr(SvPVX(sv));
947         break;
948     case '[':
949         arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
950         break;
951     case '?':
952         statusvalue = U_S(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
953         break;
954     case '!':
955         errno = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);             /* will anyone ever use this? */
956         break;
957     case '<':
958         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
959         if (delaymagic) {
960             delaymagic |= DM_RUID;
961             break;                              /* don't do magic till later */
962         }
963 #ifdef HAS_SETRUID
964         (void)setruid((UIDTYPE)uid);
965 #else
966 #ifdef HAS_SETREUID
967         (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1);
968 #else
969         if (uid == euid)                /* special case $< = $> */
970             (void)setuid(uid);
971         else
972             croak("setruid() not implemented");
973 #endif
974 #endif
975         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
976         tainting |= (euid != uid || egid != gid);
977         break;
978     case '>':
979         euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
980         if (delaymagic) {
981             delaymagic |= DM_EUID;
982             break;                              /* don't do magic till later */
983         }
984 #ifdef HAS_SETEUID
985         (void)seteuid((UIDTYPE)euid);
986 #else
987 #ifdef HAS_SETREUID
988         (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid);
989 #else
990         if (euid == uid)                /* special case $> = $< */
991             setuid(euid);
992         else
993             croak("seteuid() not implemented");
994 #endif
995 #endif
996         euid = (I32)geteuid();
997         tainting |= (euid != uid || egid != gid);
998         break;
999     case '(':
1000         gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1001         if (delaymagic) {
1002             delaymagic |= DM_RGID;
1003             break;                              /* don't do magic till later */
1004         }
1005 #ifdef HAS_SETRGID
1006         (void)setrgid((GIDTYPE)gid);
1007 #else
1008 #ifdef HAS_SETREGID
1009         (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
1010 #else
1011         if (gid == egid)                        /* special case $( = $) */
1012             (void)setgid(gid);
1013         else
1014             croak("setrgid() not implemented");
1015 #endif
1016 #endif
1017         gid = (I32)getgid();
1018         tainting |= (euid != uid || egid != gid);
1019         break;
1020     case ')':
1021         egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1022         if (delaymagic) {
1023             delaymagic |= DM_EGID;
1024             break;                              /* don't do magic till later */
1025         }
1026 #ifdef HAS_SETEGID
1027         (void)setegid((GIDTYPE)egid);
1028 #else
1029 #ifdef HAS_SETREGID
1030         (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
1031 #else
1032         if (egid == gid)                        /* special case $) = $( */
1033             (void)setgid(egid);
1034         else
1035             croak("setegid() not implemented");
1036 #endif
1037 #endif
1038         egid = (I32)getegid();
1039         tainting |= (euid != uid || egid != gid);
1040         break;
1041     case ':':
1042         chopset = SvPVX(sv);
1043         break;
1044     case '0':
1045         if (!origalen) {
1046             s = origargv[0];
1047             s += strlen(s);
1048             /* See if all the arguments are contiguous in memory */
1049             for (i = 1; i < origargc; i++) {
1050                 if (origargv[i] == s + 1)
1051                     s += strlen(++s);   /* this one is ok too */
1052             }
1053             if (origenviron[0] == s + 1) {      /* can grab env area too? */
1054                 my_setenv("NoNeSuCh", Nullch);
1055                                             /* force copy of environment */
1056                 for (i = 0; origenviron[i]; i++)
1057                     if (origenviron[i] == s + 1)
1058                         s += strlen(++s);
1059             }
1060             origalen = s - origargv[0];
1061         }
1062         s = SvPVX(sv);
1063         i = SvCUR(sv);
1064         if (i >= origalen) {
1065             i = origalen;
1066             SvCUR_set(sv, i);
1067             *SvEND(sv) = '\0';
1068             Copy(s, origargv[0], i, char);
1069         }
1070         else {
1071             Copy(s, origargv[0], i, char);
1072             s = origargv[0]+i;
1073             *s++ = '\0';
1074             while (++i < origalen)
1075                 *s++ = '\0';
1076             for (i = 1; i < origargc; i++)
1077                 origargv[i] = NULL;
1078         }
1079         break;
1080     }
1081     return 0;
1082 }
1083
1084 I32
1085 whichsig(sig)
1086 char *sig;
1087 {
1088     register char **sigv;
1089
1090     for (sigv = sig_name+1; *sigv; sigv++)
1091         if (strEQ(sig,*sigv))
1092             return sigv - sig_name;
1093 #ifdef SIGCLD
1094     if (strEQ(sig,"CHLD"))
1095         return SIGCLD;
1096 #endif
1097 #ifdef SIGCHLD
1098     if (strEQ(sig,"CLD"))
1099         return SIGCHLD;
1100 #endif
1101     return 0;
1102 }
1103
1104 static handlertype
1105 sighandler(sig)
1106 I32 sig;
1107 {
1108     dSP;
1109     GV *gv;
1110     SV *sv;
1111     CV *cv;
1112     CONTEXT *cx;
1113     AV *oldstack;
1114     I32 hasargs = 1;
1115     I32 items = 1;
1116     I32 gimme = G_SCALAR;
1117
1118 #ifdef OS2              /* or anybody else who requires SIG_ACK */
1119     signal(sig, SIG_ACK);
1120 #endif
1121
1122     gv = gv_fetchpv(
1123         SvPVx(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]),
1124           TRUE), na), TRUE);
1125     cv = GvCV(gv);
1126     if (!cv && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
1127         if (sig_name[sig][1] == 'H')
1128             gv = gv_fetchpv(SvPVx(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE), na),
1129               TRUE);
1130         else
1131             gv = gv_fetchpv(SvPVx(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE), na),
1132               TRUE);
1133         cv = GvCV(gv);  /* gag */
1134     }
1135     if (!cv) {
1136         if (dowarn)
1137             warn("SIG%s handler \"%s\" not defined.\n",
1138                 sig_name[sig], GvENAME(gv) );
1139         return;
1140     }
1141
1142     oldstack = stack;
1143     SWITCHSTACK(stack, signalstack);
1144
1145     sv = sv_mortalcopy(&sv_undef);
1146     sv_setpv(sv,sig_name[sig]);
1147     PUSHs(sv);
1148
1149     ENTER;
1150     SAVETMPS;
1151
1152     push_return(op);
1153     push_return(0);
1154     PUSHBLOCK(cx, CXt_SUB, sp);
1155     PUSHSUB(cx);
1156     cx->blk_sub.savearray = GvAV(defgv);
1157     cx->blk_sub.argarray = av_fake(items, sp);
1158     GvAV(defgv) = cx->blk_sub.argarray;
1159     CvDEPTH(cv)++;
1160     if (CvDEPTH(cv) >= 2) {
1161         if (CvDEPTH(cv) == 100 && dowarn)
1162             warn("Deep recursion on subroutine \"%s\"",GvENAME(gv));
1163     }
1164     op = CvSTART(cv);
1165     PUTBACK;
1166     run();              /* Does the LEAVE for us. */
1167
1168     SWITCHSTACK(signalstack, oldstack);
1169     op = pop_return();
1170
1171     return;
1172 }