[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

    SvTAINTED_on(sv);

#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

#if defined(START_MY_CXT) && defined(MY_CXT_CLONE)
# define USE_MY_CXT 1
#else
# define USE_MY_CXT 0
#endif

#if USE_MY_CXT
# define MY_CXT_KEY "Cwd::_guts"XS_VERSION
typedef struct {
    SV *empty_string_sv, *slash_string_sv;
} my_cxt_t;
START_MY_CXT
# define dUSE_MY_CXT dMY_CXT
# define EMPTY_STRING_SV MY_CXT.empty_string_sv
# define SLASH_STRING_SV MY_CXT.slash_string_sv
# define POPULATE_MY_CXT do { \
	MY_CXT.empty_string_sv = newSVpvs(""); \
	MY_CXT.slash_string_sv = newSVpvs("/"); \
    } while(0)
#else
# define dUSE_MY_CXT dNOOP
# define EMPTY_STRING_SV sv_2mortal(newSVpvs(""))
# define SLASH_STRING_SV sv_2mortal(newSVpvs("/"))
#endif

#define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i)
static
bool
THX_invocant_is_unix(pTHX_ SV *invocant)
{
    /*
     * This is used to enable optimisations that avoid method calls
     * by knowing how they would resolve.  False negatives, disabling
     * the optimisation where it would actually behave correctly, are
     * acceptable.
     */
    return SvPOK(invocant) && SvCUR(invocant) == 16 &&
	!memcmp(SvPVX(invocant), "File::Spec::Unix", 16);
}

#define unix_canonpath(p) THX_unix_canonpath(aTHX_ p)
static
SV *
THX_unix_canonpath(pTHX_ SV *path)
{
    SV *retval;
    char const *p, *pe, *q;
    STRLEN l;
    char *o;
    STRLEN plen;
    SvGETMAGIC(path);
    if(!SvOK(path)) return &PL_sv_undef;
    p = SvPV_nomg(path, plen);
    if(plen == 0) return newSVpvs("");
    pe = p + plen;
    retval = newSV(plen);
#ifdef SvUTF8
    if(SvUTF8(path)) SvUTF8_on(retval);
#endif
    o = SvPVX(retval);
    if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') {
	q = (const char *) memchr(p+2, '/', pe-(p+2));
	if(!q) q = pe;
	l = q - p;
	memcpy(o, p, l);
	p = q;
	o += l;
    }
    /*
     * The transformations performed here are:
     *   . squeeze multiple slashes
     *   . eliminate "." segments, except one if that's all there is
     *   . eliminate leading ".." segments
     *   . eliminate trailing slash, unless it's all there is
     */
    if(p[0] == '/') {
	*o++ = '/';
	while(1) {
	    do { p++; } while(p[0] == '/');
	    if(p[0] == '.' && p[1] == '.' && (p+2 == pe || p[2] == '/')) {
		p++;
		/* advance past second "." next time round loop */
	    } else if(p[0] == '.' && (p+1 == pe || p[1] == '/')) {
		/* advance past "." next time round loop */
	    } else {
		break;
	    }
	}
    } else if(p[0] == '.' && p[1] == '/') {
	do {
	    p++;
	    do { p++; } while(p[0] == '/');
	} while(p[0] == '.' && p[1] == '/');
	if(p == pe) *o++ = '.';
    }
    if(p == pe) goto end;
    while(1) {
	q = (const char *) memchr(p, '/', pe-p);
	if(!q) q = pe;
	l = q - p;
	memcpy(o, p, l);
	p = q;
	o += l;
	if(p == pe) goto end;
	while(1) {
	    do { p++; } while(p[0] == '/');
	    if(p == pe) goto end;
	    if(p[0] != '.') break;
	    if(p+1 == pe) goto end;
	    if(p[1] != '/') break;
	    p++;
	}
	*o++ = '/';
    }
    end: ;
    *o = 0;
    SvPOK_on(retval);
    SvCUR_set(retval, o - SvPVX(retval));
    return retval;
}

MODULE = Cwd		PACKAGE = Cwd

PROTOTYPES: DISABLE

BOOT:
#if USE_MY_CXT
{
    MY_CXT_INIT;
    POPULATE_MY_CXT;
}
#endif

#if USE_MY_CXT

void
CLONE(...)
CODE:
	PERL_UNUSED_VAR(items);
	{ MY_CXT_CLONE; POPULATE_MY_CXT; }

#endif

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;
    SvTAINTED_on(TARG);
}

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);
    SvTAINTED_on(TARG);
}

#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);
    SvTAINTED_on(TARG);
}

#endif

MODULE = Cwd		PACKAGE = File::Spec::Unix

SV *
canonpath(SV *self, SV *path = &PL_sv_undef, ...)
CODE:
    PERL_UNUSED_VAR(self);
    RETVAL = unix_canonpath(path);
OUTPUT:
    RETVAL

SV *
_fn_canonpath(SV *path = &PL_sv_undef, ...)
CODE:
    RETVAL = unix_canonpath(path);
OUTPUT:
    RETVAL

SV *
catdir(SV *self, ...)
PREINIT:
    dUSE_MY_CXT;
    SV *joined;
CODE:
    EXTEND(SP, items+1);
    ST(items) = EMPTY_STRING_SV;
    joined = sv_newmortal();
    do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
    if(invocant_is_unix(self)) {
	RETVAL = unix_canonpath(joined);
    } else {
	ENTER;
	PUSHMARK(SP);
	EXTEND(SP, 2);
	PUSHs(self);
	PUSHs(joined);
	PUTBACK;
	call_method("canonpath", G_SCALAR);
	SPAGAIN;
	RETVAL = POPs;
	LEAVE;
	SvREFCNT_inc(RETVAL);
    }
OUTPUT:
    RETVAL

SV *
_fn_catdir(...)
PREINIT:
    dUSE_MY_CXT;
    SV *joined;
CODE:
    EXTEND(SP, items+1);
    ST(items) = EMPTY_STRING_SV;
    joined = sv_newmortal();
    do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
    RETVAL = unix_canonpath(joined);
OUTPUT:
    RETVAL

SV *
catfile(SV *self, ...)
PREINIT:
    dUSE_MY_CXT;
CODE:
    if(invocant_is_unix(self)) {
	if(items == 1) {
	    RETVAL = &PL_sv_undef;
	} else {
	    SV *file = unix_canonpath(ST(items-1));
	    if(items == 2) {
		RETVAL = file;
	    } else {
		SV *dir = sv_newmortal();
		sv_2mortal(file);
		ST(items-1) = EMPTY_STRING_SV;
		do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
		RETVAL = unix_canonpath(dir);
		if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
		    sv_catsv(RETVAL, SLASH_STRING_SV);
		sv_catsv(RETVAL, file);
	    }
	}
    } else {
	SV *file, *dir;
	ENTER;
	PUSHMARK(SP);
	EXTEND(SP, 2);
	PUSHs(self);
	PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
	PUTBACK;
	call_method("canonpath", G_SCALAR);
	SPAGAIN;
	file = POPs;
	LEAVE;
	if(items <= 2) {
	    RETVAL = SvREFCNT_inc(file);
	} else {
	    char const *pv;
	    STRLEN len;
	    bool need_slash;
	    SP--;
	    ENTER;
	    PUSHMARK(&ST(-1));
	    PUTBACK;
	    call_method("catdir", G_SCALAR);
	    SPAGAIN;
	    dir = POPs;
	    LEAVE;
	    pv = SvPV(dir, len);
	    need_slash = len == 0 || pv[len-1] != '/';
	    RETVAL = newSVsv(dir);
	    if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
	    sv_catsv(RETVAL, file);
	}
    }
OUTPUT:
    RETVAL

SV *
_fn_catfile(...)
PREINIT:
    dUSE_MY_CXT;
CODE:
    if(items == 0) {
	RETVAL = &PL_sv_undef;
    } else {
	SV *file = unix_canonpath(ST(items-1));
	if(items == 1) {
	    RETVAL = file;
	} else {
	    SV *dir = sv_newmortal();
	    sv_2mortal(file);
	    ST(items-1) = EMPTY_STRING_SV;
	    do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
	    RETVAL = unix_canonpath(dir);
	    if(SvCUR(RETVAL) == 0 || SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
		sv_catsv(RETVAL, SLASH_STRING_SV);
	    sv_catsv(RETVAL, file);
	}
    }
OUTPUT:
    RETVAL
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
a9939470	254	SvTAINTED_on(sv);
a9939470 NC	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 NC	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 NC	388	#endif
	389
	390	#else
	391	return FALSE;
	392	#endif
	393	}
	394
	395	#endif
	396
