Convert ext/B/t/debug.t to Test::More. (Diagnostics are good, m'kay)

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

diff --git a/perl.c b/perl.c
index 973a306..9c7b314 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1,7 +1,7 @@
 /*    perl.c
  *
  *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -580,6 +580,7 @@ perl_destruct(pTHXx)
 
     if (CALL_FPTR(PL_threadhook)(aTHX)) {
         /* Threads hook has vetoed further cleanup */
+       PL_veto_cleanup = TRUE;
         return STATUS_EXIT;
     }
 
@@ -1325,6 +1326,11 @@ Releases a Perl interpreter.  See L<perlembed>.
 void
 perl_free(pTHXx)
 {
+    dVAR;
+
+    if (PL_veto_cleanup)
+       return;
+
 #ifdef PERL_TRACK_MEMPOOL
     {
        /*
@@ -1381,7 +1387,7 @@ __attribute__((destructor))
 perl_fini(void)
 {
     dVAR;
-    if (PL_curinterp)
+    if (PL_curinterp  && !PL_veto_cleanup)
        FREE_THREAD_KEY;
 }
 
@@ -2061,11 +2067,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     }
 #endif
 
-    if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
-        PL_compiling.cop_warnings
-           = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
-    }
-
     if (!scriptname)
        scriptname = argv[0];
     if (PL_e_script) {
@@ -2477,33 +2478,47 @@ Perl_get_hv(pTHX_ const char *name, I32 create)
 /*
 =head1 CV Manipulation Functions
 
+=for apidoc p||get_cvn_flags
+
+Returns the CV of the specified Perl subroutine.  C<flags> are passed to
+C<gv_fetchpvn_flags>. If C<GV_ADD> is set and the Perl subroutine does not
+exist then it will be declared (which has the same effect as saying
+C<sub name;>).  If C<GV_ADD> is not set and the subroutine does not exist
+then NULL is returned.
+
 =for apidoc p||get_cv
 
-Returns the CV of the specified Perl subroutine.  If C<create> is set and
-the Perl subroutine does not exist then it will be declared (which has the
-same effect as saying C<sub name;>).  If C<create> is not set and the
-subroutine does not exist then NULL is returned.
+Uses C<strlen> to get the length of C<name>, then calls C<get_cvn_flags>.
 
 =cut
 */
 
 CV*
-Perl_get_cv(pTHX_ const char *name, I32 create)
+Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags)
 {
-    GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
+    GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV);
     /* XXX unsafe for threads if eval_owner isn't held */
     /* XXX this is probably not what they think they're getting.
      * It has the same effect as "sub name;", i.e. just a forward
      * declaration! */
-    if (create && !GvCVu(gv))
+    if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) {
+       SV *const sv = newSVpvn(name,len);
+       SvFLAGS(sv) |= flags & SVf_UTF8;
        return newSUB(start_subparse(FALSE, 0),
-                     newSVOP(OP_CONST, 0, newSVpv(name,0)),
+                     newSVOP(OP_CONST, 0, sv),
                      NULL, NULL);
+    }
     if (gv)
        return GvCVu(gv);
     return NULL;
 }
 
+CV*
+Perl_get_cv(pTHX_ const char *name, I32 flags)
+{
+    return get_cvn_flags(name, strlen(name), flags);
+}
+
 /* Be sure to refetch the stack pointer after calling these routines. */
 
 /*
@@ -3299,7 +3314,7 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 
        PerlIO_printf(PerlIO_stdout(),
-                     "\n\nCopyright 1987-2006, Larry Wall\n");
+                     "\n\nCopyright 1987-2007, Larry Wall\n");
 #ifdef MACOS_TRADITIONAL
        PerlIO_printf(PerlIO_stdout(),
                      "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
@@ -3376,8 +3391,9 @@ this system using \"man perl\" or \"perldoc perl\".  If you have access to the\n
 Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
        my_exit(0);
     case 'w':
-       if (! (PL_dowarn & G_WARN_ALL_MASK))
+       if (! (PL_dowarn & G_WARN_ALL_MASK)) {
            PL_dowarn |= G_WARN_ON;
+       }
        s++;
        return s;
     case 'W':