X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=0c525579af891fa060157508f59dc102329d8da0;hb=9731c6ca89275fa6ca122bfe3be4600e5836a905;hp=f2fc06390fb83faa768aa9b415ac6ff5d38bbb28;hpb=554b3ecafd2a8f619792c82298bc621b9e48a923;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index f2fc063..0c52557 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-1997 Larry Wall + * Copyright (c) 1987-1998 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -69,6 +69,9 @@ static void init_ids _((void)); static void init_debugger _((void)); static void init_lexer _((void)); static void init_main_stash _((void)); +#ifdef USE_THREADS +static struct perl_thread * init_main_thread _((void)); +#endif /* USE_THREADS */ static void init_perllib _((void)); static void init_postdump_symbols _((int, char **, char **)); static void init_predump_symbols _((void)); @@ -80,21 +83,8 @@ static void validate_suid _((char *, char*)); static int fdscript = -1; -#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) -#include -static void -catch_sigsegv(int signo, struct sigcontext_struct sc) -{ - signal(SIGSEGV, SIG_DFL); - fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n" - "return_address = 0x%lx, eip = 0x%lx\n", - sc.cr2, __builtin_return_address(0), sc.eip); - fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR); -} -#endif - PerlInterpreter * -perl_alloc() +perl_alloc(void) { PerlInterpreter *sv_interp; @@ -104,13 +94,12 @@ perl_alloc() } void -perl_construct( sv_interp ) -register PerlInterpreter *sv_interp; +perl_construct(register PerlInterpreter *sv_interp) { #ifdef USE_THREADS int i; #ifndef FAKE_THREADS - struct thread *thr; + struct perl_thread *thr; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ @@ -126,9 +115,12 @@ register PerlInterpreter *sv_interp; #ifdef USE_THREADS INIT_THREADS; +#ifdef ALLOC_THREAD_KEY + ALLOC_THREAD_KEY; +#else if (pthread_key_create(&thr_key, 0)) croak("panic: pthread_key_create"); - MUTEX_INIT(&malloc_mutex); +#endif MUTEX_INIT(&sv_mutex); /* * Safe to use basic SV functions from now on (though @@ -139,7 +131,7 @@ register PerlInterpreter *sv_interp; MUTEX_INIT(&threads_mutex); COND_INIT(&nthreads_cond); - thr = new_struct_thread(0); + thr = init_main_thread(); #endif /* USE_THREADS */ linestr = NEWSV(65,80); @@ -219,8 +211,7 @@ register PerlInterpreter *sv_interp; } void -perl_destruct(sv_interp) -register PerlInterpreter *sv_interp; +perl_destruct(register PerlInterpreter *sv_interp) { dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ @@ -307,7 +298,7 @@ register PerlInterpreter *sv_interp; #ifdef DEBUGGING { char *s; - if (s = getenv("PERL_DESTRUCT_LEVEL")) { + if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) { int i = atoi(s); if (destruct_level < i) destruct_level = i; @@ -413,36 +404,6 @@ register PerlInterpreter *sv_interp; /* defgv, aka *_ should be taken care of elsewhere */ -#if 0 /* just about all regexp stuff, seems to be ok */ - - /* shortcuts to regexp stuff */ - leftgv = Nullgv; - ampergv = Nullgv; - - SAVEFREEOP(curpm); - SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */ - - regprecomp = NULL; /* uncompiled string. */ - regparse = NULL; /* Input-scan pointer. */ - regxend = NULL; /* End of input for compile */ - regnpar = 0; /* () count. */ - regcode = NULL; /* Code-emit pointer; ®dummy = don't. */ - regsize = 0; /* Code size. */ - regnaughty = 0; /* How bad is this pattern? */ - regsawback = 0; /* Did we see \1, ...? */ - - reginput = NULL; /* String-input pointer. */ - regbol = NULL; /* Beginning of input, for ^ check. */ - regeol = NULL; /* End of input, for $ check. */ - regstartp = (char **)NULL; /* Pointer to startp array. */ - regendp = (char **)NULL; /* Ditto for endp. */ - reglastparen = 0; /* Similarly for lastparen. */ - regtill = NULL; /* How far we are required to go. */ - regflags = 0; /* are we folding, multilining? */ - regprev = (char)NULL; /* char before regbol, \n if none */ - -#endif /* if 0 */ - /* clean up after study() */ SvREFCNT_dec(lastscream); lastscream = Nullsv; @@ -467,8 +428,7 @@ register PerlInterpreter *sv_interp; envgv = Nullgv; siggv = Nullgv; incgv = Nullgv; - errhv = Nullhv; - errsv = Nullsv; + errgv = Nullgv; argvgv = Nullgv; argvoutgv = Nullgv; stdingv = Nullgv; @@ -555,7 +515,6 @@ register PerlInterpreter *sv_interp; DEBUG_P(debprofdump()); #ifdef USE_THREADS MUTEX_DESTROY(&sv_mutex); - MUTEX_DESTROY(&malloc_mutex); MUTEX_DESTROY(&eval_mutex); COND_DESTROY(&eval_cond); @@ -579,8 +538,7 @@ register PerlInterpreter *sv_interp; } void -perl_free(sv_interp) -PerlInterpreter *sv_interp; +perl_free(PerlInterpreter *sv_interp) { if (!(curinterp = sv_interp)) return; @@ -588,12 +546,7 @@ PerlInterpreter *sv_interp; } int -perl_parse(sv_interp, xsinit, argc, argv, env) -PerlInterpreter *sv_interp; -void (*xsinit)_((void)); -int argc; -char **argv; -char **env; +perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env) { dTHR; register SV *sv; @@ -723,7 +676,7 @@ setuid perl scripts securely.\n"); croak("No -e allowed in setuid scripts"); if (!e_fp) { e_tmpname = savepv(TMPPATH); - (void)mktemp(e_tmpname); + (void)PerlLIO_mktemp(e_tmpname); if (!*e_tmpname) croak("Can't mktemp()"); e_fp = PerlIO_open(e_tmpname,"w"); @@ -855,7 +808,7 @@ print \" \\@INC:\\n @INC\\n\";"); } switch_end: - if (!tainting && (s = getenv("PERL5OPT"))) { + if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) { while (s && *s) { while (isSPACE(*s)) s++; @@ -887,7 +840,7 @@ print \" \\@INC:\\n @INC\\n\";"); } else if (scriptname == Nullch) { #ifdef MSDOS - if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) + if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) moreswitches("h"); #endif scriptname = "-"; @@ -931,14 +884,10 @@ print \" \\@INC:\\n @INC\\n\";"); boot_core_UNIVERSAL(); if (xsinit) (*xsinit)(); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) init_os_extras(); #endif -#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__) - DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv);); -#endif - init_predump_symbols(); if (!do_undump) init_postdump_symbols(argc,argv,env); @@ -947,6 +896,7 @@ print \" \\@INC:\\n @INC\\n\";"); /* now parse the script */ + SETERRNO(0,SS$_NORMAL); error_count = 0; if (yyparse() || error_count) { if (minus_c) @@ -968,11 +918,7 @@ print \" \\@INC:\\n @INC\\n\";"); /* now that script is parsed, we can modify record separator */ SvREFCNT_dec(rs); rs = SvREFCNT_inc(nrs); -#ifdef USE_THREADS - sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs); -#else - sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); -#endif /* USE_THREADS */ + sv_setsv(perl_get_sv("/", TRUE), rs); if (do_undump) my_unexec(); @@ -983,7 +929,7 @@ print \" \\@INC:\\n @INC\\n\";"); FREETMPS; #ifdef MYMALLOC - if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) + if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2) dump_mstats("after compilation:"); #endif @@ -994,8 +940,7 @@ print \" \\@INC:\\n @INC\\n\";"); } int -perl_run(sv_interp) -PerlInterpreter *sv_interp; +perl_run(PerlInterpreter *sv_interp) { dTHR; I32 oldscope; @@ -1021,7 +966,7 @@ PerlInterpreter *sv_interp; if (endav) call_list(oldscope, endav); #ifdef MYMALLOC - if (getenv("PERL_DEBUG_MSTATS")) + if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif JMPENV_POP; @@ -1080,20 +1025,26 @@ PerlInterpreter *sv_interp; } SV* -perl_get_sv(name, create) -char* name; -I32 create; +perl_get_sv(char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PV); + GV *gv; +#ifdef USE_THREADS + if (name[1] == '\0' && !isALPHA(name[0])) { + PADOFFSET tmp = find_threadsv(name); + if (tmp != NOT_IN_PAD) { + dTHR; + return THREADSV(tmp); + } + } +#endif /* USE_THREADS */ + gv = gv_fetchpv(name, create, SVt_PV); if (gv) return GvSV(gv); return Nullsv; } AV* -perl_get_av(name, create) -char* name; -I32 create; +perl_get_av(char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVAV); if (create) @@ -1104,9 +1055,7 @@ I32 create; } HV* -perl_get_hv(name, create) -char* name; -I32 create; +perl_get_hv(char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVHV); if (create) @@ -1117,9 +1066,7 @@ I32 create; } CV* -perl_get_cv(name, create) -char* name; -I32 create; +perl_get_cv(char *name, I32 create) { GV* gv = gv_fetchpv(name, create, SVt_PVCV); if (create && !GvCVu(gv)) @@ -1135,12 +1082,11 @@ I32 create; /* Be sure to refetch the stack pointer after calling these routines. */ I32 -perl_call_argv(subname, flags, argv) -char *subname; -I32 flags; /* See G_* flags in cop.h */ -register char **argv; /* null terminated arg list */ +perl_call_argv(char *sub_name, I32 flags, register char **argv) + + /* See G_* flags in cop.h */ + /* null terminated arg list */ { - dTHR; dSP; PUSHMARK(sp); @@ -1151,23 +1097,22 @@ register char **argv; /* null terminated arg list */ } PUTBACK; } - return perl_call_pv(subname, flags); + return perl_call_pv(sub_name, flags); } I32 -perl_call_pv(subname, flags) -char *subname; /* name of the subroutine */ -I32 flags; /* See G_* flags in cop.h */ +perl_call_pv(char *sub_name, I32 flags) + /* name of the subroutine */ + /* See G_* flags in cop.h */ { - return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags); + return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags); } I32 -perl_call_method(methname, flags) -char *methname; /* name of the subroutine */ -I32 flags; /* See G_* flags in cop.h */ +perl_call_method(char *methname, I32 flags) + /* name of the subroutine */ + /* See G_* flags in cop.h */ { - dTHR; dSP; OP myop; if (!op) @@ -1180,9 +1125,9 @@ I32 flags; /* See G_* flags in cop.h */ /* May be called with any of a CV, a GV, or an SV containing the name. */ I32 -perl_call_sv(sv, flags) -SV* sv; -I32 flags; /* See G_* flags in cop.h */ +perl_call_sv(SV *sv, I32 flags) + + /* See G_* flags in cop.h */ { dTHR; LOGOP myop; /* fake syntax tree node */ @@ -1229,7 +1174,7 @@ I32 flags; /* See G_* flags in cop.h */ markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme = GIMME_V; ENTER; @@ -1244,7 +1189,7 @@ I32 flags; /* See G_* flags in cop.h */ if (flags & G_KEEPERR) in_eval |= 4; else - sv_setpv(errsv,""); + sv_setpv(ERRSV,""); } markstack_ptr++; @@ -1289,7 +1234,7 @@ I32 flags; /* See G_* flags in cop.h */ runops(); retval = stack_sp - (stack_base + oldmark); if ((flags & G_EVAL) && !(flags & G_KEEPERR)) - sv_setpv(errsv,""); + sv_setpv(ERRSV,""); cleanup: if (flags & G_EVAL) { @@ -1297,7 +1242,7 @@ I32 flags; /* See G_* flags in cop.h */ SV **newsp; PMOP *newpm; I32 gimme; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 optype; POPBLOCK(cx,newpm); @@ -1324,9 +1269,9 @@ I32 flags; /* See G_* flags in cop.h */ /* Eval a string. The G_EVAL flag is always assumed. */ I32 -perl_eval_sv(sv, flags) -SV* sv; -I32 flags; /* See G_* flags in cop.h */ +perl_eval_sv(SV *sv, I32 flags) + + /* See G_* flags in cop.h */ { dTHR; UNOP myop; /* fake syntax tree node */ @@ -1398,7 +1343,7 @@ I32 flags; /* See G_* flags in cop.h */ runops(); retval = stack_sp - (stack_base + oldmark); if (!(flags & G_KEEPERR)) - sv_setpv(errsv,""); + sv_setpv(ERRSV,""); cleanup: JMPENV_POP; @@ -1413,11 +1358,8 @@ I32 flags; /* See G_* flags in cop.h */ } SV* -perl_eval_pv(p, croak_on_error) -char* p; -I32 croak_on_error; +perl_eval_pv(char *p, I32 croak_on_error) { - dTHR; dSP; SV* sv = newSVpv(p, 0); @@ -1429,8 +1371,8 @@ I32 croak_on_error; sv = POPs; PUTBACK; - if (croak_on_error && SvTRUE(errsv)) - croak(SvPV(errsv, na)); + if (croak_on_error && SvTRUE(ERRSV)) + croak(SvPVx(ERRSV, na)); return sv; } @@ -1438,8 +1380,7 @@ I32 croak_on_error; /* Require a module. */ void -perl_require_pv(pv) -char* pv; +perl_require_pv(char *pv) { SV* sv = sv_newmortal(); sv_setpv(sv, "require '"); @@ -1449,10 +1390,7 @@ char* pv; } void -magicname(sym,name,namlen) -char *sym; -char *name; -I32 namlen; +magicname(char *sym, char *name, I32 namlen) { register GV *gv; @@ -1461,8 +1399,8 @@ I32 namlen; } static void -usage(name) /* XXX move this out into a module ? */ -char *name; +usage(char *name) /* XXX move this out into a module ? */ + { /* This message really ought to be max 23 lines. * Removed -h because the user already knows that opton. Others? */ @@ -1504,8 +1442,7 @@ NULL /* This routine handles any switches that can be given during run */ char * -moreswitches(s) -char *s; +moreswitches(char *s) { I32 numlen; U32 rschar; @@ -1574,7 +1511,7 @@ char *s; return s; case 'h': usage(origargv[0]); - exit(0); + PerlProc_exit(0); case 'i': if (inplace) Safefree(inplace); @@ -1698,16 +1635,17 @@ char *s; LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - printf("\n\nCopyright 1987-1997, Larry Wall\n"); + printf("\n\nCopyright 1987-1998, Larry Wall\n"); #ifdef MSDOS printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef DJGPP printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\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" - "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n"); + "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist printf("atariST series port, ++jrb bammi@cadence.com\n"); @@ -1715,7 +1653,7 @@ char *s; printf("\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\n"); - exit(0); + PerlProc_exit(0); case 'w': dowarn = TRUE; s++; @@ -1727,6 +1665,9 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") break; case '-': case 0: +#ifdef WIN32 + case '\r': +#endif case '\n': case '\t': break; @@ -1749,7 +1690,7 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n") /* unexec() can be found in the Gnu emacs distribution */ void -my_unexec() +my_unexec(void) { #ifdef UNEXEC SV* prog; @@ -1766,7 +1707,7 @@ my_unexec() if (status) PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", SvPVX(prog), SvPVX(file)); - exit(status); + PerlProc_exit(status); #else # ifdef VMS # include @@ -1778,7 +1719,7 @@ my_unexec() } static void -init_main_stash() +init_main_stash(void) { dTHR; GV *gv; @@ -1801,28 +1742,21 @@ init_main_stash() incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(incgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); - errsv = newSVpv("", 0); - errhv = newHV(); + errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); + GvMULTI_on(errgv); (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ - sv_grow(errsv, 240); /* Preallocate - for immediate signals. */ - sv_setpvn(errsv, "", 0); + sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ + sv_setpvn(ERRSV, "", 0); curstash = defstash; compiling.cop_stash = defstash; debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); + globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ 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; @@ -1861,7 +1795,7 @@ SV *sv; * * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search * proceeds as follows: - * If DOSISH: + * If DOSISH or VMSISH: * + look for ./scriptname{,.foo,.bar} * + search the PATH for scriptname{,.foo,.bar} * @@ -1871,11 +1805,20 @@ SV *sv; */ #ifdef VMS +# ifdef ALWAYS_DEFTYPES + len = strlen(scriptname); + if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { + int hasdir, idx = 0, deftypes = 1; + bool seen_dot = 1; + + hasdir = !dosearch || (strpbrk(scriptname,":[= 0) { - rsfp = PerlIO_fdopen(fdscript,"r"); + rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ @@ -2102,7 +2045,7 @@ sed %s -e \"/^[^#]/b\" \ croak("Can't do seteuid!\n"); } #endif /* IAMSUID */ - rsfp = my_popen(SvPVX(cmd), "r"); + rsfp = PerlProc_popen(SvPVX(cmd), "r"); SvREFCNT_dec(cmd); SvREFCNT_dec(cpp); } @@ -2111,7 +2054,7 @@ sed %s -e \"/^[^#]/b\" \ rsfp = PerlIO_stdin(); } else { - rsfp = PerlIO_open(scriptname,"r"); + rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #if defined(HAS_FCNTL) && defined(F_SETFD) if (rsfp) fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ @@ -2126,7 +2069,7 @@ sed %s -e \"/^[^#]/b\" \ if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); + PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); croak("Can't do setuid\n"); } #endif @@ -2137,9 +2080,7 @@ sed %s -e \"/^[^#]/b\" \ } static void -validate_suid(validarg, scriptname) -char *validarg; -char *scriptname; +validate_suid(char *validarg, char *scriptname) { int which; @@ -2167,7 +2108,7 @@ char *scriptname; dTHR; char *s, *s2; - if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ + if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ croak("Can't stat script \"%s\"",origfilename); if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; @@ -2182,7 +2123,7 @@ char *scriptname; * But I don't think it's too important. The manual lies when * it says access() is useful in setuid programs. */ - if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/ + if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/ croak("Permission denied"); #else /* If we can swap euid and uid, then we can determine access rights @@ -2208,7 +2149,7 @@ char *scriptname; if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { (void)PerlIO_close(rsfp); - if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ + if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ PerlIO_printf(rsfp, "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n", @@ -2216,7 +2157,7 @@ char *scriptname; (long)statbuf.st_dev, (long)statbuf.st_ino, SvPVX(GvSV(curcop->cop_filegv)), (long)statbuf.st_uid, (long)statbuf.st_gid); - (void)my_pclose(rsfp); + (void)PerlProc_pclose(rsfp); } croak("Permission denied\n"); } @@ -2275,7 +2216,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); (void)PerlIO_close(rsfp); #ifndef IAMSUID /* try again */ - execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); + PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv); #endif croak("Can't do setuid\n"); } @@ -2348,7 +2289,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* exec the real perl, substituting fd script for scriptname. */ /* (We pass script name as "subdir" of fd, which perl will grok.) */ PerlIO_rewind(rsfp); - lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ + PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ; if (!origargv[which]) croak("Permission denied"); @@ -2357,14 +2298,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif - execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */ + PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */ croak("Can't do setuid\n"); #endif /* IAMSUID */ #else /* !DOSUID */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW dTHR; - Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ + PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) @@ -2379,7 +2320,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); } static void -find_beginning() +find_beginning(void) { register char *s, *s2; @@ -2401,14 +2342,14 @@ find_beginning() /*SUPPRESS 530*/ while (s = moreswitches(s)) ; } - if (cddir && chdir(cddir) < 0) + if (cddir && PerlDir_chdir(cddir) < 0) croak("Can't chdir to %s",cddir); } } } static void -init_ids() +init_ids(void) { uid = (int)getuid(); euid = (int)geteuid(); @@ -2422,8 +2363,7 @@ init_ids() } static void -forbid_setid(s) -char *s; +forbid_setid(char *s) { if (euid != uid) croak("No %s allowed while running setuid", s); @@ -2432,7 +2372,7 @@ char *s; } static void -init_debugger() +init_debugger(void) { dTHR; curstash = debstash; @@ -2451,8 +2391,7 @@ init_debugger() } void -init_stacks(ARGS) -dARGS +init_stacks(ARGSproto) { curstack = newAV(); mainstack = curstack; /* remember in case we switch stacks */ @@ -2463,8 +2402,8 @@ dARGS stack_sp = stack_base; stack_max = stack_base + 127; - cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */ - New(50,cxstack,cxstack_max + 1,CONTEXT); + cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */ + New(50,cxstack,cxstack_max + 1,PERL_CONTEXT); cxstack_ix = -1; New(50,tmps_stack,128,SV*); @@ -2511,7 +2450,7 @@ dARGS } static void -nuke_stacks() +nuke_stacks(void) { dTHR; Safefree(cxstack); @@ -2525,7 +2464,7 @@ nuke_stacks() static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ static void -init_lexer() +init_lexer(void) { tmpfp = rsfp; rsfp = Nullfp; @@ -2535,18 +2474,13 @@ init_lexer() } static void -init_predump_symbols() +init_predump_symbols(void) { dTHR; GV *tmpgv; GV *othergv; -#ifdef USE_THREADS - sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1); -#else - sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); -#endif /* USE_THREADS */ - + sv_setpvn(perl_get_sv("\"", TRUE), " ", 1); stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); IoIFP(GvIOp(stdingv)) = PerlIO_stdin(); @@ -2576,10 +2510,7 @@ init_predump_symbols() } static void -init_postdump_symbols(argc,argv,env) -register int argc; -register char **argv; -register char **env; +init_postdump_symbols(register int argc, register char **argv, register char **env) { dTHR; char *s; @@ -2645,7 +2576,7 @@ register char **env; if (!(s = strchr(*env,'='))) continue; *s++ = '\0'; -#ifdef WIN32 +#if defined(WIN32) || defined(MSDOS) (void)strupr(*env); #endif sv = newSVpv(s--,0); @@ -2653,7 +2584,7 @@ register char **env; *s = '='; #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV) /* Sins of the RTL. See note in my_setenv(). */ - (void)putenv(savepv(*env)); + (void)PerlEnv_putenv(savepv(*env)); #endif } #endif @@ -2667,16 +2598,16 @@ register char **env; } static void -init_perllib() +init_perllib(void) { char *s; if (!tainting) { #ifndef VMS - s = getenv("PERL5LIB"); + s = PerlEnv_getenv("PERL5LIB"); if (s) incpush(s, TRUE); else - incpush(getenv("PERLLIB"), FALSE); + incpush(PerlEnv_getenv("PERLLIB"), FALSE); #else /* VMS */ /* Treat PERL5?LIB as a possible search list logical name -- the * "natural" VMS idiom for a Unix path string. We allow each @@ -2692,7 +2623,7 @@ init_perllib() } /* 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); @@ -2712,10 +2643,6 @@ init_perllib() #ifdef SITELIB_EXP incpush(SITELIB_EXP, FALSE); #endif -#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */ - incpush(OLDARCHLIB_EXP, FALSE); -#endif - if (!tainting) incpush(".", FALSE); } @@ -2734,9 +2661,7 @@ init_perllib() #endif static void -incpush(p, addsubdirs) -char *p; -int addsubdirs; +incpush(char *p, int addsubdirs) { SV *subdir = Nullsv; static char *archpat_auto; @@ -2745,7 +2670,7 @@ int addsubdirs; return; if (addsubdirs) { - subdir = newSV(0); + subdir = NEWSV(55,0); if (!archpat_auto) { STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) + sizeof("//auto")); @@ -2761,7 +2686,7 @@ int addsubdirs; /* Break at all separators */ while (p && *p) { - SV *libdir = newSV(0); + SV *libdir = NEWSV(55,0); char *s; /* skip any consecutive separators */ @@ -2825,10 +2750,73 @@ int addsubdirs; SvREFCNT_dec(subdir); } +#ifdef USE_THREADS +static struct perl_thread * +init_main_thread() +{ + struct perl_thread *thr; + XPV *xpv; + + Newz(53, thr, 1, struct perl_thread); + curcop = &compiling; + thr->cvcache = newHV(); + thr->threadsv = newAV(); + /* thr->threadsvp is set when find_threadsv is called */ + thr->specific = newAV(); + thr->errhv = newHV(); + thr->flags = THRf_R_JOINABLE; + MUTEX_INIT(&thr->mutex); + /* Handcraft thrsv similarly to mess_sv */ + New(53, thrsv, 1, SV); + Newz(53, xpv, 1, XPV); + SvFLAGS(thrsv) = SVt_PV; + SvANY(thrsv) = (void*)xpv; + SvREFCNT(thrsv) = 1 << 30; /* practically infinite */ + SvPVX(thrsv) = (char*)thr; + SvCUR_set(thrsv, sizeof(thr)); + SvLEN_set(thrsv, sizeof(thr)); + *SvEND(thrsv) = '\0'; /* in the trailing_nul field */ + thr->oursv = thrsv; + curcop = &compiling; + chopset = " \n-"; + + MUTEX_LOCK(&threads_mutex); + nthreads++; + thr->tid = 0; + thr->next = thr; + thr->prev = thr; + MUTEX_UNLOCK(&threads_mutex); + +#ifdef HAVE_THREAD_INTERN + init_thread_intern(thr); +#endif + +#ifdef SET_THREAD_SELF + SET_THREAD_SELF(thr); +#else + thr->self = pthread_self(); +#endif /* SET_THREAD_SELF */ + SET_THR(thr); + + /* + * These must come after the SET_THR because sv_setpvn does + * SvTAINT and the taint fields require dTHR. + */ + 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; + thr->errsv = newSVpv("", 0); + (void) find_threadsv("@"); /* Ensure $@ is initialised early */ + return thr; +} +#endif /* USE_THREADS */ + void -call_list(oldscope, list) -I32 oldscope; -AV* list; +call_list(I32 oldscope, AV *list) { dTHR; line_t oldline = curcop->cop_line; @@ -2836,7 +2824,7 @@ AV* list; dJMPENV; int ret; - while (AvFILL(list) >= 0) { + while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); @@ -2844,20 +2832,21 @@ AV* list; JMPENV_PUSH(ret); switch (ret) { case 0: { + SV* atsv = ERRSV; PUSHMARK(stack_sp); perl_call_sv((SV*)cv, G_EVAL|G_DISCARD); - (void)SvPV(errsv, len); + (void)SvPV(atsv, len); if (len) { JMPENV_POP; curcop = &compiling; curcop->cop_line = oldline; if (list == beginav) - sv_catpv(errsv, "BEGIN failed--compilation aborted"); + sv_catpv(atsv, "BEGIN failed--compilation aborted"); else - sv_catpv(errsv, "END failed--cleanup aborted"); + sv_catpv(atsv, "END failed--cleanup aborted"); while (scopestack_ix > oldscope) LEAVE; - croak("%s", SvPVX(errsv)); + croak("%s", SvPVX(atsv)); } } break; @@ -2899,8 +2888,7 @@ AV* list; } void -my_exit(status) -U32 status; +my_exit(U32 status) { dTHR; @@ -2923,7 +2911,7 @@ U32 status; } void -my_failure_exit() +my_failure_exit(void) { #ifdef VMS if (vaxc$errno & 1) { @@ -2946,10 +2934,10 @@ my_failure_exit() } static void -my_exit_jump() +my_exit_jump(void) { dTHR; - register CONTEXT *cx; + register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -2972,3 +2960,6 @@ my_exit_jump() JMPENV_JUMP(2); } + + +