-char rcsid[] = "$Header: perly.c,v 3.0.1.10 91/01/11 18:22:48 lwall Locked $\nPatch level: ###\n";
+char rcsid[] = "$Header: perl.c,v 4.0 91/03/20 01:37:44 lwall Locked $\nPatch level: ###\n";
/*
* Copyright (c) 1989, Larry Wall
*
* You may distribute under the terms of the GNU General Public License
* as specified in the README file that comes with the perl 3.0 kit.
*
- * $Log: perly.c,v $
- * Revision 3.0.1.10 91/01/11 18:22:48 lwall
- * patch42: added -0 option
- * patch42: ANSIfied the stat mode checking
- * patch42: executables for multiple versions may now coexist
- *
- * Revision 3.0.1.9 90/11/10 01:53:26 lwall
- * patch38: random cleanup
- * patch38: more msdos/os2 upgrades
- * patch38: references to $0 produced core dumps
- * patch38: added hooks for unexec()
- *
- * Revision 3.0.1.8 90/10/16 10:14:20 lwall
- * patch29: *foo now prints as *package'foo
- * patch29: added waitpid
- * patch29: the debugger now understands packages and evals
- * patch29: added -M, -A and -C
- * patch29: -w sometimes printed spurious warnings about ARGV and ENV
- * patch29: require "./foo" didn't work right
- * patch29: require error messages referred to wrong file
- *
- * Revision 3.0.1.7 90/08/13 22:22:22 lwall
- * patch28: defined(@array) and defined(%array) didn't work right
- *
- * Revision 3.0.1.6 90/08/09 04:55:50 lwall
- * patch19: added -x switch to extract script from input trash
- * patch19: Added -c switch to do compilation only
- * patch19: added numeric interpretation of $]
- * patch19: added require operator
- * patch19: $0, %ENV, @ARGV were wrong in dumped script
- * patch19: . is now explicitly in @INC (and last)
- *
- * Revision 3.0.1.5 90/03/27 16:20:57 lwall
- * patch16: MSDOS support
- * patch16: do FILE inside eval blows up
- *
- * Revision 3.0.1.4 90/02/28 18:06:41 lwall
- * patch9: perl can now start up other interpreters scripts
- * patch9: nested evals clobbered their longjmp environment
- * patch9: eval could mistakenly return undef in array context
- *
- * Revision 3.0.1.3 89/12/21 20:15:41 lwall
- * patch7: ANSI strerror() is now supported
- * patch7: errno may now be a macro with an lvalue
- * patch7: allowed setuid scripts to have a space after #!
- *
- * Revision 3.0.1.2 89/11/17 15:34:42 lwall
- * patch5: fixed possible confusion about current effective gid
- *
- * Revision 3.0.1.1 89/11/11 04:50:04 lwall
- * patch2: moved yydebug to where its type didn't matter
- *
- * Revision 3.0 89/10/18 15:22:21 lwall
- * 3.0 baseline
+ * $Log: perl.c,v $
+ * Revision 4.0 91/03/20 01:37:44 lwall
+ * 4.0 baseline.
*
*/
static char* moreswitches();
static char* cddir;
+#ifndef __STDC__
extern char **environ;
+#endif /* ! __STDC__ */
static bool minus_c;
static char patchlevel[6];
+static char *nrs = "\n";
+static int nrschar = '\n'; /* final char of rs, or 0777 if none */
+static int nrslen = 1;
main(argc,argv,env)
register int argc;
origargv = argv;
origargc = argc;
+ origenviron = environ;
uid = (int)getuid();
euid = (int)geteuid();
gid = (int)getgid();
egid = (int)getegid();
- sprintf(patchlevel,"%3.3s%2.2d", rcsid+19, PATCHLEVEL);
+ sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
#ifdef MSDOS
/*
* There is no way we can refer to them from Perl so close them to save
case 'd':
case 'D':
case 'i':
+ case 'l':
case 'n':
case 'p':
case 'u':
argc++,argv--;
argv[0] = e_tmpname;
}
+
+#ifdef MSDOS
+#define PERLLIB_SEP ';'
+#else
+#define PERLLIB_SEP ':'
+#endif
+#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */
+ {
+ char * s2 = getenv("PERLLIB");
+
+ if ( s2 ) {
+ /* Break at all separators */
+ while ( *s2 ) {
+ /* First, skip any consecutive separators */
+ while ( *s2 == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* (void)apush(stab_array(incstab),str_make(".",1)); */
+ s2++;
+ }
+ if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
+ (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
+ s2 = s+1;
+ } else {
+ (void)apush(stab_array(incstab),str_make(s2,0));
+ break;
+ }
+ }
+ }
+ }
+#endif /* TAINT */
+
#ifndef PRIVLIB
#define PRIVLIB "/usr/local/lib/perl"
#endif
doextract = FALSE;
#ifdef IAMSUID /* actually, this is caught earlier */
if (euid != uid && !euid) /* if running suidperl */
-#ifdef SETEUID
+#ifdef HAS_SETEUID
(void)seteuid(uid); /* musn't stay setuid root */
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
(void)setreuid(-1, uid);
#else
setuid(uid);
stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
}
str_free(str); /* free -I directories */
+ str = Nullstr;
/* do we need to emulate setuid on scripts? */
int len;
#ifdef IAMSUID
-#ifndef SETREUID
+#ifndef HAS_SETREUID
/* 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
if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
fatal("Permission denied\n");
}
-#endif /* SETREUID */
+#endif /* HAS_SETREUID */
#endif /* IAMSUID */
if (!S_ISREG(statbuf.st_mode))
}
if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
-#ifdef SETEGID
+#ifdef HAS_SETEGID
(void)setegid(statbuf.st_gid);
#else
-#ifdef SETREGID
+#ifdef HAS_SETREGID
(void)setregid((GIDTYPE)-1,statbuf.st_gid);
#else
setgid(statbuf.st_gid);
#endif
if (statbuf.st_mode & S_ISUID) {
if (statbuf.st_uid != euid)
-#ifdef SETEUID
+#ifdef HAS_SETEUID
(void)seteuid(statbuf.st_uid); /* all that for this */
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
(void)setreuid((UIDTYPE)-1,statbuf.st_uid);
#else
setuid(statbuf.st_uid);
#endif
}
else if (uid) /* oops, mustn't run as root */
-#ifdef SETEUID
+#ifdef HAS_SETEUID
(void)seteuid((UIDTYPE)uid);
#else
-#ifdef SETREUID
+#ifdef HAS_SETREUID
(void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
#else
setuid((UIDTYPE)uid);
(void)hadd(sigstab);
}
- magicalize("!#?^~=-%123456789.+&*()<>,\\/[|`':\024");
+ magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\024\027");
userinit(); /* in case linked C routines want magical variables */
amperstab = stabent("&",allstabs);
statname = Str_new(66,0); /* last filename we did stat on */
+ /* now that script is parsed, we can modify record separator */
+
+ rs = nrs;
+ rslen = nrslen;
+ rschar = nrschar;
+ str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
+
if (do_undump)
my_unexec();
argc--,argv++;
break;
}
- str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
+ if (s = index(argv[0], '=')) {
+ *s++ = '\0';
+ str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
+ }
+ else
+ str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
}
}
#ifdef TAINT
tainted = 1;
#endif
- if (tmpstab = stabent("0",allstabs))
+ if (tmpstab = stabent("0",allstabs)) {
str_set(stab_val(tmpstab),origfilename);
+ magicname("0", Nullch, 0);
+ }
+ if (tmpstab = stabent("\020",allstabs))
+ str_set(stab_val(tmpstab),origargv[0]);
if (argvstab = stabent("ARGV",allstabs)) {
argvstab->str_pok |= SP_MULTI;
(void)aadd(argvstab);
/* NOTREACHED */
}
+void
magicalize(list)
register char *list;
{
magicname(sym, Nullch, 0);
}
-int
+void
magicname(sym,name,namlen)
char *sym;
char *name;
}
}
-/* this routine is in perly.c by virtue of being sort of an alternate main() */
+/* this routine is in perl.c by virtue of being sort of an alternate main() */
int
do_eval(str,optype,stash,gimme,arglast)
{
STR **st = stack->ary_array;
int retval;
- CMD *myroot;
+ CMD *myroot = Nullcmd;
ARRAY *ar;
int i;
CMD * VOLATILE oldcurcmd = curcmd;
VOLATILE int oldsave = savestack->ary_fill;
VOLATILE int oldperldb = perldb;
SPAT * VOLATILE oldspat = curspat;
+ SPAT * VOLATILE oldlspat = lastspat;
static char *last_eval = Nullch;
static CMD *last_root = Nullcmd;
VOLATILE int sp = arglast[0];
char *specfilename;
char *tmpfilename;
+ int parsing = 1;
tmps_base = tmps_max;
if (curstash != stash) {
else {
if (last_root && !in_eval) {
Safefree(last_eval);
+ last_eval = Nullch;
cmd_free(last_root);
last_root = Nullcmd;
}
}
curcmd->c_filestab = fstab(tmpfilename);
Safefree(tmpfilename);
+ tmpfilename = Nullch;
if (!rsfp) {
curcmd = oldcurcmd;
tmps_base = oldtmps_base;
deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
}
#endif
+ eval_root = Nullcmd;
if (setjmp(loop_stack[loop_ptr].loop_env)) {
retval = 1;
- last_root = Nullcmd;
}
else {
error_count = 0;
else if (in_eval == 1) {
if (last_root) {
Safefree(last_eval);
+ last_eval = Nullch;
cmd_free(last_root);
}
- last_eval = savestr(bufptr);
last_root = Nullcmd;
+ last_eval = savestr(bufptr);
retval = yyparse();
retval |= error_count;
if (!retval)
last_root = eval_root;
+ if (!last_root) {
+ Safefree(last_eval);
+ last_eval = Nullch;
+ }
}
else
retval = yyparse();
sp = arglast[0];
if (gimme != G_ARRAY)
st[++sp] = &str_undef;
- last_root = Nullcmd; /* can't free on error, for some reason */
+ 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
+ if (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_static(st[i]);
+ st[i] = str_mortal(st[i]);
/* if we don't save result, free zaps it */
if (in_eval != 1 && myroot != last_root)
cmd_free(myroot);
loop_ptr--;
tmps_base = oldtmps_base;
curspat = oldspat;
+ lastspat = oldlspat;
if (savestack->ary_fill > oldsave) /* let them use local() */
restorelist(oldsave);
moreswitches(s)
char *s;
{
+ int numlen;
+
reswitch:
switch (*s) {
case '0':
- record_separator = 0;
- if (s[1] == '0' && !isdigit(s[2]))
- rslen = 0;
- while (*s >= '0' && *s <= '7') {
- record_separator <<= 3;
- record_separator += *s++ & 7;
+ nrschar = scanoct(s, 4, &numlen);
+ nrs = nsavestr("\n",1);
+ *nrs = nrschar;
+ if (nrschar > 0377) {
+ nrslen = 0;
+ nrs = "";
}
- return s;
+ else if (!nrschar && numlen >= 2) {
+ nrslen = 2;
+ nrs = "\n\n";
+ nrschar = '\n';
+ }
+ return s + numlen;
case 'a':
minus_a = TRUE;
s++;
if (euid != uid || egid != gid)
fatal("No -D allowed in setuid scripts");
#endif
- debug = atoi(s+1);
+ debug = atoi(s+1) | 32768;
#else
warn("Recompile perl with -DDEBUGGING to use -D switch\n");
#endif
- break;
+ for (s++; isdigit(*s); s++) ;
+ return s;
case 'i':
inplace = savestr(s+1);
for (s = inplace; *s && !isspace(*s); s++) ;
*s = '\0';
- argvoutstab = stabent("ARGVOUT",TRUE);
break;
case 'I':
#ifdef TAINT
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++;
s++;
return s;
case 'v':
- fputs("\nThis is perl, version 3.0\n\n",stdout);
+ fputs("\nThis is perl, version 4.0\n\n",stdout);
fputs(rcsid,stdout);
- fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",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);
#endif
fputs("\n\
Perl may be copied only under the terms of the GNU General Public License,\n\
-a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
+a copy of which can be found with the Perl 4.0 distribution kit.\n",stdout);
#ifdef MSDOS
usage(origargv[0]);
#endif
fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
exit(status);
#else
- abort(); /* for use with undump */
+# ifndef SIGABRT
+# define SIGABRT SIGILL
+# endif
+# ifndef SIGILL
+# define SIGILL 6 /* blech */
+# endif
+ kill(getpid(),SIGABRT); /* for use with undump */
#endif
}
projects / p5sagit/p5-mst-13.2.git / blobdiff