Upgrade to Cwd 2.13

[p5sagit/p5-mst-13.2.git] / ext / Cwd / Cwd.xs

diff --git a/ext/Cwd/Cwd.xs b/ext/Cwd/Cwd.xs
index 19d3afd..04ab25e 100644 (file)
--- a/ext/Cwd/Cwd.xs
+++ b/ext/Cwd/Cwd.xs
@@ -73,8 +73,7 @@ bsd_realpath(path, resolved)
        dTHX;
        return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
 #else
-       struct stat sb;
-       int n, rootd, serrno;
+       int rootd, serrno;
        char *p, *q, wbuf[MAXPATHLEN];
        int symlinks = 0;
 
@@ -124,9 +123,12 @@ loop:
                p = resolved;
 
 #if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
+    {
+       struct stat sb;
        /* Deal with the last component. */
        if (lstat(p, &sb) == 0) {
                if (S_ISLNK(sb.st_mode)) {
+                       int n;
                        if (++symlinks > MAXSYMLINKS) {
                                errno = ELOOP;
                                goto err1;
@@ -143,6 +145,7 @@ loop:
                        p = "";
                }
        }
+    }
 #endif
 
        /*
@@ -163,7 +166,7 @@ loop:
                rootd = 0;
 
        if (*wbuf) {
-               if (strlen(resolved) + strlen(wbuf) + rootd + 1 > MAXPATHLEN) {
+               if (strlen(resolved) + strlen(wbuf) + (1 - rootd) + 1 > MAXPATHLEN) {
                        errno = ENAMETOOLONG;
                        goto err1;
                }
@@ -207,17 +210,172 @@ err2:
 #endif
 }
 
+#ifndef getcwd_sv
+/* Taken from perl 5.8's util.c */
+int getcwd_sv(pTHX_ register SV *sv)
+{
+#ifndef PERL_MICRO
+
+#ifndef INCOMPLETE_TAINTS
+    SvTAINTED_on(sv);
+#endif
+
+#ifdef HAS_GETCWD
+    {
+       char buf[MAXPATHLEN];
+
+       /* Some getcwd()s automatically allocate a buffer of the given
+        * size from the heap if they are given a NULL buffer pointer.
+        * The problem is that this behaviour is not portable. */
+       if (getcwd(buf, sizeof(buf) - 1)) {
+           STRLEN len = strlen(buf);
+           sv_setpvn(sv, buf, len);
+           return TRUE;
+       }
+       else {
+           sv_setsv(sv, &PL_sv_undef);
+           return FALSE;
+       }
+    }
+
+#else
+
+    Stat_t statbuf;
+    int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
+    int namelen, pathlen=0;
+    DIR *dir;
+    Direntry_t *dp;
+
+    (void)SvUPGRADE(sv, SVt_PV);
+
+    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;
+       }
+
+       if (pathlen + namelen + 1 >= MAXPATHLEN) {
+           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
+    }
+
+    if (pathlen) {
+       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");
+    }
+
+    return TRUE;
+#endif
+
+#else
+    return FALSE;
+#endif
+}
+
+#endif
+
+
 MODULE = Cwd           PACKAGE = Cwd
 
 PROTOTYPES: ENABLE
 
 void
 fastcwd()
+PROTOTYPE: DISABLE
 PPCODE:
 {
     dXSTARG;
     getcwd_sv(TARG);
     XSprePUSH; PUSHTARG;
+#ifndef INCOMPLETE_TAINTS
+    SvTAINTED_on(TARG);
+#endif
 }
 
 void