#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
#endif /* LEAKTEST */
+/* These must be defined when not using Perl's malloc for binary
+ * compatibility */
+
+#ifndef MYMALLOC
+
+Malloc_t Perl_malloc (MEM_SIZE nbytes)
+{
+ dTHXs;
+ return PerlMem_malloc(nbytes);
+}
+
+Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size)
+{
+ dTHXs;
+ return PerlMem_calloc(elements, size);
+}
+
+Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes)
+{
+ dTHXs;
+ return PerlMem_realloc(where, nbytes);
+}
+
+Free_t Perl_mfree (Malloc_t where)
+{
+ dTHXs;
+ PerlMem_free(where);
+}
+
+#endif
+
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
top2:
/*SUPPRESS 560*/
if ((tmp = table[*s])) {
-#ifdef POINTERRIGOR
- if (bigend - s > tmp) {
- s += tmp;
- goto top2;
- }
- s += tmp;
-#else
if ((s += tmp) < bigend)
goto top2;
-#endif
goto check_end;
}
else { /* less expensive than calling strncmp() */
if (!(pos += PL_screamnext[pos]))
goto cant_find;
}
-#ifdef POINTERRIGOR
- do {
- if (pos >= stop_pos) break;
- if (big[pos-previous] != first)
- continue;
- for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
- if (*s++ != *x++) {
- s--;
- break;
- }
- }
- if (s == littleend) {
- *old_posp = pos;
- if (!last) return (char *)(big+pos-previous);
- found = 1;
- }
- } while ( pos += PL_screamnext[pos] );
- return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
-#else /* !POINTERRIGOR */
big -= previous;
do {
if (pos >= stop_pos) break;
} while ( pos += PL_screamnext[pos] );
if (last && found)
return (char *)(big+(*old_posp));
-#endif /* POINTERRIGOR */
check_tail:
if (!SvTAIL(littlestr) || (end_shift > 0))
return Nullch;
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');
/* 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) {
#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)
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) {
#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]);
#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)