As suggested by Arthur: the threads and threads::shared

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index ebf5ca1..30db9e3 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -258,11 +258,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 +294,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<perlembed>.
@@ -412,6 +425,11 @@ perl_destruct(pTHXx)
     LEAVE;
     FREETMPS;
 
+    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 */
@@ -668,6 +686,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 +706,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);
@@ -1428,6 +1450,22 @@ print \"  \\@INC:\\n    @INC\\n\";");
     if (!PL_do_undump)
        init_postdump_symbols(argc,argv,env);
 
+    if (PL_wantutf8) { /* Requires init_predump_symbols(). */
+        IO* io;
+        PerlIO* fp;
+        SV* sv;
+        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 */
@@ -2274,8 +2312,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");
@@ -2485,7 +2528,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(),
@@ -2647,8 +2690,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 +2798,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 +2810,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 +2834,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 +2862,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");
@@ -3537,6 +3578,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