07f43755 Z	397	#if defined(START_MY_CXT) && defined(MY_CXT_CLONE)
	398	# define USE_MY_CXT 1
	399	#else
	400	# define USE_MY_CXT 0
	401	#endif
	402
	403	#if USE_MY_CXT
	404	# define MY_CXT_KEY "Cwd::_guts"XS_VERSION
	405	typedef struct {
	406	SV empty_string_sv, slash_string_sv;
	407	} my_cxt_t;
	408	START_MY_CXT
	409	# define dUSE_MY_CXT dMY_CXT
	410	# define EMPTY_STRING_SV MY_CXT.empty_string_sv
	411	# define SLASH_STRING_SV MY_CXT.slash_string_sv
	412	# define POPULATE_MY_CXT do { \
	413	MY_CXT.empty_string_sv = newSVpvs(""); \
	414	MY_CXT.slash_string_sv = newSVpvs("/"); \
	415	} while(0)
	416	#else
	417	# define dUSE_MY_CXT dNOOP
	418	# define EMPTY_STRING_SV sv_2mortal(newSVpvs(""))
	419	# define SLASH_STRING_SV sv_2mortal(newSVpvs("/"))
	420	#endif
	421
	422	#define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i)
	423	static
	424	bool
	425	THX_invocant_is_unix(pTHX_ SV *invocant)
	426	{
	427	/*
	428	* This is used to enable optimisations that avoid method calls
	429	* by knowing how they would resolve. False negatives, disabling
	430	* the optimisation where it would actually behave correctly, are
	431	* acceptable.
	432	*/
	433	return SvPOK(invocant) && SvCUR(invocant) == 16 &&
	434	!memcmp(SvPVX(invocant), "File::Spec::Unix", 16);
	435	}
	436
	437	#define unix_canonpath(p) THX_unix_canonpath(aTHX_ p)
	438	static
	439	SV *
	440	THX_unix_canonpath(pTHX_ SV *path)
	441	{
	442	SV *retval;
	443	char const p, pe, *q;
	444	STRLEN l;
	445	char *o;
	446	STRLEN plen;
	447	SvGETMAGIC(path);
	448	if(!SvOK(path)) return &PL_sv_undef;
	449	p = SvPV_nomg(path, plen);
	450	if(plen == 0) return newSVpvs("");
	451	pe = p + plen;
	452	retval = newSV(plen);
	453	#ifdef SvUTF8
	454	if(SvUTF8(path)) SvUTF8_on(retval);
	455	#endif
	456	o = SvPVX(retval);
	457	if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') {
b1cb0d6f	458	q = (const char *) memchr(p+2, '/', pe-(p+2));
07f43755 Z	459	if(!q) q = pe;
	460	l = q - p;
	461	memcpy(o, p, l);
	462	p = q;
	463	o += l;
	464	}
	465	/*
	466	* The transformations performed here are:
	467	* . squeeze multiple slashes
	468	* . eliminate "." segments, except one if that's all there is
	469	* . eliminate leading ".." segments
	470	* . eliminate trailing slash, unless it's all there is
	471	*/
	472	if(p[0] == '/') {
	473	*o++ = '/';
	474	while(1) {
	475	do { p++; } while(p[0] == '/');
	476	if(p[0] == '.' && p[1] == '.' && (p+2 == pe \|\| p[2] == '/')) {
	477	p++;
	478	/* advance past second "." next time round loop */
	479	} else if(p[0] == '.' && (p+1 == pe \|\| p[1] == '/')) {
	480	/* advance past "." next time round loop */
	481	} else {
	482	break;
	483	}
	484	}
	485	} else if(p[0] == '.' && p[1] == '/') {
	486	do {
	487	p++;
	488	do { p++; } while(p[0] == '/');
	489	} while(p[0] == '.' && p[1] == '/');
	490	if(p == pe) *o++ = '.';
	491	}
	492	if(p == pe) goto end;
	493	while(1) {
b1cb0d6f	494	q = (const char *) memchr(p, '/', pe-p);
07f43755 Z	495	if(!q) q = pe;
	496	l = q - p;
	497	memcpy(o, p, l);
	498	p = q;
	499	o += l;
	500	if(p == pe) goto end;
	501	while(1) {
	502	do { p++; } while(p[0] == '/');
	503	if(p == pe) goto end;
	504	if(p[0] != '.') break;
	505	if(p+1 == pe) goto end;
	506	if(p[1] != '/') break;
	507	p++;
	508	}
	509	*o++ = '/';
	510	}
	511	end: ;
	512	*o = 0;
	513	SvPOK_on(retval);
	514	SvCUR_set(retval, o - SvPVX(retval));
	515	return retval;
	516	}
