1 /* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:21:48 $
3 * Copyright (c) 1993, 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.
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
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);
125 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
126 if (mg->mg_type == type)
133 mg_copy(sv, nsv, key, klen)
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);
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);
170 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
175 #define handlertype void
177 #define handlertype int
180 static handlertype sighandler();
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 '&':
195 paren = atoi(mg->mg_ptr);
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;
212 paren = curpm->op_pmregexp->lastparen;
218 if (curpm->op_pmregexp &&
219 (s = curpm->op_pmregexp->subbeg) ) {
220 i = curpm->op_pmregexp->startp[0] - s;
232 if (curpm->op_pmregexp &&
233 (s = curpm->op_pmregexp->endp[0]) ) {
234 return (STRLEN) (curpm->op_pmregexp->subend - s);
241 return (STRLEN)ofslen;
243 return (STRLEN)orslen;
246 if (!SvPOK(sv) && SvNIOK(sv))
262 switch (*mg->mg_ptr) {
263 case '\004': /* ^D */
264 sv_setiv(sv,(I32)(debug & 32767));
266 case '\006': /* ^F */
267 sv_setiv(sv,(I32)maxsysfd);
271 sv_setpv(sv, inplace);
273 sv_setsv(sv,&sv_undef);
275 case '\020': /* ^P */
276 sv_setiv(sv,(I32)perldb);
278 case '\024': /* ^T */
279 sv_setiv(sv,(I32)basetime);
281 case '\027': /* ^W */
282 sv_setiv(sv,(I32)dowarn);
284 case '1': case '2': case '3': case '4':
285 case '5': case '6': case '7': case '8': case '9': case '&':
287 paren = atoi(GvENAME(mg->mg_obj));
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;
296 sv_setsv(sv,&sv_undef);
299 sv_setsv(sv,&sv_undef);
304 paren = curpm->op_pmregexp->lastparen;
310 if (curpm->op_pmregexp &&
311 (s = curpm->op_pmregexp->subbeg) ) {
312 i = curpm->op_pmregexp->startp[0] - s;
324 if (curpm->op_pmregexp &&
325 (s = curpm->op_pmregexp->endp[0]) ) {
326 sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
334 if (last_in_gv && GvIO(last_in_gv)) {
335 sv_setiv(sv,(I32)GvIO(last_in_gv)->lines);
340 sv_setiv(sv,(I32)statusvalue);
343 s = GvIO(defoutgv)->top_name;
347 sv_setpv(sv,GvENAME(defoutgv));
352 s = GvIO(defoutgv)->fmt_name;
354 s = GvENAME(defoutgv);
359 sv_setiv(sv,(I32)GvIO(defoutgv)->page_len);
362 sv_setiv(sv,(I32)GvIO(defoutgv)->lines_left);
365 sv_setiv(sv,(I32)GvIO(defoutgv)->page);
373 sv_setiv(sv,(I32)arybase);
377 GvIO(defoutgv) = newIO();
378 sv_setiv(sv, (GvIO(defoutgv)->flags & IOf_FLUSH) != 0 );
381 sv_setpvn(sv,ofs,ofslen);
384 sv_setpvn(sv,ors,orslen);
390 sv_setnv(sv,(double)errno);
391 sv_setpv(sv, errno ? strerror(errno) : "");
392 SvNOK_on(sv); /* what a wonderful hack! */
395 sv_setiv(sv,(I32)uid);
398 sv_setiv(sv,(I32)euid);
402 (void)sprintf(s,"%d",(int)gid);
406 (void)sprintf(s,"%d",(int)egid);
414 GROUPSTYPE gary[NGROUPS];
416 i = getgroups(NGROUPS,gary);
418 (void)sprintf(s," %ld", (long)gary[i]);
433 magic_getuvar(sv, mg)
437 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
439 if (uf && uf->uf_val)
440 (*uf->uf_val)(uf->uf_index, sv);
452 my_setenv(mg->mg_ptr,s);
453 /* And you'll never guess what the dog had */
454 /* in its mouth... */
456 if (s && strEQ(mg->mg_ptr,"PATH")) {
457 char *strend = SvEND(sv);
460 s = cpytill(tokenbuf,s,strend,':',&i);
463 || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
464 SvPRIVATE(sv) |= SVp_TAINTEDDIR;
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"))
484 (void)signal(i,SIG_IGN);
488 else if (strEQ(s,"DEFAULT") || !*s)
489 (void)signal(i,SIG_DFL);
491 (void)signal(i,sighandler);
492 if (!strchr(s,'\'')) {
493 sprintf(tokenbuf, "main'%s",s);
494 sv_setpv(sv,tokenbuf);
515 HV* stash = SvSTASH(SvRV(rv));
516 GV* gv = gv_fetchmethod(stash, "fetch");
520 if (!gv || !GvCV(gv)) {
521 croak("No fetch method for magical variable in package \"%s\"",
524 Zero(&myop, 1, BINOP);
525 myop.op_last = (OP *) &myop;
526 myop.op_next = Nullop;
527 myop.op_flags = OPf_STACKED;
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)));
544 if (op = pp_entersubr())
561 HV* stash = SvSTASH(SvRV(rv));
562 GV* gv = gv_fetchmethod(stash, "store");
566 if (!gv || !GvCV(gv)) {
567 croak("No store method for magical variable in package \"%s\"",
570 Zero(&myop, 1, BINOP);
571 myop.op_last = (OP *) &myop;
572 myop.op_next = Nullop;
573 myop.op_flags = OPf_STACKED;
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)));
591 if (op = pp_entersubr())
603 magic_clearpack(sv,mg)
608 HV* stash = SvSTASH(SvRV(rv));
609 GV* gv = gv_fetchmethod(stash, "delete");
613 if (!gv || !GvCV(gv)) {
614 croak("No delete method for magical variable in package \"%s\"",
617 Zero(&myop, 1, BINOP);
618 myop.op_last = (OP *) &myop;
619 myop.op_next = Nullop;
620 myop.op_flags = OPf_STACKED;
632 PUSHs(sv_mortalcopy(newSVpv(mg->mg_ptr, mg->mg_len)));
634 PUSHs(sv_mortalcopy(newSViv(mg->mg_len)));
637 if (op = pp_entersubr())
649 magic_nextpack(sv,mg,key)
655 HV* stash = SvSTASH(SvRV(rv));
656 GV* gv = gv_fetchmethod(stash, SvOK(key) ? "nextkey" : "firstkey");
660 if (!gv || !GvCV(gv)) {
661 croak("No fetch method for magical variable in package \"%s\"",
664 Zero(&myop, 1, BINOP);
665 myop.op_last = (OP *) &myop;
666 myop.op_next = Nullop;
667 myop.op_flags = OPf_STACKED;
682 if (op = pp_entersubr())
694 magic_setdbline(sv,mg)
705 svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
706 if (svp && SvIOK(*svp) && (o = (OP*)SvSTASH(*svp)))
709 warn("Can't break at that line\n");
714 magic_getarylen(sv,mg)
718 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + arybase);
723 magic_setarylen(sv,mg)
727 av_fill((AV*)mg->mg_obj, (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) - arybase);
736 gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
751 if (*s == '*' && s[1])
753 gv = gv_fetchpv(s,TRUE);
758 GvGP(sv) = gp_ref(GvGP(gv));
769 magic_setsubstr(sv,mg)
773 char *tmps = SvPVX(sv);
776 sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps,SvCUR(sv));
781 magic_gettaint(sv,mg)
790 magic_settaint(sv,mg)
804 do_vecset(sv); /* XXX slurp this routine */
809 magic_setmglob(sv,mg)
833 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
835 if (uf && uf->uf_set)
836 (*uf->uf_set)(uf->uf_index, sv);
847 switch (*mg->mg_ptr) {
848 case '\004': /* ^D */
849 debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 32768;
852 case '\006': /* ^F */
853 maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
859 inplace = savestr(SvPVX(sv));
863 case '\020': /* ^P */
864 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
873 case '\024': /* ^T */
874 basetime = (time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
876 case '\027': /* ^W */
877 dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
881 save_sptr((SV**)&last_in_gv);
884 Safefree(GvIO(defoutgv)->top_name);
885 GvIO(defoutgv)->top_name = s = savestr(SvPVX(sv));
886 GvIO(defoutgv)->top_gv = gv_fetchpv(s,TRUE);
889 Safefree(GvIO(defoutgv)->fmt_name);
890 GvIO(defoutgv)->fmt_name = s = savestr(SvPVX(sv));
891 GvIO(defoutgv)->fmt_gv = gv_fetchpv(s,TRUE);
894 GvIO(defoutgv)->page_len = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
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;
902 GvIO(defoutgv)->page = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
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;
913 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
914 multiline = (i != 0);
918 nrs = rs = SvPVX(sv);
919 nrslen = rslen = SvCUR(sv);
920 if (rspara = !rslen) {
924 nrschar = rschar = rs[rslen - 1];
927 nrschar = rschar = 0777; /* fake a non-existent char */
934 ors = savestr(SvPVX(sv));
940 ofs = savestr(SvPVX(sv));
946 ofmt = savestr(SvPVX(sv));
949 arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
952 statusvalue = U_S(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
955 errno = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); /* will anyone ever use this? */
958 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
960 delaymagic |= DM_RUID;
961 break; /* don't do magic till later */
964 (void)setruid((UIDTYPE)uid);
967 (void)setreuid((UIDTYPE)uid, (UIDTYPE)-1);
969 if (uid == euid) /* special case $< = $> */
972 croak("setruid() not implemented");
975 uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
976 tainting |= (euid != uid || egid != gid);
979 euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
981 delaymagic |= DM_EUID;
982 break; /* don't do magic till later */
985 (void)seteuid((UIDTYPE)euid);
988 (void)setreuid((UIDTYPE)-1, (UIDTYPE)euid);
990 if (euid == uid) /* special case $> = $< */
993 croak("seteuid() not implemented");
996 euid = (I32)geteuid();
997 tainting |= (euid != uid || egid != gid);
1000 gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1002 delaymagic |= DM_RGID;
1003 break; /* don't do magic till later */
1006 (void)setrgid((GIDTYPE)gid);
1009 (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
1011 if (gid == egid) /* special case $( = $) */
1014 croak("setrgid() not implemented");
1017 gid = (I32)getgid();
1018 tainting |= (euid != uid || egid != gid);
1021 egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1023 delaymagic |= DM_EGID;
1024 break; /* don't do magic till later */
1027 (void)setegid((GIDTYPE)egid);
1030 (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
1032 if (egid == gid) /* special case $) = $( */
1035 croak("setegid() not implemented");
1038 egid = (I32)getegid();
1039 tainting |= (euid != uid || egid != gid);
1042 chopset = SvPVX(sv);
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 */
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)
1060 origalen = s - origargv[0];
1064 if (i >= origalen) {
1068 Copy(s, origargv[0], i, char);
1071 Copy(s, origargv[0], i, char);
1074 while (++i < origalen)
1076 for (i = 1; i < origargc; i++)
1088 register char **sigv;
1090 for (sigv = sig_name+1; *sigv; sigv++)
1091 if (strEQ(sig,*sigv))
1092 return sigv - sig_name;
1094 if (strEQ(sig,"CHLD"))
1098 if (strEQ(sig,"CLD"))
1116 I32 gimme = G_SCALAR;
1118 #ifdef OS2 /* or anybody else who requires SIG_ACK */
1119 signal(sig, SIG_ACK);
1123 SvPVx(*hv_fetch(GvHVn(siggv),sig_name[sig],strlen(sig_name[sig]),
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),
1131 gv = gv_fetchpv(SvPVx(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE), na),
1133 cv = GvCV(gv); /* gag */
1137 warn("SIG%s handler \"%s\" not defined.\n",
1138 sig_name[sig], GvENAME(gv) );
1143 SWITCHSTACK(stack, signalstack);
1145 sv = sv_mortalcopy(&sv_undef);
1146 sv_setpv(sv,sig_name[sig]);
1154 PUSHBLOCK(cx, CXt_SUB, sp);
1156 cx->blk_sub.savearray = GvAV(defgv);
1157 cx->blk_sub.argarray = av_fake(items, sp);
1158 GvAV(defgv) = cx->blk_sub.argarray;
1160 if (CvDEPTH(cv) >= 2) {
1161 if (CvDEPTH(cv) == 100 && dowarn)
1162 warn("Deep recursion on subroutine \"%s\"",GvENAME(gv));
1166 run(); /* Does the LEAVE for us. */
1168 SWITCHSTACK(signalstack, oldstack);