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

#define PERL_NO_GET_CONTEXT

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

#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

#ifndef VMS
/*
 * 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])
{
	char *p, *q, *s;
	size_t left_len, resolved_len;
	unsigned symlinks;
	int serrno;
	char left[MAXPATHLEN], next_token[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 ((STRLEN)(s - left) >= (STRLEN)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;
				char symlink[MAXPATHLEN];
				
				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 ((STRLEN)(slen + 1) >= (STRLEN)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_ 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: DISABLE

void
getcwd(...)
ALIAS:
    fastcwd=1
PPCODE:
{
    dXSTARG;
    /* fastcwd takes zero parameters:  */
    if (ix == 1 && items != 0)
	croak_xs_usage(cv,  "");
    getcwd_sv(TARG);
    XSprePUSH; PUSHTARG;
#ifndef INCOMPLETE_TAINTS
    SvTAINTED_on(TARG);
#endif
}

void
abs_path(pathsv=Nullsv)
    SV *pathsv
PPCODE:
{
    dXSTARG;
    char *const path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
    char buf[MAXPATHLEN];

    if (
#ifdef VMS
	Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
#else
	bsd_realpath(path, buf)
#endif
    ) {
	sv_setpv_mg(TARG, buf);
        SvPOK_only(TARG);
	SvTAINTED_on(TARG);
    }
    else
        sv_setsv(TARG, &PL_sv_undef);

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

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

void
getdcwd(...)
PROTOTYPE: ENABLE
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_setpv_mg(TARG, dir);
        SvPOK_only(TARG);
    }
    else
        sv_setsv(TARG, &PL_sv_undef);

    Safefree(dir);

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

#endif
Commit	Line	Data
c30da3b5 NC	1	#define PERL_NO_GET_CONTEXT
c30da3b5 NC	2
0d2079fa BS	3	#include "EXTERN.h"
	4	#include "perl.h"
	5	#include "XSUB.h"
9bc94e3d S	6	#define NEED_my_strlcpy
	7	#define NEED_my_strlcat
	8	#include "ppport.h"
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	*
6dfee1ec	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
66a378bd	58	#ifndef VMS
03d70c89	59	/*
bf7c0a3d	60	* char realpath(const char path, char resolved[MAXPATHLEN]);
03d70c89 JH	61	*
	62	* Find the real name of path, by removing all ".", ".." and symlink
	63	* components. Returns (resolved) on success, or (NULL) on failure,
	64	* in which case the path which caused trouble is left in (resolved).
	65	*/
	66	static
	67	char *
