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

#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

/*
 * 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"
9bc94e3d S	4	#define NEED_my_strlcpy
	5	#define NEED_my_strlcat
	6	#include "ppport.h"
0d2079fa	7
c70498c1 JH	8	#ifdef I_UNISTD
	9	# include <unistd.h>
	10	#endif
	11
bf7c0a3d	12	/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
03d70c89	13	* Renamed here to bsd_realpath() to avoid library conflicts.
99f36a73 RGS	14	*/
	15
	16	/* See
	17	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html
	18	* for the details of why the BSD license is compatible with the
	19	* AL/GPL standard perl license.
	20	*/
03d70c89 JH	21
03d70c89 JH	22	/*
bf7c0a3d	23	* Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
03d70c89 JH	24	*
	25	* Redistribution and use in source and binary forms, with or without
	26	* modification, are permitted provided that the following conditions
	27	* are met:
	28	* 1. Redistributions of source code must retain the above copyright
	29	* notice, this list of conditions and the following disclaimer.
	30	* 2. Redistributions in binary form must reproduce the above copyright
	31	* notice, this list of conditions and the following disclaimer in the
	32	* documentation and/or other materials provided with the distribution.
bf7c0a3d SP	33	* 3. The names of the authors may not be used to endorse or promote
	34	* products derived from this software without specific prior written
	35	* permission.
03d70c89	36	*
bf7c0a3d	37	* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
03d70c89 JH	38	* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
03d70c89 JH	39	* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
bf7c0a3d	40	* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
03d70c89 JH	41	* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
	42	* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
	43	* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
	44	* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
	45	* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
	46	* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
	47	* SUCH DAMAGE.
	48	*/
	49
03d70c89 JH	50	/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
	51
	52	#ifndef MAXSYMLINKS
	53	#define MAXSYMLINKS 8
	54	#endif
	55
	56	/*
bf7c0a3d	57	* char realpath(const char path, char resolved[MAXPATHLEN]);
03d70c89 JH	58	*
	59	* Find the real name of path, by removing all ".", ".." and symlink
	60	* components. Returns (resolved) on success, or (NULL) on failure,
	61	* in which case the path which caused trouble is left in (resolved).
	62	*/
	63	static
	64	char *
