X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=bc53f5ec52b81a4d08a4878d7e93101c4ac1212b;hb=b7b1864f76048b3925a3516e05f0ced40aaebf56;hp=9595fd2b2be2788d7afcca21c1edf82a9d838fe2;hpb=0fa190096f28eaa3c2a08a9aa7c333cd24617fd7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 9595fd2..bc53f5e 100644 --- a/perl.c +++ b/perl.c @@ -24,6 +24,13 @@ char *getenv _((char *)); /* Usually in */ #endif +#ifdef I_FCNTL +#include +#endif +#ifdef I_SYS_FILE +#include +#endif + dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n"; #ifdef IAMSUID @@ -130,6 +137,9 @@ perl_construct(register PerlInterpreter *sv_interp) COND_INIT(&eval_cond); MUTEX_INIT(&threads_mutex); COND_INIT(&nthreads_cond); +#ifdef EMULATE_ATOMIC_REFCOUNTS + MUTEX_INIT(&svref_mutex); +#endif /* EMULATE_ATOMIC_REFCOUNTS */ thr = init_main_thread(); #endif /* USE_THREADS */ @@ -166,6 +176,7 @@ perl_construct(register PerlInterpreter *sv_interp) #endif } + init_stacks(ARGS); #ifdef MULTIPLICITY I_REINIT; perl_destruct_level = 1; @@ -201,7 +212,6 @@ perl_construct(register PerlInterpreter *sv_interp) fdpid = newAV(); /* for remembering popen pids by fd */ - init_stacks(ARGS); DEBUG( { New(51,debname,128,char); New(52,debdelim,128,char); @@ -420,10 +430,6 @@ perl_destruct(register PerlInterpreter *sv_interp) endav = Nullav; initav = Nullav; - /* temp stack during pp_sort() */ - SvREFCNT_dec(sortstack); - sortstack = Nullav; - /* shortcuts just get cleared */ envgv = Nullgv; siggv = Nullgv; @@ -487,7 +493,7 @@ perl_destruct(register PerlInterpreter *sv_interp) if (hent) { warn("Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); - HeVAL(hent) = Nullsv; + HeVAL(hent) = &sv_undef; hent = HeNEXT(hent); } if (!hent) { @@ -556,6 +562,7 @@ perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **a char *validarg = ""; I32 oldscope; AV* comppadlist; + int e_tmpfd = -1; dJMPENV; int ret; @@ -675,13 +682,36 @@ setuid perl scripts securely.\n"); if (euid != uid || egid != gid) croak("No -e allowed in setuid scripts"); if (!e_fp) { +#if defined(HAS_UMASK) && !defined(VMS) + int oldumask = PerlLIO_umask(0177); +#endif e_tmpname = savepv(TMPPATH); +#ifdef HAS_MKSTEMP + e_tmpfd = PerlLIO_mkstemp(e_tmpname); +#else /* use mktemp() */ (void)PerlLIO_mktemp(e_tmpname); if (!*e_tmpname) - croak("Can't mktemp()"); + croak("Cannot generate temporary filename"); +# if defined(HAS_OPEN3) && defined(O_EXCL) + e_tmpfd = open(e_tmpname, + O_WRONLY | O_CREAT | O_EXCL, + 0600); +# else + (void)UNLINK(e_tmpname); + /* Yes, potential race. But at least we can say we tried. */ e_fp = PerlIO_open(e_tmpname,"w"); - if (!e_fp) - croak("Cannot open temporary file"); +# endif +#endif /* ifdef HAS_MKSTEMP */ +#if defined(HAS_MKSTEMP) || (defined(HAS_OPEN3) && defined(O_EXCL)) + if (e_tmpfd < 0) + croak("Cannot create temporary file \"%s\"", e_tmpname); + e_fp = PerlIO_fdopen(e_tmpfd,"w"); +#endif + if (!e_fp) + croak("Cannot create temporary file \"%s\"", e_tmpname); +#if defined(HAS_UMASK) && !defined(VMS) + (void)PerlLIO_umask(oldumask); +#endif } if (*++s) PerlIO_puts(e_fp,s); @@ -913,6 +943,7 @@ print \" \\@INC:\\n @INC\\n\";"); (void)UNLINK(e_tmpname); Safefree(e_tmpname); e_tmpname = Nullch; + e_tmpfd = -1; } /* now that script is parsed, we can modify record separator */ @@ -942,7 +973,7 @@ print \" \\@INC:\\n @INC\\n\";"); int perl_run(PerlInterpreter *sv_interp) { - dTHR; + dSP; I32 oldscope; dJMPENV; int ret; @@ -978,10 +1009,7 @@ perl_run(PerlInterpreter *sv_interp) JMPENV_POP; return 1; } - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } + POPSTACK_TO(mainstack); break; } @@ -1089,7 +1117,7 @@ perl_call_argv(char *sub_name, I32 flags, register char **argv) { dSP; - PUSHMARK(sp); + PUSHMARK(SP); if (argv) { while (*argv) { XPUSHs(sv_2mortal(newSVpv(*argv,0))); @@ -1129,9 +1157,8 @@ perl_call_sv(SV *sv, I32 flags) /* See G_* flags in cop.h */ { - dTHR; + dSP; LOGOP myop; /* fake syntax tree node */ - SV** sp = stack_sp; I32 oldmark; I32 retval; I32 oldscope; @@ -1273,10 +1300,9 @@ perl_eval_sv(SV *sv, I32 flags) /* See G_* flags in cop.h */ { - dTHR; + dSP; UNOP myop; /* fake syntax tree node */ - SV** sp = stack_sp; - I32 oldmark = sp - stack_base; + I32 oldmark = SP - stack_base; I32 retval; I32 oldscope; dJMPENV; @@ -1363,7 +1389,7 @@ perl_eval_pv(char *p, I32 croak_on_error) dSP; SV* sv = newSVpv(p, 0); - PUSHMARK(sp); + PUSHMARK(SP); perl_eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -1641,7 +1667,7 @@ moreswitches(char *s) #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"); - printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n"); + printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" @@ -1850,7 +1876,7 @@ open_script(char *scriptname, bool dosearch, SV *sv) #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (Stat(cur,&statbuf) >= 0) { + if (PerlLIO_stat(cur,&statbuf) >= 0) { dosearch = 0; scriptname = cur; #ifdef SEARCH_EXTS @@ -1918,7 +1944,7 @@ open_script(char *scriptname, bool dosearch, SV *sv) do { #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); - retval = Stat(tokenbuf,&statbuf); + retval = PerlLIO_stat(tokenbuf,&statbuf); #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ && extidx>=0 && ext[extidx] /* try an extension? */ @@ -1941,7 +1967,7 @@ open_script(char *scriptname, bool dosearch, SV *sv) xfailed = savepv(tokenbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0)) + if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0)) #endif seen_dot = 1; /* Disable message. */ if (!xfound) @@ -2066,7 +2092,7 @@ sed %s -e \"/^[^#]/b\" \ if (!rsfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ - if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && + if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); @@ -2144,7 +2170,7 @@ validate_suid(char *validarg, char *scriptname) #endif || getuid() != euid || geteuid() != uid) croak("Can't swap uid and euid"); /* really paranoid */ - if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) + if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0) croak("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { @@ -2390,26 +2416,30 @@ init_debugger(void) curstash = defstash; } +#ifndef STRESS_REALLOC +#define REASONABLE(size) (size) +#else +#define REASONABLE(size) (1) /* unreasonable */ +#endif + void init_stacks(ARGSproto) { - curstack = newAV(); + /* start with 128-item stack and 8K cxstack */ + curstackinfo = new_stackinfo(REASONABLE(128), + REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); + curstackinfo->si_type = SI_MAIN; + curstack = curstackinfo->si_stack; mainstack = curstack; /* remember in case we switch stacks */ - AvREAL_off(curstack); /* not a real array */ - av_extend(curstack,127); stack_base = AvARRAY(curstack); stack_sp = stack_base; - stack_max = stack_base + 127; - - cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */ - New(50,cxstack,cxstack_max + 1,PERL_CONTEXT); - cxstack_ix = -1; + stack_max = stack_base + AvMAX(curstack); - New(50,tmps_stack,128,SV*); + New(50,tmps_stack,REASONABLE(128),SV*); tmps_floor = -1; tmps_ix = -1; - tmps_max = 128; + tmps_max = REASONABLE(128); /* * The following stacks almost certainly should be per-interpreter, @@ -2419,41 +2449,53 @@ init_stacks(ARGSproto) if (markstack) { markstack_ptr = markstack; } else { - New(54,markstack,64,I32); + New(54,markstack,REASONABLE(32),I32); markstack_ptr = markstack; - markstack_max = markstack + 64; + markstack_max = markstack + REASONABLE(32); } + SET_MARKBASE; + if (scopestack) { scopestack_ix = 0; } else { - New(54,scopestack,32,I32); + New(54,scopestack,REASONABLE(32),I32); scopestack_ix = 0; - scopestack_max = 32; + scopestack_max = REASONABLE(32); } if (savestack) { savestack_ix = 0; } else { - New(54,savestack,128,ANY); + New(54,savestack,REASONABLE(128),ANY); savestack_ix = 0; - savestack_max = 128; + savestack_max = REASONABLE(128); } if (retstack) { retstack_ix = 0; } else { - New(54,retstack,16,OP*); + New(54,retstack,REASONABLE(16),OP*); retstack_ix = 0; - retstack_max = 16; + retstack_max = REASONABLE(16); } } +#undef REASONABLE + static void nuke_stacks(void) { dTHR; - Safefree(cxstack); + while (curstackinfo->si_next) + curstackinfo = curstackinfo->si_next; + while (curstackinfo) { + PERL_SI *p = curstackinfo->si_prev; + SvREFCNT_dec(curstackinfo->si_stack); + Safefree(curstackinfo->si_cxstack); + Safefree(curstackinfo); + curstackinfo = p; + } Safefree(tmps_stack); DEBUG( { Safefree(debname); @@ -2729,7 +2771,7 @@ incpush(char *p, int addsubdirs) /* .../archname/version if -d .../archname/version/auto */ sv_setsv(subdir, libdir); sv_catpv(subdir, archpat_auto); - if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(incgv), newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto")); @@ -2737,7 +2779,7 @@ incpush(char *p, int addsubdirs) /* .../archname if -d .../archname/auto */ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME), strlen(patchlevel) + 1, "", 0); - if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 && + if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) av_push(GvAVn(incgv), newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));