c7304ea2	68	bsd_realpath(const char *path, char resolved[MAXPATHLEN])
03d70c89	69	{
c7304ea2 NC	70	char p, q, *s;
	71	size_t left_len, resolved_len;
	72	unsigned symlinks;
	73	int serrno;
8304a6c4	74	char left[MAXPATHLEN], next_token[MAXPATHLEN];
03d70c89	75
c7304ea2 NC	76	serrno = errno;
	77	symlinks = 0;
	78	if (path[0] == '/') {
	79	resolved[0] = '/';
	80	resolved[1] = '\0';
	81	if (path[1] == '\0')
	82	return (resolved);
	83	resolved_len = 1;
	84	left_len = my_strlcpy(left, path + 1, sizeof(left));
	85	} else {
	86	if (getcwd(resolved, MAXPATHLEN) == NULL) {
	87	my_strlcpy(resolved, ".", MAXPATHLEN);
03d70c89 JH	88	return (NULL);
03d70c89 JH	89	}
c7304ea2 NC	90	resolved_len = strlen(resolved);
	91	left_len = my_strlcpy(left, path, sizeof(left));
	92	}
	93	if (left_len >= sizeof(left) \|\| resolved_len >= MAXPATHLEN) {
	94	errno = ENAMETOOLONG;
e3d944f4 JH	95	return (NULL);
e3d944f4 JH	96	}
03d70c89 JH	97
03d70c89 JH	98	/*
6dfee1ec	99	* Iterate over path components in 'left'.
03d70c89	100	*/
c7304ea2 NC	101	while (left_len != 0) {
c7304ea2 NC	102	/*
6dfee1ec	103	* Extract the next path component and adjust 'left'
c7304ea2 NC	104	* and its length.
	105	*/
	106	p = strchr(left, '/');
	107	s = p ? p : left + left_len;
c33e8be1	108	if ((STRLEN)(s - left) >= (STRLEN)sizeof(next_token)) {
c7304ea2 NC	109	errno = ENAMETOOLONG;
c7304ea2 NC	110	return (NULL);
03d70c89	111	}
c7304ea2 NC	112	memcpy(next_token, left, s - left);
	113	next_token[s - left] = '\0';
	114	left_len -= s - left;
	115	if (p != NULL)
	116	memmove(left, s + 1, left_len + 1);
	117	if (resolved[resolved_len - 1] != '/') {
	118	if (resolved_len + 1 >= MAXPATHLEN) {
	119	errno = ENAMETOOLONG;
	120	return (NULL);
03d70c89	121	}
c7304ea2 NC	122	resolved[resolved_len++] = '/';
c7304ea2 NC	123	resolved[resolved_len] = '\0';
03d70c89	124	}
c7304ea2 NC	125	if (next_token[0] == '\0')
	126	continue;
	127	else if (strcmp(next_token, ".") == 0)
	128	continue;
	129	else if (strcmp(next_token, "..") == 0) {
	130	/*
	131	* Strip the last path component except when we have
	132	* single "/"
	133	*/
	134	if (resolved_len > 1) {
	135	resolved[resolved_len - 1] = '\0';
	136	q = strrchr(resolved, '/') + 1;
	137	*q = '\0';
	138	resolved_len = q - resolved;
	139	}
	140	continue;
91f3b821	141	}
03d70c89 JH	142
03d70c89 JH	143	/*
c7304ea2 NC	144	* Append the next path component and lstat() it. If
	145	* lstat() fails we still can return successfully if
	146	* there are no more path components left.
03d70c89	147	*/
c7304ea2 NC	148	resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
	149	if (resolved_len >= MAXPATHLEN) {
	150	errno = ENAMETOOLONG;
	151	return (NULL);
	152	}
8304a6c4	153	#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
c7304ea2 NC	154	{
	155	struct stat sb;
	156	if (lstat(resolved, &sb) != 0) {
	157	if (errno == ENOENT && p == NULL) {
	158	errno = serrno;
	159	return (resolved);
	160	}
	161	return (NULL);
	162	}
	163	if (S_ISLNK(sb.st_mode)) {
	164	int slen;
8304a6c4	165	char symlink[MAXPATHLEN];
c7304ea2 NC	166
	167	if (symlinks++ > MAXSYMLINKS) {
	168	errno = ELOOP;
	169	return (NULL);
	170	}
	171	slen = readlink(resolved, symlink, sizeof(symlink) - 1);
	172	if (slen < 0)
	173	return (NULL);
	174	symlink[slen] = '\0';
	175	if (symlink[0] == '/') {
	176	resolved[1] = 0;
	177	resolved_len = 1;
	178	} else if (resolved_len > 1) {
	179	/* Strip the last path component. */
	180	resolved[resolved_len - 1] = '\0';
	181	q = strrchr(resolved, '/') + 1;
	182	*q = '\0';
	183	resolved_len = q - resolved;
	184	}
03d70c89 JH	185
03d70c89 JH	186	/*
c7304ea2 NC	187	* If there are any path components left, then
c7304ea2 NC	188	* append them to symlink. The result is placed
6dfee1ec	189	* in 'left'.
03d70c89	190	*/
c7304ea2 NC	191	if (p != NULL) {
c7304ea2 NC	192	if (symlink[slen - 1] != '/') {
c33e8be1	193	if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
8304a6c4	194	errno = ENAMETOOLONG;
c7304ea2	195	return (NULL);
8304a6c4	196	}
c7304ea2 NC	197	symlink[slen] = '/';
c7304ea2 NC	198	symlink[slen + 1] = 0;
8304a6c4	199	}
c7304ea2 NC	200	left_len = my_strlcat(symlink, left, sizeof(left));
	201	if (left_len >= sizeof(left)) {
	202	errno = ENAMETOOLONG;
	203	return (NULL);
8304a6c4 NC	204	}
8304a6c4 NC	205	}
c7304ea2 NC	206	left_len = my_strlcpy(left, symlink, sizeof(left));
	207	}
	208	}
8304a6c4	209	#endif
c7304ea2	210	}
03d70c89	211
c7304ea2 NC	212	/*
	213	* Remove trailing slash except when the resolved pathname
	214	* is a single "/".
	215	*/
	216	if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
	217	resolved[resolved_len - 1] = '\0';
