X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ecaf18ba026d59067ac15344724117defc493850;hb=7b57b0ead8ab6b3f08be8b4ded2364d260db25a1;hp=d089df4e69e99dd1b0cbf77c50e7a31d29cbb2c9;hpb=9692f7e7da6d0e69b8995374e7ea7d5f6bd54236;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index d089df4..ecaf18b 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -533,7 +533,7 @@ Perl_new_collate(pTHX_ char *newcoll) if (! newcoll) { if (PL_collation_name) { - PL_collation_ix++; + ++PL_collation_ix; Safefree(PL_collation_name); PL_collation_name = NULL; } @@ -544,10 +544,9 @@ Perl_new_collate(pTHX_ char *newcoll) } if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { - PL_collation_ix++; - if (PL_collation_name) - Safefree(PL_collation_name); - PL_collation_name = stdize_locale(newcoll); + ++PL_collation_ix; + Safefree(PL_collation_name); + PL_collation_name = stdize_locale(savepv(newcoll)); PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); { @@ -576,13 +575,20 @@ Perl_set_numeric_radix(pTHX) struct lconv* lc; lc = localeconv(); - if (lc && lc->decimal_point) - /* We assume that decimal separator aka the radix - * character is always a single character. If it - * ever is a string, this needs to be rethunk. */ - PL_numeric_radix = *lc->decimal_point; + if (lc && lc->decimal_point) { + if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { + SvREFCNT_dec(PL_numeric_radix_sv); + PL_numeric_radix_sv = Nullsv; + } + else { + if (PL_numeric_radix_sv) + sv_setpv(PL_numeric_radix_sv, lc->decimal_point); + else + PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); + } + } else - PL_numeric_radix = 0; + PL_numeric_radix_sv = Nullsv; # endif /* HAS_LOCALECONV */ #endif /* USE_LOCALE_NUMERIC */ } @@ -606,9 +612,8 @@ Perl_new_numeric(pTHX_ char *newnum) } if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) { - if (PL_numeric_name) - Safefree(PL_numeric_name); - PL_numeric_name = stdize_locale(newnum); + Safefree(PL_numeric_name); + PL_numeric_name = stdize_locale(savepv(newnum)); PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); PL_numeric_local = TRUE; set_numeric_radix(); @@ -660,7 +665,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) * -1 = fallback to C locale failed */ -#ifdef USE_LOCALE +#if defined(USE_LOCALE) #ifdef USE_LOCALE_CTYPE char *curctype = NULL; @@ -803,6 +808,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) lc_all ? lc_all : "unset", lc_all ? '"' : ')'); +#if defined(USE_ENVIRON_ARRAY) { char **e; for (e = environ; *e; e++) { @@ -813,6 +819,10 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (int)(p - *e), *e, p + 1); } } +#else + PerlIO_printf(Perl_error_log, + "\t(possibly more locale environment variables)\n"); +#endif PerlIO_printf(Perl_error_log, "\tLANG = %c%s%c\n", @@ -1023,7 +1033,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s--, i++; } } - sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ + sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ @@ -2029,47 +2039,6 @@ Perl_my_setenv(pTHX_ char *nam, char *val) void Perl_my_setenv(pTHX_ char *nam,char *val) { - -#ifdef USE_WIN32_RTL_ENV - - register char *envstr; - STRLEN namlen = strlen(nam); - STRLEN vallen; - char *oldstr = environ[setenv_getix(nam)]; - - /* putenv() has totally broken semantics in both the Borland - * and Microsoft CRTLs. They either store the passed pointer in - * the environment without making a copy, or make a copy and don't - * free it. And on top of that, they dont free() old entries that - * are being replaced/deleted. This means the caller must - * free any old entries somehow, or we end up with a memory - * leak every time my_setenv() is called. One might think - * one could directly manipulate environ[], like the UNIX code - * above, but direct changes to environ are not allowed when - * calling putenv(), since the RTLs maintain an internal - * *copy* of environ[]. Bad, bad, *bad* stink. - * GSAR 97-06-07 - */ - - if (!val) { - if (!oldstr) - return; - val = ""; - vallen = 0; - } - else - vallen = strlen(val); - envstr = (char*)safesysmalloc((namlen + vallen + 3) * sizeof(char)); - (void)sprintf(envstr,"%s=%s",nam,val); - (void)PerlEnv_putenv(envstr); - if (oldstr) - safesysfree(oldstr); -#ifdef _MSC_VER - safesysfree(envstr); /* MSVCRT leaks without this */ -#endif - -#else /* !USE_WIN32_RTL_ENV */ - register char *envstr; STRLEN len = strlen(nam) + 3; if (!val) { @@ -2080,8 +2049,6 @@ Perl_my_setenv(pTHX_ char *nam,char *val) (void)sprintf(envstr,"%s=%s",nam,val); (void)PerlEnv_putenv(envstr); Safefree(envstr); - -#endif } #endif /* WIN32 */ @@ -2342,6 +2309,133 @@ VTOH(vtohs,short) VTOH(vtohl,long) #endif +PerlIO * +Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) +{ +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) + int p[2]; + register I32 This, that; + register Pid_t pid; + SV *sv; + I32 did_pipes = 0; + int pp[2]; + + PERL_FLUSHALL_FOR_CHILD; + This = (*mode == 'w'); + that = !This; + if (PL_tainting) { + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); + } + if (PerlProc_pipe(p) < 0) + return Nullfp; + /* Try for another pipe pair for error return */ + if (PerlProc_pipe(pp) >= 0) + did_pipes = 1; + while ((pid = vfork()) < 0) { + if (errno != EAGAIN) { + PerlLIO_close(p[This]); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } + return Nullfp; + } + sleep(5); + } + if (pid == 0) { + /* Child */ +#undef THIS +#undef THAT +#define THIS that +#define THAT This + /* Close parent's end of _the_ pipe */ + PerlLIO_close(p[THAT]); + /* Close parent's end of error status pipe (if any) */ + if (did_pipes) { + PerlLIO_close(pp[0]); +#if defined(HAS_FCNTL) && defined(F_SETFD) + /* Close error pipe automatically if exec works */ + fcntl(pp[1], F_SETFD, FD_CLOEXEC); +#endif + } + /* Now dup our end of _the_ pipe to right position */ + if (p[THIS] != (*mode == 'r')) { + PerlLIO_dup2(p[THIS], *mode == 'r'); + PerlLIO_close(p[THIS]); + } +#if !defined(HAS_FCNTL) || !defined(F_SETFD) + /* No automatic close - do it by hand */ +# ifndef NOFILE +# define NOFILE 20 +# endif + { + int fd; + + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { + if (fd != pp[1]) + PerlLIO_close(fd); + } + } +#endif + do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); + PerlProc__exit(1); +#undef THIS +#undef THAT + } + /* Parent */ + do_execfree(); /* free any memory malloced by child on vfork */ + /* Close child's end of pipe */ + PerlLIO_close(p[that]); + if (did_pipes) + PerlLIO_close(pp[1]); + /* Keep the lower of the two fd numbers */ + if (p[that] < p[This]) { + PerlLIO_dup2(p[This], p[that]); + PerlLIO_close(p[This]); + p[This] = p[that]; + } + LOCK_FDPID_MUTEX; + sv = *av_fetch(PL_fdpid,p[This],TRUE); + UNLOCK_FDPID_MUTEX; + (void)SvUPGRADE(sv,SVt_IV); + SvIVX(sv) = pid; + PL_forkprocess = pid; + /* If we managed to get status pipe check for exec fail */ + if (did_pipes && pid > 0) { + int errkid; + int n = 0, n1; + + while (n < sizeof(int)) { + n1 = PerlLIO_read(pp[0], + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + PerlLIO_close(pp[0]); + did_pipes = 0; + if (n) { /* Error */ + int pid2, status; + if (n != sizeof(int)) + Perl_croak(aTHX_ "panic: kid popen errno read"); + do { + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); + errno = errkid; /* Propagate errno from kid */ + return Nullfp; + } + } + if (did_pipes) + PerlLIO_close(pp[0]); + return PerlIO_fdopen(p[This], mode); +#else + Perl_croak(aTHX_ "List form of piped open not implemented"); + return (PerlIO *) NULL; +#endif +} + /* VMS' my_popen() is in VMS.c, same with OS/2. */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) PerlIO * @@ -2410,11 +2504,16 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #ifndef NOFILE #define NOFILE 20 #endif - for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) - if (fd != pp[1]) - PerlLIO_close(fd); + { + int fd; + + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) + if (fd != pp[1]) + PerlLIO_close(fd); + } #endif - do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */ + /* may or may not use the shell */ + do_exec3(cmd, pp[1], did_pipes); PerlProc__exit(1); } #endif /* defined OS2 */ @@ -2457,8 +2556,12 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(pp[0]); did_pipes = 0; if (n) { /* Error */ + int pid2, status; if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); + do { + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); errno = errkid; /* Propagate errno from kid */ return Nullfp; } @@ -2546,8 +2649,10 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART +#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#endif #ifdef SA_NOCLDWAIT if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; @@ -2578,8 +2683,10 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART +#if !defined(USE_PERLIO) || defined(PERL_OLD_SIGNALS) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#endif #ifdef SA_NOCLDWAIT if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; @@ -2650,7 +2757,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Pid_t pid; Pid_t pid2; bool close_failed; - int saved_errno; + int saved_errno = 0; #ifdef VMS int saved_vaxc_errno; #endif @@ -2661,7 +2768,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); UNLOCK_FDPID_MUTEX; - pid = SvIVX(*svp); + pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; SvREFCNT_dec(*svp); *svp = &PL_sv_undef; #ifdef OS2 @@ -2706,13 +2813,14 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { + if (!pid) + return -1; +#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) + { SV *sv; SV** svp; char spid[TYPE_CHARS(int)]; - if (!pid) - return -1; -#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) if (pid > 0) { sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); @@ -2734,6 +2842,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } + } } #endif #ifdef HAS_WAITPID @@ -2823,80 +2932,74 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi U32 Perl_cast_ulong(pTHX_ NV f) { - long along; - + if (f < 0.0) + return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; + if (f < U32_MAX_P1) { #if CASTFLAGS & 2 -# define BIGDOUBLE 2147483648.0 - if (f >= BIGDOUBLE) - return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; -#endif - if (f >= 0.0) - return (unsigned long)f; - along = (long)f; - return (unsigned long)along; -} -# undef BIGDOUBLE - -/* Unfortunately, on some systems the cast_uv() function doesn't - work with the system-supplied definition of ULONG_MAX. The - comparison (f >= ULONG_MAX) always comes out true. It must be a - problem with the compiler constant folding. - - In any case, this workaround should be fine on any two's complement - system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your - ccflags. - --Andy Dougherty -*/ - -/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead - of LONG_(MIN/MAX). - -- Kenneth Albanowski -*/ - -#ifndef MY_UV_MAX -# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) + if (f < U32_MAX_P1_HALF) + return (U32) f; + f -= U32_MAX_P1_HALF; + return ((U32) f) | (1 + U32_MAX >> 1); +#else + return (U32) f; #endif + } + return f > 0 ? U32_MAX : 0 /* NaN */; +} I32 Perl_cast_i32(pTHX_ NV f) { - if (f >= I32_MAX) - return (I32) I32_MAX; - if (f <= I32_MIN) - return (I32) I32_MIN; - return (I32) f; + if (f < I32_MAX_P1) + return f < I32_MIN ? I32_MIN : (I32) f; + if (f < U32_MAX_P1) { +#if CASTFLAGS & 2 + if (f < U32_MAX_P1_HALF) + return (I32)(U32) f; + f -= U32_MAX_P1_HALF; + return (I32)(((U32) f) | (1 + U32_MAX >> 1)); +#else + return (I32)(U32) f; +#endif + } + return f > 0 ? (I32)U32_MAX : 0 /* NaN */; } IV Perl_cast_iv(pTHX_ NV f) { - if (f >= IV_MAX) { - UV uv; - - if (f >= (NV)UV_MAX) - return (IV) UV_MAX; - uv = (UV) f; - return (IV)uv; - } - if (f <= IV_MIN) - return (IV) IV_MIN; - return (IV) f; + if (f < IV_MAX_P1) + return f < IV_MIN ? IV_MIN : (IV) f; + if (f < UV_MAX_P1) { +#if CASTFLAGS & 2 + /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */ + if (f < UV_MAX_P1_HALF) + return (IV)(UV) f; + f -= UV_MAX_P1_HALF; + return (IV)(((UV) f) | (1 + UV_MAX >> 1)); +#else + return (IV)(UV) f; +#endif + } + return f > 0 ? (IV)UV_MAX : 0 /* NaN */; } UV Perl_cast_uv(pTHX_ NV f) { - if (f >= MY_UV_MAX) - return (UV) MY_UV_MAX; - if (f < 0) { - IV iv; - - if (f < IV_MIN) - return (UV)IV_MIN; - iv = (IV) f; - return (UV) iv; - } + if (f < 0.0) + return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; + if (f < UV_MAX_P1) { +#if CASTFLAGS & 2 + if (f < UV_MAX_P1_HALF) + return (UV) f; + f -= UV_MAX_P1_HALF; + return ((UV) f) | (1 + UV_MAX >> 1); +#else return (UV) f; +#endif + } + return f > 0 ? UV_MAX : 0 /* NaN */; } #ifndef HAS_RENAME @@ -3389,11 +3492,11 @@ Perl_get_context(void) Perl_croak_nocontext("panic: pthread_getspecific"); return (void*)t; # else -# ifdef I_MACH_CTHREADS +# ifdef I_MACH_CTHREADS return (void*)cthread_data(cthread_self()); -# else - return (void*)pthread_getspecific(PL_thr_key); -# endif +# else + return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); +# endif # endif #else return (void*)NULL; @@ -3497,7 +3600,7 @@ Perl_condpair_magic(pTHX_ SV *sv) MAGIC *mg; SvUPGRADE(sv, SVt_PVMG); - mg = mg_find(sv, 'm'); + mg = mg_find(sv, PERL_MAGIC_mutex); if (!mg) { condpair_t *cp; @@ -3507,7 +3610,7 @@ Perl_condpair_magic(pTHX_ SV *sv) COND_INIT(&cp->cond); cp->owner = 0; LOCK_CRED_MUTEX; /* XXX need separate mutex? */ - mg = mg_find(sv, 'm'); + mg = mg_find(sv, PERL_MAGIC_mutex); if (mg) { /* someone else beat us to initialising it */ UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ @@ -3517,7 +3620,7 @@ Perl_condpair_magic(pTHX_ SV *sv) Safefree(cp); } else { - sv_magic(sv, Nullsv, 'm', 0, 0); + sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0); mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); @@ -3643,9 +3746,9 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ PL_nrs = newSVsv(t->Tnrs); - PL_rs = SvREFCNT_inc(PL_nrs); + PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; PL_last_in_gv = Nullgv; - PL_ofs_sv = SvREFCNT_inc(PL_ofs_sv); + PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv; PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); PL_chopset = t->Tchopset; PL_bodytarget = newSVsv(t->Tbodytarget); @@ -3661,7 +3764,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) if (*svp && *svp != &PL_sv_undef) { SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); - sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); + sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1); DEBUG_S(PerlIO_printf(Perl_debug_log, "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", (IV)i, t, thr)); @@ -3869,28 +3972,28 @@ Perl_my_fflush_all(pTHX) extern void _fwalk(int (*)(FILE *)); _fwalk(&fflush); return 0; -# else - long open_max = -1; +# else # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) + long open_max = -1; # ifdef PERL_FFLUSH_ALL_FOPEN_MAX open_max = PERL_FFLUSH_ALL_FOPEN_MAX; # else -# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) +# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) open_max = sysconf(_SC_OPEN_MAX); -# else -# ifdef FOPEN_MAX +# else +# ifdef FOPEN_MAX open_max = FOPEN_MAX; -# else -# ifdef OPEN_MAX +# else +# ifdef OPEN_MAX open_max = OPEN_MAX; -# else -# ifdef _NFILE +# else +# ifdef _NFILE open_max = _NFILE; +# endif +# endif # endif # endif # endif -# endif -# endif if (open_max > 0) { long i; for (i = 0; i < open_max; i++) @@ -3912,24 +4015,183 @@ Perl_my_atof(pTHX_ const char* s) { NV x = 0.0; #ifdef USE_LOCALE_NUMERIC - if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { + if (PL_numeric_local && IN_LOCALE) { NV y; - Perl_atof2(s, x); + Perl_atof2(aTHX_ s, &x); SET_NUMERIC_STANDARD(); - Perl_atof2(s, y); + Perl_atof2(aTHX_ s, &y); SET_NUMERIC_LOCAL(); if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) return y; } else - Perl_atof2(s, x); + Perl_atof2(aTHX_ s, &x); #else - Perl_atof2(s, x); + Perl_atof2(aTHX_ s, &x); #endif return x; } +NV +S_mulexp10(NV value, I32 exponent) +{ + NV result = 1.0; + NV power = 10.0; + bool negative = 0; + I32 bit; + + if (exponent == 0) + return value; + else if (exponent < 0) { + negative = 1; + exponent = -exponent; + } + for (bit = 1; exponent; bit <<= 1) { + if (exponent & bit) { + exponent ^= bit; + result *= power; + } + power *= power; + } + return negative ? value / result : value * result; +} + +char* +Perl_my_atof2(pTHX_ const char* orig, NV* value) +{ + NV result = 0.0; + bool negative = 0; + char* s = (char*)orig; + char* point = "."; /* locale-dependent decimal point equivalent */ + STRLEN pointlen = 1; + bool seendigit = 0; + I32 expextra = 0; + I32 exponent = 0; + I32 i; +/* this is arbitrary */ +#define PARTLIM 6 +/* we want the largest integers we can usefully use */ +#if defined(HAS_QUAD) && defined(USE_64_BIT_INT) +# define PARTSIZE ((int)TYPE_DIGITS(U64)-1) + U64 part[PARTLIM]; +#else +# define PARTSIZE ((int)TYPE_DIGITS(U32)-1) + U32 part[PARTLIM]; +#endif + I32 ipart = 0; /* index into part[] */ + I32 offcount; /* number of digits in least significant part */ + +#ifdef USE_LOCALE_NUMERIC + if (PL_numeric_radix_sv && IN_LOCALE) + point = SvPV(PL_numeric_radix_sv, pointlen); +#endif + + /* sign */ + switch (*s) { + case '-': + negative = 1; + /* fall through */ + case '+': + ++s; + } + + part[0] = offcount = 0; + if (isDIGIT(*s)) { + seendigit = 1; /* get this over with */ + + /* skip leading zeros */ + while (*s == '0') + ++s; + } + + /* integer digits */ + while (isDIGIT(*s)) { + if (++offcount > PARTSIZE) { + if (++ipart < PARTLIM) { + part[ipart] = 0; + offcount = 1; /* ++0 */ + } + else { + /* limits of precision reached */ + --ipart; + --offcount; + if (*s >= '5') + ++part[ipart]; + while (isDIGIT(*s)) { + ++expextra; + ++s; + } + /* warn of loss of precision? */ + break; + } + } + part[ipart] = part[ipart] * 10 + (*s++ - '0'); + } + + /* decimal point */ + if (memEQ(s, point, pointlen)) { + s += pointlen; + if (isDIGIT(*s)) + seendigit = 1; /* get this over with */ + + /* decimal digits */ + while (isDIGIT(*s)) { + if (++offcount > PARTSIZE) { + if (++ipart < PARTLIM) { + part[ipart] = 0; + offcount = 1; /* ++0 */ + } + else { + /* limits of precision reached */ + --ipart; + --offcount; + if (*s >= '5') + ++part[ipart]; + while (isDIGIT(*s)) + ++s; + /* warn of loss of precision? */ + break; + } + } + --expextra; + part[ipart] = part[ipart] * 10 + (*s++ - '0'); + } + } + + /* combine components of mantissa */ + for (i = 0; i <= ipart; ++i) + result += S_mulexp10((NV)part[ipart - i], + i ? offcount + (i - 1) * PARTSIZE : 0); + + if (seendigit && (*s == 'e' || *s == 'E')) { + bool expnegative = 0; + + ++s; + switch (*s) { + case '-': + expnegative = 1; + /* fall through */ + case '+': + ++s; + } + while (isDIGIT(*s)) + exponent = exponent * 10 + (*s++ - '0'); + if (expnegative) + exponent = -exponent; + } + + /* now apply the exponent */ + exponent += expextra; + result = S_mulexp10(result, exponent); + + /* now apply the sign */ + if (negative) + result = -result; + *value = result; + return s; +} + void Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) { @@ -3940,11 +4202,12 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ PL_op_desc[op]; char *pars = OP_IS_FILETEST(op) ? "" : "()"; - char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? + char *type = OP_IS_SOCKET(op) || + (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"; char *name = NULL; - if (io && IoTYPE(io) == IoTYPE_CLOSED) { + if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { vile = "closed"; warn_type = WARN_CLOSED; } @@ -3978,9 +4241,655 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) else { Perl_warner(aTHX_ warn_type, "%s%s on %s %s", func, pars, vile, type); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) Perl_warner(aTHX_ warn_type, "\t(Are you trying to call %s%s on dirhandle?)\n", func, pars); } } + +#ifdef EBCDIC +/* in ASCII order, not that it matters */ +static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"; + +int +Perl_ebcdic_control(pTHX_ int ch) +{ + if (ch > 'a') { + char *ctlp; + + if (islower(ch)) + ch = toupper(ch); + + if ((ctlp = strchr(controllablechars, ch)) == 0) { + Perl_die(aTHX_ "unrecognised control character '%c'\n", ch); + } + + if (ctlp == controllablechars) + return('\177'); /* DEL */ + else + return((unsigned char)(ctlp - controllablechars - 1)); + } else { /* Want uncontrol */ + if (ch == '\177' || ch == -1) + return('?'); + else if (ch == '\157') + return('\177'); + else if (ch == '\174') + return('\000'); + else if (ch == '^') /* '\137' in 1047, '\260' in 819 */ + return('\036'); + else if (ch == '\155') + return('\037'); + else if (0 < ch && ch < (sizeof(controllablechars) - 1)) + return(controllablechars[ch+1]); + else + Perl_die(aTHX_ "invalid control request: '\\%03o'\n", ch & 0xFF); + } +} +#endif + +/* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) + * fields for which we don't have Configure support yet: + * char *tm_zone; -- abbreviation of timezone name + * long tm_gmtoff; -- offset from GMT in seconds + * To workaround core dumps from the uninitialised tm_zone we get the + * system to give us a reasonable struct to copy. This fix means that + * strftime uses the tm_zone and tm_gmtoff values returned by + * localtime(time()). That should give the desired result most of the + * time. But probably not always! + * + * This is a temporary workaround to be removed once Configure + * support is added and NETaa14816 is considered in full. + * It does not address tzname aspects of NETaa14816. + */ +#ifdef HAS_GNULIBC +# ifndef STRUCT_TM_HASZONE +# define STRUCT_TM_HASZONE +# endif +#endif + +void +Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ +{ +#ifdef STRUCT_TM_HASZONE + Time_t now; + (void)time(&now); + Copy(localtime(&now), ptm, 1, struct tm); +#endif +} + +/* + * mini_mktime - normalise struct tm values without the localtime() + * semantics (and overhead) of mktime(). + */ +void +Perl_mini_mktime(pTHX_ struct tm *ptm) +{ + int yearday; + int secs; + int month, mday, year, jday; + int odd_cent, odd_year; + +#define DAYS_PER_YEAR 365 +#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) +#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) +#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) +#define SECS_PER_HOUR (60*60) +#define SECS_PER_DAY (24*SECS_PER_HOUR) +/* parentheses deliberately absent on these two, otherwise they don't work */ +#define MONTH_TO_DAYS 153/5 +#define DAYS_TO_MONTH 5/153 +/* offset to bias by March (month 4) 1st between month/mday & year finding */ +#define YEAR_ADJUST (4*MONTH_TO_DAYS+1) +/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ +#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ + +/* + * Year/day algorithm notes: + * + * With a suitable offset for numeric value of the month, one can find + * an offset into the year by considering months to have 30.6 (153/5) days, + * using integer arithmetic (i.e., with truncation). To avoid too much + * messing about with leap days, we consider January and February to be + * the 13th and 14th month of the previous year. After that transformation, + * we need the month index we use to be high by 1 from 'normal human' usage, + * so the month index values we use run from 4 through 15. + * + * Given that, and the rules for the Gregorian calendar (leap years are those + * divisible by 4 unless also divisible by 100, when they must be divisible + * by 400 instead), we can simply calculate the number of days since some + * arbitrary 'beginning of time' by futzing with the (adjusted) year number, + * the days we derive from our month index, and adding in the day of the + * month. The value used here is not adjusted for the actual origin which + * it normally would use (1 January A.D. 1), since we're not exposing it. + * We're only building the value so we can turn around and get the + * normalised values for the year, month, day-of-month, and day-of-year. + * + * For going backward, we need to bias the value we're using so that we find + * the right year value. (Basically, we don't want the contribution of + * March 1st to the number to apply while deriving the year). Having done + * that, we 'count up' the contribution to the year number by accounting for + * full quadracenturies (400-year periods) with their extra leap days, plus + * the contribution from full centuries (to avoid counting in the lost leap + * days), plus the contribution from full quad-years (to count in the normal + * leap days), plus the leftover contribution from any non-leap years. + * At this point, if we were working with an actual leap day, we'll have 0 + * days left over. This is also true for March 1st, however. So, we have + * to special-case that result, and (earlier) keep track of the 'odd' + * century and year contributions. If we got 4 extra centuries in a qcent, + * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. + * Otherwise, we add back in the earlier bias we removed (the 123 from + * figuring in March 1st), find the month index (integer division by 30.6), + * and the remainder is the day-of-month. We then have to convert back to + * 'real' months (including fixing January and February from being 14/15 in + * the previous year to being in the proper year). After that, to get + * tm_yday, we work with the normalised year and get a new yearday value for + * January 1st, which we subtract from the yearday value we had earlier, + * representing the date we've re-built. This is done from January 1 + * because tm_yday is 0-origin. + * + * Since POSIX time routines are only guaranteed to work for times since the + * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm + * applies Gregorian calendar rules even to dates before the 16th century + * doesn't bother me. Besides, you'd need cultural context for a given + * date to know whether it was Julian or Gregorian calendar, and that's + * outside the scope for this routine. Since we convert back based on the + * same rules we used to build the yearday, you'll only get strange results + * for input which needed normalising, or for the 'odd' century years which + * were leap years in the Julian calander but not in the Gregorian one. + * I can live with that. + * + * This algorithm also fails to handle years before A.D. 1 gracefully, but + * that's still outside the scope for POSIX time manipulation, so I don't + * care. + */ + + year = 1900 + ptm->tm_year; + month = ptm->tm_mon; + mday = ptm->tm_mday; + /* allow given yday with no month & mday to dominate the result */ + if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { + month = 0; + mday = 0; + jday = 1 + ptm->tm_yday; + } + else { + jday = 0; + } + if (month >= 2) + month+=2; + else + month+=14, year--; + yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; + yearday += month*MONTH_TO_DAYS + mday + jday; + /* + * Note that we don't know when leap-seconds were or will be, + * so we have to trust the user if we get something which looks + * like a sensible leap-second. Wild values for seconds will + * be rationalised, however. + */ + if ((unsigned) ptm->tm_sec <= 60) { + secs = 0; + } + else { + secs = ptm->tm_sec; + ptm->tm_sec = 0; + } + secs += 60 * ptm->tm_min; + secs += SECS_PER_HOUR * ptm->tm_hour; + if (secs < 0) { + if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { + /* got negative remainder, but need positive time */ + /* back off an extra day to compensate */ + yearday += (secs/SECS_PER_DAY)-1; + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); + } + else { + yearday += (secs/SECS_PER_DAY); + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); + } + } + else if (secs >= SECS_PER_DAY) { + yearday += (secs/SECS_PER_DAY); + secs %= SECS_PER_DAY; + } + ptm->tm_hour = secs/SECS_PER_HOUR; + secs %= SECS_PER_HOUR; + ptm->tm_min = secs/60; + secs %= 60; + ptm->tm_sec += secs; + /* done with time of day effects */ + /* + * The algorithm for yearday has (so far) left it high by 428. + * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to + * bias it by 123 while trying to figure out what year it + * really represents. Even with this tweak, the reverse + * translation fails for years before A.D. 0001. + * It would still fail for Feb 29, but we catch that one below. + */ + jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ + yearday -= YEAR_ADJUST; + year = (yearday / DAYS_PER_QCENT) * 400; + yearday %= DAYS_PER_QCENT; + odd_cent = yearday / DAYS_PER_CENT; + year += odd_cent * 100; + yearday %= DAYS_PER_CENT; + year += (yearday / DAYS_PER_QYEAR) * 4; + yearday %= DAYS_PER_QYEAR; + odd_year = yearday / DAYS_PER_YEAR; + year += odd_year; + yearday %= DAYS_PER_YEAR; + if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ + month = 1; + yearday = 29; + } + else { + yearday += YEAR_ADJUST; /* recover March 1st crock */ + month = yearday*DAYS_TO_MONTH; + yearday -= month*MONTH_TO_DAYS; + /* recover other leap-year adjustment */ + if (month > 13) { + month-=14; + year++; + } + else { + month-=2; + } + } + ptm->tm_year = year - 1900; + if (yearday) { + ptm->tm_mday = yearday; + ptm->tm_mon = month; + } + else { + ptm->tm_mday = 31; + ptm->tm_mon = month - 1; + } + /* re-build yearday based on Jan 1 to get tm_yday */ + year--; + yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; + yearday += 14*MONTH_TO_DAYS + 1; + ptm->tm_yday = jday - yearday; + /* fix tm_wday if not overridden by caller */ + if ((unsigned)ptm->tm_wday > 6) + ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; +} + +char * +Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) +{ +#ifdef HAS_STRFTIME + char *buf; + int buflen; + struct tm mytm; + int len; + + init_tm(&mytm); /* XXX workaround - see init_tm() above */ + mytm.tm_sec = sec; + mytm.tm_min = min; + mytm.tm_hour = hour; + mytm.tm_mday = mday; + mytm.tm_mon = mon; + mytm.tm_year = year; + mytm.tm_wday = wday; + mytm.tm_yday = yday; + mytm.tm_isdst = isdst; + mini_mktime(&mytm); + buflen = 64; + New(0, buf, buflen, char); + len = strftime(buf, buflen, fmt, &mytm); + /* + ** The following is needed to handle to the situation where + ** tmpbuf overflows. Basically we want to allocate a buffer + ** and try repeatedly. The reason why it is so complicated + ** is that getting a return value of 0 from strftime can indicate + ** one of the following: + ** 1. buffer overflowed, + ** 2. illegal conversion specifier, or + ** 3. the format string specifies nothing to be returned(not + ** an error). This could be because format is an empty string + ** or it specifies %p that yields an empty string in some locale. + ** If there is a better way to make it portable, go ahead by + ** all means. + */ + if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0')) + return buf; + else { + /* Possibly buf overflowed - try again with a bigger buf */ + int fmtlen = strlen(fmt); + int bufsize = fmtlen + buflen; + + New(0, buf, bufsize, char); + while (buf) { + buflen = strftime(buf, bufsize, fmt, &mytm); + if (buflen > 0 && buflen < bufsize) + break; + /* heuristic to prevent out-of-memory errors */ + if (bufsize > 100*fmtlen) { + Safefree(buf); + buf = NULL; + break; + } + bufsize *= 2; + Renew(buf, bufsize, char); + } + return buf; + } +#else + Perl_croak(aTHX_ "panic: no strftime"); +#endif +} + + +#define SV_CWD_RETURN_UNDEF \ +sv_setsv(sv, &PL_sv_undef); \ +return FALSE + +#define SV_CWD_ISDOT(dp) \ + (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ + (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) + +/* +=for apidoc sv_getcwd + +Fill the sv with current working directory + +=cut +*/ + +/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. + * rewritten again by dougm, optimized for use with xs TARG, and to prefer + * getcwd(3) if available + * Comments from the orignal: + * This is a faster version of getcwd. It's also more dangerous + * 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) +{ +#ifndef PERL_MICRO + +#ifndef HAS_GETCWD + 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; + } + + orig_cdev = statbuf.st_dev; + orig_cino = statbuf.st_ino; + cdev = orig_cdev; + cino = orig_cino; + + for (;;) { + odev = cdev; + oino = cino; + + if (PerlDir_chdir("..") < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { +#ifdef DIRNAMLEN + namelen = dp->d_namlen; +#else + namelen = strlen(dp->d_name); +#endif + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } + + if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } + + if (!dp) { + SV_CWD_RETURN_UNDEF; + } + + SvGROW(sv, pathlen + namelen + 1); + + if (pathlen) { + /* shift down */ + Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } + + /* prepend current directory to the front */ + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); + +#ifdef VOID_CLOSEDIR + PerlDir_close(dir); +#else + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } +#endif + } + + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); + + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (cdev != orig_cdev || cino != orig_cino) { + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); + } +#endif + + return TRUE; +#else + return FALSE; +#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; + +#ifdef HAS_REALPATH + /* Be paranoid about the use of realpath(), + * it is an infamous source of buffer overruns. */ + + /* Is the source buffer too long? + * Don't use strlen() to avoid running off the end. */ + s = memchr(path, '\0', MAXPATHLEN); + pathlen = s ? s - path : MAXPATHLEN; + 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 +}