a9939470	517
f22d8e4b	518	MODULE = Cwd PACKAGE = Cwd
0d2079fa	519
1d0561d5	520	PROTOTYPES: DISABLE
0d2079fa	521
07f43755 Z	522	BOOT:
	523	#if USE_MY_CXT
	524	{
	525	MY_CXT_INIT;
	526	POPULATE_MY_CXT;
	527	}
	528	#endif
	529
	530	#if USE_MY_CXT
	531
	532	void
	533	CLONE(...)
	534	CODE:
	535	PERL_UNUSED_VAR(items);
	536	{ MY_CXT_CLONE; POPULATE_MY_CXT; }
	537
	538	#endif
	539
f22d8e4b	540	void
23bb49fa	541	getcwd(...)
2cdb8b94 NC	542	ALIAS:
2cdb8b94 NC	543	fastcwd=1
fa52125f SP	544	PPCODE:
	545	{
	546	dXSTARG;
2cdb8b94 NC	547	/* fastcwd takes zero parameters: */
	548	if (ix == 1 && items != 0)
	549	croak_xs_usage(cv, "");
fa52125f SP	550	getcwd_sv(TARG);
fa52125f SP	551	XSprePUSH; PUSHTARG;
fa52125f	552	SvTAINTED_on(TARG);
fa52125f SP	553	}
	554
	555	void
03d70c89 JH	556	abs_path(pathsv=Nullsv)
03d70c89 JH	557	SV *pathsv
f22d8e4b	558	PPCODE:
2ae52c40	559	{
f22d8e4b	560	dXSTARG;
66a378bd	561	char const path = pathsv ? SvPV_nolen(pathsv) : (char )".";
00536bfc	562	char buf[MAXPATHLEN];
03d70c89	563
66a378bd NC	564	if (
	565	#ifdef VMS
	566	Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
	567	#else
	568	bsd_realpath(path, buf)
	569	#endif
	570	) {
	571	sv_setpv_mg(TARG, buf);
00536bfc	572	SvPOK_only(TARG);
ea715489	573	SvTAINTED_on(TARG);
2ae52c40	574	}
03d70c89	575	else
ea715489	576	sv_setsv(TARG, &PL_sv_undef);
2ae52c40	577
66a378bd	578	XSprePUSH; PUSHs(TARG);
ea715489	579	SvTAINTED_on(TARG);
2ae52c40	580	}
09122b95	581
42d1cefd	582	#if defined(WIN32) && !defined(UNDER_CE)
09122b95 RGS	583
	584	void
	585	getdcwd(...)
