X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=fd25ebb03e85a1ea70a0281d2de1dfcb9b954b58;hb=01ca579eedb21d1163dfcced9189fc4352bc9dcd;hp=0ff9f4e99017b3bf3900c9bf83f1429314060bda;hpb=54b9620dd49f76536ba0792f6f471615a414bd6a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 0ff9f4e..fd25ebb 100644 --- a/perl.c +++ b/perl.c @@ -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 **)); @@ -88,7 +88,7 @@ static int fdscript = -1; static void catch_sigsegv(int signo, struct sigcontext_struct sc) { - signal(SIGSEGV, SIG_DFL); + PerlProc_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); @@ -112,7 +112,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 +134,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 +311,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 +528,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 +689,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 +821,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 +853,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,12 +897,12 @@ 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);); + DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv);); #endif init_predump_symbols(); @@ -915,6 +913,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 +935,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->threadsv, find_threadsv("/"), 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 +946,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 +983,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; @@ -1055,7 +1050,7 @@ perl_get_sv(char *name, I32 create) PADOFFSET tmp = find_threadsv(name); if (tmp != NOT_IN_PAD) { dTHR; - return *av_fetch(thr->threadsv, tmp, FALSE); + return THREADSV(tmp); } } #endif /* USE_THREADS */ @@ -1104,7 +1099,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 +1114,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 +1528,7 @@ moreswitches(char *s) return s; case 'h': usage(origargv[0]); - exit(0); + PerlProc_exit(0); case 'i': if (inplace) Safefree(inplace); @@ -1663,6 +1658,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"); #endif #ifdef OS2 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" @@ -1674,7 +1670,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 +1682,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 +1724,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 +1820,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 +1830,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 +2070,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 +2079,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 +2094,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 +2133,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 +2148,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 +2174,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 +2182,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 +2241,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 +2314,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 +2323,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 +2367,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 +2505,7 @@ init_predump_symbols(void) GV *tmpgv; GV *othergv; -#ifdef USE_THREADS - sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),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 +2601,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 +2609,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 +2628,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 +2699,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 +2715,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 +2780,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->threadsv = newAV(); + /* thr->threadsvp is set when find_threadsv is called */ thr->specific = newAV(); thr->errhv = newHV(); thr->flags = THRf_R_JOINABLE; @@ -2848,7 +2852,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 +2990,4 @@ my_exit_jump(void) } +