X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=f7131d0682b9d73b4c3750f31d9727cb0d874192;hb=06bd180242168640a1733ced8fea2dbabcdc44d0;hp=ebf5ca121d691dbf0ef82006e99af42dc0d64c84;hpb=48c6b404cfbd1c2c7ca26e9a9abd0c281bc5836f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index ebf5ca1..f7131d0 100644 --- a/perl.c +++ b/perl.c @@ -16,6 +16,11 @@ #include "perl.h" #include "patchlevel.h" /* for local_patches */ +#ifdef NETWARE +#include "nwutil.h" +char *nw_get_sitelib(const char *pl); +#endif + /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD #include @@ -258,11 +263,9 @@ perl_construct(pTHXx) PL_fdpid = newAV(); /* for remembering popen pids by fd */ PL_modglobal = newHV(); /* pointers to per-interpreter module globals */ PL_errors = newSVpvn("",0); -#ifdef DEBUGGING sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ - sv_setpvn(PERL_DEBUG_PAD(1), "", 0); - sv_setpvn(PERL_DEBUG_PAD(2), "", 0); -#endif + sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ + sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ #ifdef USE_ITHREADS PL_regex_padav = newAV(); av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */ @@ -296,6 +299,21 @@ perl_construct(pTHXx) } /* +=for apidoc nothreadhook + +Stub that provides thread hook for perl_destruct when there are +no threads. + +=cut +*/ + +int +Perl_nothreadhook(pTHX) +{ + return 0; +} + +/* =for apidoc perl_destruct Shuts down a Perl interpreter. See L. @@ -412,11 +430,20 @@ perl_destruct(pTHXx) LEAVE; FREETMPS; + /* Need to flush since END blocks can produce output */ + my_fflush_all(); + + if (CALL_FPTR(PL_threadhook)(aTHX)) { + /* Threads hook has vetoed further cleanup */ + return STATUS_NATIVE_EXPORT; + } + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ if (PL_main_root) { - PL_curpad = AvARRAY(PL_comppad); + /* If running under -d may not have PL_comppad. */ + PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; op_free(PL_main_root); PL_main_root = Nullop; } @@ -464,7 +491,7 @@ perl_destruct(pTHXx) #endif /* The exit() function will do everything that needs doing. */ - return STATUS_NATIVE_EXPORT;; + return STATUS_NATIVE_EXPORT; } /* jettison our possibly duplicated environment */ @@ -472,7 +499,13 @@ perl_destruct(pTHXx) * so we certainly shouldn't free it here */ #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) - if (environ != PL_origenviron) { + if (environ != PL_origenviron +#ifdef USE_ITHREADS + /* only main thread can free environ[0] contents */ + && PL_curinterp == aTHX +#endif + ) + { I32 i; for (i = 0; environ[i]; i++) @@ -668,6 +701,8 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_totitle); SvREFCNT_dec(PL_utf8_tolower); SvREFCNT_dec(PL_utf8_tofold); + SvREFCNT_dec(PL_utf8_idstart); + SvREFCNT_dec(PL_utf8_idcont); PL_utf8_alnum = Nullsv; PL_utf8_alnumc = Nullsv; PL_utf8_ascii = Nullsv; @@ -686,6 +721,8 @@ perl_destruct(pTHXx) PL_utf8_totitle = Nullsv; PL_utf8_tolower = Nullsv; PL_utf8_tofold = Nullsv; + PL_utf8_idstart = Nullsv; + PL_utf8_idcont = Nullsv; if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); @@ -795,8 +832,15 @@ perl_destruct(pTHXx) SvANY(&PL_sv_no) = NULL; SvFLAGS(&PL_sv_no) = 0; - SvREFCNT(&PL_sv_undef) = 0; - SvREADONLY_off(&PL_sv_undef); + { + int i; + for (i=0; i<=2; i++) { + SvREFCNT(PERL_DEBUG_PAD(i)) = 0; + sv_clear(PERL_DEBUG_PAD(i)); + SvANY(PERL_DEBUG_PAD(i)) = NULL; + SvFLAGS(PERL_DEBUG_PAD(i)) = 0; + } + } if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); @@ -806,6 +850,13 @@ perl_destruct(pTHXx) PerlIO_cleanup(aTHX); #endif + /* sv_undef needs to stay immortal until after PerlIO_cleanup + as currently layers use it rather than Nullsv as a marker + for no arg - and will try and SvREFCNT_dec it. + */ + SvREFCNT(&PL_sv_undef) = 0; + SvREADONLY_off(&PL_sv_undef); + Safefree(PL_origfilename); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -890,7 +941,7 @@ perl_free(pTHXx) # endif PerlMem_free(aTHXx); # ifdef NETWARE - nw5_delete_internal_host(host); + nw_delete_internal_host(host); # else win32_delete_internal_host(host); # endif @@ -1428,6 +1479,27 @@ print \" \\@INC:\\n @INC\\n\";"); if (!PL_do_undump) init_postdump_symbols(argc,argv,env); + /* PL_wantutf8 is conditionally turned on by + * locale.c:Perl_init_i18nl10n() if the environment + * look like the user wants to use UTF-8. */ + if (PL_wantutf8) { /* Requires init_predump_symbols(). */ + IO* io; + PerlIO* fp; + SV* sv; + /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR + * _and_ the default open discipline. */ + if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) { + sv_setpvn(sv, ":utf8\0:utf8", 11); + SvSETMAGIC(sv); + } + } + init_lexer(); /* now parse the script */ @@ -1582,7 +1654,9 @@ S_run_body(pTHX_ I32 oldscope) if (PL_minus_c) { #ifdef MACOS_TRADITIONAL - PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); + PerlIO_printf(Perl_error_log, "%s%s syntax OK\n", + (gMacPerl_ErrorFormat ? "# " : ""), + MacPerl_MPWFileName(PL_origfilename)); #else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); #endif @@ -2206,7 +2280,7 @@ Perl_moreswitches(pTHX_ char *s) else if (!rschar && numlen >= 2) PL_rs = newSVpvn("", 0); else { - char ch = rschar; + char ch = (char)rschar; PL_rs = newSVpvn(&ch, 1); } return s + numlen; @@ -2274,8 +2348,13 @@ Perl_moreswitches(pTHX_ char *s) PL_debug = atoi(s+1); for (s++; isDIGIT(*s); s++) ; } +#ifdef EBCDIC + if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "-Dp not implemented on this platform\n"); +#endif PL_debug |= DEBUG_TOP_FLAG; -#else +#else /* !DEBUGGING */ if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Recompile perl with -DDEBUGGING to use -D switch\n"); @@ -2286,10 +2365,16 @@ Perl_moreswitches(pTHX_ char *s) } case 'h': usage(PL_origargv[0]); - PerlProc_exit(0); + my_exit(0); case 'i': if (PL_inplace) Safefree(PL_inplace); +#if defined(__CYGWIN__) /* do backup extension automagically */ + if (*(s+1) == '\0') { + PL_inplace = savepv(".bak"); + return s+1; + } +#endif /* __CYGWIN__ */ PL_inplace = savepv(s+1); /*SUPPRESS 530*/ for (s = PL_inplace; *s && !isSPACE(*s); s++) ; @@ -2485,7 +2570,7 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef __VOS__ PerlIO_printf(PerlIO_stdout(), - "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n"); + "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n"); #endif #ifdef __OPEN_VM PerlIO_printf(PerlIO_stdout(), @@ -2518,7 +2603,7 @@ GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using `man perl' or `perldoc perl'. If you have access to the\n\ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); - PerlProc_exit(0); + my_exit(0); case 'w': if (! (PL_dowarn & G_WARN_ALL_MASK)) PL_dowarn |= G_WARN_ON; @@ -2647,8 +2732,6 @@ S_init_main_stash(pTHX) { GV *gv; - - PL_curstash = PL_defstash = newHV(); PL_curstname = newSVpvn("main",4); gv = gv_fetchpv("main::",TRUE, SVt_PVHV); @@ -2757,8 +2840,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) /* This strips off Perl comments which might interfere with - the C pre-processor, including #!. #line directives are - deliberately stripped to avoid confusion with Perl's version + the C pre-processor, including #!. #line directives are + deliberately stripped to avoid confusion with Perl's version of #line. FWP played some golf with it so it will fit into VMS's 255 character buffer. */ @@ -2769,7 +2852,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) Perl_sv_setpvf(aTHX_ cmd, "\ %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", - perl, quote, code, quote, scriptname, cpp, + perl, quote, code, quote, scriptname, cpp, cpp_discard_flag, sv, CPPMINUS); PL_doextract = FALSE; @@ -2793,8 +2876,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } # endif /* IAMSUID */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "PL_preprocess: cmd=\"%s\"\n", + DEBUG_P(PerlIO_printf(Perl_debug_log, + "PL_preprocess: cmd=\"%s\"\n", SvPVX(cmd))); PL_rsfp = PerlProc_popen(SvPVX(cmd), "r"); @@ -2821,8 +2904,8 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { /* try again */ - PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, - BIN_EXP, (int)PERL_REVISION, + PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, + BIN_EXP, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION), PL_origargv); Perl_croak(aTHX_ "Can't do setuid\n"); @@ -2893,7 +2976,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) defined(HAS_STRUCT_FS_DATA) && \ defined(NOSTAT_ONE) # define FD_ON_NOSUID_CHECK_OKAY - struct stat fdst; + Stat_t fdst; if (fstat(fd, &fdst) == 0) { struct ustat us; @@ -2923,7 +3006,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd) # define FD_ON_NOSUID_CHECK_OKAY FILE *mtab = fopen("/etc/mtab", "r"); struct mntent *entry; - struct stat stb, fsb; + Stat_t stb, fsb; if (mtab && (fstat(fd, &stb) == 0)) { while (entry = getmntent(mtab)) { @@ -3003,7 +3086,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) * Then we just have to make sure he or she can execute it. */ { - struct stat tmpstatbuf; + Stat_t tmpstatbuf; if ( #ifdef HAS_SETREUID @@ -3446,6 +3529,17 @@ S_procself_val(pTHX_ SV *sv, char *arg0) { char buf[MAXPATHLEN]; int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); + + /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) + includes a spurious NUL which will cause $^X to fail in system + or backticks (this will prevent extensions from being built and + many tests from working). readlink is not meant to add a NUL. + Normal readlink works fine. + */ + if (len > 0 && buf[len-1] == '\0') { + len--; + } + /* FreeBSD's implementation is acknowledged to be imperfect, sometimes returning the text "unknown" from the readlink rather than the path to the executable (or returning an error from the readlink). Any valid @@ -3513,8 +3607,14 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register */ if (!env) env = environ; - if (env != environ) + if (env != environ +# ifdef USE_ITHREADS + && PL_curinterp == aTHX +# endif + ) + { environ[0] = Nullch; + } if (env) for (; *env; env++) { if (!(s = strchr(*env,'='))) @@ -3537,6 +3637,14 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); SvREADONLY_on(GvSV(tmpgv)); } + + /* touch @F array to prevent spurious warnings 20020415 MJD */ + if (PL_minus_a) { + (void) get_av("main::F", TRUE | GV_ADDMULTI); + } + /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */ + (void) get_av("main::-", TRUE | GV_ADDMULTI); + (void) get_av("main::+", TRUE | GV_ADDMULTI); } STATIC void @@ -3576,7 +3684,7 @@ S_init_perllib(pTHX) #endif #ifdef MACOS_TRADITIONAL { - struct stat tmpstatbuf; + Stat_t tmpstatbuf; SV * privdir = NEWSV(55, 0); char * macperl = PerlEnv_getenv("MACPERL"); @@ -3704,8 +3812,11 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) p = Nullch; /* break out */ } #ifdef MACOS_TRADITIONAL - if (!strchr(SvPVX(libdir), ':')) - sv_insert(libdir, 0, 0, ":", 1); + if (!strchr(SvPVX(libdir), ':')) { + char buf[256]; + + sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0)); + } if (SvPVX(libdir)[SvCUR(libdir)-1] != ':') sv_catpv(libdir, ":"); #endif @@ -3720,7 +3831,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) const char *incverlist[] = { PERL_INC_VERSION_LIST }; const char **incver; #endif - struct stat tmpstatbuf; + Stat_t tmpstatbuf; #ifdef VMS char *unix; STRLEN len;