OS/2 multi-architecture

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

diff --git a/util.c b/util.c
index b72a8f2..a88c25d 100644 (file)
--- a/util.c
+++ b/util.c
@@ -26,17 +26,6 @@
 #endif
 #endif
 
-#ifdef I_VFORK
-#  include <vfork.h>
-#endif
-
-/* Put this after #includes because fork and vfork prototypes may
-   conflict.
-*/
-#ifndef HAS_VFORK
-#   define vfork fork
-#endif
-
 #ifdef I_SYS_WAIT
 #  include <sys/wait.h>
 #endif
@@ -1003,17 +992,60 @@ Perl_mess(pTHX_ const char *pat, ...)
     return retval;
 }
 
+STATIC COP*
+S_closest_cop(pTHX_ COP *cop, OP *o)
+{
+    /* Look for PL_op starting from o.  cop is the last COP we've seen. */
+
+    if (!o || o == PL_op) return cop;
+
+    if (o->op_flags & OPf_KIDS) {
+       OP *kid;
+       for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+       {
+           COP *new_cop;
+
+           /* If the OP_NEXTSTATE has been optimised away we can still use it
+            * the get the file and line number. */
+
+           if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
+               cop = (COP *)kid;
+
+           /* Keep searching, and return when we've found something. */
+
+           new_cop = closest_cop(cop, kid);
+           if (new_cop) return new_cop;
+       }
+    }
+
+    /* Nothing found. */
+
+    return 0;
+}
+
 SV *
 Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
     SV *sv = mess_alloc();
     static char dgd[] = " during global destruction.\n";
+    COP *cop;
 
     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
-       if (CopLINE(PL_curcop))
+
+       /*
+        * Try and find the file and line for PL_op.  This will usually be
+        * PL_curcop, but it might be a cop that has been optimised away.  We
+        * can try to find such a cop by searching through the optree starting
+        * from the sibling of PL_curcop.
+        */
+
+       cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
+       if (!cop) cop = PL_curcop;
+
+       if (CopLINE(cop))
            Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
-                          CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+                          CopFILE(cop), (IV)CopLINE(cop));
        if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
            bool line_mode = (RsSIMPLE(PL_rs) &&
                              SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
@@ -1815,7 +1847,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     /* Try for another pipe pair for error return */
     if (PerlProc_pipe(pp) >= 0)
        did_pipes = 1;
-    while ((pid = vfork()) < 0) {
+    while ((pid = PerlProc_fork()) < 0) {
        if (errno != EAGAIN) {
            PerlLIO_close(p[This]);
            if (did_pipes) {
@@ -1867,7 +1899,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 #undef THAT
     }
     /* Parent */
-    do_execfree();     /* free any memory malloced by child on vfork */
+    do_execfree();     /* free any memory malloced by child on fork */
     /* Close child's end of pipe */
     PerlLIO_close(p[that]);
     if (did_pipes)
@@ -1948,7 +1980,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
        return Nullfp;
     if (doexec && PerlProc_pipe(pp) >= 0)
        did_pipes = 1;
-    while ((pid = (doexec?vfork():fork())) < 0) {
+    while ((pid = PerlProc_fork()) < 0) {
        if (errno != EAGAIN) {
            PerlLIO_close(p[This]);
            if (did_pipes) {
@@ -2009,7 +2041,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #undef THIS
 #undef THAT
     }
-    do_execfree();     /* free any memory malloced by child on vfork */
+    do_execfree();     /* free any memory malloced by child on fork */
     PerlLIO_close(p[that]);
     if (did_pipes)
        PerlLIO_close(pp[1]);
@@ -2084,6 +2116,54 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 
 #endif /* !DOSISH */
 
+/* this is called in parent before the fork() */
+void
+Perl_atfork_lock(void)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+    /* locks must be held in locking order (if any) */
+#  ifdef MYMALLOC
+    MUTEX_LOCK(&PL_malloc_mutex);
+#  endif
+    OP_REFCNT_LOCK;
+#endif
+}
+
+/* this is called in both parent and child after the fork() */
+void
+Perl_atfork_unlock(void)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+    /* locks must be released in same order as in atfork_lock() */
+#  ifdef MYMALLOC
+    MUTEX_UNLOCK(&PL_malloc_mutex);
+#  endif
+    OP_REFCNT_UNLOCK;
+#endif
+}
+
+Pid_t
+Perl_my_fork(void)
+{
+#if defined(HAS_FORK)
+    Pid_t pid;
+#if (defined(USE_THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
+    atfork_lock();
+    pid = fork();
+    atfork_unlock();
+#else
+    /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
+     * handlers elsewhere in the code */
+    pid = fork();
+#endif
+    return pid;
+#else
+    /* this "canna happen" since nothing should be calling here if !HAS_FORK */
+    Perl_croak_nocontext("fork() not available");
+    return 0;
+#endif /* HAS_FORK */
+}
+
 #ifdef DUMP_FDS
 void
 Perl_dump_fds(pTHX_ char *s)