#define sv_collxfrm Perl_sv_collxfrm
#endif
#define sv_compile_2op Perl_sv_compile_2op
+#define sv_getcwd Perl_sv_getcwd
#define sv_dec Perl_sv_dec
#define sv_dump Perl_sv_dump
#define sv_derived_from Perl_sv_derived_from
#define sv_pos_b2u Perl_sv_pos_b2u
#define sv_pvutf8n_force Perl_sv_pvutf8n_force
#define sv_pvbyten_force Perl_sv_pvbyten_force
+#define sv_realpath Perl_sv_realpath
#define sv_reftype Perl_sv_reftype
#define sv_replace Perl_sv_replace
#define sv_report_used Perl_sv_report_used
#define sv_collxfrm(a,b) Perl_sv_collxfrm(aTHX_ a,b)
#endif
#define sv_compile_2op(a,b,c,d) Perl_sv_compile_2op(aTHX_ a,b,c,d)
+#define sv_getcwd(a) Perl_sv_getcwd(aTHX_ a)
#define sv_dec(a) Perl_sv_dec(aTHX_ a)
#define sv_dump(a) Perl_sv_dump(aTHX_ a)
#define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b)
#define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b)
#define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b)
#define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b)
+#define sv_realpath(a,b,c) Perl_sv_realpath(aTHX_ a,b,c)
#define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b)
#define sv_replace(a,b) Perl_sv_replace(aTHX_ a,b)
#define sv_report_used() Perl_sv_report_used(aTHX)
#endif
#define Perl_sv_compile_2op CPerlObj::Perl_sv_compile_2op
#define sv_compile_2op Perl_sv_compile_2op
+#define Perl_sv_getcwd CPerlObj::Perl_sv_getcwd
+#define sv_getcwd Perl_sv_getcwd
#define Perl_sv_dec CPerlObj::Perl_sv_dec
#define sv_dec Perl_sv_dec
#define Perl_sv_dump CPerlObj::Perl_sv_dump
#define sv_pvutf8n_force Perl_sv_pvutf8n_force
#define Perl_sv_pvbyten_force CPerlObj::Perl_sv_pvbyten_force
#define sv_pvbyten_force Perl_sv_pvbyten_force
+#define Perl_sv_realpath CPerlObj::Perl_sv_realpath
+#define sv_realpath Perl_sv_realpath
#define Perl_sv_reftype CPerlObj::Perl_sv_reftype
#define sv_reftype Perl_sv_reftype
#define Perl_sv_replace CPerlObj::Perl_sv_replace
redo FUNC;
}
} else {
- warn "$file:$line:$in";
+ warn "$file:$line:$in (=cut missing?)";
}
}
}
Ap |char* |sv_collxfrm |SV* sv|STRLEN* nxp
#endif
Ap |OP* |sv_compile_2op |SV* sv|OP** startp|char* code|AV** avp
+Apd |int |sv_getcwd |SV* sv
Apd |void |sv_dec |SV* sv
Ap |void |sv_dump |SV* sv
Apd |bool |sv_derived_from|SV* sv|const char* name
Aopd |char* |sv_pvn_force |SV* sv|STRLEN* lp
Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp
Ap |char* |sv_pvbyten_force|SV* sv|STRLEN* lp
+Apd |int |sv_realpath |SV* sv|char *path|STRLEN len
Apd |char* |sv_reftype |SV* sv|int ob
Apd |void |sv_replace |SV* sv|SV* nsv
Ap |void |sv_report_used
#include "perl.h"
#include "XSUB.h"
-/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
- * 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. */
-char *
-_cwdxs_fastcwd(void)
-{
-/* XXX Should we just use getcwd(3) if available? */
- struct stat statbuf;
- int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
- int i = 0, j = 0, k = 0, ndirs = 16, pathlen = 0, namelen;
- DIR *dir;
- Direntry_t *dp;
- char **names, *path;
-
- Newz(0, names, ndirs, char*);
-
- if (PerlLIO_lstat(".", &statbuf) < 0) {
- Safefree(names);
- return FALSE;
- }
- 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) {
- Safefree(names);
- return FALSE;
- }
- if (PerlLIO_stat(".", &statbuf) < 0) {
- Safefree(names);
- return FALSE;
- }
- cdev = statbuf.st_dev;
- cino = statbuf.st_ino;
- if (odev == cdev && oino == cino)
- break;
-
- if (!(dir = PerlDir_open("."))) {
- Safefree(names);
- return FALSE;
- }
-
- while ((dp = PerlDir_read(dir)) != NULL) {
- if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
- Safefree(names);
- return FALSE;
- }
- if (strEQ(dp->d_name, "."))
- continue;
- if (strEQ(dp->d_name, ".."))
- continue;
- tdev = statbuf.st_dev;
- tino = statbuf.st_ino;
- if (tino == oino && tdev == odev)
- break;
- }
-
- if (!dp) {
- Safefree(names);
- return FALSE;
- }
-
- if (i >= ndirs) {
- ndirs += 16;
- Renew(names, ndirs, char*);
- }
-#ifdef DIRNAMLEN
- namelen = dp->d_namlen;
-#else
- namelen = strlen(dp->d_name);
-#endif
- Newz(0, *(names + i), namelen + 1, char);
- Copy(dp->d_name, *(names + i), namelen, char);
- *(names[i] + namelen) = '\0';
- pathlen += (namelen + 1);
- ++i;
-
-#ifdef VOID_CLOSEDIR
- PerlDir_close(dir);
-#else
- if (PerlDir_close(dir) < 0) {
- Safefree(names);
- return FALSE;
- }
-#endif
- }
-
- Newz(0, path, pathlen + 1, char);
- for (j = i - 1; j >= 0; j--) {
- *(path + k) = '/';
- Copy(names[j], path + k + 1, strlen(names[j]) + 1, char);
- k = k + strlen(names[j]) + 1;
- Safefree(names[j]);
- }
+MODULE = Cwd PACKAGE = Cwd
- if (PerlDir_chdir(path) < 0) {
- Safefree(names);
- Safefree(path);
- return FALSE;
- }
- if (PerlLIO_stat(".", &statbuf) < 0) {
- Safefree(names);
- Safefree(path);
- return FALSE;
- }
- 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");
+PROTOTYPES: ENABLE
- Safefree(names);
- return(path);
+void
+fastcwd()
+PPCODE:
+{
+ dXSTARG;
+ sv_getcwd(TARG);
+ XSprePUSH; PUSHTARG;
}
-char *
-_cwdxs_abs_path(char *start)
+void
+abs_path(svpath=Nullsv)
+ SV *svpath
+PPCODE:
{
- DIR *parent;
- Direntry_t *dp;
- char dotdots[MAXPATHLEN] = { 0 };
- char name[MAXPATHLEN] = { 0 };
- char *cwd;
- int namelen = 0;
- struct stat cst, pst, tst;
-
- if (PerlLIO_stat(start, &cst) < 0) {
- warn("abs_path: stat(\"%s\"): %s", start, Strerror(errno));
- return FALSE;
- }
-
- Newz(0, cwd, MAXPATHLEN, char);
- Copy(start, dotdots, strlen(start), char);
-
- for (;;) {
- strcat(dotdots, "/..");
- StructCopy(&cst, &pst, struct stat);
+ dXSTARG;
+ char *path;
+ STRLEN len;
- if (PerlLIO_stat(dotdots, &cst) < 0) {
- Safefree(cwd);
- warn("abs_path: stat(\"%s\"): %s", dotdots, Strerror(errno));
- return FALSE;
+ if (svpath) {
+ path = SvPV(svpath, len);
}
-
- 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))) {
- Safefree(cwd);
- warn("abs_path: opendir(\"%s\"): %s", dotdots, Strerror(errno));
- return FALSE;
- }
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- while ((dp = PerlDir_read(parent)) != NULL) {
- if (strEQ(dp->d_name, "."))
- continue;
- if (strEQ(dp->d_name, ".."))
- 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) {
- Safefree(cwd);
- PerlDir_close(parent);
- warn("abs_path: lstat(\"%s\"): %s", name, Strerror(errno));
- return FALSE;
- }
-
- if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino)
- break;
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- }
-
-
- if (!dp && errno) {
- warn("abs_path: readdir(\"%s\"): %s", dotdots, Strerror(errno));
- Safefree(cwd);
- return FALSE;
- }
-
- Move(cwd, cwd + namelen + 1, strlen(cwd), char);
- Copy(dp->d_name, cwd + 1, namelen, char);
-#ifdef VOID_CLOSEDIR
- PerlDir_close(parent);
-#else
- if (PerlDir_close(parent) < 0) {
- warn("abs_path: closedir(\"%s\"): %s", dotdots, Strerror(errno));
- Safefree(cwd);
- return FALSE;
- }
-#endif
- *cwd = '/';
+ else {
+ path = ".";
+ len = 1;
}
- }
- return cwd;
+ sv_realpath(TARG, path, len);
+ XSprePUSH; PUSHTARG;
}
-
-
-MODULE = Cwd PACKAGE = Cwd
-
-PROTOTYPES: ENABLE
-
-char *
-_fastcwd()
-PPCODE:
- char * buf;
- buf = _cwdxs_fastcwd();
- if (buf) {
- PUSHs(sv_2mortal(newSVpv(buf, 0)));
- Safefree(buf);
- }
- else
- XSRETURN_UNDEF;
-
-char *
-_abs_path(start = ".")
- char * start
-PREINIT:
- char * buf;
-PPCODE:
- buf = _cwdxs_abs_path(start);
- if (buf) {
- PUSHs(sv_2mortal(newSVpv(buf, 0)));
- Safefree(buf);
- }
- else
- XSRETURN_UNDEF;
Perl_sv_cmp_locale
Perl_sv_collxfrm
Perl_sv_compile_2op
+Perl_sv_getcwd
Perl_sv_dec
Perl_sv_dump
Perl_sv_derived_from
Perl_sv_pvn_force
Perl_sv_pvutf8n_force
Perl_sv_pvbyten_force
+Perl_sv_realpath
Perl_sv_reftype
Perl_sv_replace
Perl_sv_report_used
our @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
our @EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
-# Indicates if the XS portion has been loaded or not
-my $Booted = 0;
+eval {
+ require XSLoader;
+ XSLoader::load('Cwd');
+};
# The 'natural and safe form' for UNIX (pwd may be setuid root)
abs_path('.');
}
-# Now a callout to an XSUB. We have to delay booting of the XSUB
-# until the first time fastcwd is called since Cwd::cwd is needed in the
-# building of perl when dynamic loading may be unavailable
-sub fastcwd {
- unless ($Booted) {
- require XSLoader;
- XSLoader::load("Cwd");
- ++$Booted;
- }
- return &Cwd::_fastcwd;
-}
-
-
# Keeps track of current working directory in PWD environment var
# Usage:
# use Cwd 'chdir';
1;
}
-# Now a callout to an XSUB
-sub abs_path
-{
- unless ($Booted) {
- require XSLoader;
- XSLoader::load("Cwd");
- ++$Booted;
- }
- return &Cwd::_abs_path(@_);
-}
-
# added function alias for those of us more
# used to the libc function. --tchrist 27-Jan-00
*realpath = \&abs_path;
#define Perl_sv_compile_2op pPerl->Perl_sv_compile_2op
#undef sv_compile_2op
#define sv_compile_2op Perl_sv_compile_2op
+#undef Perl_sv_getcwd
+#define Perl_sv_getcwd pPerl->Perl_sv_getcwd
+#undef sv_getcwd
+#define sv_getcwd Perl_sv_getcwd
#undef Perl_sv_dec
#define Perl_sv_dec pPerl->Perl_sv_dec
#undef sv_dec
#define Perl_sv_pvbyten_force pPerl->Perl_sv_pvbyten_force
#undef sv_pvbyten_force
#define sv_pvbyten_force Perl_sv_pvbyten_force
+#undef Perl_sv_realpath
+#define Perl_sv_realpath pPerl->Perl_sv_realpath
+#undef sv_realpath
+#define sv_realpath Perl_sv_realpath
#undef Perl_sv_reftype
#define Perl_sv_reftype pPerl->Perl_sv_reftype
#undef sv_reftype
return ((CPerlObj*)pPerl)->Perl_sv_compile_2op(sv, startp, code, avp);
}
+#undef Perl_sv_getcwd
+int
+Perl_sv_getcwd(pTHXo_ SV* sv)
+{
+ return ((CPerlObj*)pPerl)->Perl_sv_getcwd(sv);
+}
+
#undef Perl_sv_dec
void
Perl_sv_dec(pTHXo_ SV* sv)
return ((CPerlObj*)pPerl)->Perl_sv_pvbyten_force(sv, lp);
}
+#undef Perl_sv_realpath
+int
+Perl_sv_realpath(pTHXo_ SV* sv, char *path, STRLEN len)
+{
+ return ((CPerlObj*)pPerl)->Perl_sv_realpath(sv, path, len);
+}
+
#undef Perl_sv_reftype
char*
Perl_sv_reftype(pTHXo_ SV* sv, int ob)
compute it. The return value is the new hash entry so created. It will be
NULL if the operation failed or if the value did not need to be actually
stored within the hash (as in the case of tied hashes). Otherwise the
-contents of the return value can be accessed using the C<He???> macros
+contents of the return value can be accessed using the C<He?> macros
described here. Note that the caller is responsible for suitably
incrementing the reference count of C<val> before the call, and
decrementing it if the function returned NULL.
=for hackers
Found in file sv.h
-=item SvTYPE
-
-Returns the type of the SV. See C<svtype>.
+=item svtype
- svtype SvTYPE(SV* sv)
+An enum of flags for Perl types. These are found in the file B<sv.h>
+in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
=for hackers
Found in file sv.h
-=item svtype
+=item SvTYPE
-An enum of flags for Perl types. These are found in the file B<sv.h>
-in the C<svtype> enum. Test these flags with the C<SvTYPE> macro.
+Returns the type of the SV. See C<svtype>.
+
+ svtype SvTYPE(SV* sv)
=for hackers
Found in file sv.h
=for hackers
Found in file sv.c
+=item sv_getcwd
+
+Fill the sv with current working directory
+
+ int sv_getcwd(SV* sv)
+
+=for hackers
+Found in file util.c
+
=item sv_gets
Get a line from the filehandle and store it into the SV, optionally
=for hackers
Found in file sv.c
+=item sv_realpath
+
+Emulate realpath(3)
+
+XXX: add configure test for realpath(3) and prefer if available
+ int sv_realpath(SV* sv, char *path, STRLEN len)
+
+=for hackers
+Found in file util.c
+
=item sv_reftype
Returns a string describing what the SV is a reference to.
PERL_CALLCONV char* Perl_sv_collxfrm(pTHX_ SV* sv, STRLEN* nxp);
#endif
PERL_CALLCONV OP* Perl_sv_compile_2op(pTHX_ SV* sv, OP** startp, char* code, AV** avp);
+PERL_CALLCONV int Perl_sv_getcwd(pTHX_ SV* sv);
PERL_CALLCONV void Perl_sv_dec(pTHX_ SV* sv);
PERL_CALLCONV void Perl_sv_dump(pTHX_ SV* sv);
PERL_CALLCONV bool Perl_sv_derived_from(pTHX_ SV* sv, const char* name);
PERL_CALLCONV char* Perl_sv_pvn_force(pTHX_ SV* sv, STRLEN* lp);
PERL_CALLCONV char* Perl_sv_pvutf8n_force(pTHX_ SV* sv, STRLEN* lp);
PERL_CALLCONV char* Perl_sv_pvbyten_force(pTHX_ SV* sv, STRLEN* lp);
+PERL_CALLCONV int Perl_sv_realpath(pTHX_ SV* sv, char *path, STRLEN len);
PERL_CALLCONV char* Perl_sv_reftype(pTHX_ SV* sv, int ob);
PERL_CALLCONV void Perl_sv_replace(pTHX_ SV* sv, SV* nsv);
PERL_CALLCONV void Perl_sv_report_used(pTHX);
#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 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) {
+ CWDXS_RETURN_SVUNDEF(sv);
+ }
+
+ 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)) {dp->d_name[0] == '.'
+ 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;
+}
+
+/*
+=for apidoc sv_realpath
+
+Emulate realpath(3)
+
+XXX: add configure test for realpath(3) and prefer if available
+=cut
+ */
+int
+Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len)
+{
+ DIR *parent;
+ Direntry_t *dp;
+ char dotdots[MAXPATHLEN] = { 0 };
+ char name[MAXPATHLEN] = { 0 };
+ int namelen = 0, pathlen = 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;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff