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 84ef3af..30db9e3 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -294,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>.
@@ -410,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 */
@@ -666,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;
@@ -684,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);
@@ -2504,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(),
@@ -2666,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);
@@ -2776,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.
         */
@@ -2788,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;
@@ -2812,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");
@@ -2840,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");
@@ -3556,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