/* 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.
#endif
#endif
-/* XXX If this causes problems, set i_unistd=undef in the hint file. */
-#ifdef I_UNISTD
-# include <unistd.h>
-#endif
-
#ifdef I_VFORK
# include <vfork.h>
#endif
Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
-#ifdef HAS_64K_LIMIT
+#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
PerlIO_printf(Perl_error_log,
"Reallocation too large: %lx\n", size) FLUSH;
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
-
+
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (!wh)
return safexmalloc(0,size);
-
+
{
MEM_SIZE old = sizeof_chunk(where - ALIGN);
int t = typeof_chunk(where - ALIGN);
register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
-
+
xycount[t][SIZE_TO_Y(old)]--;
xycount[t][SIZE_TO_Y(size)]++;
xcount[t] += size - old;
I32 x;
char *where = (char*)wh;
MEM_SIZE size;
-
+
if (!where)
return;
where -= ALIGN;
for (j = 0; j < MAXYCOUNT; j++) {
subtot[j] = 0;
}
-
+
PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
for (i = 0; i < MAXXCOUNT; i++) {
total += xcount[i];
}
if (flag == 0
? xcount[i] /* Have something */
- : (flag == 2
+ : (flag == 2
? xcount[i] != lastxcount[i] /* Changed */
: xcount[i] > lastxcount[i])) { /* Growed */
- PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
+ PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
lastxcount[i] = xcount[i];
for (j = 0; j < MAXYCOUNT; j++) {
- if ( flag == 0
+ if ( flag == 0
? xycount[i][j] /* Have something */
- : (flag == 2
+ : (flag == 2
? xycount[i][j] != lastxycount[i][j] /* Changed */
: xycount[i][j] > lastxycount[i][j])) { /* Growed */
- PerlIO_printf(Perl_debug_log,"%3ld ",
- flag == 2
- ? xycount[i][j] - lastxycount[i][j]
+ PerlIO_printf(Perl_debug_log,"%3ld ",
+ flag == 2
+ ? xycount[i][j] - lastxycount[i][j]
: xycount[i][j]);
lastxycount[i][j] = xycount[i][j];
} else {
* Set up for a new ctype locale.
*/
void
-Perl_new_ctype(pTHX_ const char *newctype)
+Perl_new_ctype(pTHX_ char *newctype)
{
#ifdef USE_LOCALE_CTYPE
}
/*
+ * Standardize the locale name from a string returned by 'setlocale'.
+ *
+ * The standard return value of setlocale() is either
+ * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
+ * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
+ * (the space-separated values represent the various sublocales,
+ * in some unspecificed order)
+ *
+ * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
+ * which is harmful for further use of the string in setlocale().
+ *
+ */
+STATIC char *
+S_stdize_locale(pTHX_ char *locs)
+{
+ char *s;
+ bool okay = TRUE;
+
+ if ((s = strchr(locs, '='))) {
+ char *t;
+
+ okay = FALSE;
+ if ((t = strchr(s, '.'))) {
+ char *u;
+
+ if ((u = strchr(t, '\n'))) {
+
+ if (u[1] == 0) {
+ STRLEN len = u - s;
+ Move(s + 1, locs, len, char);
+ locs[len] = 0;
+ okay = TRUE;
+ }
+ }
+ }
+ }
+
+ if (!okay)
+ Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
+
+ return locs;
+}
+
+/*
* Set up for a new collation locale.
*/
void
-Perl_new_collate(pTHX_ const char *newcoll)
+Perl_new_collate(pTHX_ char *newcoll)
{
#ifdef USE_LOCALE_COLLATE
++PL_collation_ix;
Safefree(PL_collation_name);
PL_collation_name = NULL;
- PL_collation_standard = TRUE;
- PL_collxfrm_base = 0;
- PL_collxfrm_mult = 2;
}
+ PL_collation_standard = TRUE;
+ PL_collxfrm_base = 0;
+ PL_collxfrm_mult = 2;
return;
}
if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
++PL_collation_ix;
Safefree(PL_collation_name);
- PL_collation_name = savepv(newcoll);
+ PL_collation_name = stdize_locale(savepv(newcoll));
PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
{
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 */
}
* Set up for a new numeric locale.
*/
void
-Perl_new_numeric(pTHX_ const char *newnum)
+Perl_new_numeric(pTHX_ char *newnum)
{
#ifdef USE_LOCALE_NUMERIC
if (PL_numeric_name) {
Safefree(PL_numeric_name);
PL_numeric_name = NULL;
- PL_numeric_standard = TRUE;
- PL_numeric_local = TRUE;
}
+ PL_numeric_standard = TRUE;
+ PL_numeric_local = TRUE;
return;
}
if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
Safefree(PL_numeric_name);
- PL_numeric_name = savepv(newnum);
+ PL_numeric_name = stdize_locale(savepv(newnum));
PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
PL_numeric_local = TRUE;
set_numeric_radix();
setlocale(LC_NUMERIC, "C");
PL_numeric_standard = TRUE;
PL_numeric_local = FALSE;
+ set_numeric_radix();
}
#endif /* USE_LOCALE_NUMERIC */
* -1 = fallback to C locale failed
*/
-#ifdef USE_LOCALE
+#if defined(USE_LOCALE)
#ifdef USE_LOCALE_CTYPE
char *curctype = NULL;
(!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
+ else
+ curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll =
(!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
+ else
+ curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum =
(!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
+ else
+ curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
#ifdef USE_LOCALE_CTYPE
if (! (curctype = setlocale(LC_CTYPE, "")))
setlocale_failure = TRUE;
+ else
+ curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll = setlocale(LC_COLLATE, "")))
setlocale_failure = TRUE;
+ else
+ curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum = setlocale(LC_NUMERIC, "")))
setlocale_failure = TRUE;
+ else
+ curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
if (setlocale_failure) {
char *p;
- bool locwarn = (printwarn > 1 ||
+ bool locwarn = (printwarn > 1 ||
(printwarn &&
(!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
if (locwarn) {
#ifdef LC_ALL
-
+
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed.\n");
#else /* !LC_ALL */
-
+
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed for the categories:\n\t");
#ifdef USE_LOCALE_CTYPE
lc_all ? lc_all : "unset",
lc_all ? '"' : ')');
+#if defined(USE_ENVIRON_ARRAY)
{
char **e;
for (e = environ; *e; e++) {
(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",
#endif /* ! LC_ALL */
#ifdef USE_LOCALE_CTYPE
- curctype = setlocale(LC_CTYPE, Nullch);
+ curctype = savepv(setlocale(LC_CTYPE, Nullch));
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
- curcoll = setlocale(LC_COLLATE, Nullch);
+ curcoll = savepv(setlocale(LC_COLLATE, Nullch));
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
- curnum = setlocale(LC_NUMERIC, Nullch);
+ curnum = savepv(setlocale(LC_NUMERIC, Nullch));
#endif /* USE_LOCALE_NUMERIC */
}
+ else {
#ifdef USE_LOCALE_CTYPE
new_ctype(curctype);
#ifdef USE_LOCALE_NUMERIC
new_numeric(curnum);
#endif /* USE_LOCALE_NUMERIC */
+ }
#endif /* USE_LOCALE */
+#ifdef USE_LOCALE_CTYPE
+ if (curctype != NULL)
+ Safefree(curctype);
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (curcoll != NULL)
+ Safefree(curcoll);
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (curnum != NULL)
+ Safefree(curnum);
+#endif /* USE_LOCALE_NUMERIC */
return ok;
}
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 */
register I32 multiline = flags & FBMrf_MULTILINE;
if (bigend - big < littlelen) {
- if ( SvTAIL(littlestr)
+ if ( SvTAIL(littlestr)
&& (bigend - big == littlelen - 1)
- && (littlelen == 1
+ && (littlelen == 1
|| (*big == *little &&
memEQ((char *)big, (char *)little, littlelen - 1))))
return (char*)big;
}
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
- if (s >= big && bigend[-1] == '\n' && *s == *little
+ if (s >= big && bigend[-1] == '\n' && *s == *little
/* Automatically of length > 2 */
&& memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
{
}
return b;
}
-
+
{ /* Do actual FBM. */
register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
register unsigned char *oldlittle;
of ends of some substring of bigstr.
If `last' we want the last occurence.
old_posp is the way of communication between consequent calls if
- the next call needs to find the .
+ the next call needs to find the .
The initial *old_posp should be -1.
Note that we take into account SvTAIL, so one can get extra
char *
Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
{
- dTHR;
register unsigned char *s, *x;
register unsigned char *big;
register I32 pos;
? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
cant_find:
- if ( BmRARE(littlestr) == '\n'
+ if ( BmRARE(littlestr) == '\n'
&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
little = (unsigned char *)(SvPVX(littlestr));
littleend = little + SvCUR(littlestr);
found = 1;
}
} while ( pos += PL_screamnext[pos] );
- if (last && found)
+ if (last && found)
return (char *)(big+(*old_posp));
#endif /* POINTERRIGOR */
check_tail:
STATIC SV *
S_mess_alloc(pTHX)
{
- dTHR;
SV *sv;
XPVMG *any;
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
- dTHR;
if (CopLINE(PL_curcop))
Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
- line_mode ? "line" : "chunk",
+ line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
#ifdef USE_THREADS
OP *
Perl_vdie(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
int was_in_eval = PL_in_eval;
HV *stash;
void
Perl_vcroak(pTHX_ const char* pat, va_list *args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
PerlIO_write(serr, message, msglen);
#ifdef LEAKTEST
- DEBUG_L(*message == '!'
+ DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
? (message[2]=='!' ? 2 : 1)
: 0)
void
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
- dTHR;
char *message;
HV *stash;
GV *gv;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
SV *msg;
-
+
ENTER;
save_re_context();
msg = newSVpvn(message, msglen);
SvREADONLY_on(msg);
SAVEFREESV(msg);
-
+
PUSHSTACKi(PERLSI_DIEHOOK);
PUSHMARK(sp);
XPUSHs(msg);
else {
if (PL_warnhook) {
/* sv_2cv might call Perl_warn() */
- dTHR;
SV *oldwarnhook = PL_warnhook;
ENTER;
SAVESPTR(PL_warnhook);
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
SV *msg;
-
+
ENTER;
save_re_context();
msg = newSVpvn(message, msglen);
SvREADONLY_on(msg);
SAVEFREESV(msg);
-
+
PUSHSTACKi(PERLSI_WARNHOOK);
PUSHMARK(sp);
XPUSHs(msg);
PerlIO *serr = Perl_error_log;
PerlIO_write(serr, message, msglen);
#ifdef LEAKTEST
- DEBUG_L(xstat());
+ DEBUG_L(*message == '!'
+ ? (xstat(message[1]=='!'
+ ? (message[2]=='!' ? 2 : 1)
+ : 0)
+ , 0)
+ : 0);
#endif
(void)PerlIO_flush(serr);
}
}
}
-#ifndef VMS /* VMS' my_setenv() is in VMS.c */
-#if !defined(WIN32) && !defined(__CYGWIN__)
+#ifdef USE_ENVIRON_ARRAY
+ /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
+#if !defined(WIN32)
void
Perl_my_setenv(pTHX_ char *nam, char *val)
{
(void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
#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 */
(void)putenv(new_env);
+# endif /* __CYGWIN__ */
#endif /* PERL_USE_SAFE_PUTENV */
}
-#else /* WIN32 || __CYGWIN__ */
-#if defined(__CYGWIN__)
-/*
- * Save environ of perl.exe, currently Cygwin links in separate environ's
- * for each exe/dll. Probably should be a member of impure_ptr.
- */
-static char ***Perl_main_environ;
-
-EXTERN_C void
-Perl_my_setenv_init(char ***penviron)
-{
- Perl_main_environ = penviron;
-}
-
-void
-Perl_my_setenv(pTHX_ char *nam, char *val)
-{
- /* You can not directly manipulate the environ[] array because
- * the routines do some additional work that syncs the Cygwin
- * environment with the Windows environment.
- */
- char *oldstr = environ[setenv_getix(nam)];
-
- if (!val) {
- if (!oldstr)
- return;
- unsetenv(nam);
- safesysfree(oldstr);
- return;
- }
- setenv(nam, val, 1);
- environ = *Perl_main_environ; /* environ realloc can occur in setenv */
- if(oldstr && environ[setenv_getix(nam)] != oldstr)
- safesysfree(oldstr);
-}
-#else /* if WIN32 */
+#else /* WIN32 */
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) {
(void)sprintf(envstr,"%s=%s",nam,val);
(void)PerlEnv_putenv(envstr);
Safefree(envstr);
-
-#endif
}
#endif /* WIN32 */
-#endif
I32
Perl_setenv_getix(pTHX_ char *nam)
return i;
}
-#endif /* !VMS */
+#endif /* !VMS && !EPOC*/
#ifdef UNLINK_ALL_VERSIONS
I32
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 *
if (doexec) {
return my_syspopen(aTHX_ cmd,mode);
}
-#endif
+#endif
This = (*mode == 'w');
that = !This;
if (doexec && PL_tainting) {
#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 */
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;
}
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
- /* Needs work for PerlIO ! */
- /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
PERL_FLUSHALL_FOR_CHILD;
- return popen(PerlIO_exportFILE(cmd, 0), mode);
+ /* 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(popen(cmd, mode), 0);
}
#endif
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;
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;
Pid_t pid;
Pid_t pid2;
bool close_failed;
- int saved_errno;
+ int saved_errno = 0;
#ifdef VMS
int saved_vaxc_errno;
#endif
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
if (pid == -1) { /* Opened by popen. */
return my_syspclose(ptr);
}
-#endif
+#endif
if ((close_failed = (PerlIO_close(ptr) == EOF))) {
saved_errno = errno;
#ifdef VMS
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 (pid > 0) {
sprintf(spid, "%"IVdf, (IV)pid);
svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
return pid;
}
+ }
}
+#endif
#ifdef HAS_WAITPID
# ifdef HAS_WAITPID_RUNTIME
if (!HAS_WAITPID_RUNTIME)
#else
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
-#endif
+#endif
{
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
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 <doughera@lafcol.lafayette.edu>
-*/
-
-/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
- of LONG_(MIN/MAX).
- -- Kenneth Albanowski <kjahds@kjahds.com>
-*/
-
-#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
#endif /* !HAS_RENAME */
NV
-Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
+Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
{
register char *s = start;
register NV rnv = 0.0;
continue;
}
else {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal binary digit '%c' ignored", *s);
register UV xuv = ruv << 1;
if ((xuv >> 1) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
- ) {
- dTHR;
+ ) {
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Binary number > 0b11111111111111111111111111111111 non-portable");
}
NV
-Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
+Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
{
register char *s = start;
register NV rnv = 0.0;
* as soon as non-octal characters are seen, complain only iff
* someone seems to want to use the digits eight and nine). */
if (*s == '8' || *s == '9') {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal octal digit '%c' ignored", *s);
register UV xuv = ruv << 3;
if ((xuv >> 3) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
|| (!overflowed && ruv > 0xffffffff )
#endif
) {
- dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Octal number > 037777777777 non-portable");
}
NV
-Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
+Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
{
register char *s = start;
register NV rnv = 0.0;
register UV ruv = 0;
- register bool seenx = FALSE;
register bool overflowed = FALSE;
char *hexdigit;
+ if (len > 2) {
+ if (s[0] == 'x') {
+ s++;
+ len--;
+ }
+ else if (len > 3 && s[0] == '0' && s[1] == 'x') {
+ s+=2;
+ len-=2;
+ }
+ }
+
for (; len-- && *s; s++) {
hexdigit = strchr((char *) PL_hexdigit, *s);
if (!hexdigit) {
--len;
++s;
}
- else if (seenx == FALSE && *s == 'x' && ruv == 0) {
- /* Disallow 0xxx0x0xxx... */
- seenx = TRUE;
- continue;
- }
else {
- dTHR;
if (ckWARN(WARN_DIGIT))
Perl_warner(aTHX_ WARN_DIGIT,
"Illegal hexadecimal digit '%c' ignored", *s);
register UV xuv = ruv << 4;
if ((xuv >> 4) != ruv) {
- dTHR;
overflowed = TRUE;
rnv = (NV) ruv;
if (ckWARN_d(WARN_OVERFLOW))
#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
- ) {
- dTHR;
+ ) {
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
"Hexadecimal number > 0xffffffff non-portable");
char*
Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
{
- dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
char tmpbuf[MAXPATHLEN];
}
#ifndef DOSISH
if (!xfound && !seen_dot && !xfailed &&
- (PerlLIO_stat(scriptname,&PL_statbuf) < 0
+ (PerlLIO_stat(scriptname,&PL_statbuf) < 0
|| S_ISDIR(PL_statbuf.st_mode)))
#endif
seen_dot = 1; /* Disable message. */
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;
{
perl_os_thread t;
perl_cond cond = *cp;
-
+
if (!cond)
return;
t = cond->thread;
{
perl_os_thread t;
perl_cond cond, cond_next;
-
+
for (cond = *cp; cond; cond = cond_next) {
t = cond->thread;
/* Insert t in the runnable queue just ahead of us */
if (thr->i.next_run == thr)
Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
-
+
New(666, cond, 1, struct perl_wait_queue);
cond->thread = thr;
cond->next = *cp;
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;
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? */
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);
PL_dirty = 0;
PL_localizing = 0;
Zero(&PL_hv_fetch_ent_mh, 1, HE);
+ PL_efloatbuf = (char*)NULL;
+ PL_efloatsize = 0;
#else
Zero(thr, 1, struct perl_thread);
#endif
thr->specific = newAV();
thr->errsv = newSVpvn("", 0);
thr->flags = THRf_R_JOINABLE;
+ thr->thr_done = 0;
MUTEX_INIT(&thr->mutex);
JMPENV_BOOTSTRAP;
- PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR) */
+ PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */
PL_restartop = 0;
PL_statname = NEWSV(66,0);
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_ofslen = t->Tofslen;
- PL_ofs = savepvn(t->Tofs, PL_ofslen);
+ 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);
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));
}
- }
+ }
thr->threadsvp = AvARRAY(thr->threadsv);
MUTEX_LOCK(&PL_threads_mutex);
#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
/*
* This hack is to force load of "huge" support from libm.a
- * So it is in perl for (say) POSIX to use.
+ * So it is in perl for (say) POSIX to use.
* Needed for SunOS with Sun's 'acc' for example.
*/
-NV
+NV
Perl_huge(void)
{
# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
I32
Perl_my_fflush_all(pTHX)
{
-#ifdef FFLUSH_NULL
+#if defined(FFLUSH_NULL)
return PerlIO_flush(NULL);
#else
+# if defined(HAS__FWALK)
+ /* undocumented, unprototyped, but very useful BSDism */
+ extern void _fwalk(int (*)(FILE *));
+ _fwalk(&fflush);
+ return 0;
+# else
+# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
long open_max = -1;
-# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
-# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
+# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
-# else
-# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
+# else
+# 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
-# endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
return 0;
}
-# endif
+# endif
SETERRNO(EBADF,RMS$_IFI);
return EOF;
+# endif
#endif
}
NV
Perl_my_atof(pTHX_ const char* s)
{
+ NV x = 0.0;
#ifdef USE_LOCALE_NUMERIC
- if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
- NV x, y;
+ if (PL_numeric_local && IN_LOCALE) {
+ NV y;
- x = Perl_atof(s);
+ Perl_atof2(aTHX_ s, &x);
SET_NUMERIC_STANDARD();
- y = Perl_atof(s);
+ Perl_atof2(aTHX_ s, &y);
SET_NUMERIC_LOCAL();
if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
return y;
- return x;
}
else
- return Perl_atof(s);
+ Perl_atof2(aTHX_ s, &x);
#else
- return Perl_atof(s);
+ 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_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj)
+Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
{
- SV *sv;
- char *name;
+ char *vile;
+ I32 warn_type;
+ char *func =
+ op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
+ PL_op_desc[op];
+ char *pars = OP_IS_FILETEST(op) ? "" : "()";
+ char *type = OP_IS_SOCKET(op) ||
+ (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
+ "socket" : "filehandle";
+ char *name = NULL;
+
+ if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
+ vile = "closed";
+ warn_type = WARN_CLOSED;
+ }
+ else {
+ vile = "unopened";
+ warn_type = WARN_UNOPENED;
+ }
+
+ if (gv && isGV(gv)) {
+ SV *sv = sv_newmortal();
+ gv_efullname4(sv, gv, Nullch, FALSE);
+ name = SvPVX(sv);
+ }
+
+ if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
+ if (name && *name)
+ Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for %sput",
+ name,
+ (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+ else
+ Perl_warner(aTHX_ WARN_IO, "Filehandle opened only for %sput",
+ (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+ } else if (name && *name) {
+ Perl_warner(aTHX_ warn_type,
+ "%s%s on %s %s %s", func, pars, vile, type, name);
+ if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+ Perl_warner(aTHX_ warn_type,
+ "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+ func, pars, name);
+ }
+ else {
+ Perl_warner(aTHX_ warn_type,
+ "%s%s on %s %s", func, pars, vile, type);
+ 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
- assert(gv);
+/* 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
- sv = sv_newmortal();
- gv_efullname4(sv, gv, Nullch, FALSE);
- name = SvPVX(sv);
+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
+}
- Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name);
+/*
+ * 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 */
- if (io && IoDIRP(io))
- Perl_warner(aTHX_ WARN_CLOSED,
- "\t(Are you trying to call %s() on dirhandle %s?)\n",
- func, name);
+/*
+ * 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
}
projects / p5sagit/p5-mst-13.2.git / blobdiff