[perl5.git] / ext / Cwd / Cwd.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifndef NO_PPPORT_H
#   define NEED_my_strlcpy
#   define NEED_my_strlcat
#   include "ppport.h"
#endif

#ifdef I_UNISTD
#   include <unistd.h>
#endif

/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
 * Renamed here to bsd_realpath() to avoid library conflicts.
 */

/* See
 * http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html
 * for the details of why the BSD license is compatible with the
 * AL/GPL standard perl license.
 */

/*
 * Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. The names of the authors may not be used to endorse or promote
 *    products derived from this software without specific prior written
 *    permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

/* OpenBSD system #includes removed since the Perl ones should do. --jhi */

#ifndef MAXSYMLINKS
#define MAXSYMLINKS 8
#endif

/*
 * char *realpath(const char *path, char resolved[MAXPATHLEN]);
 *
 * Find the real name of path, by removing all ".", ".." and symlink
 * components.  Returns (resolved) on success, or (NULL) on failure,
 * in which case the path which caused trouble is left in (resolved).
 */
static
char *
bsd_realpath(const char *path, char resolved[MAXPATHLEN])
{
#ifdef VMS
       dTHX;
       return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
#else
	char *p, *q, *s;
	size_t left_len, resolved_len;
	unsigned symlinks;
	int serrno;
	char left[MAXPATHLEN], next_token[MAXPATHLEN], symlink[MAXPATHLEN];

	serrno = errno;
	symlinks = 0;
	if (path[0] == '/') {
		resolved[0] = '/';
		resolved[1] = '\0';
		if (path[1] == '\0')
			return (resolved);
		resolved_len = 1;
		left_len = my_strlcpy(left, path + 1, sizeof(left));
	} else {
		if (getcwd(resolved, MAXPATHLEN) == NULL) {
			my_strlcpy(resolved, ".", MAXPATHLEN);
		return (NULL);
	}
		resolved_len = strlen(resolved);
		left_len = my_strlcpy(left, path, sizeof(left));
	}
	if (left_len >= sizeof(left) || resolved_len >= MAXPATHLEN) {
		errno = ENAMETOOLONG;
		return (NULL);
	}

	/*
	 * Iterate over path components in `left'.
	 */
	while (left_len != 0) {
		/*
		 * Extract the next path component and adjust `left'
		 * and its length.
		 */
		p = strchr(left, '/');
		s = p ? p : left + left_len;
		if (s - left >= sizeof(next_token)) {
			errno = ENAMETOOLONG;
			return (NULL);
			}
		memcpy(next_token, left, s - left);
		next_token[s - left] = '\0';
		left_len -= s - left;
		if (p != NULL)
			memmove(left, s + 1, left_len + 1);
		if (resolved[resolved_len - 1] != '/') {
			if (resolved_len + 1 >= MAXPATHLEN) {
				errno = ENAMETOOLONG;
				return (NULL);
		}
			resolved[resolved_len++] = '/';
			resolved[resolved_len] = '\0';
	}
		if (next_token[0] == '\0')
			continue;
		else if (strcmp(next_token, ".") == 0)
			continue;
		else if (strcmp(next_token, "..") == 0) {
			/*
			 * Strip the last path component except when we have
			 * single "/"
			 */
			if (resolved_len > 1) {
				resolved[resolved_len - 1] = '\0';
				q = strrchr(resolved, '/') + 1;
				*q = '\0';
				resolved_len = q - resolved;
			}
			continue;
    }

	/*
		 * Append the next path component and lstat() it. If
		 * lstat() fails we still can return successfully if
		 * there are no more path components left.
	 */
		resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
		if (resolved_len >= MAXPATHLEN) {
			errno = ENAMETOOLONG;
			return (NULL);
		}
	#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
		{
			struct stat sb;
			if (lstat(resolved, &sb) != 0) {
				if (errno == ENOENT && p == NULL) {
					errno = serrno;
					return (resolved);
				}
				return (NULL);
			}
			if (S_ISLNK(sb.st_mode)) {
				int slen;
				
				if (symlinks++ > MAXSYMLINKS) {
					errno = ELOOP;
					return (NULL);
				}
				slen = readlink(resolved, symlink, sizeof(symlink) - 1);
				if (slen < 0)
					return (NULL);
				symlink[slen] = '\0';
				if (symlink[0] == '/') {
					resolved[1] = 0;
					resolved_len = 1;
				} else if (resolved_len > 1) {
					/* Strip the last path component. */
					resolved[resolved_len - 1] = '\0';
					q = strrchr(resolved, '/') + 1;
					*q = '\0';
					resolved_len = q - resolved;
				}

	/*
				 * If there are any path components left, then
				 * append them to symlink. The result is placed
				 * in `left'.
	 */
				if (p != NULL) {
					if (symlink[slen - 1] != '/') {
						if (slen + 1 >= sizeof(symlink)) {
			errno = ENAMETOOLONG;
							return (NULL);
		}
						symlink[slen] = '/';
						symlink[slen + 1] = 0;
	}
					left_len = my_strlcat(symlink, left, sizeof(left));
					if (left_len >= sizeof(left)) {
						errno = ENAMETOOLONG;
						return (NULL);
	}
	}
				left_len = my_strlcpy(left, symlink, sizeof(left));
			}
		}
	#endif
	}

	/*
	 * Remove trailing slash except when the resolved pathname
	 * is a single "/".
	 */
	if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
		resolved[resolved_len - 1] = '\0';
	return (resolved);
#endif
}

