don't quit if =head* wasn't found (suggested by Roland Bauer

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

diff --git a/util.c b/util.c
index 5f867ae..7c83d03 100644 (file)
--- a/util.c
+++ b/util.c
@@ -546,7 +546,7 @@ Perl_new_collate(pTHX_ const char *newcoll)
 }
 
 void
-perl_set_numeric_radix(void)
+Perl_set_numeric_radix(pTHX)
 {
 #ifdef USE_LOCALE_NUMERIC
 # ifdef HAS_LOCALECONV
@@ -589,7 +589,7 @@ Perl_new_numeric(pTHX_ const char *newnum)
        PL_numeric_name = savepv(newnum);
        PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
        PL_numeric_local = TRUE;
-       perl_set_numeric_radix();
+       set_numeric_radix();
     }
 
 #endif /* USE_LOCALE_NUMERIC */
@@ -618,7 +618,7 @@ Perl_set_numeric_local(pTHX)
        setlocale(LC_NUMERIC, PL_numeric_name);
        PL_numeric_standard = FALSE;
        PL_numeric_local = TRUE;
-       perl_set_numeric_radix();
+       set_numeric_radix();
     }
 
 #endif /* USE_LOCALE_NUMERIC */
@@ -1363,28 +1363,36 @@ S_mess_alloc(pTHX)
     return sv;
 }
 
-#ifdef PERL_IMPLICIT_CONTEXT
+#if defined(PERL_IMPLICIT_CONTEXT)
 char *
 Perl_form_nocontext(const char* pat, ...)
 {
     dTHX;
-    SV *sv = mess_alloc();
+    char *retval;
     va_list args;
     va_start(args, pat);
-    sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+    retval = vform(pat, &args);
     va_end(args);
-    return SvPVX(sv);
+    return retval;
 }
-#endif
+#endif /* PERL_IMPLICIT_CONTEXT */
 
 char *
 Perl_form(pTHX_ const char* pat, ...)
 {
-    SV *sv = mess_alloc();
+    char *retval;
     va_list args;
     va_start(args, pat);
-    sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+    retval = vform(pat, &args);
     va_end(args);
+    return retval;
+}
+
+char *
+Perl_vform(pTHX_ const char *pat, va_list *args)
+{
+    SV *sv = mess_alloc();
+    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
     return SvPVX(sv);
 }
 
@@ -1408,13 +1416,17 @@ Perl_mess(pTHX_ const char *pat, va_list *args)
                      line_mode ? "line" : "chunk", 
                      (long)IoLINES(GvIOp(PL_last_in_gv)));
        }
+#ifdef USE_THREADS
+       if (thr->tid)
+           Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
+#endif
        sv_catpv(sv, PL_dirty ? dgd : ".\n");
     }
     return sv;
 }
 
-STATIC OP *
-S_do_die(pTHX_ const char* pat, va_list *args)
+OP *
+Perl_vdie(pTHX_ const char* pat, va_list *args)
 {
     dTHR;
     char *message;
@@ -1481,7 +1493,7 @@ S_do_die(pTHX_ const char* pat, va_list *args)
     return PL_restartop;
 }
 
-#ifdef PERL_IMPLICIT_CONTEXT
+#if defined(PERL_IMPLICIT_CONTEXT)
 OP *
 Perl_die_nocontext(const char* pat, ...)
 {
@@ -1489,11 +1501,11 @@ Perl_die_nocontext(const char* pat, ...)
     OP *o;
     va_list args;
     va_start(args, pat);
-    o = do_die(pat, &args);
+    o = vdie(pat, &args);
     va_end(args);
     return o;
 }
-#endif
+#endif /* PERL_IMPLICIT_CONTEXT */
 
 OP *
 Perl_die(pTHX_ const char* pat, ...)
@@ -1501,13 +1513,13 @@ Perl_die(pTHX_ const char* pat, ...)
     OP *o;
     va_list args;
     va_start(args, pat);
-    o = do_die(pat, &args);
+    o = vdie(pat, &args);
     va_end(args);
     return o;
 }
 
-STATIC void
-S_do_croak(pTHX_ const char* pat, va_list *args)
+void
+Perl_vcroak(pTHX_ const char* pat, va_list *args)
 {
     dTHR;
     char *message;
@@ -1564,14 +1576,14 @@ S_do_croak(pTHX_ const char* pat, va_list *args)
     my_failure_exit();
 }
 
-#ifdef PERL_IMPLICIT_CONTEXT
+#if defined(PERL_IMPLICIT_CONTEXT)
 void
 Perl_croak_nocontext(const char *pat, ...)
 {
     dTHX;
     va_list args;
     va_start(args, pat);
-    do_croak(pat, &args);
+    vcroak(pat, &args);
     /* NOTREACHED */
     va_end(args);
 }
@@ -1582,13 +1594,13 @@ Perl_croak(pTHX_ const char *pat, ...)
 {
     va_list args;
     va_start(args, pat);
-    do_croak(pat, &args);
+    vcroak(pat, &args);
     /* NOTREACHED */
     va_end(args);
 }
 
-STATIC void
-S_do_warn(pTHX_ const char* pat, va_list *args)
+void
+Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
     char *message;
     HV *stash;
@@ -1640,14 +1652,14 @@ S_do_warn(pTHX_ const char* pat, va_list *args)
     (void)PerlIO_flush(PerlIO_stderr());
 }
 
-#ifdef PERL_IMPLICIT_CONTEXT
+#if defined(PERL_IMPLICIT_CONTEXT)
 void
 Perl_warn_nocontext(const char *pat, ...)
 {
     dTHX;
     va_list args;
     va_start(args, pat);
-    do_warn(pat, &args);
+    vwarn(pat, &args);
     va_end(args);
 }
 #endif /* PERL_IMPLICIT_CONTEXT */
