#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]);
return PerlIO_fdopen(p[This], mode);
}
#else
-#if defined(atarist) || defined(DJGPP)
+#if defined(atarist)
FILE *popen();
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
*/
return PerlIO_importFILE(popen(cmd, mode), 0);
}
+#else
+#if defined(DJGPP)
+FILE *djgpp_popen();
+PerlIO *
+Perl_my_popen(pTHX_ char *cmd, char *mode)
+{
+ PERL_FLUSHALL_FOR_CHILD;
+ /* Call system's popen() to get a FILE *, then import it.
+ used 0 for 2nd parameter to PerlIO_importFILE;
+ apparently not used
+ */
+ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0);
+}
+#endif
#endif
#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)
return;
}
-#if defined(atarist) || defined(OS2) || defined(DJGPP)
+#if defined(atarist) || defined(OS2)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
I32 result = pclose(f);
+ PerlIO_releaseFILE(ptr,f);
+ return result;
+}
+#endif
+
#if defined(DJGPP)
+int djgpp_pclose();
+I32
+Perl_my_pclose(pTHX_ PerlIO *ptr)
+{
+ /* Needs work for PerlIO ! */
+ FILE *f = PerlIO_findFILE(ptr);
+ I32 result = djgpp_pclose(f);
result = (result << 8) & 0xff00;
-#endif
PerlIO_releaseFILE(ptr,f);
return result;
}
mg->mg_len = sizeof(cp);
UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
- "%p: condpair_magic %p\n", thr, sv));)
+ "%p: condpair_magic %p\n", thr, sv)));
}
}
return mg;
MgOWNER(mg) = thr;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": Perl_lock lock 0x%"UVxf"\n",
- PTR2UV(thr), PTR2UV(sv));)
+ PTR2UV(thr), PTR2UV(sv)));
MUTEX_UNLOCK(MgMUTEXP(mg));
SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
}
(dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
/*
-=for apidoc sv_getcwd
+=for apidoc getcwd_sv
Fill the sv with current working directory
* back into. */
int
-Perl_sv_getcwd(pTHX_ register SV *sv)
+Perl_getcwd_sv(pTHX_ register SV *sv)
{
#ifndef PERL_MICRO
#ifdef HAS_GETCWD
{
- char* buf;
-
- SvPOK_off(sv);
- New(0, buf, MAXPATHLEN, char);
- if (buf) {
- buf[MAXPATHLEN - 1] = 0;
- /* Yes, some getcwd()s automatically allocate a buffer
- * if given a NULL one. Portability is the problem.
- * XXX Configure probe needed. */
- if (getcwd(buf, MAXPATHLEN - 1)) {
- STRLEN len = strlen(buf);
- sv_setpvn(sv, buf, len);
- SvPOK_only(sv);
- SvCUR_set(sv, len);
- }
- else
- sv_setsv(sv, &PL_sv_undef);
- Safefree(buf);
- }
- else
- sv_setsv(sv, &PL_sv_undef);
-
- return SvPOK(sv) ? TRUE : FALSE;
+ char buf[MAXPATHLEN];
+
+ /* Some getcwd()s automatically allocate a buffer of the given
+ * size from the heap if they are given a NULL buffer pointer.
+ * The problem is that this behaviour is not portable. */
+ if (getcwd(buf, sizeof(buf) - 1)) {
+ STRLEN len = strlen(buf);
+ sv_setpvn(sv, buf, len);
+ return TRUE;
+ }
+ else {
+ sv_setsv(sv, &PL_sv_undef);
+ return FALSE;
+ }
}
#else
#endif
}
- SvCUR_set(sv, pathlen);
- *SvEND(sv) = '\0';
- SvPOK_only(sv);
+ if (pathlen) {
+ SvCUR_set(sv, pathlen);
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv);
- if (PerlDir_chdir(SvPVX(sv)) < 0) {
- SV_CWD_RETURN_UNDEF;
+ if (PerlDir_chdir(SvPVX(sv)) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
}
if (PerlLIO_stat(".", &statbuf) < 0) {
SV_CWD_RETURN_UNDEF;
https://perl5.git.perl.org / perl5.git / blobdiff