03d70c89	218	return (resolved);
03d70c89	219	}
66a378bd	220	#endif
03d70c89	221
99f36a73 RGS	222	#ifndef SV_CWD_RETURN_UNDEF
	223	#define SV_CWD_RETURN_UNDEF \
	224	sv_setsv(sv, &PL_sv_undef); \
	225	return FALSE
	226	#endif
	227
	228	#ifndef OPpENTERSUB_HASTARG
	229	#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
	230	#endif
	231
	232	#ifndef dXSTARG
	233	#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
	234	? PAD_SV(PL_op->op_targ) : sv_newmortal())
	235	#endif
	236
	237	#ifndef XSprePUSH
	238	#define XSprePUSH (sp = PL_stack_base + ax - 1)
	239	#endif
	240
	241	#ifndef SV_CWD_ISDOT
	242	#define SV_CWD_ISDOT(dp) \
	243	(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' \|\| \
	244	(dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
	245	#endif
	246
a9939470	247	#ifndef getcwd_sv
1955c8df	248	/* Taken from perl 5.8's util.c */
09122b95	249	#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
5aaab254	250	int Perl_getcwd_sv(pTHX_ SV *sv)
a9939470 NC	251	{
	252	#ifndef PERL_MICRO
	253
	254	#ifndef INCOMPLETE_TAINTS
	255	SvTAINTED_on(sv);
	256	#endif
	257
	258	#ifdef HAS_GETCWD
	259	{
	260	char buf[MAXPATHLEN];
	261
	262	/* Some getcwd()s automatically allocate a buffer of the given
	263	* size from the heap if they are given a NULL buffer pointer.
	264	* The problem is that this behaviour is not portable. */
	265	if (getcwd(buf, sizeof(buf) - 1)) {
	266	STRLEN len = strlen(buf);
	267	sv_setpvn(sv, buf, len);
	268	return TRUE;
	269	}
	270	else {
	271	sv_setsv(sv, &PL_sv_undef);
	272	return FALSE;
	273	}
	274	}
	275
	276	#else
f6342b4b	277	{
a9939470 NC	278	Stat_t statbuf;
	279	int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
	280	int namelen, pathlen=0;
	281	DIR *dir;
	282	Direntry_t *dp;
	283
	284	(void)SvUPGRADE(sv, SVt_PV);
	285
	286	if (PerlLIO_lstat(".", &statbuf) < 0) {
	287	SV_CWD_RETURN_UNDEF;
	288	}
	289
	290	orig_cdev = statbuf.st_dev;
	291	orig_cino = statbuf.st_ino;
	292	cdev = orig_cdev;
	293	cino = orig_cino;
	294
	295	for (;;) {
	296	odev = cdev;
	297	oino = cino;
	298
	299	if (PerlDir_chdir("..") < 0) {
	300	SV_CWD_RETURN_UNDEF;
	301	}
	302	if (PerlLIO_stat(".", &statbuf) < 0) {
	303	SV_CWD_RETURN_UNDEF;
	304	}
	305
	306	cdev = statbuf.st_dev;
	307	cino = statbuf.st_ino;
	308
	309	if (odev == cdev && oino == cino) {
	310	break;
	311	}
	312	if (!(dir = PerlDir_open("."))) {
	313	SV_CWD_RETURN_UNDEF;
	314	}
	315
	316	while ((dp = PerlDir_read(dir)) != NULL) {
	317	#ifdef DIRNAMLEN
	318	namelen = dp->d_namlen;
	319	#else
	320	namelen = strlen(dp->d_name);
	321	#endif
	322	/* skip . and .. */
	323	if (SV_CWD_ISDOT(dp)) {
	324	continue;
	325	}
	326
	327	if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
	328	SV_CWD_RETURN_UNDEF;
	329	}
	330
	331	tdev = statbuf.st_dev;
	332	tino = statbuf.st_ino;
	333	if (tino == oino && tdev == odev) {
	334	break;
	335	}
	336	}
	337
	338	if (!dp) {
	339	SV_CWD_RETURN_UNDEF;
	340	}
	341
342	if (pathlen + namelen + 1 >= MAXPATHLEN) {
343	SV_CWD_RETURN_UNDEF;
344	}
345
346	SvGROW(sv, pathlen + namelen + 1);
347
348	if (pathlen) {
349	/* shift down */
350	Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
351	}
352
353	/* prepend current directory to the front */
354	*SvPVX(sv) = '/';
355	Move(dp->d_name, SvPVX(sv)+1, namelen, char);
356	pathlen += (namelen + 1);
357
358	#ifdef VOID_CLOSEDIR
359	PerlDir_close(dir);
360	#else
361	if (PerlDir_close(dir) < 0) {
362	SV_CWD_RETURN_UNDEF;
363	}
364	#endif
365	}
366
367	if (pathlen) {
368	SvCUR_set(sv, pathlen);
369	*SvEND(sv) = '\0';
370	SvPOK_only(sv);
371
372	if (PerlDir_chdir(SvPVX(sv)) < 0) {
373	SV_CWD_RETURN_UNDEF;
374	}
375	}
376	if (PerlLIO_stat(".", &statbuf) < 0) {
377	SV_CWD_RETURN_UNDEF;
378	}
379
380	cdev = statbuf.st_dev;
381	cino = statbuf.st_ino;
382
383	if (cdev != orig_cdev \|\| cino != orig_cino) {
384	Perl_croak(aTHX_ "Unstable directory path, "
385	"current directory changed unexpectedly");
386	}
387
388	return TRUE;
f6342b4b	389	}
a9939470 NC	390	#endif
	391
	392	#else
	393	return FALSE;
	394	#endif
	395	}
	396
	397	#endif
	398
	399