1d0561d5	586	PROTOTYPE: ENABLE
09122b95 RGS	587	PPCODE:
	588	{
	589	dXSTARG;
	590	int drive;
	591	char *dir;
	592
	593	/* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
	594	if ( items == 0 \|\|
	595	(items == 1 && (!SvOK(ST(0)) \|\| (SvPOK(ST(0)) && !SvCUR(ST(0))))))
	596	drive = 0;
	597	else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
	598	isALPHA(SvPVX(ST(0))[0]))
	599	drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
	600	else
	601	croak("Usage: getdcwd(DRIVE)");
	602
275e8705 RGS	603	New(0,dir,MAXPATHLEN,char);
275e8705 RGS	604	if (_getdcwd(drive, dir, MAXPATHLEN)) {
66a378bd	605	sv_setpv_mg(TARG, dir);
09122b95 RGS	606	SvPOK_only(TARG);
	607	}
	608	else
	609	sv_setsv(TARG, &PL_sv_undef);
	610
99f36a73 RGS	611	Safefree(dir);
99f36a73 RGS	612
66a378bd	613	XSprePUSH; PUSHs(TARG);
09122b95	614	SvTAINTED_on(TARG);
09122b95 RGS	615	}
	616
	617	#endif
07f43755 Z	618
	619	MODULE = Cwd PACKAGE = File::Spec::Unix
	620
	621	SV *
	622	canonpath(SV self, SV path = &PL_sv_undef, ...)
	623	CODE:
	624	PERL_UNUSED_VAR(self);
	625	RETVAL = unix_canonpath(path);
	626	OUTPUT:
	627	RETVAL
	628
	629	SV *
	630	_fn_canonpath(SV *path = &PL_sv_undef, ...)
	631	CODE:
	632	RETVAL = unix_canonpath(path);
	633	OUTPUT:
	634	RETVAL
	635
	636	SV *
	637	catdir(SV *self, ...)
	638	PREINIT:
	639	dUSE_MY_CXT;
	640	SV *joined;
	641	CODE:
	642	EXTEND(SP, items+1);
	643	ST(items) = EMPTY_STRING_SV;
	644	joined = sv_newmortal();
	645	do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
	646	if(invocant_is_unix(self)) {
	647	RETVAL = unix_canonpath(joined);
	648	} else {
	649	ENTER;
	650	PUSHMARK(SP);
	651	EXTEND(SP, 2);
	652	PUSHs(self);
	653	PUSHs(joined);
	654	PUTBACK;
	655	call_method("canonpath", G_SCALAR);
	656	SPAGAIN;
	657	RETVAL = POPs;
	658	LEAVE;
	659	SvREFCNT_inc(RETVAL);
	660	}
	661	OUTPUT:
	662	RETVAL
	663
	664	SV *
	665	_fn_catdir(...)
	666	PREINIT:
	667	dUSE_MY_CXT;
	668	SV *joined;
	669	CODE:
	670	EXTEND(SP, items+1);
	671	ST(items) = EMPTY_STRING_SV;
	672	joined = sv_newmortal();
	673	do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
	674	RETVAL = unix_canonpath(joined);
	675	OUTPUT:
	676	RETVAL
	677
	678	SV *
	679	catfile(SV *self, ...)
	680	PREINIT:
	681	dUSE_MY_CXT;
682	CODE:
683	if(invocant_is_unix(self)) {
684	if(items == 1) {
685	RETVAL = &PL_sv_undef;
686	} else {
687	SV *file = unix_canonpath(ST(items-1));
688	if(items == 2) {
689	RETVAL = file;
690	} else {
691	SV *dir = sv_newmortal();
692	sv_2mortal(file);
693	ST(items-1) = EMPTY_STRING_SV;
694	do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
695	RETVAL = unix_canonpath(dir);
696	if(SvCUR(RETVAL) == 0 \|\| SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
697	sv_catsv(RETVAL, SLASH_STRING_SV);
698	sv_catsv(RETVAL, file);
699	}
700	}
701	} else {
702	SV file, dir;
703	ENTER;
704	PUSHMARK(SP);
705	EXTEND(SP, 2);
706	PUSHs(self);
707	PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
708	PUTBACK;
709	call_method("canonpath", G_SCALAR);
710	SPAGAIN;
711	file = POPs;
712	LEAVE;
713	if(items <= 2) {
714	RETVAL = SvREFCNT_inc(file);
715	} else {
716	char const *pv;
717	STRLEN len;
718	bool need_slash;
719	SP--;
720	ENTER;
721	PUSHMARK(&ST(-1));
722	PUTBACK;
723	call_method("catdir", G_SCALAR);
724	SPAGAIN;
725	dir = POPs;
726	LEAVE;
727	pv = SvPV(dir, len);
728	need_slash = len == 0 \|\| pv[len-1] != '/';
729	RETVAL = newSVsv(dir);
730	if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
731	sv_catsv(RETVAL, file);
732	}
733	}
734	OUTPUT:
735	RETVAL
736
737	SV *
738	_fn_catfile(...)
739	PREINIT:
740	dUSE_MY_CXT;
741	CODE:
742	if(items == 0) {
743	RETVAL = &PL_sv_undef;
744	} else {
745	SV *file = unix_canonpath(ST(items-1));
746	if(items == 1) {
747	RETVAL = file;
748	} else {
749	SV *dir = sv_newmortal();
750	sv_2mortal(file);
751	ST(items-1) = EMPTY_STRING_SV;
752	do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
753	RETVAL = unix_canonpath(dir);
754	if(SvCUR(RETVAL) == 0 \|\| SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
755	sv_catsv(RETVAL, SLASH_STRING_SV);
756	sv_catsv(RETVAL, file);
757	}
758	}
759	OUTPUT:
760	RETVAL