X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=41d2e04025a4cb7341972396c5be055b8c133ac5;hb=eefabb09a1a549c1747d7c554d375ecb16cafff1;hp=6f3e15c2d066dbb4af1764e8a5cbf08812bf95d4;hpb=c277df42229d99fecbc76f5da53793a409ac66e1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 6f3e15c..41d2e04 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. @@ -70,7 +70,7 @@ static void init_debugger _((void)); static void init_lexer _((void)); static void init_main_stash _((void)); #ifdef USE_THREADS -static struct thread * init_main_thread _((void)); +static struct perl_thread * init_main_thread _((void)); #endif /* USE_THREADS */ static void init_perllib _((void)); static void init_postdump_symbols _((int, char **, char **)); @@ -83,19 +83,6 @@ 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(void) { @@ -112,7 +99,7 @@ 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 */ @@ -134,7 +121,6 @@ perl_construct(register PerlInterpreter *sv_interp) if (pthread_key_create(&thr_key, 0)) croak("panic: pthread_key_create"); #endif - MUTEX_INIT(&malloc_mutex); MUTEX_INIT(&sv_mutex); /* * Safe to use basic SV functions from now on (though @@ -312,7 +298,7 @@ perl_destruct(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; @@ -529,7 +515,6 @@ perl_destruct(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); @@ -691,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"); @@ -823,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++; @@ -855,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 = "-"; @@ -899,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); @@ -915,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) @@ -936,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(); @@ -951,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 @@ -988,7 +966,7 @@ perl_run(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; @@ -1052,10 +1030,10 @@ perl_get_sv(char *name, I32 create) GV *gv; #ifdef USE_THREADS if (name[1] == '\0' && !isALPHA(name[0])) { - PADOFFSET tmp = find_thread_magical(name); + PADOFFSET tmp = find_threadsv(name); if (tmp != NOT_IN_PAD) { dTHR; - return *av_fetch(thr->magicals, tmp, FALSE); + return THREADSV(tmp); } } #endif /* USE_THREADS */ @@ -1104,7 +1082,7 @@ perl_get_cv(char *name, I32 create) /* Be sure to refetch the stack pointer after calling these routines. */ I32 -perl_call_argv(char *subname, I32 flags, register char **argv) +perl_call_argv(char *sub_name, I32 flags, register char **argv) /* See G_* flags in cop.h */ /* null terminated arg list */ @@ -1119,15 +1097,15 @@ perl_call_argv(char *subname, I32 flags, register char **argv) } PUTBACK; } - return perl_call_pv(subname, flags); + return perl_call_pv(sub_name, flags); } I32 -perl_call_pv(char *subname, I32 flags) +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 @@ -1533,7 +1511,7 @@ moreswitches(char *s) return s; case 'h': usage(origargv[0]); - exit(0); + PerlProc_exit(0); case 'i': if (inplace) Safefree(inplace); @@ -1657,16 +1635,17 @@ moreswitches(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\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"); @@ -1674,7 +1653,7 @@ moreswitches(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++; @@ -1686,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; @@ -1725,7 +1707,7 @@ my_unexec(void) 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 @@ -1821,7 +1803,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} * @@ -1831,11 +1813,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 */ @@ -2062,7 +2053,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); } @@ -2071,7 +2062,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 */ @@ -2086,7 +2077,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 @@ -2125,7 +2116,7 @@ validate_suid(char *validarg, 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; @@ -2140,7 +2131,7 @@ validate_suid(char *validarg, 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 @@ -2166,7 +2157,7 @@ validate_suid(char *validarg, 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", @@ -2174,7 +2165,7 @@ validate_suid(char *validarg, 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"); } @@ -2233,7 +2224,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"); } @@ -2306,7 +2297,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"); @@ -2315,14 +2306,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) @@ -2359,7 +2350,7 @@ find_beginning(void) /*SUPPRESS 530*/ while (s = moreswitches(s)) ; } - if (cddir && chdir(cddir) < 0) + if (cddir && PerlDir_chdir(cddir) < 0) croak("Can't chdir to %s",cddir); } } @@ -2497,12 +2488,7 @@ init_predump_symbols(void) 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(); @@ -2598,7 +2584,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e if (!(s = strchr(*env,'='))) continue; *s++ = '\0'; -#ifdef WIN32 +#if defined(WIN32) || defined(MSDOS) (void)strupr(*env); #endif sv = newSVpv(s--,0); @@ -2606,7 +2592,7 @@ init_postdump_symbols(register int argc, register char **argv, register char **e *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 @@ -2625,11 +2611,11 @@ 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 @@ -2696,7 +2682,7 @@ incpush(char *p, int addsubdirs) return; if (addsubdirs) { - subdir = newSV(0); + subdir = NEWSV(55,0); if (!archpat_auto) { STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel) + sizeof("//auto")); @@ -2712,7 +2698,7 @@ incpush(char *p, int addsubdirs) /* Break at all separators */ while (p && *p) { - SV *libdir = newSV(0); + SV *libdir = NEWSV(55,0); char *s; /* skip any consecutive separators */ @@ -2777,16 +2763,17 @@ incpush(char *p, int addsubdirs) } #ifdef USE_THREADS -static struct thread * +static struct perl_thread * init_main_thread() { - struct thread *thr; + struct perl_thread *thr; XPV *xpv; - Newz(53, thr, 1, struct thread); + Newz(53, thr, 1, struct perl_thread); curcop = &compiling; thr->cvcache = newHV(); - thr->magicals = newAV(); + thr->threadsv = newAV(); + /* thr->threadsvp is set when find_threadsv is called */ thr->specific = newAV(); thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; @@ -2835,6 +2822,7 @@ init_main_thread() sv_setpvn(bodytarget, "", 0); formtarget = bodytarget; thr->errsv = newSVpv("", 0); + (void) find_threadsv("@"); /* Ensure $@ is initialised early */ return thr; } #endif /* USE_THREADS */ @@ -2848,7 +2836,7 @@ call_list(I32 oldscope, AV *list) dJMPENV; int ret; - while (AvFILL(list) >= 0) { + while (AvFILL(list) >= 0) { CV *cv = (CV*)av_shift(list); SAVEFREESV(cv); @@ -2986,3 +2974,4 @@ my_exit_jump(void) } +