c7304ea2	65	bsd_realpath(const char *path, char resolved[MAXPATHLEN])
03d70c89	66	{
e3d944f4	67	#ifdef VMS
32af7c23 CL	68	dTHX;
32af7c23 CL	69	return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
e3d944f4	70	#else
c7304ea2 NC	71	char p, q, *s;
	72	size_t left_len, resolved_len;
	73	unsigned symlinks;
	74	int serrno;
	75	char left[MAXPATHLEN], next_token[MAXPATHLEN], symlink[MAXPATHLEN];
03d70c89	76
c7304ea2 NC	77	serrno = errno;
	78	symlinks = 0;
	79	if (path[0] == '/') {
	80	resolved[0] = '/';
	81	resolved[1] = '\0';
	82	if (path[1] == '\0')
	83	return (resolved);
	84	resolved_len = 1;
	85	left_len = my_strlcpy(left, path + 1, sizeof(left));
	86	} else {
	87	if (getcwd(resolved, MAXPATHLEN) == NULL) {
	88	my_strlcpy(resolved, ".", MAXPATHLEN);
03d70c89 JH	89	return (NULL);
03d70c89 JH	90	}
c7304ea2 NC	91	resolved_len = strlen(resolved);
	92	left_len = my_strlcpy(left, path, sizeof(left));
	93	}
	94	if (left_len >= sizeof(left) \|\| resolved_len >= MAXPATHLEN) {
	95	errno = ENAMETOOLONG;
e3d944f4 JH	96	return (NULL);
e3d944f4 JH	97	}
03d70c89 JH	98
03d70c89 JH	99	/*
c7304ea2	100	* Iterate over path components in `left'.
03d70c89	101	*/
c7304ea2 NC	102	while (left_len != 0) {
	103	/*
	104	* Extract the next path component and adjust `left'
	105	* and its length.
	106	*/
	107	p = strchr(left, '/');
	108	s = p ? p : left + left_len;
	109	if (s - left >= sizeof(next_token)) {
	110	errno = ENAMETOOLONG;
	111	return (NULL);
03d70c89	112	}
c7304ea2 NC	113	memcpy(next_token, left, s - left);
	114	next_token[s - left] = '\0';
	115	left_len -= s - left;
	116	if (p != NULL)
	117	memmove(left, s + 1, left_len + 1);
	118	if (resolved[resolved_len - 1] != '/') {
	119	if (resolved_len + 1 >= MAXPATHLEN) {
	120	errno = ENAMETOOLONG;
	121	return (NULL);
03d70c89	122	}
c7304ea2 NC	123	resolved[resolved_len++] = '/';
c7304ea2 NC	124	resolved[resolved_len] = '\0';
03d70c89	125	}
c7304ea2 NC	126	if (next_token[0] == '\0')
	127	continue;
	128	else if (strcmp(next_token, ".") == 0)
	129	continue;
	130	else if (strcmp(next_token, "..") == 0) {
	131	/*
	132	* Strip the last path component except when we have
	133	* single "/"
	134	*/
	135	if (resolved_len > 1) {
	136	resolved[resolved_len - 1] = '\0';
	137	q = strrchr(resolved, '/') + 1;
	138	*q = '\0';
	139	resolved_len = q - resolved;
	140	}
	141	continue;
91f3b821	142	}
03d70c89 JH	143
03d70c89 JH	144	/*
c7304ea2 NC	145	* Append the next path component and lstat() it. If
	146	* lstat() fails we still can return successfully if
	147	* there are no more path components left.
03d70c89	148	*/
c7304ea2 NC	149	resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
	150	if (resolved_len >= MAXPATHLEN) {
	151	errno = ENAMETOOLONG;
	152	return (NULL);
	153	}
	154	#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
	155	{
	156	struct stat sb;
	157	if (lstat(resolved, &sb) != 0) {
	158	if (errno == ENOENT && p == NULL) {
	159	errno = serrno;
	160	return (resolved);
	161	}
	162	return (NULL);
	163	}
	164	if (S_ISLNK(sb.st_mode)) {
	165	int slen;
	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
	188	* append them to symlink. The result is placed
	189	* in `left'.
03d70c89	190	*/
c7304ea2 NC	191	if (p != NULL) {
	192	if (symlink[slen - 1] != '/') {
	193	if (slen + 1 >= sizeof(symlink)) {
03d70c89	194	errno = ENAMETOOLONG;
c7304ea2	195	return (NULL);
03d70c89	196	}
c7304ea2 NC	197	symlink[slen] = '/';
c7304ea2 NC	198	symlink[slen + 1] = 0;
03d70c89	199	}
c7304ea2 NC	200	left_len = my_strlcat(symlink, left, sizeof(left));
	201	if (left_len >= sizeof(left)) {
	202	errno = ENAMETOOLONG;
	203	return (NULL);
03d70c89	204	}
e3d944f4	205	}
c7304ea2 NC	206	left_len = my_strlcpy(left, symlink, sizeof(left));
	207	}
	208	}
	209	#endif
	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);
e3d944f4	219	#endif
03d70c89 JH	220	}
03d70c89 JH	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 RGS	249	#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
09122b95 RGS	250	int Perl_getcwd_sv(pTHX_ register 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
f22d8e4b	402	PROTOTYPES: ENABLE
0d2079fa	403
f22d8e4b DM	404	void
f22d8e4b DM	405	fastcwd()
7ddb28a3	406	PROTOTYPE: DISABLE
f22d8e4b DM	407	PPCODE:
	408	{
	409	dXSTARG;
89423764	410	getcwd_sv(TARG);
f22d8e4b	411	XSprePUSH; PUSHTARG;
248785eb RGS	412	#ifndef INCOMPLETE_TAINTS
	413	SvTAINTED_on(TARG);
	414	#endif
0d2079fa BS	415	}
0d2079fa BS	416
f22d8e4b	417	void
23bb49fa	418	getcwd(...)
fa52125f SP	419	PROTOTYPE: DISABLE
	420	PPCODE:
	421	{
	422	dXSTARG;
	423	getcwd_sv(TARG);
	424	XSprePUSH; PUSHTARG;
	425	#ifndef INCOMPLETE_TAINTS
	426	SvTAINTED_on(TARG);
	427	#endif
	428	}
	429
	430	void
03d70c89 JH	431	abs_path(pathsv=Nullsv)
03d70c89 JH	432	SV *pathsv
99f36a73	433	PROTOTYPE: DISABLE
f22d8e4b	434	PPCODE:
2ae52c40	435	{
f22d8e4b DM	436	dXSTARG;
f22d8e4b DM	437	char *path;
00536bfc	438	char buf[MAXPATHLEN];
03d70c89	439
07409e01	440	path = pathsv ? SvPV_nolen(pathsv) : (char *)".";
03d70c89	441
00536bfc JH	442	if (bsd_realpath(path, buf)) {
	443	sv_setpvn(TARG, buf, strlen(buf));
	444	SvPOK_only(TARG);
ea715489	445	SvTAINTED_on(TARG);
2ae52c40	446	}
03d70c89	447	else
ea715489	448	sv_setsv(TARG, &PL_sv_undef);
2ae52c40	449
f22d8e4b	450	XSprePUSH; PUSHTARG;
ea715489 JH	451	#ifndef INCOMPLETE_TAINTS
	452	SvTAINTED_on(TARG);
	453	#endif
2ae52c40	454	}
09122b95	455
42d1cefd	456	#if defined(WIN32) && !defined(UNDER_CE)
09122b95 RGS	457
	458	void
	459	getdcwd(...)
	460	PPCODE:
	461	{
	462	dXSTARG;
	463	int drive;
	464	char *dir;
	465
	466	/* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
	467	if ( items == 0 \|\|
	468	(items == 1 && (!SvOK(ST(0)) \|\| (SvPOK(ST(0)) && !SvCUR(ST(0))))))
	469	drive = 0;
	470	else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
	471	isALPHA(SvPVX(ST(0))[0]))
	472	drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
	473	else
	474	croak("Usage: getdcwd(DRIVE)");
	475
275e8705 RGS	476	New(0,dir,MAXPATHLEN,char);
275e8705 RGS	477	if (_getdcwd(drive, dir, MAXPATHLEN)) {
09122b95	478	sv_setpvn(TARG, dir, strlen(dir));
09122b95 RGS	479	SvPOK_only(TARG);
	480	}
	481	else
	482	sv_setsv(TARG, &PL_sv_undef);
	483
99f36a73 RGS	484	Safefree(dir);
99f36a73 RGS	485
09122b95 RGS	486	XSprePUSH; PUSHTARG;
	487	#ifndef INCOMPLETE_TAINTS
	488	SvTAINTED_on(TARG);
	489	#endif
	490	}
	491
	492	#endif