#ifndef SV_CWD_RETURN_UNDEF
#define SV_CWD_RETURN_UNDEF \
sv_setsv(sv, &PL_sv_undef); \
return FALSE
#endif

#ifndef OPpENTERSUB_HASTARG
#define OPpENTERSUB_HASTARG     32      /* Called from OP tree. */
#endif

#ifndef dXSTARG
#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
                             ? PAD_SV(PL_op->op_targ) : sv_newmortal())
#endif

#ifndef XSprePUSH
#define XSprePUSH (sp = PL_stack_base + ax - 1)
#endif

#ifndef SV_CWD_ISDOT
#define SV_CWD_ISDOT(dp) \
    (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
        (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
#endif

#ifndef getcwd_sv
/* Taken from perl 5.8's util.c */
#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
int Perl_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
getcwd(...)
PROTOTYPE: DISABLE
PPCODE:
{
    dXSTARG;
    getcwd_sv(TARG);
    XSprePUSH; PUSHTARG;
#ifndef INCOMPLETE_TAINTS
    SvTAINTED_on(TARG);
#endif
}

void
abs_path(pathsv=Nullsv)
    SV *pathsv
PROTOTYPE: DISABLE
PPCODE:
{
    dXSTARG;
    char *path;
    char buf[MAXPATHLEN];

    path = pathsv ? SvPV_nolen(pathsv) : (char *)".";

    if (bsd_realpath(path, buf)) {
        sv_setpvn(TARG, buf, strlen(buf));
        SvPOK_only(TARG);
	SvTAINTED_on(TARG);
    }
    else
        sv_setsv(TARG, &PL_sv_undef);

    XSprePUSH; PUSHTARG;
#ifndef INCOMPLETE_TAINTS
    SvTAINTED_on(TARG);
#endif
}

#if defined(WIN32) && !defined(UNDER_CE)

void
getdcwd(...)
PPCODE:
{
    dXSTARG;
    int drive;
    char *dir;

    /* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
    if ( items == 0 ||
        (items == 1 && (!SvOK(ST(0)) || (SvPOK(ST(0)) && !SvCUR(ST(0))))))
        drive = 0;
    else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
             isALPHA(SvPVX(ST(0))[0]))
        drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
    else
        croak("Usage: getdcwd(DRIVE)");

    New(0,dir,MAXPATHLEN,char);
    if (_getdcwd(drive, dir, MAXPATHLEN)) {
        sv_setpvn(TARG, dir, strlen(dir));
        SvPOK_only(TARG);
    }
    else
        sv_setsv(TARG, &PL_sv_undef);

    Safefree(dir);

    XSprePUSH; PUSHTARG;
#ifndef INCOMPLETE_TAINTS
    SvTAINTED_on(TARG);
#endif
}

#endif
Commit	Line	Data
0d2079fa BS	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
dfa4e5d3	4	#ifndef NO_PPPORT_H
bf7c0a3d SP	5	# define NEED_my_strlcpy
bf7c0a3d SP	6	# define NEED_my_strlcat
4ce45bab JH	7	# include "ppport.h"
4ce45bab JH	8	#endif
0d2079fa	9
c70498c1 JH	10	#ifdef I_UNISTD
	11	# include <unistd.h>
	12	#endif
	13
bf7c0a3d	14	/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
03d70c89	15	* Renamed here to bsd_realpath() to avoid library conflicts.
99f36a73 RGS	16	*/
	17
	18	/* See
	19	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html
	20	* for the details of why the BSD license is compatible with the
	21	* AL/GPL standard perl license.
	22	*/
03d70c89 JH	23
03d70c89 JH	24	/*
bf7c0a3d	25	* Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
03d70c89 JH	26	*
	27	* Redistribution and use in source and binary forms, with or without
	28	* modification, are permitted provided that the following conditions
	29	* are met:
	30	* 1. Redistributions of source code must retain the above copyright
	31	* notice, this list of conditions and the following disclaimer.
	32	* 2. Redistributions in binary form must reproduce the above copyright
	33	* notice, this list of conditions and the following disclaimer in the
	34	* documentation and/or other materials provided with the distribution.
bf7c0a3d SP	35	* 3. The names of the authors may not be used to endorse or promote
	36	* products derived from this software without specific prior written
	37	* permission.
03d70c89	38	*
bf7c0a3d	39	* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
03d70c89 JH	40	* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
03d70c89 JH	41	* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
bf7c0a3d	42	* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
03d70c89 JH	43	* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
	44	* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
	45	* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
	46	* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
	47	* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
	48	* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
	49	* SUCH DAMAGE.
	50	*/
	51
03d70c89 JH	52	/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
	53
	54	#ifndef MAXSYMLINKS
	55	#define MAXSYMLINKS 8
	56	#endif
	57
	58	/*
bf7c0a3d	59	* char realpath(const char path, char resolved[MAXPATHLEN]);
03d70c89 JH	60	*
	61	* Find the real name of path, by removing all ".", ".." and symlink
	62	* components. Returns (resolved) on success, or (NULL) on failure,
	63	* in which case the path which caused trouble is left in (resolved).
	64	*/
	65	static
	66	char *
c7304ea2	67	bsd_realpath(const char *path, char resolved[MAXPATHLEN])
03d70c89	68	{
e3d944f4	69	#ifdef VMS
32af7c23 CL	70	dTHX;
32af7c23 CL	71	return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
e3d944f4	72	#else
c7304ea2 NC	73	char p, q, *s;
	74	size_t left_len, resolved_len;
	75	unsigned symlinks;
	76	int serrno;
	77	char left[MAXPATHLEN], next_token[MAXPATHLEN], symlink[MAXPATHLEN];
03d70c89	78
c7304ea2 NC	79	serrno = errno;
	80	symlinks = 0;
	81	if (path[0] == '/') {
	82	resolved[0] = '/';
	83	resolved[1] = '\0';
	84	if (path[1] == '\0')
	85	return (resolved);
	86	resolved_len = 1;
	87	left_len = my_strlcpy(left, path + 1, sizeof(left));
	88	} else {
	89	if (getcwd(resolved, MAXPATHLEN) == NULL) {
	90	my_strlcpy(resolved, ".", MAXPATHLEN);
03d70c89 JH	91	return (NULL);
03d70c89 JH	92	}
c7304ea2 NC	93	resolved_len = strlen(resolved);
	94	left_len = my_strlcpy(left, path, sizeof(left));
	95	}
	96	if (left_len >= sizeof(left) \|\| resolved_len >= MAXPATHLEN) {
	97	errno = ENAMETOOLONG;
e3d944f4 JH	98	return (NULL);
e3d944f4 JH	99	}
03d70c89 JH	100
03d70c89 JH	101	/*
c7304ea2	102	* Iterate over path components in `left'.
03d70c89	103	*/
c7304ea2 NC	104	while (left_len != 0) {
	105	/*
	106	* Extract the next path component and adjust `left'
	107	* and its length.
	108	*/
	109	p = strchr(left, '/');
	110	s = p ? p : left + left_len;
	111	if (s - left >= sizeof(next_token)) {
	112	errno = ENAMETOOLONG;
	113	return (NULL);
03d70c89	114	}
c7304ea2 NC	115	memcpy(next_token, left, s - left);
	116	next_token[s - left] = '\0';
	117	left_len -= s - left;
	118	if (p != NULL)
	119	memmove(left, s + 1, left_len + 1);
	120	if (resolved[resolved_len - 1] != '/') {
	121	if (resolved_len + 1 >= MAXPATHLEN) {
	122	errno = ENAMETOOLONG;
	123	return (NULL);
03d70c89	124	}
c7304ea2 NC	125	resolved[resolved_len++] = '/';
c7304ea2 NC	126	resolved[resolved_len] = '\0';
03d70c89	127	}
c7304ea2 NC	128	if (next_token[0] == '\0')
	129	continue;
	130	else if (strcmp(next_token, ".") == 0)
	131	continue;
	132	else if (strcmp(next_token, "..") == 0) {
	133	/*
	134	* Strip the last path component except when we have
	135	* single "/"
	136	*/
	137	if (resolved_len > 1) {
	138	resolved[resolved_len - 1] = '\0';
	139	q = strrchr(resolved, '/') + 1;
	140	*q = '\0';
	141	resolved_len = q - resolved;
	142	}
	143	continue;
91f3b821	144	}
03d70c89 JH	145
03d70c89 JH	146	/*
c7304ea2 NC	147	* Append the next path component and lstat() it. If
	148	* lstat() fails we still can return successfully if
	149	* there are no more path components left.
03d70c89	150	*/
c7304ea2 NC	151	resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
	152	if (resolved_len >= MAXPATHLEN) {
	153	errno = ENAMETOOLONG;
	154	return (NULL);
	155	}
	156	#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
	157	{
	158	struct stat sb;
	159	if (lstat(resolved, &sb) != 0) {
	160	if (errno == ENOENT && p == NULL) {
	161	errno = serrno;
	162	return (resolved);
	163	}
	164	return (NULL);
	165	}
	166	if (S_ISLNK(sb.st_mode)) {
	167	int slen;
	168
	169	if (symlinks++ > MAXSYMLINKS) {
	170	errno = ELOOP;
	171	return (NULL);
	172	}
	173	slen = readlink(resolved, symlink, sizeof(symlink) - 1);
	174	if (slen < 0)
	175	return (NULL);
	176	symlink[slen] = '\0';
	177	if (symlink[0] == '/') {
	178	resolved[1] = 0;
	179	resolved_len = 1;
	180	} else if (resolved_len > 1) {
	181	/* Strip the last path component. */
	182	resolved[resolved_len - 1] = '\0';
	183	q = strrchr(resolved, '/') + 1;
	184	*q = '\0';
	185	resolved_len = q - resolved;
	186	}
03d70c89 JH	187
03d70c89 JH	188	/*
c7304ea2 NC	189	* If there are any path components left, then
	190	* append them to symlink. The result is placed
	191	* in `left'.
03d70c89	192	*/
c7304ea2 NC	193	if (p != NULL) {
	194	if (symlink[slen - 1] != '/') {
	195	if (slen + 1 >= sizeof(symlink)) {
03d70c89	196	errno = ENAMETOOLONG;
c7304ea2	197	return (NULL);
03d70c89	198	}
c7304ea2 NC	199	symlink[slen] = '/';
c7304ea2 NC	200	symlink[slen + 1] = 0;
03d70c89	201	}
c7304ea2 NC	202	left_len = my_strlcat(symlink, left, sizeof(left));
	203	if (left_len >= sizeof(left)) {
	204	errno = ENAMETOOLONG;
	205	return (NULL);
03d70c89	206	}
e3d944f4	207	}
c7304ea2 NC	208	left_len = my_strlcpy(left, symlink, sizeof(left));
	209	}
	210	}
	211	#endif
	212	}
03d70c89	213
c7304ea2 NC	214	/*
	215	* Remove trailing slash except when the resolved pathname
	216	* is a single "/".
	217	*/
	218	if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
	219	resolved[resolved_len - 1] = '\0';
03d70c89	220	return (resolved);
e3d944f4	221	#endif
03d70c89 JH	222	}
03d70c89 JH	223
99f36a73 RGS	224	#ifndef SV_CWD_RETURN_UNDEF
	225	#define SV_CWD_RETURN_UNDEF \
	226	sv_setsv(sv, &PL_sv_undef); \
	227	return FALSE
	228	#endif
	229
	230	#ifndef OPpENTERSUB_HASTARG
	231	#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
	232	#endif
	233
	234	#ifndef dXSTARG
	235	#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
	236	? PAD_SV(PL_op->op_targ) : sv_newmortal())
	237	#endif
	238
	239	#ifndef XSprePUSH
	240	#define XSprePUSH (sp = PL_stack_base + ax - 1)
	241	#endif
	242
	243	#ifndef SV_CWD_ISDOT
	244	#define SV_CWD_ISDOT(dp) \
	245	(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' \|\| \
	246	(dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
	247	#endif
	248
a9939470	249	#ifndef getcwd_sv
1955c8df	250	/* Taken from perl 5.8's util.c */
09122b95 RGS	251	#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
09122b95 RGS	252	int Perl_getcwd_sv(pTHX_ register SV *sv)
a9939470 NC	253	{
	254	#ifndef PERL_MICRO
	255
	256	#ifndef INCOMPLETE_TAINTS
	257	SvTAINTED_on(sv);
	258	#endif
	259
	260	#ifdef HAS_GETCWD
	261	{
	262	char buf[MAXPATHLEN];
	263
	264	/* Some getcwd()s automatically allocate a buffer of the given
	265	* size from the heap if they are given a NULL buffer pointer.
	266	* The problem is that this behaviour is not portable. */
	267	if (getcwd(buf, sizeof(buf) - 1)) {
	268	STRLEN len = strlen(buf);
	269	sv_setpvn(sv, buf, len);
	270	return TRUE;
	271	}
	272	else {
	273	sv_setsv(sv, &PL_sv_undef);
	274	return FALSE;
	275	}
	276	}
	277
	278	#else
f6342b4b	279	{
a9939470 NC	280	Stat_t statbuf;
	281	int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
	282	int namelen, pathlen=0;
	283	DIR *dir;
	284	Direntry_t *dp;
	285
	286	(void)SvUPGRADE(sv, SVt_PV);
	287
	288	if (PerlLIO_lstat(".", &statbuf) < 0) {
	289	SV_CWD_RETURN_UNDEF;
	290	}
	291
	292	orig_cdev = statbuf.st_dev;
	293	orig_cino = statbuf.st_ino;
	294	cdev = orig_cdev;
	295	cino = orig_cino;
	296
	297	for (;;) {
	298	odev = cdev;
	299	oino = cino;
	300
	301	if (PerlDir_chdir("..") < 0) {
	302	SV_CWD_RETURN_UNDEF;
	303	}
	304	if (PerlLIO_stat(".", &statbuf) < 0) {
	305	SV_CWD_RETURN_UNDEF;
	306	}
	307
	308	cdev = statbuf.st_dev;
	309	cino = statbuf.st_ino;
	310
	311	if (odev == cdev && oino == cino) {
	312	break;
	313	}
	314	if (!(dir = PerlDir_open("."))) {
	315	SV_CWD_RETURN_UNDEF;
	316	}
	317
	318	while ((dp = PerlDir_read(dir)) != NULL) {
	319	#ifdef DIRNAMLEN
	320	namelen = dp->d_namlen;
	321	#else
	322	namelen = strlen(dp->d_name);
	323	#endif
	324	/* skip . and .. */
	325	if (SV_CWD_ISDOT(dp)) {
	326	continue;
	327	}
	328
	329	if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
	330	SV_CWD_RETURN_UNDEF;
	331	}
	332
	333	tdev = statbuf.st_dev;
	334	tino = statbuf.st_ino;
	335	if (tino == oino && tdev == odev) {
	336	break;
	337	}
	338	}
	339
	340	if (!dp) {
	341	SV_CWD_RETURN_UNDEF;
	342	}
	343
344	if (pathlen + namelen + 1 >= MAXPATHLEN) {
345	SV_CWD_RETURN_UNDEF;
346	}
347
348	SvGROW(sv, pathlen + namelen + 1);
349
350	if (pathlen) {
351	/* shift down */
352	Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
353	}
354
355	/* prepend current directory to the front */
356	*SvPVX(sv) = '/';
357	Move(dp->d_name, SvPVX(sv)+1, namelen, char);
358	pathlen += (namelen + 1);
359
360	#ifdef VOID_CLOSEDIR
361	PerlDir_close(dir);
362	#else
363	if (PerlDir_close(dir) < 0) {
364	SV_CWD_RETURN_UNDEF;
365	}
366	#endif
367	}
368
369	if (pathlen) {
370	SvCUR_set(sv, pathlen);
371	*SvEND(sv) = '\0';
372	SvPOK_only(sv);
373
374	if (PerlDir_chdir(SvPVX(sv)) < 0) {
375	SV_CWD_RETURN_UNDEF;
376	}
377	}
378	if (PerlLIO_stat(".", &statbuf) < 0) {
379	SV_CWD_RETURN_UNDEF;
380	}
381
382	cdev = statbuf.st_dev;
383	cino = statbuf.st_ino;
384
385	if (cdev != orig_cdev \|\| cino != orig_cino) {
386	Perl_croak(aTHX_ "Unstable directory path, "
387	"current directory changed unexpectedly");
388	}
389
390	return TRUE;
f6342b4b	391	}
a9939470 NC	392	#endif
	393
	394	#else
	395	return FALSE;
	396	#endif
	397	}
	398
	399	#endif
	400
	401
f22d8e4b	402	MODULE = Cwd PACKAGE = Cwd
0d2079fa	403
f22d8e4b	404	PROTOTYPES: ENABLE
0d2079fa	405
f22d8e4b DM	406	void
f22d8e4b DM	407	fastcwd()
7ddb28a3	408	PROTOTYPE: DISABLE
f22d8e4b DM	409	PPCODE:
	410	{
	411	dXSTARG;
89423764	412	getcwd_sv(TARG);
f22d8e4b	413	XSprePUSH; PUSHTARG;
248785eb RGS	414	#ifndef INCOMPLETE_TAINTS
	415	SvTAINTED_on(TARG);
	416	#endif
0d2079fa BS	417	}
0d2079fa BS	418
f22d8e4b	419	void
23bb49fa	420	getcwd(...)
fa52125f SP	421	PROTOTYPE: DISABLE
	422	PPCODE:
	423	{
	424	dXSTARG;
	425	getcwd_sv(TARG);
	426	XSprePUSH; PUSHTARG;
	427	#ifndef INCOMPLETE_TAINTS
	428	SvTAINTED_on(TARG);
	429	#endif
	430	}
	431
	432	void
03d70c89 JH	433	abs_path(pathsv=Nullsv)
03d70c89 JH	434	SV *pathsv
99f36a73	435	PROTOTYPE: DISABLE
f22d8e4b	436	PPCODE:
2ae52c40	437	{
f22d8e4b DM	438	dXSTARG;
f22d8e4b DM	439	char *path;
00536bfc	440	char buf[MAXPATHLEN];
03d70c89	441
07409e01	442	path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
03d70c89	443
00536bfc JH	444	if (bsd_realpath(path, buf)) {
	445	sv_setpvn(TARG, buf, strlen(buf));
	446	SvPOK_only(TARG);
ea715489	447	SvTAINTED_on(TARG);
2ae52c40	448	}
03d70c89	449	else
ea715489	450	sv_setsv(TARG, &PL_sv_undef);
2ae52c40	451
f22d8e4b	452	XSprePUSH; PUSHTARG;
ea715489 JH	453	#ifndef INCOMPLETE_TAINTS
	454	SvTAINTED_on(TARG);
	455	#endif
2ae52c40	456	}
09122b95	457
42d1cefd	458	#if defined(WIN32) && !defined(UNDER_CE)
09122b95 RGS	459
	460	void
	461	getdcwd(...)
	462	PPCODE:
	463	{
	464	dXSTARG;
	465	int drive;
	466	char *dir;
	467
	468	/* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
	469	if ( items == 0 \|\|
	470	(items == 1 && (!SvOK(ST(0)) \|\| (SvPOK(ST(0)) && !SvCUR(ST(0))))))
	471	drive = 0;
	472	else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
	473	isALPHA(SvPVX(ST(0))[0]))
	474	drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
	475	else
	476	croak("Usage: getdcwd(DRIVE)");
	477
275e8705 RGS	478	New(0,dir,MAXPATHLEN,char);
275e8705 RGS	479	if (_getdcwd(drive, dir, MAXPATHLEN)) {
09122b95	480	sv_setpvn(TARG, dir, strlen(dir));
09122b95 RGS	481	SvPOK_only(TARG);
	482	}
	483	else
	484	sv_setsv(TARG, &PL_sv_undef);
	485
99f36a73 RGS	486	Safefree(dir);
99f36a73 RGS	487
09122b95 RGS	488	XSprePUSH; PUSHTARG;
	489	#ifndef INCOMPLETE_TAINTS
	490	SvTAINTED_on(TARG);
	491	#endif
	492	}
	493
	494	#endif