3 * Copyright (c) 1991-1994, Larry Wall
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.
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."
18 /* Omit -- it causes too much grief on mixed systems.
29 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
30 MGVTBL* vtbl = mg->mg_virtual;
32 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
36 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
47 U32 savemagic = SvMAGICAL(sv) | SvREADONLY(sv);
49 assert(SvGMAGICAL(sv));
52 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
54 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
55 MGVTBL* vtbl = mg->mg_virtual;
56 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
57 (*vtbl->svt_get)(sv, mg);
58 if (mg->mg_flags & MGf_GSKIP)
64 SvFLAGS(sv) |= savemagic;
68 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
79 U32 savemagic = SvMAGICAL(sv);
83 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
84 MGVTBL* vtbl = mg->mg_virtual;
85 nextmg = mg->mg_moremagic; /* it may delete itself */
86 if (mg->mg_flags & MGf_GSKIP) {
87 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
90 if (vtbl && vtbl->svt_set)
91 (*vtbl->svt_set)(sv, mg);
96 SvFLAGS(sv) |= savemagic;
100 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
115 MGVTBL* vtbl = mg->mg_virtual;
116 if (vtbl && vtbl->svt_len) {
117 U32 savemagic = SvMAGICAL(sv);
120 SvFLAGS(sv) |= (SvFLAGS(sv)&(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
122 /* omit MGf_GSKIP -- not changed here */
123 len = (*vtbl->svt_len)(sv, mg);
125 SvFLAGS(sv) |= savemagic;
127 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
133 junk = SvPV(sv, len);
142 U32 savemagic = SvMAGICAL(sv);
145 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
147 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
148 MGVTBL* vtbl = mg->mg_virtual;
149 /* omit GSKIP -- never set here */
151 if (vtbl && vtbl->svt_clear)
152 (*vtbl->svt_clear)(sv, mg);
155 SvFLAGS(sv) |= savemagic;
157 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
168 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
169 if (mg->mg_type == type)
176 mg_copy(sv, nsv, key, klen)
184 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
185 if (isUPPER(mg->mg_type)) {
186 sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
199 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
200 MGVTBL* vtbl = mg->mg_virtual;
201 moremagic = mg->mg_moremagic;
202 if (vtbl && vtbl->svt_free)
203 (*vtbl->svt_free)(sv, mg);
204 if (mg->mg_ptr && mg->mg_type != 'g')
205 Safefree(mg->mg_ptr);
206 if (mg->mg_flags & MGf_REFCOUNTED)
207 SvREFCNT_dec(mg->mg_obj);
214 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
228 switch (*mg->mg_ptr) {
229 case '1': case '2': case '3': case '4':
230 case '5': case '6': case '7': case '8': case '9': case '&':
232 paren = atoi(mg->mg_ptr);
234 if (curpm->op_pmregexp &&
235 paren <= curpm->op_pmregexp->nparens &&
236 (s = curpm->op_pmregexp->startp[paren]) &&
237 (t = curpm->op_pmregexp->endp[paren]) ) {
247 paren = curpm->op_pmregexp->lastparen;
256 if (curpm->op_pmregexp &&
257 (s = curpm->op_pmregexp->subbeg) ) {
258 i = curpm->op_pmregexp->startp[0] - s;
266 if (curpm->op_pmregexp &&
267 (s = curpm->op_pmregexp->endp[0]) ) {
268 return (STRLEN) (curpm->op_pmregexp->subend - s);
273 return (STRLEN)ofslen;
275 return (STRLEN)orslen;
278 if (!SvPOK(sv) && SvNIOK(sv))
295 switch (*mg->mg_ptr) {
296 case '\001': /* ^A */
297 sv_setsv(sv, bodytarget);
299 case '\004': /* ^D */
300 sv_setiv(sv,(I32)(debug & 32767));
302 case '\006': /* ^F */
303 sv_setiv(sv,(I32)maxsysfd);
305 case '\010': /* ^H */
306 sv_setiv(sv,(I32)hints);
310 sv_setpv(sv, inplace);
312 sv_setsv(sv,&sv_undef);
314 case '\020': /* ^P */
315 sv_setiv(sv,(I32)perldb);
317 case '\024': /* ^T */
318 sv_setiv(sv,(I32)basetime);
320 case '\027': /* ^W */
321 sv_setiv(sv,(I32)dowarn);
323 case '1': case '2': case '3': case '4':
324 case '5': case '6': case '7': case '8': case '9': case '&':
326 paren = atoi(GvENAME(mg->mg_obj));
328 if (curpm->op_pmregexp &&
329 paren <= curpm->op_pmregexp->nparens &&
330 (s = curpm->op_pmregexp->startp[paren]) &&
331 (t = curpm->op_pmregexp->endp[paren]) ) {
336 if (tainting && (tmg = mg_find(sv,'t')))
337 tmg->mg_len = 0; /* guarantee $1 untainted */
342 sv_setsv(sv,&sv_undef);
346 paren = curpm->op_pmregexp->lastparen;
350 sv_setsv(sv,&sv_undef);
354 if (curpm->op_pmregexp &&
355 (s = curpm->op_pmregexp->subbeg) ) {
356 i = curpm->op_pmregexp->startp[0] - s;
363 sv_setsv(sv,&sv_undef);
367 if (curpm->op_pmregexp &&
368 (s = curpm->op_pmregexp->endp[0]) ) {
369 sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
373 sv_setsv(sv,&sv_undef);
377 if (GvIO(last_in_gv)) {
378 sv_setiv(sv,(I32)IoLINES(GvIO(last_in_gv)));
383 sv_setiv(sv,(I32)statusvalue);
386 s = IoTOP_NAME(GvIOp(defoutgv));
390 sv_setpv(sv,GvENAME(defoutgv));
395 s = IoFMT_NAME(GvIOp(defoutgv));
397 s = GvENAME(defoutgv);
402 sv_setiv(sv,(I32)IoPAGE_LEN(GvIOp(defoutgv)));
405 sv_setiv(sv,(I32)IoLINES_LEFT(GvIOp(defoutgv)));
408 sv_setiv(sv,(I32)IoPAGE(GvIOp(defoutgv)));
416 sv_setiv(sv,(I32)curcop->cop_arybase);
419 sv_setiv(sv, (IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
422 sv_setpvn(sv,ofs,ofslen);
425 sv_setpvn(sv,ors,orslen);
431 sv_setnv(sv,(double)errno);
432 sv_setpv(sv, errno ? Strerror(errno) : "");
433 SvNOK_on(sv); /* what a wonderful hack! */
436 sv_setiv(sv,(I32)uid);
439 sv_setiv(sv,(I32)euid);
443 (void)sprintf(s,"%d",(int)gid);
447 (void)sprintf(s,"%d",(int)egid);
455 Groups_t gary[NGROUPS];
457 i = getgroups(NGROUPS,gary);
459 (void)sprintf(s," %ld", (long)gary[i]);
475 magic_getuvar(sv, mg)
479 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
481 if (uf && uf->uf_val)
482 (*uf->uf_val)(uf->uf_index, sv);
495 my_setenv(mg->mg_ptr,s);
496 #ifdef DYNAMIC_ENV_FETCH
497 /* We just undefd an environment var. Is a replacement */
498 /* waiting in the wings? */
501 if (envsvp = hv_fetch(GvHVn(envgv),mg->mg_ptr,mg->mg_len,FALSE))
502 s = SvPV(*envsvp,len);
505 /* And you'll never guess what the dog had */
506 /* in its mouth... */
508 if (s && strEQ(mg->mg_ptr,"PATH")) {
509 char *strend = s + len;
512 s = cpytill(tokenbuf,s,strend,':',&i);
515 || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
524 magic_clearenv(sv,mg)
528 my_setenv(mg->mg_ptr,Nullch);
543 if (strEQ(s,"__DIE__"))
545 else if (strEQ(s,"__WARN__"))
547 else if (strEQ(s,"__PARSE__"))
550 croak("No such hook: %s", s);
554 i = whichsig(s); /* ...no, a brick */
556 if (dowarn || strEQ(s,"ALARM"))
557 warn("No such signal: SIG%s", s);
561 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
563 (void)signal(i,sighandler);
565 *svp = SvREFCNT_inc(sv);
568 s = SvPV_force(sv,na);
569 if (strEQ(s,"IGNORE")) {
571 (void)signal(i,SIG_IGN);
575 else if (strEQ(s,"DEFAULT") || !*s) {
577 (void)signal(i,SIG_DFL);
582 if (!strchr(s,':') && !strchr(s,'\'')) {
583 sprintf(tokenbuf, "main::%s",s);
584 sv_setpv(sv,tokenbuf);
587 (void)signal(i,sighandler);
589 *svp = SvREFCNT_inc(sv);
606 magic_setamagic(sv,mg)
610 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
615 #endif /* OVERLOAD */
618 magic_methpack(sv,mg,meth)
631 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
632 else if (mg->mg_type == 'p')
633 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
636 if (perl_call_method(meth, G_SCALAR))
637 sv_setsv(sv, *stack_sp--);
649 magic_methpack(sv,mg,"FETCH");
651 mg->mg_flags |= MGf_GSKIP;
666 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
667 else if (mg->mg_type == 'p')
668 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
672 perl_call_method("STORE", G_SCALAR|G_DISCARD);
678 magic_clearpack(sv,mg)
682 return magic_methpack(sv,mg,"DELETE");
685 int magic_wipepack(sv,mg)
695 perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
701 magic_nextpack(sv,mg,key)
707 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
718 if (perl_call_method(meth, G_SCALAR))
719 sv_setsv(key, *stack_sp--);
727 magic_existspack(sv,mg)
731 return magic_methpack(sv,mg,"EXISTS");
735 magic_setdbline(sv,mg)
746 svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
747 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
750 warn("Can't break at that line\n");
755 magic_getarylen(sv,mg)
759 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
764 magic_setarylen(sv,mg)
768 av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
777 SV* lsv = LvTARG(sv);
779 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
780 mg = mg_find(lsv, 'g');
781 if (mg && mg->mg_len >= 0) {
782 sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
795 SV* lsv = LvTARG(sv);
801 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
802 mg = mg_find(lsv, 'g');
806 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
807 mg = mg_find(lsv, 'g');
809 else if (!SvOK(sv)) {
813 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
815 pos = SvIV(sv) - curcop->cop_arybase;
833 gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
848 if (*s == '*' && s[1])
850 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
855 GvGP(sv) = gp_ref(GvGP(gv));
866 magic_setsubstr(sv,mg)
871 char *tmps = SvPV(sv,len);
872 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
877 magic_gettaint(sv,mg)
883 else if (mg->mg_len & 2 && mg->mg_obj == sv) /* kludge */
889 magic_settaint(sv,mg)
911 do_vecset(sv); /* XXX slurp this routine */
916 magic_setmglob(sv,mg)
939 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
941 if (uf && uf->uf_set)
942 (*uf->uf_set)(uf->uf_index, sv);
954 switch (*mg->mg_ptr) {
955 case '\001': /* ^A */
956 sv_setsv(bodytarget, sv);
958 case '\004': /* ^D */
959 debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
962 case '\006': /* ^F */
963 maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
965 case '\010': /* ^H */
966 hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
972 inplace = savepv(SvPV(sv,na));
976 case '\020': /* ^P */
977 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
986 case '\024': /* ^T */
987 basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
989 case '\027': /* ^W */
990 dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
995 save_sptr((SV**)&last_in_gv);
998 IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1001 Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1002 IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1003 IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1006 Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1007 IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1008 IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1011 IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1014 IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1015 if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1016 IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1019 IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1022 IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
1023 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
1024 IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
1028 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1029 multiline = (i != 0);
1033 nrs = rs = SvPV_force(sv,rslen);
1035 if (rspara = !rslen) {
1039 nrschar = rschar = rs[rslen - 1];
1042 nrschar = rschar = 0777; /* fake a non-existent char */
1049 ors = savepv(SvPV(sv,orslen));
1054 ofs = savepv(SvPV(sv, ofslen));
1059 ofmt = savepv(SvPV(sv,na));
1062 compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1065 statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1068 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SS$_ABORT); /* will anyone ever use this? */
1071 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1073 delaymagic |= DM_RUID;
1074 break; /* don't do magic till later */
1077 (void)setruid((Uid_t)uid);
1080 (void)setreuid((Uid_t)uid, (Uid_t)-1);
1082 #ifdef HAS_SETRESUID
1083 (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1085 if (uid == euid) /* special case $< = $> */
1088 uid = (I32)getuid();
1089 croak("setruid() not implemented");
1094 uid = (I32)getuid();
1095 tainting |= (euid != uid || egid != gid);
1098 euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1100 delaymagic |= DM_EUID;
1101 break; /* don't do magic till later */
1104 (void)seteuid((Uid_t)euid);
1107 (void)setreuid((Uid_t)-1, (Uid_t)euid);
1109 #ifdef HAS_SETRESUID
1110 (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1112 if (euid == uid) /* special case $> = $< */
1115 euid = (I32)geteuid();
1116 croak("seteuid() not implemented");
1121 euid = (I32)geteuid();
1122 tainting |= (euid != uid || egid != gid);
1125 gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1127 delaymagic |= DM_RGID;
1128 break; /* don't do magic till later */
1131 (void)setrgid((Gid_t)gid);
1134 (void)setregid((Gid_t)gid, (Gid_t)-1);
1136 #ifdef HAS_SETRESGID
1137 (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1139 if (gid == egid) /* special case $( = $) */
1142 gid = (I32)getgid();
1143 croak("setrgid() not implemented");
1148 gid = (I32)getgid();
1149 tainting |= (euid != uid || egid != gid);
1152 egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1154 delaymagic |= DM_EGID;
1155 break; /* don't do magic till later */
1158 (void)setegid((Gid_t)egid);
1161 (void)setregid((Gid_t)-1, (Gid_t)egid);
1163 #ifdef HAS_SETRESGID
1164 (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1166 if (egid == gid) /* special case $) = $( */
1169 egid = (I32)getegid();
1170 croak("setegid() not implemented");
1175 egid = (I32)getegid();
1176 tainting |= (euid != uid || egid != gid);
1179 chopset = SvPV_force(sv,na);
1185 /* See if all the arguments are contiguous in memory */
1186 for (i = 1; i < origargc; i++) {
1187 if (origargv[i] == s + 1)
1188 s += strlen(++s); /* this one is ok too */
1190 if (origenviron[0] == s + 1) { /* can grab env area too? */
1191 my_setenv("NoNeSuCh", Nullch);
1192 /* force copy of environment */
1193 for (i = 0; origenviron[i]; i++)
1194 if (origenviron[i] == s + 1)
1197 origalen = s - origargv[0];
1199 s = SvPV_force(sv,len);
1201 if (i >= origalen) {
1205 Copy(s, origargv[0], i, char);
1208 Copy(s, origargv[0], i, char);
1211 while (++i < origalen)
1214 for (i = 1; i < origargc; i++)
1215 origargv[i] = Nullch;
1226 register char **sigv;
1228 for (sigv = sig_name+1; *sigv; sigv++)
1229 if (strEQ(sig,*sigv))
1230 return sigv - sig_name;
1232 if (strEQ(sig,"CHLD"))
1236 if (strEQ(sig,"CLD"))
1253 #ifdef OS2 /* or anybody else who requires SIG_ACK */
1254 signal(sig, SIG_ACK);
1257 cv = sv_2cv(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]),
1260 if (!cv || !CvROOT(cv) &&
1261 *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
1263 if (sig_name[sig][1] == 'H')
1264 cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE),
1267 cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE),
1271 if (!cv || !CvROOT(cv)) {
1273 warn("SIG%s handler \"%s\" not defined.\n",
1274 sig_name[sig], GvENAME(gv) );
1279 if (stack != signalstack)
1280 AvFILL(signalstack) = 0;
1281 SWITCHSTACK(stack, signalstack);
1283 sv = sv_newmortal();
1284 sv_setpv(sv,sig_name[sig]);
1289 perl_call_sv((SV*)cv, G_DISCARD);
1291 SWITCHSTACK(signalstack, oldstack);