X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=52ad7ca9c22c7f7d9ee81b2f13dc17457468e374;hb=4b556e6ce00fc77d7d2644507d0f76c5004f26de;hp=41d2e04025a4cb7341972396c5be055b8c133ac5;hpb=eefabb09a1a549c1747d7c554d375ecb16cafff1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 41d2e04..52ad7ca 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; @@ -197,11 +208,11 @@ perl_construct(register PerlInterpreter *sv_interp) localpatches = local_patches; /* For possible -v */ #endif - PerlIO_init(); /* Hook to IO system */ + PerlIO_init(); /* Hook to IO system */ - fdpid = newAV(); /* for remembering popen pids by fd */ + fdpid = newAV(); /* for remembering popen pids by fd */ + modglobal = newHV(); /* pointers to per-interpreter module globals */ - init_stacks(ARGS); DEBUG( { New(51,debname,128,char); New(52,debdelim,128,char); @@ -317,6 +328,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; @@ -340,6 +352,12 @@ perl_destruct(register PerlInterpreter *sv_interp) SvREFCNT_dec(parsehook); parsehook = Nullsv; + /* call exit list functions */ + while (exitlistlen-- > 0) + exitlist[exitlistlen].fn(exitlist[exitlistlen].ptr); + + Safefree(exitlist); + if (destruct_level == 0){ DEBUG_P(debprofdump()); @@ -420,10 +438,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; @@ -545,6 +559,15 @@ perl_free(PerlInterpreter *sv_interp) Safefree(sv_interp); } +void +perl_atexit(void (*fn) (void *), void *ptr) +{ + Renew(exitlist, exitlistlen+1, PerlExitListEntry); + exitlist[exitlistlen].fn = fn; + exitlist[exitlistlen].ptr = ptr; + ++exitlistlen; +} + int perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env) { @@ -556,6 +579,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 +699,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 +960,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 +990,7 @@ print \" \\@INC:\\n @INC\\n\";"); int perl_run(PerlInterpreter *sv_interp) { - dTHR; + dSP; I32 oldscope; dJMPENV; int ret; @@ -978,10 +1026,7 @@ perl_run(PerlInterpreter *sv_interp) JMPENV_POP; return 1; } - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } + POPSTACK_TO(mainstack); break; } @@ -1089,7 +1134,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 +1174,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 +1317,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 +1406,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 +1684,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 +1798,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 +1893,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 +1961,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 +1984,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 +2109,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 +2187,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 +2433,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 +2466,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); @@ -2631,7 +2682,7 @@ init_perllib(void) } /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB + ARCHLIB PRIVLIB SITEARCH and SITELIB */ #ifdef APPLLIB_EXP incpush(APPLLIB_EXP, FALSE); @@ -2651,10 +2702,6 @@ init_perllib(void) #ifdef SITELIB_EXP incpush(SITELIB_EXP, FALSE); #endif -#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ - incpush(OLDARCHLIB_EXP, FALSE); -#endif - if (!tainting) incpush(".", FALSE); } @@ -2741,7 +2788,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")); @@ -2749,7 +2796,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")); @@ -2948,7 +2995,7 @@ my_failure_exit(void) static void my_exit_jump(void) { - dTHR; + dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -2963,6 +3010,7 @@ my_exit_jump(void) e_tmpname = Nullch; } + POPSTACK_TO(mainstack); if (cxstack_ix >= 0) { if (cxstack_ix > 0) dounwind(0);