path: root/eval

void
save_lines(array, sv)
AV *array;
SV *sv;
{
    register char *s = sv->sv_ptr;
    register char *send = sv->sv_ptr + sv->sv_cur;
    register char *t;
    register int line = 1;

    while (s && s < send) {
	SV *tmpstr = NEWSV(85,0);

	t = index(s, '\n');
	if (t)
	    t++;
	else
	    t = send;

	sv_setpvn(tmpstr, s, t - s);
	av_store(array, line++, tmpstr);
	s = t;
    }
}

int
do_eval(sv,optype,stash,savecmd,gimme,arglast)
SV *sv;
int optype;
HV *stash;
int savecmd;
int gimme;
int *arglast;
{
    SV **st = stack->av_array;
    int retval;
    COP *myroot = Nullcop;
    AV *ar;
    int i;
    COP * VOL oldcurcmd = curcmd;
    VOL int oldtmps_floor = tmps_floor;
    VOL int oldsave = savestack->av_fill;
    VOL int oldperldb = perldb;
    PM * VOL oldspat = curspat;
    PM * VOL oldlspat = lastspat;

    VOL int sp = arglast[0];
    char *specfilename;
    char *tmpfilename;
    int parsing = 1;

    tmps_floor = tmps_ix;
    if (curstash != stash) {
	(void)save_hptr(&curstash);
	curstash = stash;
    }
    sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
    if (curcmd->cop_line == 0)		/* don't debug debugger... */
	perldb = FALSE;
    curcmd = &compiling;
    if (optype == OP_EVAL) {		/* normal oldeval */
	curcmd->cop_filestab = gv_fetchfile("(oldeval)");
	curcmd->cop_line = 1;
	sv_setsv(linestr,sv);
	sv_catpv(linestr,";\n;\n");	/* be kind to them */
	if (perldb)
	    save_lines(GvAV(curcmd->cop_filestab), linestr);
    }
    else {
	if (last_root && !in_eval) {
	    Safefree(last_eval);
	    last_eval = Nullch;
	    cop_free(last_root);
	    last_root = Nullcop;
	}
	specfilename = SvPV(sv);
	sv_setpv(linestr,"");
	if (optype == OP_REQUIRE && &sv_undef !=
	  hv_fetch(GvHVn(incstab), specfilename, strlen(specfilename), 0)) {
	    curcmd = oldcurcmd;
	    tmps_floor = oldtmps_floor;
	    st[++sp] = &sv_yes;
	    perldb = oldperldb;
	    return sp;
	}
	tmpfilename = savestr(specfilename);
	if (*tmpfilename == '/' ||
	    (*tmpfilename == '.' && 
		(tmpfilename[1] == '/' ||
		 (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
	{
	    rsfp = fopen(tmpfilename,"r");
	}
	else {
	    ar = GvAVn(incstab);
	    for (i = 0; i <= ar->av_fill; i++) {
		(void)sprintf(buf, "%s/%s",
		  SvPV(av_fetch(ar,i,TRUE)), specfilename);
		rsfp = fopen(buf,"r");
		if (rsfp) {
		    char *s = buf;

		    if (*s == '.' && s[1] == '/')
			s += 2;
		    Safefree(tmpfilename);
		    tmpfilename = savestr(s);
		    break;
		}
	    }
	}
	curcmd->cop_filestab = gv_fetchfile(tmpfilename);
	Safefree(tmpfilename);
	tmpfilename = Nullch;
	if (!rsfp) {
	    curcmd = oldcurcmd;
	    tmps_floor = oldtmps_floor;
	    if (optype == OP_REQUIRE) {
		sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
		if (instr(tokenbuf,".h "))
		    strcat(tokenbuf," (change .h to .ph maybe?)");
		if (instr(tokenbuf,".ph "))
		    strcat(tokenbuf," (did you run h2ph?)");
		fatal("%s",tokenbuf);
	    }
	    if (gimme != G_ARRAY)
		st[++sp] = &sv_undef;
	    perldb = oldperldb;
	    return sp;
	}
	curcmd->cop_line = 0;
    }
    in_eval++;
    oldoldbufptr = oldbufptr = bufptr = SvPV(linestr);
    bufend = bufptr + linestr->sv_cur;
    if (++cxstack_ix >= block_max) {
	block_max += 128;
	Renew(block_stack, block_max, struct loop);
    }
    block_stack[cxstack_ix].block_label = "_EVAL_";
    block_stack[cxstack_ix].block_sp = sp;
#ifdef DEBUGGING
    if (debug & 4) {
	deb("(Pushing label #%d _EVAL_)\n", cxstack_ix);
    }
#endif
    eval_root = Nullcop;
    if (setjmp(block_stack[cxstack_ix].block_env)) {
	retval = 1;
    }
    else {
	error_count = 0;
	if (rsfp) {
	    retval = yyparse();
	    retval |= error_count;
	}
	else if (last_root && last_elen == bufend - bufptr
	  && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
	    retval = 0;
	    eval_root = last_root;	/* no point in reparsing */
	}
	else if (in_eval == 1 && !savecmd) {
	    if (last_root) {
		Safefree(last_eval);
		last_eval = Nullch;
		cop_free(last_root);
	    }
	    last_root = Nullcop;
	    last_elen = bufend - bufptr;
	    last_eval = nsavestr(bufptr, last_elen);
	    retval = yyparse();
	    retval |= error_count;
	    if (!retval)
		last_root = eval_root;
	    if (!last_root) {
		Safefree(last_eval);
		last_eval = Nullch;
	    }
	}
	else
	    retval = yyparse();
    }
    myroot = eval_root;		/* in case cop_exec does another oldeval! */

    if (retval || error_count) {
	st = stack->av_array;
	sp = arglast[0];
	if (gimme != G_ARRAY)
	    st[++sp] = &sv_undef;
	if (parsing) {
#ifndef MANGLEDPARSE
#ifdef DEBUGGING
	    if (debug & 128)
		fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
#endif
	    cop_free(eval_root);
#endif
	    /*SUPPRESS 29*/ /*SUPPRESS 30*/
	    if ((COP*)eval_root == last_root)
		last_root = Nullcop;
	    eval_root = myroot = Nullcop;
	}
	if (rsfp) {
	    fclose(rsfp);
	    rsfp = 0;
	}
    }
    else {
	parsing = 0;
	sp = cop_exec(eval_root,gimme,sp);
	st = stack->av_array;
	for (i = arglast[0] + 1; i <= sp; i++)
	    st[i] = sv_mortalcopy(st[i]);
				/* if we don't save result, free zaps it */
	if (savecmd)
	    eval_root = myroot;
	else if (in_eval != 1 && myroot != last_root)
	    cop_free(myroot);
    }

    perldb = oldperldb;
    in_eval--;
#ifdef DEBUGGING
    if (debug & 4) {
	char *tmps = block_stack[cxstack_ix].block_label;
	deb("(Popping label #%d %s)\n",cxstack_ix,
	    tmps ? tmps : "" );
    }
#endif
    cxstack_ix--;
    tmps_floor = oldtmps_floor;
    curspat = oldspat;
    lastspat = oldlspat;
    if (savestack->av_fill > oldsave)	/* let them use local() */
	leave_scope(oldsave);

    if (optype != OP_EVAL) {
	if (retval) {
	    if (optype == OP_REQUIRE)
		fatal("%s", SvPV(GvSV(gv_fetchpv("@",TRUE))));
	}
	else {
	    curcmd = oldcurcmd;
	    if (gimme == G_SCALAR ? SvTRUE(st[sp]) : sp > arglast[0]) {
		(void)hv_store(GvHVn(incstab), specfilename,
		  strlen(specfilename), newSVsv(GvSV(curcmd->cop_filestab)),
		      0 );
	    }
	    else if (optype == OP_REQUIRE)
		fatal("%s did not return a true value", specfilename);
	}
    }
    curcmd = oldcurcmd;
    return sp;
}

int
do_try(cmd,gimme,arglast)
COP *cmd;
int gimme;
int *arglast;
{
    SV **st = stack->av_array;

    COP * VOL oldcurcmd = curcmd;
    VOL int oldtmps_floor = tmps_floor;
    VOL int oldsave = savestack->av_fill;
    PM * VOL oldspat = curspat;
    PM * VOL oldlspat = lastspat;
    VOL int sp = arglast[0];

    tmps_floor = tmps_ix;
    sv_setpv(GvSV(gv_fetchpv("@",TRUE)),"");
    in_eval++;
    if (++cxstack_ix >= block_max) {
	block_max += 128;
	Renew(block_stack, block_max, struct loop);
    }
    block_stack[cxstack_ix].block_label = "_EVAL_";
    block_stack[cxstack_ix].block_sp = sp;
#ifdef DEBUGGING
    if (debug & 4) {
	deb("(Pushing label #%d _EVAL_)\n", cxstack_ix);
    }
#endif
    if (setjmp(block_stack[cxstack_ix].block_env)) {
	st = stack->av_array;
	sp = arglast[0];
	if (gimme != G_ARRAY)
	    st[++sp] = &sv_undef;
    }
    else {
	sp = cop_exec(cmd,gimme,sp);
	st = stack->av_array;
/*	for (i = arglast[0] + 1; i <= sp; i++)
	    st[i] = sv_mortalcopy(st[i]);  not needed, I think */
				/* if we don't save result, free zaps it */
    }

    in_eval--;
#ifdef DEBUGGING
    if (debug & 4) {
	char *tmps = block_stack[cxstack_ix].block_label;
	deb("(Popping label #%d %s)\n",cxstack_ix,
	    tmps ? tmps : "" );
    }
#endif
    cxstack_ix--;
    tmps_floor = oldtmps_floor;
    curspat = oldspat;
    lastspat = oldlspat;
    curcmd = oldcurcmd;
    if (savestack->av_fill > oldsave)	/* let them use local() */
	leave_scope(oldsave);

    return sp;
}