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

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

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

/* The realpath() implementation from OpenBSD 2.9 (realpath.c 1.4)
 * Renamed here to bsd_realpath() to avoid library conflicts.
 * --jhi 2000-06-20 
 */

/* 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) 1994
 *	The Regents of the University of California.  All rights reserved.
 *
 * This code is derived from software contributed to Berkeley by
 * Jan-Simon Pendry.
 *
 * 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. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 REGENTS 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.
 */

#if defined(LIBC_SCCS) && !defined(lint)
static char *rcsid = "$OpenBSD: realpath.c,v 1.4 1998/05/18 09:55:19 deraadt Exp $";
#endif /* LIBC_SCCS and not lint */

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

#ifndef MAXSYMLINKS
#define MAXSYMLINKS 8
#endif

/*
 * char *realpath(const char *path, char resolved_path[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)
{
#ifdef VMS
       dTHX;
       return Perl_rmsexpand(aTHX_ (char*)path, resolved, NULL, 0);
#else
	int rootd, serrno;
	const char *p;
	char *q, wbuf[MAXPATHLEN];
	int symlinks = 0;

	/* Save the starting point. */
#ifdef HAS_FCHDIR
	int fd;

	if ((fd = open(".", O_RDONLY)) < 0) {
		(void)strcpy(resolved, ".");
		return (NULL);
	}
#else
	char wd[MAXPATHLEN];

	if (getcwd(wd, MAXPATHLEN - 1) == NULL) {
		(void)strcpy(resolved, ".");
		return (NULL);
	}
#endif

	/*
	 * Find the dirname and basename from the path to be resolved.
	 * Change directory to the dirname component.
	 * lstat the basename part.
	 *     if it is a symlink, read in the value and loop.
	 *     if it is a directory, then change to that directory.
	 * get the current directory name and append the basename.
	 */
	(void)strncpy(resolved, path, MAXPATHLEN - 1);
	resolved[MAXPATHLEN - 1] = '\0';
loop:
	q = strrchr(resolved, '/');
	if (q != NULL) {
		const char *dir;
		p = q + 1;
		if (q == resolved)
			dir = "/";
		else {
			do {
				--q;
			} while (q > resolved && *q == '/');
			q[1] = '\0';
			dir = resolved;
		}
		if (chdir(dir) < 0)
			goto err1;
	} else
		p = resolved;

#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
    {
	struct stat sb;
	/* Deal with the last component. */
	if (lstat(p, &sb) == 0) {
		if (S_ISLNK(sb.st_mode)) {
			int n;
			if (++symlinks > MAXSYMLINKS) {
				errno = ELOOP;
				goto err1;
			}
			n = readlink(p, resolved, MAXPATHLEN-1);
			if (n < 0)
				goto err1;
			resolved[n] = '\0';
			goto loop;
		}
		if (S_ISDIR(sb.st_mode)) {
			if (chdir(p) < 0)
				goto err1;
			p = "";
		}
	}
    }
#endif

	/*
	 * Save the last component name and get the full pathname of
	 * the current directory.
	 */
	(void)strcpy(wbuf, p);
	if (getcwd(resolved, MAXPATHLEN) == 0)
		goto err1;

	/*
	 * Join the two strings together, ensuring that the right thing
	 * happens if the last component is empty, or the dirname is root.
	 */
	if (resolved[0] == '/' && resolved[1] == '\0')
		rootd = 1;
	else
		rootd = 0;

	if (*wbuf) {
		if (strlen(resolved) + strlen(wbuf) + (1 - rootd) + 1 > MAXPATHLEN) {
			errno = ENAMETOOLONG;
			goto err1;
		}
		if (rootd == 0)
			(void)strcat(resolved, "/");
		(void)strcat(resolved, wbuf);
	}

	/* Go back to where we came from. */
#ifdef HAS_FCHDIR
	if (fchdir(fd) < 0) {
		serrno = errno;
		goto err2;
	}
#else
	if (chdir(wd) < 0) {
		serrno = errno;
		goto err2;
	}
#endif

	/* It's okay if the close fails, what's an fd more or less? */
#ifdef HAS_FCHDIR
	(void)close(fd);
#endif
	return (resolved);

err1:	serrno = errno;
#ifdef HAS_FCHDIR
	(void)fchdir(fd);
#else
	(void)chdir(wd);
#endif

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