#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 *
sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
s = (U8*)SvPV_force(sv, len);
(void)SvUPGRADE(sv, SVt_PVBM);
- if (len == 0) /* TAIL might be on on a zero-length string. */
+ if (len == 0) /* TAIL might be on a zero-length string. */
return;
if (len > 2) {
U8 mlen;
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
PL_restartop = die_where(message, msglen);
JMPENV_JUMP(3);
}
+ else if (!message)
+ message = SvPVx(ERRSV, msglen);
+
{
#ifdef USE_SFIO
/* SFIO can really mess with your errno */
#endif
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
#ifdef USE_SFIO
errno = e;
{
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
#ifdef LEAKTEST
DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
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;
}
{
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
(void)PerlIO_flush(serr);
}
my_failure_exit();
}
{
PerlIO *serr = Perl_error_log;
- PerlIO_write(serr, message, msglen);
+ PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
#ifdef LEAKTEST
DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
}
}
+/* since we've already done strlen() for both nam and val
+ * we can use that info to make things faster than
+ * sprintf(s, "%s=%s", nam, val)
+ */
+#define my_setenv_format(s, nam, nlen, val, vlen) \
+ Copy(nam, s, nlen, char); \
+ *(s+nlen) = '='; \
+ Copy(val, s+(nlen+1), vlen, char); \
+ *(s+(nlen+1+vlen)) = '\0'
+
#ifdef USE_ENVIRON_ARRAY
/* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
#if !defined(WIN32) && !defined(NETWARE)
#ifndef PERL_USE_SAFE_PUTENV
/* most putenv()s leak, so we manipulate environ directly */
register I32 i=setenv_getix(nam); /* where does it go? */
+ int nlen, vlen;
if (environ == PL_origenviron) { /* need we copy environment? */
I32 j;
for (max = i; environ[max]; max++) ;
tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
for (j=0; j<max; j++) { /* copy environment */
- tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
- strcpy(tmpenv[j], environ[j]);
+ int len = strlen(environ[j]);
+ tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ Copy(environ[j], tmpenv[j], len+1, char);
}
tmpenv[max] = Nullch;
environ = tmpenv; /* tell exec where it is now */
}
else
safesysfree(environ[i]);
- environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
+ nlen = strlen(nam);
+ vlen = strlen(val);
- (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
+ environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(environ[i], nam, nlen, val, vlen);
#else /* PERL_USE_SAFE_PUTENV */
# if defined(__CYGWIN__)
setenv(nam, val, 1);
# else
char *new_env;
-
- new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
- (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
+ int nlen = strlen(nam), vlen;
+ if (!val) {
+ val = "";
+ }
+ vlen = strlen(val);
+ new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(new_env, nam, nlen, val, vlen);
(void)putenv(new_env);
# endif /* __CYGWIN__ */
#endif /* PERL_USE_SAFE_PUTENV */
Perl_my_setenv(pTHX_ char *nam,char *val)
{
register char *envstr;
- STRLEN len = strlen(nam) + 3;
+ int nlen = strlen(nam), vlen;
+
if (!val) {
val = "";
}
- len += strlen(val);
- New(904, envstr, len, char);
- (void)sprintf(envstr,"%s=%s",nam,val);
+ vlen = strlen(val);
+ New(904, envstr, nlen+vlen+2, char);
+ my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
}
/* 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)
did_pipes = 0;
if (n) { /* Error */
int pid2, status;
+ PerlLIO_close(p[This]);
if (n != sizeof(int))
Perl_croak(aTHX_ "panic: kid popen errno read");
do {
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) {
}
#endif /* defined OS2 */
/*SUPPRESS 560*/
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
+ if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+ SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
+ SvREADONLY_on(GvSV(tmpgv));
+ }
PL_forkprocess = 0;
hv_clear(PL_pidstatus); /* we have no children */
return Nullfp;
#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]);
did_pipes = 0;
if (n) { /* Error */
int pid2, status;
+ PerlLIO_close(p[This]);
if (n != sizeof(int))
Perl_croak(aTHX_ "panic: kid popen errno read");
do {
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 PerlProc_signal(signo, handler);
}
-static int sig_trapped;
+static int sig_trapped; /* XXX signals are process-wide anyway, so we
+ ignore the implications of this for threading */
static
Signal_t
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;
}
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
register char *s;
- I32 len;
+ I32 len = 0;
int retval;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
# define SEARCH_EXTS ".bat", ".cmd", NULL
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);
PL_tainted = t->Ttainted;
PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
- PL_nrs = newSVsv(t->Tnrs);
- PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv;
+ PL_rs = newSVsv(t->Trs);
PL_last_in_gv = Nullgv;
PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv;
PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
#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;
}
/*
-=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;
+=for apidoc new_vstring
- 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;
- }
+Returns a pointer to the next character after the parsed
+vstring, as well as updating the passed in sv.
+ *
+Function must be called like
+
+ sv = NEWSV(92,5);
+ s = new_vstring(s,sv);
- 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;
- }
+The sv must already be large enough to store the vstring
+passed in.
- SvGROW(sv, pathlen + namelen + 1);
- if (pathlen) {
- /* shift down */
- Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
- }
+=cut
+*/
- *SvPVX(sv) = '/';
- Move(dp->d_name, SvPVX(sv)+1, namelen, char);
- pathlen += (namelen + 1);
+char *
+Perl_new_vstring(pTHX_ char *s, SV *sv)
+{
+ char *pos = s;
+ if (*pos == 'v') pos++; /* get past 'v' */
+ while (isDIGIT(*pos) || *pos == '_')
+ pos++;
+ if (!isALPHA(*pos)) {
+ UV rev;
+ U8 tmpbuf[UTF8_MAXLEN+1];
+ U8 *tmpend;
-#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
- }
- }
+ if (*s == 'v') s++; /* get past 'v' */
- SvCUR_set(sv, pathlen);
- SvPOK_only(sv);
+ sv_setpvn(sv, "", 0);
- return TRUE;
+ for (;;) {
+ rev = 0;
+ {
+ /* this is atoi() that tolerates underscores */
+ char *end = pos;
+ UV mult = 1;
+ if ( *(s-1) == '_') {
+ mult = 10;
+ }
+ while (--end >= s) {
+ UV orev;
+ orev = rev;
+ rev += (*end - '0') * mult;
+ mult *= 10;
+ if (orev > rev && ckWARN_d(WARN_OVERFLOW))
+ Perl_warner(aTHX_ WARN_OVERFLOW,
+ "Integer overflow in decimal number");
+ }
+ }
+ /* Append native character for the rev point */
+ tmpend = uvchr_to_utf8(tmpbuf, rev);
+ sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
+ if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
+ SvUTF8_on(sv);
+ if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
+ s = ++pos;
+ else {
+ s = pos;
+ break;
+ }
+ while (isDIGIT(*pos) )
+ pos++;
+ }
+ SvPOK_on(sv);
+ SvREADONLY_on(sv);
}
-#endif
-#else
- return FALSE;
-#endif
+ return s;
}
+
projects / p5sagit/p5-mst-13.2.git / blobdiff