perl.c

早期freebsd实现

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

	str_nset(tmpstr, s, t - s);
	astore(array, line++, tmpstr);
	s = t;
    }
}

/* this routine is in perl.c by virtue of being sort of an alternate main() */

int
do_eval(str,optype,stash,savecmd,gimme,arglast)
STR *str;
int optype;
HASH *stash;
int savecmd;
int gimme;
int *arglast;
{
    STR **st = stack->ary_array;
    int retval;
    CMD *myroot = Nullcmd;
    ARRAY *ar;
    int i;
    CMD * VOLATILE oldcurcmd = curcmd;
    VOLATILE int oldtmps_base = tmps_base;
    VOLATILE int oldsave = savestack->ary_fill;
    VOLATILE int oldperldb = perldb;
    SPAT * VOLATILE oldspat = curspat;
    SPAT * VOLATILE oldlspat = lastspat;
    static char *last_eval = Nullch;
    static long last_elen = 0;
    static CMD *last_root = Nullcmd;
    VOLATILE int sp = arglast[0];
    char *specfilename;
    char *tmpfilename;
    int parsing = 1;

    tmps_base = tmps_max;
    if (curstash != stash) {
	(void)savehptr(&curstash);
	curstash = stash;
    }
    str_set(stab_val(stabent("@",TRUE)),"");
    if (curcmd->c_line == 0)		/* don't debug debugger... */
	perldb = FALSE;
    curcmd = &compiling;
    if (optype == O_EVAL) {		/* normal eval */
	curcmd->c_filestab = fstab("(eval)");
	curcmd->c_line = 1;
	str_sset(linestr,str);
	str_cat(linestr,";\n;\n");	/* be kind to them */
	if (perldb)
	    savelines(stab_xarray(curcmd->c_filestab), linestr);
    }
    else {
	if (last_root && !in_eval) {
	    Safefree(last_eval);
	    last_eval = Nullch;
	    cmd_free(last_root);
	    last_root = Nullcmd;
	}
	specfilename = str_get(str);
	str_set(linestr,"");
	if (optype == O_REQUIRE && &str_undef !=
	  hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
	    curcmd = oldcurcmd;
	    tmps_base = oldtmps_base;
	    st[++sp] = &str_yes;
	    perldb = oldperldb;
	    return sp;
	}
	tmpfilename = savestr(specfilename);
	if (*tmpfilename == '/' ||
	    (*tmpfilename == '.' && 
		(tmpfilename[1] == '/' ||
		 (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
	{
	    rsfp = fopen(tmpfilename,"r");
	}
	else {
	    ar = stab_array(incstab);
	    for (i = 0; i <= ar->ary_fill; i++) {
		(void)sprintf(buf, "%s/%s",
		  str_get(afetch(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->c_filestab = fstab(tmpfilename);
	Safefree(tmpfilename);
	tmpfilename = Nullch;
	if (!rsfp) {
	    curcmd = oldcurcmd;
	    tmps_base = oldtmps_base;
	    if (optype == O_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] = &str_undef;
	    perldb = oldperldb;
	    return sp;
	}
	curcmd->c_line = 0;
    }
    in_eval++;
    oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
    bufend = bufptr + linestr->str_cur;
    if (++loop_ptr >= loop_max) {
	loop_max += 128;
	Renew(loop_stack, loop_max, struct loop);
    }
    loop_stack[loop_ptr].loop_label = "_EVAL_";
    loop_stack[loop_ptr].loop_sp = sp;
#ifdef DEBUGGING
    if (debug & 4) {
	deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
    }
#endif
    eval_root = Nullcmd;
    if (setjmp(loop_stack[loop_ptr].loop_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;
		cmd_free(last_root);
	    }
	    last_root = Nullcmd;
	    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 cmd_exec does another eval! */

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

    perldb = oldperldb;
    in_eval--;
#ifdef DEBUGGING
    if (debug & 4) {
	char *tmps = loop_stack[loop_ptr].loop_label;
	deb("(Popping label #%d %s)\n",loop_ptr,
	    tmps ? tmps : "" );
    }
#endif
    loop_ptr--;
    tmps_base = oldtmps_base;
    curspat = oldspat;
    lastspat = oldlspat;
    if (savestack->ary_fill > oldsave)	/* let them use local() */
	restorelist(oldsave);

    if (optype != O_EVAL) {
	if (retval) {
	    if (optype == O_REQUIRE)
		fatal("%s", str_get(stab_val(stabent("@",TRUE))));
	}
	else {
	    curcmd = oldcurcmd;
	    if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
		(void)hstore(stab_hash(incstab), specfilename,
		  strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
		      0 );
	    }
	    else if (optype == O_REQUIRE)
		fatal("%s did not return a true value", specfilename);
	}
    }
    curcmd = oldcurcmd;
    return sp;
}

int
do_try(cmd,gimme,arglast)
CMD *cmd;
int gimme;
int *arglast;
{
    STR **st = stack->ary_array;

    CMD * VOLATILE oldcurcmd = curcmd;
    VOLATILE int oldtmps_base = tmps_base;
    VOLATILE int oldsave = savestack->ary_fill;
    SPAT * VOLATILE oldspat = curspat;
    SPAT * VOLATILE oldlspat = lastspat;
    VOLATILE int sp = arglast[0];

    tmps_base = tmps_max;
    str_set(stab_val(stabent("@",TRUE)),"");
    in_eval++;
    if (++loop_ptr >= loop_max) {
	loop_max += 128;
	Renew(loop_stack, loop_max, struct loop);
    }
    loop_stack[loop_ptr].loop_label = "_EVAL_";
    loop_stack[loop_ptr].loop_sp = sp;
#ifdef DEBUGGING
    if (debug & 4) {
	deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
    }
#endif
    if (setjmp(loop_stack[loop_ptr].loop_env)) {
	st = stack->ary_array;
	sp = arglast[0];
	if (gimme != G_ARRAY)
	    st[++sp] = &str_undef;
    }
    else {
	sp = cmd_exec(cmd,gimme,sp);
	st = stack->ary_array;
/*	for (i = arglast[0] + 1; i <= sp; i++)
	    st[i] = str_mortal(st[i]);  not needed, I think */
				/* if we don't save result, free zaps it */
    }

    in_eval--;
#ifdef DEBUGGING
    if (debug & 4) {
	char *tmps = loop_stack[loop_ptr].loop_label;
	deb("(Popping label #%d %s)\n",loop_ptr,
	    tmps ? tmps : "" );
    }
#endif
    loop_ptr--;
    tmps_base = oldtmps_base;
    curspat = oldspat;
    lastspat = oldlspat;
    curcmd = oldcurcmd;
    if (savestack->ary_fill > oldsave)	/* let them use local() */
	restorelist(oldsave);

    return sp;
}

/* This routine handles any switches that can be given during run */

static char *
moreswitches(s)
char *s;
{
    int numlen;

    switch (*s) {
    case '0':
	nrschar = scanoct(s, 4, &numlen);
	nrs = nsavestr("\n",1);
	*nrs = nrschar;
	if (nrschar > 0377) {
	    nrslen = 0;
	    nrs = "";
	}
	else if (!nrschar && numlen >= 2) {
	    nrslen = 2;
	    nrs = "\n\n";
	    nrschar = '\n';
	}
	return s + numlen;
    case 'a':
	minus_a = TRUE;
	s++;
	return s;
    case 'c':
	minus_c = TRUE;
	s++;
	return s;
    case 'd':
#ifdef TAINT
	if (euid != uid || egid != gid)
	    fatal("No -d allowed in setuid scripts");
#endif
	perldb = TRUE;
	s++;
	return s;
    case 'D':
#ifdef DEBUGGING
#ifdef TAINT
	if (euid != uid || egid != gid)
	    fatal("No -D allowed in setuid scripts");
#endif
	debug = atoi(s+1) | 32768;
#else
	warn("Recompile perl with -DDEBUGGING to use -D switch\n");
#endif
	/*SUPPRESS 530*/
	for (s++; isDIGIT(*s); s++) ;
	return s;
    case 'i':
	inplace = savestr(s+1);
	/*SUPPRESS 530*/
	for (s = inplace; *s && !isSPACE(*s); s++) ;
	*s = '\0';
	break;
    case 'I':
#ifdef TAINT
	if (euid != uid || egid != gid)
	    fatal("No -I allowed in setuid scripts");
#endif
	if (*++s) {
	    (void)apush(stab_array(incstab),str_make(s,0));
	}
	else
	    fatal("No space allowed after -I");
	break;
    case 'l':
	minus_l = TRUE;
	s++;
	if (isDIGIT(*s)) {
	    ors = savestr("\n");
	    orslen = 1;
	    *ors = scanoct(s, 3 + (*s == '0'), &numlen);
	    s += numlen;
	}
	else {
	    ors = nsavestr(nrs,nrslen);
	    orslen = nrslen;
	}
	return s;
    case 'n':
	minus_n = TRUE;
	s++;
	return s;
    case 'p':
	minus_p = TRUE;
	s++;
	return s;
    case 'u':
	do_undump = TRUE;
	s++;
	return s;
    case 'U':
	unsafe = TRUE;
	s++;
	return s;
    case 'v':
	fputs("\nThis is perl, version 4.0\n\n",stdout);
	fputs(rcsid,stdout);
	fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
#ifdef MSDOS
	fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
	stdout);
#ifdef OS2
        fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
        stdout);
#endif
#endif
#ifdef atarist
        fputs("atariST series port, ++jrb  [e-mail]\n", stdout);
#endif
	fputs("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
#ifdef MSDOS
        usage(origargv[0]);
#endif
	exit(0);
    case 'w':
	dowarn = TRUE;
	s++;
	return s;
    case ' ':
    case '\n':
    case '\t':
	break;
    default:
	fatal("Switch meaningless after -x: -%s",s);
    }
    return Nullch;
}

/* compliments of Tom Christiansen */

/* unexec() can be found in the Gnu emacs distribution */

void
my_unexec()
{
#ifdef UNEXEC
    int    status;
    extern int etext;
    static char dumpname[BUFSIZ];
    static char perlpath[256];

    sprintf (dumpname, "%s.perldump", origfilename);
    sprintf (perlpath, "%s/perl", BIN);

    status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
    if (status)
	fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
    exit(status);
#else
#ifdef DOSISH
    abort();	/* nothing else to do */
#else /* ! MSDOS */
#   ifndef SIGABRT
#	define SIGABRT SIGILL
#   endif
#   ifndef SIGILL
#	define SIGILL 6		/* blech */
#   endif
    kill(getpid(),SIGABRT);	/* for use with undump */
#endif /* ! MSDOS */
#endif
}