f22d8e4b	400	MODULE = Cwd PACKAGE = Cwd
0d2079fa	401
1d0561d5	402	PROTOTYPES: DISABLE
0d2079fa	403
f22d8e4b	404	void
23bb49fa	405	getcwd(...)
2cdb8b94 NC	406	ALIAS:
2cdb8b94 NC	407	fastcwd=1
fa52125f SP	408	PPCODE:
	409	{
	410	dXSTARG;
2cdb8b94 NC	411	/* fastcwd takes zero parameters: */
	412	if (ix == 1 && items != 0)
	413	croak_xs_usage(cv, "");
fa52125f SP	414	getcwd_sv(TARG);
	415	XSprePUSH; PUSHTARG;
	416	#ifndef INCOMPLETE_TAINTS
	417	SvTAINTED_on(TARG);
	418	#endif
	419	}
	420
	421	void
03d70c89 JH	422	abs_path(pathsv=Nullsv)
03d70c89 JH	423	SV *pathsv
f22d8e4b	424	PPCODE:
2ae52c40	425	{
f22d8e4b	426	dXSTARG;
66a378bd	427	char const path = pathsv ? SvPV_nolen(pathsv) : (char )".";
00536bfc	428	char buf[MAXPATHLEN];
03d70c89	429
66a378bd NC	430	if (
	431	#ifdef VMS
	432	Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
	433	#else
	434	bsd_realpath(path, buf)
	435	#endif
	436	) {
	437	sv_setpv_mg(TARG, buf);
00536bfc	438	SvPOK_only(TARG);
ea715489	439	SvTAINTED_on(TARG);
2ae52c40	440	}
03d70c89	441	else
ea715489	442	sv_setsv(TARG, &PL_sv_undef);
2ae52c40	443
66a378bd	444	XSprePUSH; PUSHs(TARG);
ea715489 JH	445	#ifndef INCOMPLETE_TAINTS
	446	SvTAINTED_on(TARG);
	447	#endif
2ae52c40	448	}
09122b95	449
42d1cefd	450	#if defined(WIN32) && !defined(UNDER_CE)
09122b95 RGS	451
	452	void
	453	getdcwd(...)
1d0561d5	454	PROTOTYPE: ENABLE
09122b95 RGS	455	PPCODE:
	456	{
	457	dXSTARG;
	458	int drive;
	459	char *dir;
	460
	461	/* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
	462	if ( items == 0 \|\|
	463	(items == 1 && (!SvOK(ST(0)) \|\| (SvPOK(ST(0)) && !SvCUR(ST(0))))))
	464	drive = 0;
	465	else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
	466	isALPHA(SvPVX(ST(0))[0]))
	467	drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
	468	else
	469	croak("Usage: getdcwd(DRIVE)");
	470
275e8705 RGS	471	New(0,dir,MAXPATHLEN,char);
275e8705 RGS	472	if (_getdcwd(drive, dir, MAXPATHLEN)) {
66a378bd	473	sv_setpv_mg(TARG, dir);
09122b95 RGS	474	SvPOK_only(TARG);
	475	}
	476	else
	477	sv_setsv(TARG, &PL_sv_undef);
	478
99f36a73 RGS	479	Safefree(dir);
99f36a73 RGS	480
66a378bd	481	XSprePUSH; PUSHs(TARG);
09122b95 RGS	482	#ifndef INCOMPLETE_TAINTS
	483	SvTAINTED_on(TARG);
	484	#endif
	485	}
	486
	487	#endif