diff options
Diffstat (limited to 'perl.c')
| -rw-r--r-- | perl.c | 1637 |
1 files changed, 820 insertions, 817 deletions
@@ -1,4 +1,4 @@ -char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 $\nPatch level: ###\n"; +char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n"; /* * Copyright (c) 1991, Larry Wall * @@ -6,6 +6,8 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 * License or the Artistic License, as specified in the README file. * * $Log: perl.c,v $ + * Revision 4.1 92/08/07 18:25:50 lwall + * * 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 $< == $> @@ -13,7 +15,7 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 * 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: oldeval "1 #comment" didn't work * patch20: couldn't require . files * patch20: semantic compilation errors didn't abort execution * @@ -27,8 +29,8 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 * 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: added eval {} - * patch11: eval confused by string containing null + * patch11: added oldeval {} + * patch11: oldeval confused by string containing null * * Revision 4.0.1.4 91/06/10 01:23:07 lwall * patch10: perl -v printed incorrect copyright notice @@ -40,7 +42,7 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 * 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 + * patch4: debugger lost track of lines in oldeval * * Revision 4.0.1.1 91/04/11 17:49:05 lwall * patch1: fixed undefined environ problem @@ -57,8 +59,6 @@ char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.7 $$Date: 92/06/08 14:50:39 #include "perly.h" #include "patchlevel.h" -char *getenv(); - #ifdef IAMSUID #ifndef DOSUID #define DOSUID @@ -71,28 +71,147 @@ char *getenv(); #endif #endif -static char* moreswitches(); static void incpush(); -static char* cddir; -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) +static void validate_suid(); +static void find_beginning(); +static void init_main_stash(); +static void open_script(); +static void init_debugger(); +static void init_stack(); +static void init_lexer(); +static void init_context_stack(); +static void init_predump_symbols(); +static void init_postdump_symbols(); +static void init_perllib(); + +Interpreter * +perl_alloc() +{ + Interpreter *sv_interp; + Interpreter junk; + + curinterp = &junk; + Zero(&junk, 1, Interpreter); + New(53, sv_interp, 1, Interpreter); + return sv_interp; +} + +void +perl_construct( sv_interp ) +register Interpreter *sv_interp; +{ + if (!(curinterp = sv_interp)) + return; + + Zero(sv_interp, 1, Interpreter); + + /* Init the real globals? */ + if (!linestr) { + linestr = NEWSV(65,80); + + SvREADONLY_on(&sv_undef); + + sv_setpv(&sv_no,No); + SvNVn(&sv_no); + SvREADONLY_on(&sv_no); + + sv_setpv(&sv_yes,Yes); + SvNVn(&sv_yes); + SvREADONLY_on(&sv_yes); + +#ifdef MSDOS + /* + * 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 + * filehandles. + */ + (void)fclose(stdaux); + (void)fclose(stdprn); +#endif + } + +#ifdef EMBEDDED + chopset = " \n-"; + cmdline = NOLINE; + curcop = &compiling; + cxstack_ix = -1; + cxstack_max = 128; + dlmax = 128; + laststatval = -1; + laststype = OP_STAT; + maxscream = -1; + maxsysfd = MAXSYSFD; + nrs = "\n"; + nrschar = '\n'; + nrslen = 1; + rs = "\n"; + rschar = '\n'; + rsfp = Nullfp; + rslen = 1; + statname = Nullstr; + tmps_floor = -1; + tmps_ix = -1; + tmps_max = -1; +#endif + + uid = (int)getuid(); + euid = (int)geteuid(); + gid = (int)getgid(); + egid = (int)getegid(); + sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL); + + (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL); + + fdpid = newAV(); /* for remembering popen pids by fd */ + pidstatus = newHV(COEFFSIZE);/* for remembering status of dead pids */ + +#ifdef TAINT +#ifndef DOSUID + if (uid == euid && gid == egid) + taintanyway = TRUE; /* running taintperl explicitly */ +#endif +#endif + +} + +void +perl_destruct(sv_interp) +register Interpreter *sv_interp; +{ + if (!(curinterp = sv_interp)) + return; +#ifdef EMBEDDED + if (main_root) + op_free(main_root); + main_root = 0; + if (last_root) + op_free(last_root); + last_root = 0; +#endif +} + +void +perl_free(sv_interp) +Interpreter *sv_interp; +{ + if (!(curinterp = sv_interp)) + return; + Safefree(sv_interp); +} + +int +perl_parse(sv_interp, argc, argv, env) +Interpreter *sv_interp; register int argc; register char **argv; -register char **env; +char **env; { - register STR *str; + register SV *sv; register char *s; char *scriptname; char *getenv(); bool dosearch = FALSE; -#ifdef DOSUID char *validarg = ""; -#endif #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -102,45 +221,39 @@ setuid perl scripts securely.\n"); #endif #endif + if (!(curinterp = sv_interp)) + return 255; + + if (main_root) + op_free(main_root); + main_root = 0; + if (last_root) + op_free(last_root); + last_root = 0; + origargv = argv; origargc = argc; origenviron = environ; - uid = (int)getuid(); - euid = (int)geteuid(); - gid = (int)getgid(); - egid = (int)getegid(); - 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 - * space. The other alternative would be to provide STDAUX and STDPRN - * filehandles. - */ - (void)fclose(stdaux); - (void)fclose(stdprn); -#endif + + switch (setjmp(top_env)) { + case 1: + statusvalue = 255; + case 2: + return(statusvalue); /* my_exit() was called */ + case 3: + fprintf(stderr, "panic: top_env\n"); + exit(1); + } + if (do_undump) { origfilename = savestr(argv[0]); - do_undump = 0; - loop_ptr = -1; /* start label stack again */ + do_undump = FALSE; + cxstack_ix = -1; /* start label stack again */ goto just_doit; } -#ifdef TAINT -#ifndef DOSUID - if (uid == euid && gid == egid) - taintanyway = TRUE; /* running taintperl explicitly */ -#endif -#endif - (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL); - linestr = Str_new(65,80); - str_nset(linestr,"",0); - 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; + sv_setpvn(linestr,"",0); + sv = newSVpv("",0); /* first used for -I flags */ + init_main_stash(); for (argc--,argv++; argc > 0; argc--,argv++) { if (argv[0][0] != '-' || !argv[0][1]) break; @@ -162,6 +275,7 @@ setuid perl scripts securely.\n"); case 'l': case 'n': case 'p': + case 's': case 'u': case 'U': case 'v': @@ -195,17 +309,17 @@ setuid perl scripts securely.\n"); if (euid != uid || egid != gid) fatal("No -I allowed in setuid scripts"); #endif - str_cat(str,"-"); - str_cat(str,s); - str_cat(str," "); + sv_catpv(sv,"-"); + sv_catpv(sv,s); + sv_catpv(sv," "); if (*++s) { - (void)apush(stab_array(incstab),str_make(s,0)); + (void)av_push(GvAVn(incgv),newSVpv(s,0)); } else if (argv[1]) { - (void)apush(stab_array(incstab),str_make(argv[1],0)); - str_cat(str,argv[1]); + (void)av_push(GvAVn(incgv),newSVpv(argv[1],0)); + sv_catpv(sv,argv[1]); argc--,argv++; - str_cat(str," "); + sv_catpv(sv," "); } break; case 'P': @@ -216,14 +330,6 @@ setuid perl scripts securely.\n"); preprocess = TRUE; s++; goto reswitch; - case 's': -#ifdef TAINT - if (euid != uid || egid != gid) - fatal("No -s allowed in setuid scripts"); -#endif - doswitches = TRUE; - s++; - goto reswitch; case 'S': #ifdef TAINT if (euid != uid || egid != gid) @@ -255,40 +361,452 @@ setuid perl scripts securely.\n"); argc++,argv--; scriptname = e_tmpname; } + else if (scriptname == Nullch) { +#ifdef MSDOS + if ( isatty(fileno(stdin)) ) + moreswitches("v"); +#endif + scriptname = "-"; + } + + init_perllib(); + + open_script(scriptname,dosearch,sv); + + sv_free(sv); /* free -I directories */ + sv = Nullsv; + + validate_suid(validarg); + + if (doextract) + find_beginning(); + + if (perldb) + init_debugger(); + + pad = newAV(); + comppad = pad; + av_push(comppad, Nullsv); + curpad = AvARRAY(comppad); + padix = 0; + + init_stack(); + + init_lexer(); + + /* now parse the script */ + + error_count = 0; + if (yyparse() || error_count) { + if (minus_c) + fatal("%s had compilation errors.\n", origfilename); + else { + fatal("Execution of %s aborted due to compilation errors.\n", + origfilename); + } + } + curcop->cop_line = 0; + curstash = defstash; + preprocess = FALSE; + if (e_fp) { + e_fp = Nullfp; + (void)UNLINK(e_tmpname); + } + + init_context_stack(); + + init_predump_symbols(); + + if (do_undump) + my_unexec(); + + just_doit: /* come here if running an undumped a.out */ + init_postdump_symbols(argc,argv,env); + return 0; +} + +int +perl_run(sv_interp) +Interpreter *sv_interp; +{ + if (!(curinterp = sv_interp)) + return 255; + switch (setjmp(top_env)) { + case 1: + cxstack_ix = -1; /* start context stack again */ + break; + case 2: + curstash = defstash; + { + GV *gv = gv_fetchpv("END", FALSE); + + if (gv && GvCV(gv)) { + if (!setjmp(top_env)) + perl_callback("END", 0, G_SCALAR, 0, 0); + } + return(statusvalue); /* my_exit() was called */ + } + case 3: + if (!restartop) { + fprintf(stderr, "panic: restartop\n"); + exit(1); + } + if (stack != mainstack) { + dSP; + SWITCHSTACK(stack, mainstack); + } + break; + } + + if (!restartop) { + DEBUG_x(dump_all()); + DEBUG(fprintf(stderr,"\nEXECUTING...\n\n")); + + if (minus_c) { + fprintf(stderr,"%s syntax OK\n", origfilename); + my_exit(0); + } + } + + /* do it */ + + if (restartop) { + op = restartop; + restartop = 0; + run(); + } + else if (main_start) { + op = main_start; + run(); + } + else + fatal("panic: perl_run"); + + my_exit(0); +} + +void +my_exit(status) +int status; +{ + statusvalue = (unsigned short)(status & 0xffff); + longjmp(top_env, 2); +} + +/* Be sure to refetch the stack pointer after calling these routines. */ + +int +perl_callback(subname, sp, gimme, hasargs, numargs) +char *subname; +I32 sp; /* stack pointer after args are pushed */ +I32 gimme; /* called in array or scalar context */ +I32 hasargs; /* whether to create a @_ array for routine */ +I32 numargs; /* how many args are pushed on the stack */ +{ + BINOP myop; /* fake syntax tree node */ + + ENTER; + SAVESPTR(op); + stack_base = AvARRAY(stack); + stack_sp = stack_base + sp - numargs; + op = (OP*)&myop; + pp_pushmark(); /* doesn't look at op, actually, except to return */ + *stack_sp = (SV*)gv_fetchpv(subname, FALSE); + stack_sp += numargs; + + myop.op_last = hasargs ? (OP*)&myop : Nullop; + myop.op_next = Nullop; + + op = pp_entersubr(); + run(); + LEAVE; + return stack_sp - stack_base; +} + +int +perl_callv(subname, sp, gimme, argv) +char *subname; +register I32 sp; /* current stack pointer */ +I32 gimme; /* called in array or scalar context */ +register char **argv; /* null terminated arg list, NULL for no arglist */ +{ + register I32 items = 0; + I32 hasargs = (argv != 0); + + av_store(stack, ++sp, Nullsv); /* reserve spot for 1st return arg */ + if (hasargs) { + while (*argv) { + av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0))); + items++; + argv++; + } + } + return perl_callback(subname, sp, gimme, hasargs, items); +} + +void +magicalize(list) +register char *list; +{ + char sym[2]; + + sym[1] = '\0'; + while (*sym = *list++) + magicname(sym, sym, 1); +} + +void +magicname(sym,name,namlen) +char *sym; +char *name; +I32 namlen; +{ + register GV *gv; + + if (gv = gv_fetchpv(sym,allgvs)) + sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); +} #ifdef DOSISH #define PERLLIB_SEP ';' #else #define PERLLIB_SEP ':' #endif -#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */ - incpush(getenv("PERLLIB")); -#endif /* TAINT */ -#ifndef PRIVLIB -#define PRIVLIB "/usr/local/lib/perl" -#endif - incpush(PRIVLIB); - (void)apush(stab_array(incstab),str_make(".",1)); +static void +incpush(p) +char *p; +{ + char *s; + + if (!p) + return; + + /* Break at all separators */ + while (*p) { + /* First, skip any consecutive separators */ + while ( *p == PERLLIB_SEP ) { + /* Uncomment the next line for PATH semantics */ + /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */ + p++; + } + if ( (s = index(p, PERLLIB_SEP)) != Nullch ) { + (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p))); + p = s + 1; + } else { + (void)av_push(GvAVn(incgv), newSVpv(p, 0)); + break; + } + } +} - str_set(&str_no,No); - str_set(&str_yes,Yes); +/* This routine handles any switches that can be given during run */ - /* open script */ +char * +moreswitches(s) +char *s; +{ + I32 numlen; + + switch (*s) { + case '0': + nrschar = scan_oct(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 + if (isALPHA(s[1])) { + static char debopts[] = "psltocPmfrxuLHX"; + char *d; - if (scriptname == Nullch) + for (s++; *s && (d = index(debopts,*s)); s++) + debug |= 1 << (d - debopts); + } + else { + debug = atoi(s+1); + for (s++; isDIGIT(*s); s++) ; + } + debug |= 32768; +#else + warn("Recompile perl with -DDEBUGGING to use -D switch\n"); + for (s++; isDIGIT(*s); s++) ; +#endif + /*SUPPRESS 530*/ + return s; + case 'i': + if (inplace) + Safefree(inplace); + 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)av_push(GvAVn(incgv),newSVpv(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 = scan_oct(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 's': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -s allowed in setuid scripts"); +#endif + doswitches = 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 5.0, Alpha 2 (unsupported)\n\n",stdout); + fputs(rcsid,stdout); + fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993 Larry Wall\n",stdout); #ifdef MSDOS - { - if ( isatty(fileno(stdin)) ) - moreswitches("v"); - scriptname = "-"; + 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 bammi@cadence.com\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 5.0 source kit.\n",stdout); +#ifdef MSDOS + usage(origargv[0]); +#endif + exit(0); + case 'w': + dowarn = TRUE; + s++; + return s; + case ' ': + if (s[1] == '-') /* Additional switches on #! line. */ + return s+2; + break; + case 0: + 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; + + sprintf (buf, "%s.perldump", origfilename); + sprintf (tokenbuf, "%s/perl", BIN); + + status = unexec(buf, tokenbuf, &etext, sbrk(0), 0); + if (status) + fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); + my_exit(status); #else - scriptname = "-"; + ABORT(); /* for use with undump */ #endif +} + +static void +init_main_stash() +{ + curstash = defstash = newHV(0); + curstname = newSVpv("main",4); + GvHV(gv_fetchpv("_main",TRUE)) = defstash; + HvNAME(defstash) = "main"; + incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE))); + SvMULTI_on(incgv); + defgv = gv_fetchpv("_",TRUE); +} + +static void +open_script(scriptname,dosearch,sv) +char *scriptname; +bool dosearch; +SV *sv; +{ + char *xfound = Nullch; + char *xfailed = Nullch; + register char *s; + I32 len; + if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) { - char *xfound = Nullch, *xfailed = Nullch; - int len; bufend = s + strlen(s); while (*s) { @@ -316,10 +834,7 @@ setuid perl scripts securely.\n"); #endif (void)strcat(tokenbuf+len,"/"); (void)strcat(tokenbuf+len,scriptname); -#ifdef DEBUGGING - if (debug & 1) - fprintf(stderr,"Looking for %s\n",tokenbuf); -#endif + DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf)); if (stat(tokenbuf,&statbuf) < 0) /* not there? */ continue; if (S_ISREG(statbuf.st_mode) @@ -334,14 +849,11 @@ setuid perl scripts securely.\n"); fatal("Can't execute %s", xfailed ? xfailed : scriptname ); if (xfailed) Safefree(xfailed); - scriptname = savestr(xfound); + scriptname = 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); + curcop->cop_filegv = gv_fetchfile(origfilename); if (strEQ(origfilename,"-")) scriptname = ""; if (preprocess) { @@ -351,8 +863,8 @@ setuid perl scripts securely.\n"); sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp); else sprintf(tokenbuf, "%s", cpp); - str_cat(str,"-I"); - str_cat(str,PRIVLIB); + sv_catpv(sv,"-I"); + sv_catpv(sv,PRIVLIB); #ifdef MSDOS (void)sprintf(buf, "\ sed %s -e \"/^[^#]/b\" \ @@ -389,13 +901,8 @@ sed %s -e \"/^[^#]/b\" \ #endif (doextract ? "-e '1,/^#/d\n'" : ""), #endif - scriptname, tokenbuf, str_get(str), CPPMINUS); -#ifdef DEBUGGING - if (debug & 64) { - fputs(buf,stderr); - fputs("\n",stderr); - } -#endif + scriptname, tokenbuf, SvPVn(sv), CPPMINUS); + DEBUG_P(fprintf(stderr, "%s\n", buf)); doextract = FALSE; #ifdef IAMSUID /* actually, this is caught earlier */ if (euid != uid && !euid) { /* if running suidperl */ @@ -412,7 +919,7 @@ sed %s -e \"/^[^#]/b\" \ fatal("Can't do seteuid!\n"); } #endif /* IAMSUID */ - rsfp = mypopen(buf,"r"); + rsfp = my_popen(buf,"r"); } else if (!*scriptname) { #ifdef TAINT @@ -426,7 +933,7 @@ sed %s -e \"/^[^#]/b\" \ if ((FILE*)rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ - if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 && + if (euid && stat(SvPV(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ @@ -435,11 +942,14 @@ sed %s -e \"/^[^#]/b\" \ #endif #endif fatal("Can't open perl script \"%s\": %s\n", - stab_val(curcmd->c_filestab)->str_ptr, strerror(errno)); + SvPV(GvSV(curcop->cop_filegv)), strerror(errno)); } - str_free(str); /* free -I directories */ - str = Nullstr; +} +static void +validate_suid(validarg) +char *validarg; +{ /* do we need to emulate setuid on scripts? */ /* This code is for those BSD systems that have setuid #! scripts disabled @@ -471,7 +981,7 @@ sed %s -e \"/^[^#]/b\" \ 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)) { - int len; + I32 len; #ifdef IAMSUID #ifndef HAS_SETREUID @@ -483,7 +993,7 @@ sed %s -e \"/^[^#]/b\" \ * 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*/ + if (access(SvPV(GvSV(curcop->cop_filegv)),1)) /*double check*/ fatal("Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights @@ -496,20 +1006,20 @@ sed %s -e \"/^[^#]/b\" \ 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) + if (stat(SvPV(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) fatal("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { (void)fclose(rsfp); - if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */ + if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ fprintf(rsfp, "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, + SvPV(GvSV(curcop->cop_filegv)), statbuf.st_uid, statbuf.st_gid); - (void)mypclose(rsfp); + (void)my_pclose(rsfp); } fatal("Permission denied\n"); } @@ -526,7 +1036,7 @@ sed %s -e \"/^[^#]/b\" \ if (statbuf.st_mode & S_IWOTH) fatal("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ - curcmd->c_line++; + curcop->cop_line++; if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ fatal("No #! line"); @@ -647,13 +1157,18 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); } #endif /* TAINT */ #endif /* DOSUID */ +} +static void +find_beginning() +{ #if !defined(IAMSUID) && !defined(TAINT) + register char *s; /* skip forward in input to the real script? */ while (doextract) { - if ((s = str_gets(linestr, rsfp, 0)) == Nullch) + if ((s = sv_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 */ @@ -668,133 +1183,157 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); } } #endif /* !defined(IAMSUID) && !defined(TAINT) */ +} - defstab = stabent("_",TRUE); - - subname = str_make("main",4); - if (perldb) { - debstash = hnew(0); - stab_xhash(stabent("_DB",TRUE)) = debstash; - curstash = debstash; - dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE)))); - tmpstab->str_pok |= SP_MULTI; - dbargs->ary_flags = 0; - 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; - curstash = defstash; - } - - /* init tokener */ - - 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); +static void +init_debugger() +{ + GV* tmpgv; + + debstash = newHV(0); + GvHV(gv_fetchpv("_DB",TRUE)) = debstash; + curstash = debstash; + dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE)))); + SvMULTI_on(tmpgv); + AvREAL_off(dbargs); + DBgv = gv_fetchpv("DB",TRUE); + SvMULTI_on(DBgv); + DBline = gv_fetchpv("dbline",TRUE); + SvMULTI_on(DBline); + DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE)); + SvMULTI_on(tmpgv); + DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE))); + SvMULTI_on(tmpgv); + DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE))); + SvMULTI_on(tmpgv); + DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE))); + SvMULTI_on(tmpgv); + curstash = defstash; +} - /* now parse the script */ +static void +init_stack() +{ + stack = newAV(); + mainstack = stack; /* remember in case we switch stacks */ + AvREAL_off(stack); /* not a real array */ + av_fill(stack,127); av_fill(stack,-1); /* preextend stack */ + + stack_base = AvARRAY(stack); + stack_sp = stack_base; + stack_max = stack_base + 128; + + New(54,markstack,64,int); + markstack_ptr = markstack; + markstack_max = markstack + 64; + + New(54,scopestack,32,int); + scopestack_ix = 0; + scopestack_max = 32; + + New(54,savestack,128,ANY); + savestack_ix = 0; + savestack_max = 128; + + New(54,retstack,16,OP*); + retstack_ix = 0; + retstack_max = 16; +} - error_count = 0; - if (yyparse() || error_count) { - if (minus_c) - fatal("%s had compilation errors.\n", origfilename); - else { - fatal("Execution of %s aborted due to compilation errors.\n", - origfilename); - } - } +static void +init_lexer() +{ + bufend = bufptr = SvPVn(linestr); + subname = newSVpv("main",4); +} - New(50,loop_stack,128,struct loop); -#ifdef DEBUGGING - if (debug) { +static void +init_context_stack() +{ + New(50,cxstack,128,CONTEXT); + DEBUG( { New(51,debname,128,char); New(52,debdelim,128,char); - } -#endif - curstash = defstash; + } ) +} - preprocess = FALSE; - if (e_fp) { - e_fp = Nullfp; - (void)UNLINK(e_tmpname); - } +static void +init_predump_symbols() +{ + SV *sv; + GV* tmpgv; /* initialize everything that won't change if we undump */ - if (sigstab = stabent("SIG",allstabs)) { - sigstab->str_pok |= SP_MULTI; - (void)hadd(sigstab); + if (siggv = gv_fetchpv("SIG",allgvs)) { + HV *hv; + SvMULTI_on(siggv); + hv = GvHVn(siggv); + hv_magic(hv, siggv, 'S'); + + /* initialize signal stack */ + signalstack = newAV(); + av_store(signalstack, 32, Nullsv); + av_clear(signalstack); + AvREAL_off(signalstack); } 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)) - time(&basetime); + ampergv = gv_fetchpv("&",allgvs); + leftgv = gv_fetchpv("`",allgvs); + rightgv = gv_fetchpv("'",allgvs); + sawampersand = (ampergv || leftgv || rightgv); + if (tmpgv = gv_fetchpv(":",allgvs)) + sv_setpv(GvSV(tmpgv),chopset); /* these aren't necessarily magical */ - if (tmpstab = stabent("\014",allstabs)) { - str_set(stab_val(tmpstab),"\f"); - formfeed = stab_val(tmpstab); + if (tmpgv = gv_fetchpv("\014",allgvs)) { + sv_setpv(GvSV(tmpgv),"\f"); + formfeed = GvSV(tmpgv); } - if (tmpstab = stabent(";",allstabs)) - str_set(STAB_STR(tmpstab),"\034"); - if (tmpstab = stabent("]",allstabs)) { - str = STAB_STR(tmpstab); - str_set(str,rcsid); - str->str_u.str_nval = atof(patchlevel); - str->str_nok = 1; + if (tmpgv = gv_fetchpv(";",allgvs)) + sv_setpv(GvSV(tmpgv),"\034"); + if (tmpgv = gv_fetchpv("]",allgvs)) { + sv = GvSV(tmpgv); + sv_upgrade(sv, SVt_PVNV); + sv_setpv(sv,rcsid); + SvNV(sv) = atof(patchlevel); + SvNOK_on(sv); } - str_nset(stab_val(stabent("\"", TRUE)), " ", 1); - - stdinstab = stabent("STDIN",TRUE); - stdinstab->str_pok |= SP_MULTI; - if (!stab_io(stdinstab)) - 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; - if (!stab_io(tmpstab)) - stab_io(tmpstab) = stio_new(); - stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout; - defoutstab = tmpstab; - 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 */ + sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1); + + stdingv = gv_fetchpv("STDIN",TRUE); + SvMULTI_on(stdingv); + if (!GvIO(stdingv)) + GvIO(stdingv) = newIO(); + GvIO(stdingv)->ifp = stdin; + tmpgv = gv_fetchpv("stdin",TRUE); + GvIO(tmpgv) = GvIO(stdingv); + SvMULTI_on(tmpgv); + + tmpgv = gv_fetchpv("STDOUT",TRUE); + SvMULTI_on(tmpgv); + if (!GvIO(tmpgv)) + GvIO(tmpgv) = newIO(); + GvIO(tmpgv)->ofp = GvIO(tmpgv)->ifp = stdout; + defoutgv = tmpgv; + tmpgv = gv_fetchpv("stdout",TRUE); + GvIO(tmpgv) = GvIO(defoutgv); + SvMULTI_on(tmpgv); + + curoutgv = gv_fetchpv("STDERR",TRUE); + SvMULTI_on(curoutgv); + if (!GvIO(curoutgv)) + GvIO(curoutgv) = newIO(); + GvIO(curoutgv)->ofp = GvIO(curoutgv)->ifp = stderr; + tmpgv = gv_fetchpv("stderr",TRUE); + GvIO(tmpgv) = GvIO(curoutgv); + SvMULTI_on(tmpgv); + curoutgv = defoutgv; /* switch back to STDOUT */ + + statname = NEWSV(66,0); /* last filename we did stat on */ /* now that script is parsed, we can modify record separator */ @@ -802,641 +1341,105 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); rslen = nrslen; rschar = nrschar; rspara = (nrslen == 2); - str_nset(stab_val(stabent("/", TRUE)), rs, rslen); + sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen); +} - if (do_undump) - my_unexec(); +static void +init_postdump_symbols(argc,argv,env) +register int argc; +register char **argv; +register char **env; +{ + char *s; + SV *sv; + GV* tmpgv; - just_doit: /* come here if running an undumped a.out */ argc--,argv++; /* skip name of script */ if (doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { + if (!argv[0][1]) + break; if (argv[0][1] == '-') { argc--,argv++; break; } if (s = index(argv[0], '=')) { *s++ = '\0'; - str_set(stab_val(stabent(argv[0]+1,TRUE)),s); + sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s); } else - str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0); + sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1); } } + toptarget = NEWSV(0,0); + sv_upgrade(toptarget, SVt_PVFM); + sv_setpvn(toptarget, "", 0); + bodytarget = NEWSV(0,0); + sv_upgrade(bodytarget, SVt_PVFM); + sv_setpvn(bodytarget, "", 0); + formtarget = bodytarget; + #ifdef TAINT tainted = 1; #endif - if (tmpstab = stabent("0",allstabs)) { - str_set(stab_val(tmpstab),origfilename); - magicname("0", Nullch, 0); + if (tmpgv = gv_fetchpv("0",allgvs)) { + sv_setpv(GvSV(tmpgv),origfilename); + magicname("0", "0", 1); } - if (tmpstab = stabent("\030",allstabs)) - str_set(stab_val(tmpstab),origargv[0]); - if (argvstab = stabent("ARGV",allstabs)) { - argvstab->str_pok |= SP_MULTI; - (void)aadd(argvstab); - aclear(stab_array(argvstab)); + if (tmpgv = gv_fetchpv("\024",allgvs)) + time(&basetime); + if (tmpgv = gv_fetchpv("\030",allgvs)) + sv_setpv(GvSV(tmpgv),origargv[0]); + if (argvgv = gv_fetchpv("ARGV",allgvs)) { + SvMULTI_on(argvgv); + (void)gv_AVadd(argvgv); + av_clear(GvAVn(argvgv)); for (; argc > 0; argc--,argv++) { - (void)apush(stab_array(argvstab),str_make(argv[0],0)); + (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0)); } } #ifdef TAINT - (void) stabent("ENV",TRUE); /* must test PATH and IFS */ + (void) gv_fetchpv("ENV",TRUE); /* must test PATH and IFS */ #endif - if (envstab = stabent("ENV",allstabs)) { - envstab->str_pok |= SP_MULTI; - (void)hadd(envstab); - hclear(stab_hash(envstab), FALSE); + if (envgv = gv_fetchpv("ENV",allgvs)) { + HV *hv; + SvMULTI_on(envgv); + hv = GvHVn(envgv); + hv_clear(hv, FALSE); + hv_magic(hv, envgv, 'E'); if (env != environ) environ[0] = Nullch; for (; *env; env++) { if (!(s = index(*env,'='))) continue; *s++ = '\0'; - str = str_make(s--,0); - str_magic(str, envstab, 'E', *env, s - *env); - (void)hstore(stab_hash(envstab), *env, s - *env, str, 0); + sv = newSVpv(s--,0); + (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; } } #ifdef TAINT tainted = 0; #endif - if (tmpstab = stabent("$",allstabs)) - str_numset(STAB_STR(tmpstab),(double)getpid()); + if (tmpgv = gv_fetchpv("$",allgvs)) + sv_setiv(GvSV(tmpgv),(I32)getpid()); if (dowarn) { - stab_check('A','Z'); - stab_check('a','z'); - } - - if (setjmp(top_env)) /* sets goto_targ on longjump */ - loop_ptr = -1; /* start label stack again */ - -#ifdef DEBUGGING - if (debug & 1024) - dump_all(); - if (debug) - fprintf(stderr,"\nEXECUTING...\n\n"); -#endif - - if (minus_c) { - fprintf(stderr,"%s syntax OK\n", origfilename); - exit(0); - } - - /* do it */ - - (void) cmd_exec(main_root,G_SCALAR,-1); - - if (goto_targ) - fatal("Can't find label \"%s\"--aborting",goto_targ); - exit(0); - /* NOTREACHED */ -} - -void -magicalize(list) -register char *list; -{ - char sym[2]; - - sym[1] = '\0'; - while (*sym = *list++) - magicname(sym, Nullch, 0); -} - -void -magicname(sym,name,namlen) -char *sym; -char *name; -int namlen; -{ - register STAB *stab; - - if (stab = stabent(sym,allstabs)) { - stab_flags(stab) = SF_VMAGIC; - str_magic(stab_val(stab), stab, 0, name, namlen); + gv_check('A','Z'); + gv_check('a','z'); } } static void -incpush(p) -char *p; -{ - char *s; - - if (!p) - return; - - /* Break at all separators */ - while (*p) { - /* First, skip any consecutive separators */ - while ( *p == PERLLIB_SEP ) { - /* Uncomment the next line for PATH semantics */ - /* (void)apush(stab_array(incstab), str_make(".", 1)); */ - p++; - } - if ( (s = index(p, PERLLIB_SEP)) != Nullch ) { - (void)apush(stab_array(incstab), str_make(p, (int)(s - p))); - p = s + 1; - } else { - (void)apush(stab_array(incstab), str_make(p, 0)); - break; - } - } -} - -void -savelines(array, str) -ARRAY *array; -STR *str; -{ - register char *s = str->str_ptr; - register char *send = str->str_ptr + str->str_cur; - register char *t; - register int line = 1; - - while (s && s < send) { - STR *tmpstr = Str_new(85,0); - - 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 bammi@cadence.com\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() +init_perllib() { -#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); +#ifndef TAINT /* Can't allow arbitrary PERLLIB in setuid script */ + incpush(getenv("PERLLIB")); +#endif /* TAINT */ - 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 */ +#ifndef PRIVLIB +#define PRIVLIB "/usr/local/lib/perl" #endif + incpush(PRIVLIB); + (void)av_push(GvAVn(incgv),newSVpv(".",1)); } - |