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.
30 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
31 MGVTBL* vtbl = mg->mg_virtual;
33 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
37 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
48 U32 savemagic = SvMAGICAL(sv) | SvREADONLY(sv);
50 assert(SvGMAGICAL(sv));
53 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
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)
65 SvFLAGS(sv) |= savemagic;
69 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
80 U32 savemagic = SvMAGICAL(sv);
84 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
85 MGVTBL* vtbl = mg->mg_virtual;
86 nextmg = mg->mg_moremagic; /* it may delete itself */
87 if (mg->mg_flags & MGf_GSKIP) {
88 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
91 if (vtbl && vtbl->svt_set)
92 (*vtbl->svt_set)(sv, mg);
97 SvFLAGS(sv) |= savemagic;
101 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
115 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
116 MGVTBL* vtbl = mg->mg_virtual;
117 if (vtbl && vtbl->svt_len) {
118 U32 savemagic = SvMAGICAL(sv);
121 SvFLAGS(sv) |= (SvFLAGS(sv)&(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
123 /* omit MGf_GSKIP -- not changed here */
124 len = (*vtbl->svt_len)(sv, mg);
126 SvFLAGS(sv) |= savemagic;
128 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
134 junk = SvPV(sv, len);
143 U32 savemagic = SvMAGICAL(sv);
146 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
148 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
149 MGVTBL* vtbl = mg->mg_virtual;
150 /* omit GSKIP -- never set here */
152 if (vtbl && vtbl->svt_clear)
153 (*vtbl->svt_clear)(sv, mg);
156 SvFLAGS(sv) |= savemagic;
158 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
169 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
170 if (mg->mg_type == type)
177 mg_copy(sv, nsv, key, klen)
185 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
186 if (isUPPER(mg->mg_type)) {
187 sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
200 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
201 MGVTBL* vtbl = mg->mg_virtual;
202 moremagic = mg->mg_moremagic;
203 if (vtbl && vtbl->svt_free)
204 (*vtbl->svt_free)(sv, mg);
205 if (mg->mg_ptr && mg->mg_type != 'g')
206 Safefree(mg->mg_ptr);
207 if (mg->mg_flags & MGf_REFCOUNTED)
208 SvREFCNT_dec(mg->mg_obj);
215 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
229 switch (*mg->mg_ptr) {
230 case '1': case '2': case '3': case '4':
231 case '5': case '6': case '7': case '8': case '9': case '&':
233 paren = atoi(mg->mg_ptr);
235 if (curpm->op_pmregexp &&
236 paren <= curpm->op_pmregexp->nparens &&
237 (s = curpm->op_pmregexp->startp[paren]) &&
238 (t = curpm->op_pmregexp->endp[paren]) ) {
248 paren = curpm->op_pmregexp->lastparen;
257 if (curpm->op_pmregexp &&
258 (s = curpm->op_pmregexp->subbeg) ) {
259 i = curpm->op_pmregexp->startp[0] - s;
267 if (curpm->op_pmregexp &&
268 (s = curpm->op_pmregexp->endp[0]) ) {
269 return (STRLEN) (curpm->op_pmregexp->subend - s);
274 return (STRLEN)ofslen;
276 return (STRLEN)orslen;
279 if (!SvPOK(sv) && SvNIOK(sv))
296 switch (*mg->mg_ptr) {
297 case '\001': /* ^A */
298 sv_setsv(sv, bodytarget);
300 case '\004': /* ^D */
301 sv_setiv(sv,(I32)(debug & 32767));
303 case '\006': /* ^F */
304 sv_setiv(sv,(I32)maxsysfd);
306 case '\010': /* ^H */
307 sv_setiv(sv,(I32)hints);
311 sv_setpv(sv, inplace);
313 sv_setsv(sv,&sv_undef);
315 case '\020': /* ^P */
316 sv_setiv(sv,(I32)perldb);
318 case '\024': /* ^T */
319 sv_setiv(sv,(I32)basetime);
321 case '\027': /* ^W */
322 sv_setiv(sv,(I32)dowarn);
324 case '1': case '2': case '3': case '4':
325 case '5': case '6': case '7': case '8': case '9': case '&':
327 paren = atoi(GvENAME(mg->mg_obj));
329 if (curpm->op_pmregexp &&
330 paren <= curpm->op_pmregexp->nparens &&
331 (s = curpm->op_pmregexp->startp[paren]) &&
332 (t = curpm->op_pmregexp->endp[paren]) ) {
337 if (tainting && (tmg = mg_find(sv,'t')))
338 tmg->mg_len = 0; /* guarantee $1 untainted */
343 sv_setsv(sv,&sv_undef);
347 paren = curpm->op_pmregexp->lastparen;
351 sv_setsv(sv,&sv_undef);
355 if (curpm->op_pmregexp &&
356 (s = curpm->op_pmregexp->subbeg) ) {
357 i = curpm->op_pmregexp->startp[0] - s;
364 sv_setsv(sv,&sv_undef);
368 if (curpm->op_pmregexp &&
369 (s = curpm->op_pmregexp->endp[0]) ) {
370 sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
374 sv_setsv(sv,&sv_undef);
378 if (GvIO(last_in_gv)) {
379 sv_setiv(sv,(I32)IoLINES(GvIO(last_in_gv)));
384 sv_setiv(sv,(I32)statusvalue);
387 s = IoTOP_NAME(GvIOp(defoutgv));
391 sv_setpv(sv,GvENAME(defoutgv));
396 s = IoFMT_NAME(GvIOp(defoutgv));
398 s = GvENAME(defoutgv);
403 sv_setiv(sv,(I32)IoPAGE_LEN(GvIOp(defoutgv)));
406 sv_setiv(sv,(I32)IoLINES_LEFT(GvIOp(defoutgv)));
409 sv_setiv(sv,(I32)IoPAGE(GvIOp(defoutgv)));
417 sv_setiv(sv,(I32)curcop->cop_arybase);
420 sv_setiv(sv, (IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
423 sv_setpvn(sv,ofs,ofslen);
426 sv_setpvn(sv,ors,orslen);
432 sv_setnv(sv,(double)errno);
433 sv_setpv(sv, errno ? Strerror(errno) : "");
434 SvNOK_on(sv); /* what a wonderful hack! */
437 sv_setiv(sv,(I32)uid);
440 sv_setiv(sv,(I32)euid);
444 (void)sprintf(s,"%d",(int)gid);
448 (void)sprintf(s,"%d",(int)egid);
456 Groups_t gary[NGROUPS];
458 i = getgroups(NGROUPS,gary);
460 (void)sprintf(s," %ld", (long)gary[i]);
476 magic_getuvar(sv, mg)
480 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
482 if (uf && uf->uf_val)
483 (*uf->uf_val)(uf->uf_index, sv);
496 my_setenv(mg->mg_ptr,s);
497 #ifdef DYNAMIC_ENV_FETCH
498 /* We just undefd an environment var. Is a replacement */
499 /* waiting in the wings? */
502 if (envsvp = hv_fetch(GvHVn(envgv),mg->mg_ptr,mg->mg_len,FALSE))
503 s = SvPV(*envsvp,len);
506 /* And you'll never guess what the dog had */
507 /* in its mouth... */
509 if (s && strEQ(mg->mg_ptr,"PATH")) {
510 char *strend = s + len;
513 s = cpytill(tokenbuf,s,strend,':',&i);
516 || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
525 magic_clearenv(sv,mg)
529 my_setenv(mg->mg_ptr,Nullch);
544 if (strEQ(s,"__DIE__"))
546 else if (strEQ(s,"__WARN__"))
548 else if (strEQ(s,"__PARSE__"))
551 croak("No such hook: %s", s);
555 i = whichsig(s); /* ...no, a brick */
557 if (dowarn || strEQ(s,"ALARM"))
558 warn("No such signal: SIG%s", s);
562 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
564 (void)signal(i,sighandler);
566 *svp = SvREFCNT_inc(sv);
569 s = SvPV_force(sv,na);
570 if (strEQ(s,"IGNORE")) {
572 (void)signal(i,SIG_IGN);
576 else if (strEQ(s,"DEFAULT") || !*s) {
578 (void)signal(i,SIG_DFL);
583 if (!strchr(s,':') && !strchr(s,'\'')) {
584 sprintf(tokenbuf, "main::%s",s);
585 sv_setpv(sv,tokenbuf);
588 (void)signal(i,sighandler);
590 *svp = SvREFCNT_inc(sv);
607 magic_setamagic(sv,mg)
611 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
616 #endif /* OVERLOAD */
619 magic_methpack(sv,mg,meth)
632 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
633 else if (mg->mg_type == 'p')
634 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
637 if (perl_call_method(meth, G_SCALAR))
638 sv_setsv(sv, *stack_sp--);
650 magic_methpack(sv,mg,"FETCH");
652 mg->mg_flags |= MGf_GSKIP;
667 PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
668 else if (mg->mg_type == 'p')
669 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
673 perl_call_method("STORE", G_SCALAR|G_DISCARD);
679 magic_clearpack(sv,mg)
683 return magic_methpack(sv,mg,"DELETE");
686 int magic_wipepack(sv,mg)
696 perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
702 magic_nextpack(sv,mg,key)
708 char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
719 if (perl_call_method(meth, G_SCALAR))
720 sv_setsv(key, *stack_sp--);
728 magic_existspack(sv,mg)
732 return magic_methpack(sv,mg,"EXISTS");
736 magic_setdbline(sv,mg)
747 svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
748 if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
751 warn("Can't break at that line\n");
756 magic_getarylen(sv,mg)
760 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
765 magic_setarylen(sv,mg)
769 av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
778 SV* lsv = LvTARG(sv);
780 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
781 mg = mg_find(lsv, 'g');
782 if (mg && mg->mg_len >= 0) {
783 sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
796 SV* lsv = LvTARG(sv);
802 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
803 mg = mg_find(lsv, 'g');
807 sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
808 mg = mg_find(lsv, 'g');
810 else if (!SvOK(sv)) {
814 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
816 pos = SvIV(sv) - curcop->cop_arybase;
834 gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
849 if (*s == '*' && s[1])
851 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
856 GvGP(sv) = gp_ref(GvGP(gv));
867 magic_setsubstr(sv,mg)
872 char *tmps = SvPV(sv,len);
873 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
878 magic_gettaint(sv,mg)
884 else if (mg->mg_len & 2 && mg->mg_obj == sv) /* kludge */
890 magic_settaint(sv,mg)
912 do_vecset(sv); /* XXX slurp this routine */
917 magic_setmglob(sv,mg)
940 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
942 if (uf && uf->uf_set)
943 (*uf->uf_set)(uf->uf_index, sv);
955 switch (*mg->mg_ptr) {
956 case '\001': /* ^A */
957 sv_setsv(bodytarget, sv);
959 case '\004': /* ^D */
960 debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
963 case '\006': /* ^F */
964 maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
966 case '\010': /* ^H */
967 hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
973 inplace = savepv(SvPV(sv,na));
977 case '\020': /* ^P */
978 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
987 case '\024': /* ^T */
988 basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
990 case '\027': /* ^W */
991 dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
996 save_sptr((SV**)&last_in_gv);
999 IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1002 Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1003 IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1004 IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1007 Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1008 IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1009 IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1012 IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1015 IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1016 if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1017 IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1020 IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1023 IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
1024 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
1025 IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
1029 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1030 multiline = (i != 0);
1034 nrs = rs = SvPV_force(sv,rslen);
1036 if (rspara = !rslen) {
1040 nrschar = rschar = rs[rslen - 1];
1043 nrschar = rschar = 0777; /* fake a non-existent char */
1050 ors = savepv(SvPV(sv,orslen));
1055 ofs = savepv(SvPV(sv, ofslen));
1060 ofmt = savepv(SvPV(sv,na));
1063 compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1066 statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1069 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SS$_ABORT); /* will anyone ever use this? */
1072 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1074 delaymagic |= DM_RUID;
1075 break; /* don't do magic till later */
1078 (void)setruid((Uid_t)uid);
1081 (void)setreuid((Uid_t)uid, (Uid_t)-1);
1083 #ifdef HAS_SETRESUID
1084 (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1086 if (uid == euid) /* special case $< = $> */
1089 uid = (I32)getuid();
1090 croak("setruid() not implemented");
1095 uid = (I32)getuid();
1096 tainting |= (euid != uid || egid != gid);
1099 euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1101 delaymagic |= DM_EUID;
1102 break; /* don't do magic till later */
1105 (void)seteuid((Uid_t)euid);
1108 (void)setreuid((Uid_t)-1, (Uid_t)euid);
1110 #ifdef HAS_SETRESUID
1111 (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1113 if (euid == uid) /* special case $> = $< */
1116 euid = (I32)geteuid();
1117 croak("seteuid() not implemented");
1122 euid = (I32)geteuid();
1123 tainting |= (euid != uid || egid != gid);
1126 gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1128 delaymagic |= DM_RGID;
1129 break; /* don't do magic till later */
1132 (void)setrgid((Gid_t)gid);
1135 (void)setregid((Gid_t)gid, (Gid_t)-1);
1137 #ifdef HAS_SETRESGID
1138 (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1140 if (gid == egid) /* special case $( = $) */
1143 gid = (I32)getgid();
1144 croak("setrgid() not implemented");
1149 gid = (I32)getgid();
1150 tainting |= (euid != uid || egid != gid);
1153 egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1155 delaymagic |= DM_EGID;
1156 break; /* don't do magic till later */
1159 (void)setegid((Gid_t)egid);
1162 (void)setregid((Gid_t)-1, (Gid_t)egid);
1164 #ifdef HAS_SETRESGID
1165 (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1167 if (egid == gid) /* special case $) = $( */
1170 egid = (I32)getegid();
1171 croak("setegid() not implemented");
1176 egid = (I32)getegid();
1177 tainting |= (euid != uid || egid != gid);
1180 chopset = SvPV_force(sv,na);
1186 /* See if all the arguments are contiguous in memory */
1187 for (i = 1; i < origargc; i++) {
1188 if (origargv[i] == s + 1)
1189 s += strlen(++s); /* this one is ok too */
1191 if (origenviron[0] == s + 1) { /* can grab env area too? */
1192 my_setenv("NoNeSuCh", Nullch);
1193 /* force copy of environment */
1194 for (i = 0; origenviron[i]; i++)
1195 if (origenviron[i] == s + 1)
1198 origalen = s - origargv[0];
1200 s = SvPV_force(sv,len);
1202 if (i >= origalen) {
1206 Copy(s, origargv[0], i, char);
1209 Copy(s, origargv[0], i, char);
1212 while (++i < origalen)
1215 for (i = 1; i < origargc; i++)
1216 origargv[i] = Nullch;
1227 register char **sigv;
1229 for (sigv = sig_name+1; *sigv; sigv++)
1230 if (strEQ(sig,*sigv))
1231 return sig_num[sigv - sig_name];
1233 if (strEQ(sig,"CHLD"))
1237 if (strEQ(sig,"CLD"))
1248 for (i = 1; sig_num[i]; i++) /* sig_num[] is a 0-terminated list */
1249 if (sig_num[i] == sig)
1266 #ifdef OS2 /* or anybody else who requires SIG_ACK */
1267 signal(sig, SIG_ACK);
1270 signame = whichsigname(sig);
1271 cv = sv_2cv(*hv_fetch(GvHVn(siggv),signame,strlen(signame),
1274 if (!cv || !CvROOT(cv) &&
1275 *signame == 'C' && instr(signame,"LD")) {
1277 if (signame[1] == 'H')
1278 cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE),
1281 cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE),
1285 if (!cv || !CvROOT(cv)) {
1287 warn("SIG%s handler \"%s\" not defined.\n",
1288 signame, GvENAME(gv) );
1293 if (stack != signalstack)
1294 AvFILL(signalstack) = 0;
1295 SWITCHSTACK(stack, signalstack);
1297 sv = sv_newmortal();
1298 sv_setpv(sv,signame);
1303 perl_call_sv((SV*)cv, G_DISCARD);
1305 SWITCHSTACK(signalstack, oldstack);