#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
# define FD_CLOEXEC 1 /* NeXT needs this */
#endif
-/* paranoid version of system's malloc() */
-
/* NOTE: Do not call the next three routines directly. Use the macros
* in handy.h, so that we can easily redefine everything to do tracking of
* allocated hunks back to the original New to track down any memory leaks.
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
+/* paranoid version of system's malloc() */
+
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
#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 SvTAIL is actually due to \Z or \z, this gives false positives
- if PL_multiline. In fact if !PL_multiline the autoritative answer
+ if PL_multiline. In fact if !PL_multiline the authoritative answer
is not supported yet. */
char *
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');
line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (thr->tid)
Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
#endif
message = SvPV(msv, msglen);
if (ckDEAD(err)) {
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (PL_diehook) {
/* sv_2cv might call Perl_croak() */
SV *olddiehook = PL_diehook;
/* 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_5005THREADS) || 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_5005THREADS) || 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_5005THREADS) || 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;
}
void *
Perl_get_context(void)
{
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
if (pthread_getspecific(PL_thr_key, &t))
void
Perl_set_context(void *t)
{
-#if defined(USE_THREADS) || defined(USE_ITHREADS)
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
#endif /* !PERL_GET_CONTEXT_DEFINED */
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
#ifdef FAKE_THREADS
/* Very simplistic scheduler for now */
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);
}
PL_reg_start_tmpl = 0;
PL_reg_poscache = Nullch;
+ PL_peepp = MEMBER_TO_FPTR(Perl_peep);
+
/* parent thread's data needs to be locked while we make copy */
MUTEX_LOCK(&t->mutex);
#endif /* HAVE_THREAD_INTERN */
return thr;
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *
case want_vtbl_uvar:
result = &PL_vtbl_uvar;
break;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
case want_vtbl_mutex:
result = &PL_vtbl_mutex;
break;
(dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
/*
-=for apidoc sv_getcwd
+=for apidoc getcwd_sv
Fill the sv with current working directory
* because you might chdir out of a directory that you can't chdir
* back into. */
-/* XXX: this needs more porting #ifndef HAS_GETCWD */
int
-Perl_sv_getcwd(pTHX_ register SV *sv)
+Perl_getcwd_sv(pTHX_ register SV *sv)
{
#ifndef PERL_MICRO
-#ifndef HAS_GETCWD
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
+
+#ifdef HAS_GETCWD
+ {
+ 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
+
struct stat statbuf;
int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
int namelen, pathlen=0;
DIR *dir;
Direntry_t *dp;
-#endif
(void)SvUPGRADE(sv, SVt_PV);
-#ifdef HAS_GETCWD
-
- SvGROW(sv, 128);
- while ((getcwd(SvPVX(sv), SvLEN(sv)-1) == NULL) && errno == ERANGE) {
- SvGROW(sv, SvLEN(sv) + 128);
- }
- SvCUR_set(sv, strlen(SvPVX(sv)));
- SvPOK_only(sv);
-
-#else
-
if (PerlLIO_lstat(".", &statbuf) < 0) {
SV_CWD_RETURN_UNDEF;
}
SV_CWD_RETURN_UNDEF;
}
+ if (pathlen + namelen + 1 >= MAXPATHLEN) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
SvGROW(sv, pathlen + namelen + 1);
if (pathlen) {
#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;
#endif
}
-/*
-=for apidoc sv_realpath
-
-Wrap or emulate realpath(3).
-
-=cut
- */
-int
-Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len)
-{
-#ifndef PERL_MICRO
- char name[MAXPATHLEN] = { 0 }, *s;
- STRLEN pathlen, namelen;
-
- /* Don't use strlen() to avoid running off the end. */
- s = memchr(path, '\0', MAXPATHLEN);
- pathlen = s ? s - path : MAXPATHLEN;
-
-#ifdef HAS_REALPATH
-
- /* Be paranoid about the use of realpath(),
- * it is an infamous source of buffer overruns. */
-
- /* Is the source buffer too long? */
- if (pathlen == MAXPATHLEN) {
- Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)",
- path, s ? '=' : '>', MAXPATHLEN);
- SV_CWD_RETURN_UNDEF;
- }
-
- /* Here goes nothing. */
- if (realpath(path, name) == NULL) {
- Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %s",
- path, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- /* Is the destination buffer too long?
- * Don't use strlen() to avoid running off the end. */
- s = memchr(name, '\0', MAXPATHLEN);
- namelen = s ? s - name : MAXPATHLEN;
- if (namelen == MAXPATHLEN) {
- Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)",
- path, s ? '=' : '>', MAXPATHLEN);
- SV_CWD_RETURN_UNDEF;
- }
-
- /* The coast is clear? */
- sv_setpvn(sv, name, namelen);
- SvPOK_only(sv);
-
- return TRUE;
-#else
- {
- DIR *parent;
- Direntry_t *dp;
- char dotdots[MAXPATHLEN] = { 0 };
- struct stat cst, pst, tst;
-
- if (PerlLIO_stat(path, &cst) < 0) {
- Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s",
- path, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- (void)SvUPGRADE(sv, SVt_PV);
-
- if (!len) {
- len = strlen(path);
- }
- Copy(path, dotdots, len, char);
-
- for (;;) {
- strcat(dotdots, "/..");
- StructCopy(&cst, &pst, struct stat);
-
- if (PerlLIO_stat(dotdots, &cst) < 0) {
- Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- if (pst.st_dev == cst.st_dev && pst.st_ino == cst.st_ino) {
- /* We've reached the root: previous is same as current */
- break;
- } else {
- STRLEN dotdotslen = strlen(dotdots);
-
- /* Scan through the dir looking for name of previous */
- if (!(parent = PerlDir_open(dotdots))) {
- Perl_warn(aTHX_ "sv_realpath: opendir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- while ((dp = PerlDir_read(parent)) != NULL) {
- if (SV_CWD_ISDOT(dp)) {
- continue;
- }
-
- Copy(dotdots, name, dotdotslen, char);
- name[dotdotslen] = '/';
-#ifdef DIRNAMLEN
- namelen = dp->d_namlen;
-#else
- namelen = strlen(dp->d_name);
-#endif
- Copy(dp->d_name, name + dotdotslen + 1, namelen, char);
- name[dotdotslen + 1 + namelen] = 0;
-
- if (PerlLIO_lstat(name, &tst) < 0) {
- PerlDir_close(parent);
- Perl_warn(aTHX_ "sv_realpath: lstat(\"%s\"): %s",
- name, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino)
- break;
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- }
-
- if (!dp && errno) {
- Perl_warn(aTHX_ "sv_realpath: readdir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- SvGROW(sv, pathlen + namelen + 1);
- if (pathlen) {
- /* shift down */
- Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
- }
-
- *SvPVX(sv) = '/';
- Move(dp->d_name, SvPVX(sv)+1, namelen, char);
- pathlen += (namelen + 1);
-
-#ifdef VOID_CLOSEDIR
- PerlDir_close(parent);
-#else
- if (PerlDir_close(parent) < 0) {
- Perl_warn(aTHX_ "sv_realpath: closedir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-#endif
- }
- }
-
- SvCUR_set(sv, pathlen);
- SvPOK_only(sv);
-
- return TRUE;
- }
-#endif
-#else
- return FALSE;
-#endif
-}
-
https://perl5.git.perl.org / perl5.git / blobdiff