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