X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=a4e82333e9c42c72f8e78397966891bfaf53c085;hb=e17cb2a9c513ce1acd034452f9a933fcfa6c0129;hp=6b5b2f61b2f4cca3aeef8e8d79c16b685f0b8e90;hpb=dfe9444ca7881e716e9e8feaf20b55da491363ca;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 6b5b2f6..a4e8233 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); @@ -317,6 +327,7 @@ perl_destruct(register PerlInterpreter *sv_interp) op_free(main_root); main_root = Nullop; } + curcop = &compiling; main_start = Nullop; SvREFCNT_dec(main_cv); main_cv = Nullcv; @@ -420,10 +431,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; @@ -556,6 +563,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 +683,36 @@ setuid perl scripts securely.\n"); if (euid != uid || egid != gid) croak("No -e allowed in setuid scripts"); if (!e_fp) { +#ifdef HAS_UMASK + 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); +#ifdef HAS_UMASK + (void)PerlLIO_umask(oldumask); +#endif } if (*++s) PerlIO_puts(e_fp,s); @@ -913,6 +944,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 +974,7 @@ print \" \\@INC:\\n @INC\\n\";"); int perl_run(PerlInterpreter *sv_interp) { - dTHR; + dSP; I32 oldscope; dJMPENV; int ret; @@ -978,10 +1010,7 @@ perl_run(PerlInterpreter *sv_interp) JMPENV_POP; return 1; } - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } + POPSTACK_TO(mainstack); break; } @@ -1089,7 +1118,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 +1158,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 +1301,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 +1390,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 +1668,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" @@ -1755,16 +1782,8 @@ init_main_stash(void) sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1); } -#ifdef CAN_PROTOTYPE static void open_script(char *scriptname, bool dosearch, SV *sv) -#else -static void -open_script(scriptname,dosearch,sv) -char *scriptname; -bool dosearch; -SV *sv; -#endif { dTHR; char *xfound = Nullch; @@ -1858,7 +1877,7 @@ 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 @@ -1926,7 +1945,7 @@ 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? */ @@ -1949,7 +1968,7 @@ 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) @@ -2074,7 +2093,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); @@ -2152,7 +2171,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) { @@ -2398,26 +2417,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, @@ -2427,41 +2450,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; + /* curstackinfo->si_stack got nuked by sv_free_arenas() */ + Safefree(curstackinfo->si_cxstack); + Safefree(curstackinfo); + curstackinfo = p; + } Safefree(tmps_stack); DEBUG( { Safefree(debname); @@ -2737,7 +2772,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")); @@ -2745,7 +2780,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")); @@ -2944,7 +2979,7 @@ my_failure_exit(void) static void my_exit_jump(void) { - dTHR; + dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -2959,6 +2994,7 @@ my_exit_jump(void) e_tmpname = Nullch; } + POPSTACK_TO(mainstack); if (cxstack_ix >= 0) { if (cxstack_ix > 0) dounwind(0);