@@ -1657,15 +1669,35 @@ Perl_warn(pTHX_ const char *pat, ...)
 {
     va_list args;
     va_start(args, pat);
-    do_warn(pat, &args);
+    vwarn(pat, &args);
     va_end(args);
 }
 
+#if defined(PERL_IMPLICIT_CONTEXT)
+void
+Perl_warner_nocontext(U32 err, const char *pat, ...)
+{
+    dTHX;
+    va_list args;
+    va_start(args, pat);
+    vwarner(err, pat, &args);
+    va_end(args);
+}
+#endif /* PERL_IMPLICIT_CONTEXT */
+
 void
 Perl_warner(pTHX_ U32  err, const char* pat,...)
 {
-    dTHR;
     va_list args;
+    va_start(args, pat);
+    vwarner(err, pat, &args);
+    va_end(args);
+}
+
+void
+Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
+{
+    dTHR;
     char *message;
     HV *stash;
     GV *gv;
@@ -1673,10 +1705,8 @@ Perl_warner(pTHX_ U32  err, const char* pat,...)
     SV *msv;
     STRLEN msglen;
 
-    va_start(args, pat);
-    msv = mess(pat, &args);
+    msv = mess(pat, args);
     message = SvPV(msv, msglen);
-    va_end(args);
 
     if (ckDEAD(err)) {
 #ifdef USE_THREADS
@@ -2278,10 +2308,11 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
                break;
            n += n1;
        }
+       PerlLIO_close(pp[0]);
+       did_pipes = 0;
        if (n) {                        /* Error */
            if (n != sizeof(int))
                Perl_croak(aTHX_ "panic: kid popen errno read");
-           PerlLIO_close(pp[0]);
            errno = errkid;             /* Propagate errno from kid */
            return Nullfp;
        }
@@ -2752,14 +2783,15 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
     register UV retval = 0;
     bool overflowed = FALSE;
     while (len && *s >= '0' && *s <= '1') {
-      dTHR;        
-      register UV n = retval << 1;
-      if (!overflowed && (n >> 1) != retval  && ckWARN_d(WARN_UNSAFE)) {
-          Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in binary number");
-          overflowed = TRUE;
-      }
-      retval = n | (*s++ - '0');
-      len--;
+       register UV n = retval << 1;
+       if (!overflowed && (n >> 1) != retval) {
+           dTHR;
+           if (ckWARN_d(WARN_UNSAFE))
+               Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in binary number");
+           overflowed = TRUE;
+       }
+       retval = n | (*s++ - '0');
+       len--;
     }
     if (len && (*s >= '2' && *s <= '9')) {
       dTHR;
@@ -2777,10 +2809,11 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
     bool overflowed = FALSE;
 
     while (len && *s >= '0' && *s <= '7') {
-       dTHR;
        register UV n = retval << 3;
-       if (!overflowed && (n >> 3) != retval && ckWARN_d(WARN_UNSAFE)) {
-           Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in octal number");
+       if (!overflowed && (n >> 3) != retval) {
+           dTHR;
+           if (ckWARN_d(WARN_UNSAFE))
+               Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in octal number");
            overflowed = TRUE;
        }
        retval = n | (*s++ - '0');
@@ -2813,17 +2846,16 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
                dTHR;
                --s;
                if (ckWARN(WARN_UNSAFE))
-                   Perl_warner(aTHX_ WARN_UNSAFE,"Illegal hex digit '%c' ignored", *s);
+                   Perl_warner(aTHX_ WARN_UNSAFE,"Illegal hexadecimal digit '%c' ignored", *s);
                break;
            }
        }
        n = retval << 4;
-       {
+       if (!overflowed && (n >> 4) != retval) {
            dTHR;
-           if (!overflowed && (n >> 4) != retval && ckWARN_d(WARN_UNSAFE)) {
-               Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in hex number");
-               overflowed = TRUE;
-           }
+           if (ckWARN_d(WARN_UNSAFE))
+               Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in hexadecimal number");
+           overflowed = TRUE;
        }
        retval = n | ((tmp - PL_hexdigit) & 15);
     }
@@ -3182,7 +3214,7 @@ Perl_condpair_magic(pTHX_ SV *sv)
 struct perl_thread *
 Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 {
-#ifndef PERL_IMPLICIT_CONTEXT
+#if !defined(PERL_IMPLICIT_CONTEXT)
     struct perl_thread *thr;
 #endif
     SV *sv;
@@ -3206,12 +3238,13 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
     Zero(thr, 1, struct perl_thread);
 #endif
 
-    PL_protect = FUNC_NAME_TO_PTR(Perl_default_protect);
+    PL_protect = MEMBER_TO_FPTR(Perl_default_protect);
 
     thr->oursv = sv;
     init_stacks();
 
     PL_curcop = &PL_compiling;
+    thr->interp = t->interp;
     thr->cvcache = newHV();
     thr->threadsv = newAV();
     thr->specific = newAV();
@@ -3238,11 +3271,11 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t)
 
     PL_statname = NEWSV(66,0);
     PL_maxscream = -1;
-    PL_regcompp = FUNC_NAME_TO_PTR(Perl_pregcomp);
-    PL_regexecp = FUNC_NAME_TO_PTR(Perl_regexec_flags);
-    PL_regint_start = FUNC_NAME_TO_PTR(Perl_re_intuit_start);
-    PL_regint_string = FUNC_NAME_TO_PTR(Perl_re_intuit_string);
-    PL_regfree = FUNC_NAME_TO_PTR(Perl_pregfree);
+    PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
+    PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
+    PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
+    PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
+    PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
     PL_regindent = 0;
     PL_reginterp_cnt = 0;
     PL_lastscream = Nullsv;