char rcsid
[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:39:30 $\nPatch level: ###\n";
* Copyright (c) 1991, Larry Wall
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* Revision 4.0.1.8 1993/02/05 19:39:30 lwall
* patch36: the taintanyway code wasn't tainting anyway
* patch36: Malformed cmd links core dump apparently fixed
* Revision 4.0.1.7 92/06/08 14:50:39 lwall
* patch20: PERLLIB now supports multiple directories
* patch20: running taintperl explicitly now does checks even if $< == $>
* patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
* patch20: perl -P now uses location of sed determined by Configure
* patch20: form feed for formats is now specifiable via $^L
* patch20: paragraph mode now skips extra newlines automatically
* patch20: eval "1 #comment" didn't work
* patch20: couldn't require . files
* patch20: semantic compilation errors didn't abort execution
* Revision 4.0.1.6 91/11/11 16:38:45 lwall
* patch19: default arg for shift was wrong after first subroutine definition
* patch19: op/regexp.t failed from missing arg to bcmp()
* Revision 4.0.1.5 91/11/05 18:03:32 lwall
* patch11: random cleanup
* patch11: $0 was being truncated at times
* patch11: cppstdin now installed outside of source directory
* patch11: -P didn't allow use of #elif or #undef
* patch11: prepared for ctype implementations that don't define isascii()
* patch11: eval confused by string containing null
* Revision 4.0.1.4 91/06/10 01:23:07 lwall
* patch10: perl -v printed incorrect copyright notice
* Revision 4.0.1.3 91/06/07 11:40:18 lwall
* patch4: changed old $^P to $^X
* Revision 4.0.1.2 91/06/07 11:26:16 lwall
* patch4: new copyright notice
* patch4: added $^P variable to control calling of perldb routines
* patch4: added $^F variable to specify maximum system fd, default 2
* patch4: debugger lost track of lines in eval
* Revision 4.0.1.1 91/04/11 17:49:05 lwall
* patch1: fixed undefined environ problem
* Revision 4.0 91/03/20 01:37:44 lwall
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
static char* moreswitches();
static char patchlevel
[6];
static int nrschar
= '\n'; /* final char of rs, or 0777 if none */
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
fatal("suidperl is no longer needed since the kernel can now execute\n\
setuid perl scripts securely.\n");
sprintf(patchlevel
,"%3.3s%2.2d", index(rcsid
,'4'), PATCHLEVEL
);
* There is no way we can refer to them from Perl so close them to save
* space. The other alternative would be to provide STDAUX and STDPRN
origfilename
= savestr(argv
[0]);
loop_ptr
= -1; /* start label stack again */
if (uid
== euid
&& gid
== egid
)
taintanyway
= TRUE
; /* running taintperl explicitly */
(void)sprintf(index(rcsid
,'#'), "%d\n", PATCHLEVEL
);
linestr
= Str_new(65,80);
str
= str_make("",0); /* first used for -I flags */
curstash
= defstash
= hnew(0);
curstname
= str_make("main",4);
stab_xhash(stabent("_main",TRUE
)) = defstash
;
defstash
->tbl_name
= "main";
incstab
= hadd(aadd(stabent("INC",TRUE
)));
incstab
->str_pok
|= SP_MULTI
;
for (argc
--,argv
++; argc
> 0; argc
--,argv
++) {
if (argv
[0][0] != '-' || !argv
[0][1])
if (euid
!= uid
|| egid
!= gid
)
fatal("No -e allowed in setuid scripts");
e_tmpname
= savestr(TMPPATH
);
e_fp
= fopen(e_tmpname
,"w");
fatal("Cannot open temporary file");
if (euid
!= uid
|| egid
!= gid
)
fatal("No -I allowed in setuid scripts");
(void)apush(stab_array(incstab
),str_make(s
,0));
(void)apush(stab_array(incstab
),str_make(argv
[1],0));
if (euid
!= uid
|| egid
!= gid
)
fatal("No -P allowed in setuid scripts");
if (euid
!= uid
|| egid
!= gid
)
fatal("No -s allowed in setuid scripts");
if (euid
!= uid
|| egid
!= gid
)
fatal("No -S allowed in setuid scripts");
fatal("Unrecognized switch: -%s",s
);
if (fflush(e_fp
) || ferror(e_fp
) || fclose(e_fp
))
fatal("Can't write to temp file for -e: %s", strerror(errno
));
#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
incpush(getenv("PERLLIB"));
#define PRIVLIB "/usr/local/lib/perl"
(void)apush(stab_array(incstab
),str_make(".",1));
if (scriptname
== Nullch
)
if ( isatty(fileno(stdin
)) )
if (dosearch
&& !index(scriptname
, '/') && (s
= getenv("PATH"))) {
char *xfound
= Nullch
, *xfailed
= Nullch
;
s
= cpytill(tokenbuf
,s
,bufend
,':',&len
);
for (len
= 0; *s
&& *s
!= ',' && *s
!= ';'; tokenbuf
[len
++] = *s
++);
for (len
= 0; *s
&& *s
!= ';'; tokenbuf
[len
++] = *s
++);
if (len
&& tokenbuf
[len
-1] != '/')
if (len
&& ((tokenbuf
[len
-1] != '\\') && (tokenbuf
[len
-1] != '/')))
if (len
&& tokenbuf
[len
-1] != '\\')
(void)strcat(tokenbuf
+len
,"/");
(void)strcat(tokenbuf
+len
,scriptname
);
fprintf(stderr
,"Looking for %s\n",tokenbuf
);
if (stat(tokenbuf
,&statbuf
) < 0) /* not there? */
if (S_ISREG(statbuf
.st_mode
)
&& cando(S_IRUSR
,TRUE
,&statbuf
) && cando(S_IXUSR
,TRUE
,&statbuf
)) {
xfound
= tokenbuf
; /* bingo! */
xfailed
= savestr(tokenbuf
);
fatal("Can't execute %s", xfailed
? xfailed
: scriptname
);
scriptname
= savestr(xfound
);
fdpid
= anew(Nullstab
); /* for remembering popen pids by fd */
pidstatus
= hnew(COEFFSIZE
);/* for remembering status of dead pids */
origfilename
= savestr(scriptname
);
curcmd
->c_filestab
= fstab(origfilename
);
if (strEQ(origfilename
,"-"))
if (strEQ(cpp
,"cppstdin"))
sprintf(tokenbuf
, "%s/%s", SCRIPTDIR
, cpp
);
sprintf(tokenbuf
, "%s", cpp
);
-e \"/^#[ ]*include[ ]/b\" \
-e \"/^#[ ]*define[ ]/b\" \
-e \"/^#[ ]*ifdef[ ]/b\" \
-e \"/^#[ ]*ifndef[ ]/b\" \
-e \"/^#[ ]*elif[ ]/b\" \
-e \"/^#[ ]*undef[ ]/b\" \
(doextract
? "-e \"1,/^#/d\n\"" : ""),
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*define[ ]/b' \
-e '/^#[ ]*ifndef[ ]/b' \
(doextract
? "-e '1,/^#/d\n'" : ""),
scriptname
, tokenbuf
, str_get(str
), CPPMINUS
);
#ifdef IAMSUID /* actually, this is caught earlier */
if (euid
!= uid
&& !euid
) { /* if running suidperl */
(void)seteuid(uid
); /* musn't stay setuid root */
fatal("Can't do seteuid!\n");
if (euid
!= uid
|| egid
!= gid
)
fatal("Can't take set-id script from stdin");
rsfp
= fopen(scriptname
,"r");
if ((FILE*)rsfp
== Nullfp
) {
#ifndef IAMSUID /* in case script is not readable before setuid */
if (euid
&& stat(stab_val(curcmd
->c_filestab
)->str_ptr
,&statbuf
) >= 0 &&
statbuf
.st_mode
& (S_ISUID
|S_ISGID
)) {
(void)sprintf(buf
, "%s/sperl%s", BIN
, patchlevel
);
execv(buf
, origargv
); /* try again */
fatal("Can't do setuid\n");
fatal("Can't open perl script \"%s\": %s\n",
stab_val(curcmd
->c_filestab
)->str_ptr
, strerror(errno
));
str_free(str
); /* free -I directories */
/* do we need to emulate setuid on scripts? */
/* This code is for those BSD systems that have setuid #! scripts disabled
* in the kernel because of a security problem. Merely defining DOSUID
* in perl will not fix that problem, but if you have disabled setuid
* scripts in the kernel, this will attempt to emulate setuid and setgid
* on scripts that have those now-otherwise-useless bits set. The setuid
* root version must be called suidperl or sperlN.NNN. If regular perl
* discovers that it has opened a setuid script, it calls suidperl with
* the same argv that it had. If suidperl finds that the script it has
* just opened is NOT setuid root, it sets the effective uid back to the
* uid. We don't just make perl setuid root because that loses the
* effective uid we had before invoking perl, if it was different from the
* DOSUID must be defined in both perl and suidperl, and IAMSUID must
* be defined in suidperl only. suidperl must be setuid root. The
* Configure script will set this up for you if you want it.
* There is also the possibility of have a script which is running
* set-id due to a C wrapper. We want to do the TAINT checks
* on these set-id scripts, but don't want to have the overhead of
* them in normal perl, and can't use suidperl because it will lose
* the effective uid info, so we have an additional non-setuid root
* version called taintperl or tperlN.NNN that just does the TAINT checks.
if (fstat(fileno(rsfp
),&statbuf
) < 0) /* normal stat is insecure */
fatal("Can't stat script \"%s\"",origfilename
);
if (statbuf
.st_mode
& (S_ISUID
|S_ISGID
)) {
/* On this access check to make sure the directories are readable,
* there is actually a small window that the user could use to make
* filename point to an accessible directory. So there is a faint
* chance that someone could execute a setuid script down in a
* non-accessible directory. I don't know what to do about that.
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
if (access(stab_val(curcmd
->c_filestab
)->str_ptr
,1)) /*double check*/
fatal("Permission denied");
/* If we can swap euid and uid, then we can determine access rights
* with a simple stat of the file, and then compare device and
* inode to make sure we did stat() on the same file we opened.
* Then we just have to make sure he or she can execute it.
if (setreuid(euid
,uid
) < 0 || getuid() != euid
|| geteuid() != uid
)
fatal("Can't swap uid and euid"); /* really paranoid */
if (stat(stab_val(curcmd
->c_filestab
)->str_ptr
,&tmpstatbuf
) < 0)
fatal("Permission denied"); /* testing full pathname here */
if (tmpstatbuf
.st_dev
!= statbuf
.st_dev
||
tmpstatbuf
.st_ino
!= statbuf
.st_ino
) {
if (rsfp
= mypopen("/bin/mail root","w")) { /* heh, heh */
"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
uid
,tmpstatbuf
.st_dev
, tmpstatbuf
.st_ino
,
statbuf
.st_dev
, statbuf
.st_ino
,
stab_val(curcmd
->c_filestab
)->str_ptr
,
statbuf
.st_uid
, statbuf
.st_gid
);
fatal("Permission denied\n");
if (setreuid(uid
,euid
) < 0 || getuid() != uid
|| geteuid() != euid
)
fatal("Can't reswap uid and euid");
if (!cando(S_IXUSR
,FALSE
,&statbuf
)) /* can real uid exec? */
fatal("Permission denied\n");
#endif /* HAS_SETREUID */
if (!S_ISREG(statbuf
.st_mode
))
fatal("Permission denied");
if (statbuf
.st_mode
& S_IWOTH
)
fatal("Setuid/gid script is writable by world");
doswitches
= FALSE
; /* -s is insecure in suid */
if (fgets(tokenbuf
,sizeof tokenbuf
, rsfp
) == Nullch
||
strnNE(tokenbuf
,"#!",2) ) /* required even on Sys V */
while (!isSPACE(*s
)) s
++;
if (strnNE(s
-4,"perl",4) && strnNE(s
-9,"perl",4)) /* sanity check */
fatal("Not a perl script");
while (*s
== ' ' || *s
== '\t') s
++;
* #! arg must be what we saw above. They can invoke it by
* mentioning suidperl explicitly, but they may not add any strange
* arguments beyond what #! says if they do invoke suidperl that way.
if (strEQ(validarg
," PHOOEY ") ||
strnNE(s
,validarg
,len
) || !isSPACE(s
[len
]))
fatal("Args must match #! line");
if (euid
!= uid
&& (statbuf
.st_mode
& S_ISUID
) &&
fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
if (euid
) { /* oops, we're not the setuid root perl */
(void)sprintf(buf
, "%s/sperl%s", BIN
, patchlevel
);
execv(buf
, origargv
); /* try again */
fatal("Can't do setuid\n");
if (statbuf
.st_mode
& S_ISGID
&& statbuf
.st_gid
!= egid
) {
(void)setegid(statbuf
.st_gid
);
(void)setregid((GIDTYPE
)-1,statbuf
.st_gid
);
if (getegid() != statbuf
.st_gid
)
fatal("Can't do setegid!\n");
if (statbuf
.st_mode
& S_ISUID
) {
if (statbuf
.st_uid
!= euid
)
(void)seteuid(statbuf
.st_uid
); /* all that for this */
(void)setreuid((UIDTYPE
)-1,statbuf
.st_uid
);
if (geteuid() != statbuf
.st_uid
)
fatal("Can't do seteuid!\n");
else if (uid
) { /* oops, mustn't run as root */
(void)seteuid((UIDTYPE
)uid
);
(void)setreuid((UIDTYPE
)-1,(UIDTYPE
)uid
);
fatal("Can't do seteuid!\n");
if (!cando(S_IXUSR
,TRUE
,&statbuf
))
fatal("Permission denied\n"); /* they can't do this */
fatal("-P not allowed for setuid/setgid script\n");
fatal("Script is not setuid/setgid in suidperl\n");
#ifndef TAINT /* we aren't taintperl or suidperl */
/* script has a wrapper--can't run suidperl or we lose euid */
else if (euid
!= uid
|| egid
!= gid
) {
(void)sprintf(buf
, "%s/tperl%s", BIN
, patchlevel
);
execv(buf
, origargv
); /* try again */
fatal("Can't run setuid script with taint checks");
#ifndef TAINT /* we aren't taintperl or suidperl */
if (euid
!= uid
|| egid
!= gid
) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
fstat(fileno(rsfp
),&statbuf
); /* may be either wrapped or real suid */
if ((euid
!= uid
&& euid
== statbuf
.st_uid
&& statbuf
.st_mode
& S_ISUID
)
(egid
!= gid
&& egid
== statbuf
.st_gid
&& statbuf
.st_mode
& S_ISGID
)
fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* not set-id, must be wrapped */
(void)sprintf(buf
, "%s/tperl%s", BIN
, patchlevel
);
execv(buf
, origargv
); /* try again */
fatal("Can't run setuid script with taint checks");
#if !defined(IAMSUID) && !defined(TAINT)
/* skip forward in input to the real script? */
if ((s
= str_gets(linestr
, rsfp
, 0)) == Nullch
)
fatal("No Perl script found in input\n");
if (*s
== '#' && s
[1] == '!' && instr(s
,"perl")) {
ungetc('\n',rsfp
); /* to keep line count right */
if (s
= instr(s
,"perl -")) {
while (s
= moreswitches(s
)) ;
if (cddir
&& chdir(cddir
) < 0)
fatal("Can't chdir to %s",cddir
);
#endif /* !defined(IAMSUID) && !defined(TAINT) */
defstab
= stabent("_",TRUE
);
subname
= str_make("main",4);
stab_xhash(stabent("_DB",TRUE
)) = debstash
;
dbargs
= stab_xarray(aadd((tmpstab
= stabent("args",TRUE
))));
tmpstab
->str_pok
|= SP_MULTI
;
DBstab
= stabent("DB",TRUE
);
DBstab
->str_pok
|= SP_MULTI
;
DBline
= stabent("dbline",TRUE
);
DBline
->str_pok
|= SP_MULTI
;
DBsub
= hadd(tmpstab
= stabent("sub",TRUE
));
tmpstab
->str_pok
|= SP_MULTI
;
DBsingle
= stab_val((tmpstab
= stabent("single",TRUE
)));
tmpstab
->str_pok
|= SP_MULTI
;
DBtrace
= stab_val((tmpstab
= stabent("trace",TRUE
)));
tmpstab
->str_pok
|= SP_MULTI
;
DBsignal
= stab_val((tmpstab
= stabent("signal",TRUE
)));
tmpstab
->str_pok
|= SP_MULTI
;
bufend
= bufptr
= str_get(linestr
);
savestack
= anew(Nullstab
); /* for saving non-local values */
stack
= anew(Nullstab
); /* for saving non-local values */
stack
->ary_flags
= 0; /* not a real array */
afill(stack
,63); afill(stack
,-1); /* preextend stack */
afill(savestack
,63); afill(savestack
,-1);
/* now parse the script */
if (yyparse() || error_count
) {
fatal("%s had compilation errors.\n", origfilename
);
fatal("Execution of %s aborted due to compilation errors.\n",
New(50,loop_stack
,128,struct loop
);
New(51,debname
,128,char);
New(52,debdelim
,128,char);
/* initialize everything that won't change if we undump */
if (sigstab
= stabent("SIG",allstabs
)) {
sigstab
->str_pok
|= SP_MULTI
;
magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
userinit(); /* in case linked C routines want magical variables */
amperstab
= stabent("&",allstabs
);
leftstab
= stabent("`",allstabs
);
rightstab
= stabent("'",allstabs
);
sawampersand
= (amperstab
|| leftstab
|| rightstab
);
if (tmpstab
= stabent(":",allstabs
))
str_set(stab_val(tmpstab
),chopset
);
if (tmpstab
= stabent("\024",allstabs
))
/* these aren't necessarily magical */
if (tmpstab
= stabent("\014",allstabs
)) {
str_set(stab_val(tmpstab
),"\f");
formfeed
= stab_val(tmpstab
);
if (tmpstab
= stabent(";",allstabs
))
str_set(STAB_STR(tmpstab
),"\034");
if (tmpstab
= stabent("]",allstabs
)) {
str
->str_u
.str_nval
= atof(patchlevel
);
str_nset(stab_val(stabent("\"", TRUE
)), " ", 1);
stdinstab
= stabent("STDIN",TRUE
);
stdinstab
->str_pok
|= SP_MULTI
;
stab_io(stdinstab
) = stio_new();
stab_io(stdinstab
)->ifp
= stdin
;
tmpstab
= stabent("stdin",TRUE
);
stab_io(tmpstab
) = stab_io(stdinstab
);
tmpstab
->str_pok
|= SP_MULTI
;
tmpstab
= stabent("STDOUT",TRUE
);
tmpstab
->str_pok
|= SP_MULTI
;
stab_io(tmpstab
) = stio_new();
stab_io(tmpstab
)->ofp
= stab_io(tmpstab
)->ifp
= stdout
;
tmpstab
= stabent("stdout",TRUE
);
stab_io(tmpstab
) = stab_io(defoutstab
);
tmpstab
->str_pok
|= SP_MULTI
;
curoutstab
= stabent("STDERR",TRUE
);
curoutstab
->str_pok
|= SP_MULTI
;
if (!stab_io(curoutstab
))
stab_io(curoutstab
) = stio_new();
stab_io(curoutstab
)->ofp
= stab_io(curoutstab
)->ifp
= stderr
;
tmpstab
= stabent("stderr",TRUE
);
stab_io(tmpstab
) = stab_io(curoutstab
);
tmpstab
->str_pok
|= SP_MULTI
;
curoutstab
= defoutstab
; /* switch back to STDOUT */
statname
= Str_new(66,0); /* last filename we did stat on */
/* now that script is parsed, we can modify record separator */
str_nset(stab_val(stabent("/", TRUE
)), rs
, rslen
);
just_doit
: /* come here if running an undumped a.out */
argc
--,argv
++; /* skip name of script */
for (; argc
> 0 && **argv
== '-'; argc
--,argv
++) {
if (s
= index(argv
[0], '=')) {
str_set(stab_val(stabent(argv
[0]+1,TRUE
)),s
);
str_numset(stab_val(stabent(argv
[0]+1,TRUE
)),(double)1.0);
if (tmpstab
= stabent("0",allstabs
)) {
str_set(stab_val(tmpstab
),origfilename
);
magicname("0", Nullch
, 0);
if (tmpstab
= stabent("\030",allstabs
))
str_set(stab_val(tmpstab
),origargv
[0]);
if (argvstab
= stabent("ARGV",allstabs
)) {
argvstab
->str_pok
|= SP_MULTI
;
aclear(stab_array(argvstab
));
for (; argc
> 0; argc
--,argv
++) {
(void)apush(stab_array(argvstab
),str_make(argv
[0],0));
(void) stabent("ENV",TRUE
); /* must test PATH and IFS */
if (envstab
= stabent("ENV",allstabs
)) {
envstab
->str_pok
|= SP_MULTI
;
hclear(stab_hash(envstab
), FALSE
);
if (!(s
= index(*env
,'=')))
str_magic(str
, envstab
, 'E', *env
, s
- *env
);
(void)hstore(stab_hash(envstab
), *env
, s
- *env
, str
, 0);
if (tmpstab
= stabent("$",allstabs
))
str_numset(STAB_STR(tmpstab
),(double)getpid());
if (setjmp(top_env
)) /* sets goto_targ on longjump */
loop_ptr
= -1; /* start label stack again */
fprintf(stderr
,"\nEXECUTING...\n\n");
fprintf(stderr
,"%s syntax OK\n", origfilename
);
(void) cmd_exec(main_root
,G_SCALAR
,-1);
fatal("Can't find label \"%s\"--aborting",goto_targ
);
magicname(sym
, Nullch
, 0);
magicname(sym
,name
,namlen
)
if (stab
= stabent(sym
,allstabs
)) {
stab_flags(stab
) = SF_VMAGIC
;
str_magic(stab_val(stab
), stab
, 0, name
, namlen
);
/* Break at all separators */
/* First, skip any consecutive separators */
while ( *p
== PERLLIB_SEP
) {
/* Uncomment the next line for PATH semantics */
/* (void)apush(stab_array(incstab), str_make(".", 1)); */
if ( (s
= index(p
, PERLLIB_SEP
)) != Nullch
) {
(void)apush(stab_array(incstab
), str_make(p
, (int)(s
- p
)));
(void)apush(stab_array(incstab
), str_make(p
, 0));
register char *s
= str
->str_ptr
;
register char *send
= str
->str_ptr
+ str
->str_cur
;
STR
*tmpstr
= Str_new(85,0);
str_nset(tmpstr
, s
, t
- s
);
astore(array
, line
++, tmpstr
);
/* this routine is in perl.c by virtue of being sort of an alternate main() */
do_eval(str
,optype
,stash
,savecmd
,gimme
,arglast
)
STR
**st
= stack
->ary_array
;
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];
(void)savehptr(&curstash
);
str_set(stab_val(stabent("@",TRUE
)),"");
if (curcmd
->c_line
== 0) /* don't debug debugger... */
if (optype
== O_EVAL
) { /* normal eval */
curcmd
->c_filestab
= fstab("(eval)");
str_cat(linestr
,";\n;\n"); /* be kind to them */
savelines(stab_xarray(curcmd
->c_filestab
), linestr
);
if (last_root
&& !in_eval
) {
specfilename
= str_get(str
);
if (optype
== O_REQUIRE
&& &str_undef
!=
hfetch(stab_hash(incstab
), specfilename
, strlen(specfilename
), 0)) {
tmps_base
= oldtmps_base
;
tmpfilename
= savestr(specfilename
);
if (*tmpfilename
== '/' ||
(tmpfilename
[1] == '/' ||
(tmpfilename
[1] == '.' && tmpfilename
[2] == '/'))))
rsfp
= fopen(tmpfilename
,"r");
ar
= stab_array(incstab
);
for (i
= 0; i
<= ar
->ary_fill
; i
++) {
(void)sprintf(buf
, "%s/%s",
str_get(afetch(ar
,i
,TRUE
)), specfilename
);
if (*s
== '.' && s
[1] == '/')
tmpfilename
= savestr(s
);
curcmd
->c_filestab
= fstab(tmpfilename
);
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?)");
oldoldbufptr
= oldbufptr
= bufptr
= str_get(linestr
);
bufend
= bufptr
+ linestr
->str_cur
;
if (++loop_ptr
>= loop_max
) {
Renew(loop_stack
, loop_max
, struct loop
);
loop_stack
[loop_ptr
].loop_label
= "_EVAL_";
loop_stack
[loop_ptr
].loop_sp
= sp
;
deb("(Pushing label #%d _EVAL_)\n", loop_ptr
);
if (setjmp(loop_stack
[loop_ptr
].loop_env
)) {
else if (last_root
&& last_elen
== bufend
- bufptr
&& *bufptr
== *last_eval
&& !bcmp(bufptr
,last_eval
,last_elen
)){
eval_root
= last_root
; /* no point in reparsing */
else if (in_eval
== 1 && !savecmd
) {
last_elen
= bufend
- bufptr
;
last_eval
= nsavestr(bufptr
, last_elen
);
myroot
= eval_root
; /* in case cmd_exec does another eval! */
if (retval
|| error_count
) {
fprintf(stderr
,"Freeing eval_root %lx\n",(long)eval_root
);
/*SUPPRESS 29*/ /*SUPPRESS 30*/
if ((CMD
*)eval_root
== last_root
)
eval_root
= myroot
= Nullcmd
;
sp
= cmd_exec(eval_root
,gimme
,sp
);
for (i
= arglast
[0] + 1; i
<= sp
; i
++)
st
[i
] = str_mortal(st
[i
]);
/* if we don't save result, free zaps it */
else if (in_eval
!= 1 && myroot
!= last_root
)
char *tmps
= loop_stack
[loop_ptr
].loop_label
;
deb("(Popping label #%d %s)\n",loop_ptr
,
tmps_base
= oldtmps_base
;
if (savestack
->ary_fill
> oldsave
) /* let them use local() */
fatal("%s", str_get(stab_val(stabent("@",TRUE
))));
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
)),
else if (optype
== O_REQUIRE
)
fatal("%s did not return a true value", specfilename
);
do_try(cmd
,gimme
,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];
str_set(stab_val(stabent("@",TRUE
)),"");
if (++loop_ptr
>= loop_max
) {
Renew(loop_stack
, loop_max
, struct loop
);
loop_stack
[loop_ptr
].loop_label
= "_EVAL_";
loop_stack
[loop_ptr
].loop_sp
= sp
;
deb("(Pushing label #%d _EVAL_)\n", loop_ptr
);
if (setjmp(loop_stack
[loop_ptr
].loop_env
)) {
sp
= cmd_exec(cmd
,gimme
,sp
);
/* 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 */
char *tmps
= loop_stack
[loop_ptr
].loop_label
;
deb("(Popping label #%d %s)\n",loop_ptr
,
tmps_base
= oldtmps_base
;
if (savestack
->ary_fill
> oldsave
) /* let them use local() */
/* This routine handles any switches that can be given during run */
nrschar
= scanoct(s
, 4, &numlen
);
else if (!nrschar
&& numlen
>= 2) {
if (euid
!= uid
|| egid
!= gid
)
fatal("No -d allowed in setuid scripts");
if (euid
!= uid
|| egid
!= gid
)
fatal("No -D allowed in setuid scripts");
debug
= atoi(s
+1) | 32768;
warn("Recompile perl with -DDEBUGGING to use -D switch\n");
for (s
++; isDIGIT(*s
); s
++) ;
for (s
= inplace
; *s
&& !isSPACE(*s
); s
++) ;
if (euid
!= uid
|| egid
!= gid
)
fatal("No -I allowed in setuid scripts");
(void)apush(stab_array(incstab
),str_make(s
,0));
fatal("No space allowed after -I");
*ors
= scanoct(s
, 3 + (*s
== '0'), &numlen
);
ors
= nsavestr(nrs
,nrslen
);
fputs("\nThis is perl, version 4.0\n\n",stdout
);
fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout
);
fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout
);
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
);
fatal("Switch meaningless after -x: -%s",s
);
/* compliments of Tom Christiansen */
/* unexec() can be found in the Gnu emacs distribution */
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);
fprintf(stderr
, "unexec of %s into %s failed!\n", perlpath
, dumpname
);
abort(); /* nothing else to do */
# define SIGILL 6 /* blech */
kill(getpid(),SIGABRT
); /* for use with undump */