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

/*
 * ex: set ts=8 sts=4 sw=4 et:
 */

#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

/* For special handling of os390 sysplexed systems */
#define SYSNAME "$SYSNAME"
#define SYSNAME_LEN (sizeof(SYSNAME) - 1)

/* 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 remaining_len, resolved_len;
	unsigned symlinks;
	int serrno;
	char remaining[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;
            remaining_len = my_strlcpy(remaining, path + 1, sizeof(remaining));
	} else {
            if (getcwd(resolved, MAXPATHLEN) == NULL) {
                my_strlcpy(resolved, ".", MAXPATHLEN);
                return (NULL);
            }
            resolved_len = strlen(resolved);
            remaining_len = my_strlcpy(remaining, path, sizeof(remaining));
	}
	if (remaining_len >= sizeof(remaining) || resolved_len >= MAXPATHLEN) {
            errno = ENAMETOOLONG;
            return (NULL);
	}

	/*
	 * Iterate over path components in 'remaining'.
	 */
	while (remaining_len != 0) {

            /*
             * Extract the next path component and adjust 'remaining'
             * and its length.
             */

            p = strchr(remaining, '/');
            s = p ? p : remaining + remaining_len;
            if ((STRLEN)(s - remaining) >= (STRLEN)sizeof(next_token)) {
                errno = ENAMETOOLONG;
                return (NULL);
            }
            memcpy(next_token, remaining, s - remaining);
            next_token[s - remaining] = '\0';
            remaining_len -= s - remaining;
            if (p != NULL)
                memmove(remaining, s + 1, remaining_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';
#  ifdef EBCDIC /* XXX Probably this should be only os390 */
                    /* Replace all instances of $SYSNAME/foo simply by /foo */
                    if (slen > SYSNAME_LEN + strlen(next_token)
                        && strnEQ(symlink, SYSNAME, SYSNAME_LEN)
                        && *(symlink + SYSNAME_LEN) == '/'
                        && strEQ(symlink + SYSNAME_LEN + 1, next_token))
                    {
                        goto not_symlink;
                    }
#  endif
                    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 'remaining'.
                     */
                    if (p != NULL) {
                        if (symlink[slen - 1] != '/') {
                            if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
                                errno = ENAMETOOLONG;
                                return (NULL);
                            }
                            symlink[slen] = '/';
                            symlink[slen + 1] = 0;
                        }
                        remaining_len = my_strlcat(symlink, remaining, sizeof(symlink));
                        if (remaining_len >= sizeof(remaining)) {
                            errno = ENAMETOOLONG;
                            return (NULL);
                        }
                    }
                    remaining_len = my_strlcpy(remaining, symlink, sizeof(remaining));
                }
#  ifdef EBCDIC
              not_symlink: ;
#  endif
            }
#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
1a285208	1	/*
1a285208 KW	2	* ex: set ts=8 sts=4 sw=4 et:
	3	*/
	4
c30da3b5 NC	5	#define PERL_NO_GET_CONTEXT
c30da3b5 NC	6
0d2079fa BS	7	#include "EXTERN.h"
	8	#include "perl.h"
	9	#include "XSUB.h"
9bc94e3d S	10	#define NEED_my_strlcpy
	11	#define NEED_my_strlcat
	12	#include "ppport.h"
0d2079fa	13
c70498c1 JH	14	#ifdef I_UNISTD
	15	# include <unistd.h>
	16	#endif
	17
c5fb6bf8 KW	18	/* For special handling of os390 sysplexed systems */
	19	#define SYSNAME "$SYSNAME"
	20	#define SYSNAME_LEN (sizeof(SYSNAME) - 1)
	21
bf7c0a3d	22	/* The realpath() implementation from OpenBSD 3.9 to 4.2 (realpath.c 1.13)
03d70c89	23	* Renamed here to bsd_realpath() to avoid library conflicts.
99f36a73 RGS	24	*/
	25
	26	/* See
	27	* http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2004-11/msg00979.html
	28	* for the details of why the BSD license is compatible with the
	29	* AL/GPL standard perl license.
	30	*/
03d70c89 JH	31
03d70c89 JH	32	/*
bf7c0a3d	33	* Copyright (c) 2003 Constantin S. Svintsoff <kostik@iclub.nsu.ru>
03d70c89 JH	34	*
	35	* Redistribution and use in source and binary forms, with or without
	36	* modification, are permitted provided that the following conditions
	37	* are met:
	38	* 1. Redistributions of source code must retain the above copyright
	39	* notice, this list of conditions and the following disclaimer.
	40	* 2. Redistributions in binary form must reproduce the above copyright
	41	* notice, this list of conditions and the following disclaimer in the
	42	* documentation and/or other materials provided with the distribution.
bf7c0a3d SP	43	* 3. The names of the authors may not be used to endorse or promote
	44	* products derived from this software without specific prior written
	45	* permission.
03d70c89	46	*
6dfee1ec	47	* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND
03d70c89 JH	48	* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
03d70c89 JH	49	* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
bf7c0a3d	50	* ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
03d70c89 JH	51	* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
	52	* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
	53	* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
	54	* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
	55	* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
	56	* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
	57	* SUCH DAMAGE.
	58	*/
	59
03d70c89 JH	60	/* OpenBSD system #includes removed since the Perl ones should do. --jhi */
	61
	62	#ifndef MAXSYMLINKS
	63	#define MAXSYMLINKS 8
	64	#endif
	65
66a378bd	66	#ifndef VMS
03d70c89	67	/*
bf7c0a3d	68	* char realpath(const char path, char resolved[MAXPATHLEN]);
03d70c89 JH	69	*
	70	* Find the real name of path, by removing all ".", ".." and symlink
	71	* components. Returns (resolved) on success, or (NULL) on failure,
	72	* in which case the path which caused trouble is left in (resolved).
	73	*/
	74	static
	75	char *
c7304ea2	76	bsd_realpath(const char *path, char resolved[MAXPATHLEN])
03d70c89	77	{
c7304ea2	78	char p, q, *s;
84d69ee4	79	size_t remaining_len, resolved_len;
c7304ea2 NC	80	unsigned symlinks;
c7304ea2 NC	81	int serrno;
84d69ee4	82	char remaining[MAXPATHLEN], next_token[MAXPATHLEN];
03d70c89	83
c7304ea2 NC	84	serrno = errno;
	85	symlinks = 0;
	86	if (path[0] == '/') {
1a285208 KW	87	resolved[0] = '/';
	88	resolved[1] = '\0';
	89	if (path[1] == '\0')
	90	return (resolved);
	91	resolved_len = 1;
84d69ee4	92	remaining_len = my_strlcpy(remaining, path + 1, sizeof(remaining));
c7304ea2	93	} else {
1a285208 KW	94	if (getcwd(resolved, MAXPATHLEN) == NULL) {
	95	my_strlcpy(resolved, ".", MAXPATHLEN);
	96	return (NULL);
	97	}
	98	resolved_len = strlen(resolved);
84d69ee4	99	remaining_len = my_strlcpy(remaining, path, sizeof(remaining));
c7304ea2	100	}
84d69ee4	101	if (remaining_len >= sizeof(remaining) \|\| resolved_len >= MAXPATHLEN) {
1a285208 KW	102	errno = ENAMETOOLONG;
1a285208 KW	103	return (NULL);
e3d944f4	104	}
03d70c89 JH	105
03d70c89 JH	106	/*
84d69ee4	107	* Iterate over path components in 'remaining'.
03d70c89	108	*/
84d69ee4 KW	109	while (remaining_len != 0) {
84d69ee4 KW	110
1a285208	111	/*
84d69ee4	112	* Extract the next path component and adjust 'remaining'
1a285208 KW	113	* and its length.
1a285208 KW	114	*/
84d69ee4 KW	115
	116	p = strchr(remaining, '/');
	117	s = p ? p : remaining + remaining_len;
	118	if ((STRLEN)(s - remaining) >= (STRLEN)sizeof(next_token)) {
1a285208 KW	119	errno = ENAMETOOLONG;
	120	return (NULL);
	121	}
84d69ee4 KW	122	memcpy(next_token, remaining, s - remaining);
	123	next_token[s - remaining] = '\0';
	124	remaining_len -= s - remaining;
1a285208	125	if (p != NULL)
84d69ee4	126	memmove(remaining, s + 1, remaining_len + 1);
1a285208 KW	127	if (resolved[resolved_len - 1] != '/') {
	128	if (resolved_len + 1 >= MAXPATHLEN) {
	129	errno = ENAMETOOLONG;
	130	return (NULL);
	131	}
	132	resolved[resolved_len++] = '/';
	133	resolved[resolved_len] = '\0';
	134	}
	135	if (next_token[0] == '\0')
	136	continue;
	137	else if (strcmp(next_token, ".") == 0)
	138	continue;
	139	else if (strcmp(next_token, "..") == 0) {
	140	/*
	141	* Strip the last path component except when we have
	142	* single "/"
	143	*/
	144	if (resolved_len > 1) {
	145	resolved[resolved_len - 1] = '\0';
	146	q = strrchr(resolved, '/') + 1;
	147	*q = '\0';
	148	resolved_len = q - resolved;
	149	}
	150	continue;
	151	}
03d70c89	152
1a285208 KW	153	/*
	154	* Append the next path component and lstat() it. If
	155	* lstat() fails we still can return successfully if
	156	* there are no more path components left.
	157	*/
	158	resolved_len = my_strlcat(resolved, next_token, MAXPATHLEN);
	159	if (resolved_len >= MAXPATHLEN) {
	160	errno = ENAMETOOLONG;
	161	return (NULL);
	162	}
8304a6c4	163	#if defined(HAS_LSTAT) && defined(HAS_READLINK) && defined(HAS_SYMLINK)
1a285208 KW	164	{
	165	struct stat sb;
	166	if (lstat(resolved, &sb) != 0) {
	167	if (errno == ENOENT && p == NULL) {
	168	errno = serrno;
	169	return (resolved);
	170	}
	171	return (NULL);
	172	}
	173	if (S_ISLNK(sb.st_mode)) {
	174	int slen;
	175	char symlink[MAXPATHLEN];
03d70c89	176
1a285208 KW	177	if (symlinks++ > MAXSYMLINKS) {
	178	errno = ELOOP;
	179	return (NULL);
	180	}
	181	slen = readlink(resolved, symlink, sizeof(symlink) - 1);
	182	if (slen < 0)
	183	return (NULL);
	184	symlink[slen] = '\0';
cfd9941d	185	# ifdef EBCDIC /* XXX Probably this should be only os390 */
c5fb6bf8 KW	186	/* Replace all instances of $SYSNAME/foo simply by /foo */
	187	if (slen > SYSNAME_LEN + strlen(next_token)
	188	&& strnEQ(symlink, SYSNAME, SYSNAME_LEN)
	189	&& *(symlink + SYSNAME_LEN) == '/'
	190	&& strEQ(symlink + SYSNAME_LEN + 1, next_token))
	191	{
	192	goto not_symlink;
	193	}
cfd9941d	194	# endif
1a285208 KW	195	if (symlink[0] == '/') {
	196	resolved[1] = 0;
	197	resolved_len = 1;
	198	} else if (resolved_len > 1) {
	199	/* Strip the last path component. */
	200	resolved[resolved_len - 1] = '\0';
	201	q = strrchr(resolved, '/') + 1;
	202	*q = '\0';
	203	resolved_len = q - resolved;
	204	}
	205
	206	/*
	207	* If there are any path components left, then
	208	* append them to symlink. The result is placed
84d69ee4	209	* in 'remaining'.
1a285208 KW	210	*/
	211	if (p != NULL) {
	212	if (symlink[slen - 1] != '/') {
	213	if ((STRLEN)(slen + 1) >= (STRLEN)sizeof(symlink)) {
	214	errno = ENAMETOOLONG;
	215	return (NULL);
	216	}
	217	symlink[slen] = '/';
	218	symlink[slen + 1] = 0;
	219	}
84d69ee4 KW	220	remaining_len = my_strlcat(symlink, remaining, sizeof(symlink));
84d69ee4 KW	221	if (remaining_len >= sizeof(remaining)) {
1a285208 KW	222	errno = ENAMETOOLONG;
	223	return (NULL);
	224	}
	225	}
84d69ee4	226	remaining_len = my_strlcpy(remaining, symlink, sizeof(remaining));
1a285208	227	}
cfd9941d	228	# ifdef EBCDIC
c5fb6bf8	229	not_symlink: ;
cfd9941d	230	# endif
1a285208	231	}
8304a6c4	232	#endif
c7304ea2	233	}
03d70c89	234
c7304ea2 NC	235	/*
	236	* Remove trailing slash except when the resolved pathname
	237	* is a single "/".
	238	*/
	239	if (resolved_len > 1 && resolved[resolved_len - 1] == '/')
1a285208	240	resolved[resolved_len - 1] = '\0';
03d70c89	241	return (resolved);
03d70c89	242	}
66a378bd	243	#endif
03d70c89	244
99f36a73 RGS	245	#ifndef SV_CWD_RETURN_UNDEF
	246	#define SV_CWD_RETURN_UNDEF \
	247	sv_setsv(sv, &PL_sv_undef); \
	248	return FALSE
	249	#endif
	250
	251	#ifndef OPpENTERSUB_HASTARG
	252	#define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */
	253	#endif
	254
	255	#ifndef dXSTARG
	256	#define dXSTARG SV * targ = ((PL_op->op_private & OPpENTERSUB_HASTARG) \
	257	? PAD_SV(PL_op->op_targ) : sv_newmortal())
	258	#endif
	259
	260	#ifndef XSprePUSH
	261	#define XSprePUSH (sp = PL_stack_base + ax - 1)
	262	#endif
	263
	264	#ifndef SV_CWD_ISDOT
	265	#define SV_CWD_ISDOT(dp) \
	266	(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' \|\| \
	267	(dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
	268	#endif
	269
a9939470	270	#ifndef getcwd_sv
1955c8df	271	/* Taken from perl 5.8's util.c */
09122b95	272	#define getcwd_sv(a) Perl_getcwd_sv(aTHX_ a)
5aaab254	273	int Perl_getcwd_sv(pTHX_ SV *sv)
a9939470 NC	274	{
	275	#ifndef PERL_MICRO
	276
a9939470	277	SvTAINTED_on(sv);
a9939470 NC	278
	279	#ifdef HAS_GETCWD
	280	{
	281	char buf[MAXPATHLEN];
	282
	283	/* Some getcwd()s automatically allocate a buffer of the given
	284	* size from the heap if they are given a NULL buffer pointer.
	285	* The problem is that this behaviour is not portable. */
	286	if (getcwd(buf, sizeof(buf) - 1)) {
	287	STRLEN len = strlen(buf);
	288	sv_setpvn(sv, buf, len);
	289	return TRUE;
	290	}
	291	else {
	292	sv_setsv(sv, &PL_sv_undef);
	293	return FALSE;
	294	}
	295	}
	296
	297	#else
f6342b4b	298	{
a9939470 NC	299	Stat_t statbuf;
	300	int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
	301	int namelen, pathlen=0;
	302	DIR *dir;
	303	Direntry_t *dp;
	304
	305	(void)SvUPGRADE(sv, SVt_PV);
	306
	307	if (PerlLIO_lstat(".", &statbuf) < 0) {
	308	SV_CWD_RETURN_UNDEF;
	309	}
	310
	311	orig_cdev = statbuf.st_dev;
	312	orig_cino = statbuf.st_ino;
	313	cdev = orig_cdev;
	314	cino = orig_cino;
	315
	316	for (;;) {
	317	odev = cdev;
	318	oino = cino;
	319
	320	if (PerlDir_chdir("..") < 0) {
	321	SV_CWD_RETURN_UNDEF;
	322	}
	323	if (PerlLIO_stat(".", &statbuf) < 0) {
	324	SV_CWD_RETURN_UNDEF;
	325	}
	326
	327	cdev = statbuf.st_dev;
	328	cino = statbuf.st_ino;
	329
	330	if (odev == cdev && oino == cino) {
	331	break;
	332	}
	333	if (!(dir = PerlDir_open("."))) {
	334	SV_CWD_RETURN_UNDEF;
	335	}
	336
	337	while ((dp = PerlDir_read(dir)) != NULL) {
	338	#ifdef DIRNAMLEN
	339	namelen = dp->d_namlen;
	340	#else
	341	namelen = strlen(dp->d_name);
	342	#endif
	343	/* skip . and .. */
	344	if (SV_CWD_ISDOT(dp)) {
	345	continue;
	346	}
	347
	348	if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
	349	SV_CWD_RETURN_UNDEF;
	350	}
	351
	352	tdev = statbuf.st_dev;
	353	tino = statbuf.st_ino;
	354	if (tino == oino && tdev == odev) {
	355	break;
	356	}
	357	}
	358
	359	if (!dp) {
	360	SV_CWD_RETURN_UNDEF;
	361	}
	362
363	if (pathlen + namelen + 1 >= MAXPATHLEN) {
364	SV_CWD_RETURN_UNDEF;
365	}
366
367	SvGROW(sv, pathlen + namelen + 1);
368
369	if (pathlen) {
370	/* shift down */
371	Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
372	}
373
374	/* prepend current directory to the front */
375	*SvPVX(sv) = '/';
376	Move(dp->d_name, SvPVX(sv)+1, namelen, char);
377	pathlen += (namelen + 1);
378
379	#ifdef VOID_CLOSEDIR
380	PerlDir_close(dir);
381	#else
382	if (PerlDir_close(dir) < 0) {
383	SV_CWD_RETURN_UNDEF;
384	}
385	#endif
386	}
387
388	if (pathlen) {
389	SvCUR_set(sv, pathlen);
390	*SvEND(sv) = '\0';
391	SvPOK_only(sv);
392
393	if (PerlDir_chdir(SvPVX(sv)) < 0) {
394	SV_CWD_RETURN_UNDEF;
395	}
396	}
397	if (PerlLIO_stat(".", &statbuf) < 0) {
398	SV_CWD_RETURN_UNDEF;
399	}
400
401	cdev = statbuf.st_dev;
402	cino = statbuf.st_ino;
403
404	if (cdev != orig_cdev \|\| cino != orig_cino) {
405	Perl_croak(aTHX_ "Unstable directory path, "
406	"current directory changed unexpectedly");
407	}
408
409	return TRUE;
f6342b4b	410	}
a9939470 NC	411	#endif
	412
	413	#else
	414	return FALSE;
	415	#endif
	416	}
	417
	418	#endif
	419
07f43755 Z	420	#if defined(START_MY_CXT) && defined(MY_CXT_CLONE)
	421	# define USE_MY_CXT 1
	422	#else
	423	# define USE_MY_CXT 0
	424	#endif
	425
	426	#if USE_MY_CXT
	427	# define MY_CXT_KEY "Cwd::_guts"XS_VERSION
	428	typedef struct {
	429	SV empty_string_sv, slash_string_sv;
	430	} my_cxt_t;
	431	START_MY_CXT
	432	# define dUSE_MY_CXT dMY_CXT
	433	# define EMPTY_STRING_SV MY_CXT.empty_string_sv
	434	# define SLASH_STRING_SV MY_CXT.slash_string_sv
	435	# define POPULATE_MY_CXT do { \
	436	MY_CXT.empty_string_sv = newSVpvs(""); \
	437	MY_CXT.slash_string_sv = newSVpvs("/"); \
	438	} while(0)
	439	#else
	440	# define dUSE_MY_CXT dNOOP
	441	# define EMPTY_STRING_SV sv_2mortal(newSVpvs(""))
	442	# define SLASH_STRING_SV sv_2mortal(newSVpvs("/"))
	443	#endif
	444
	445	#define invocant_is_unix(i) THX_invocant_is_unix(aTHX_ i)
	446	static
	447	bool
	448	THX_invocant_is_unix(pTHX_ SV *invocant)
	449	{
	450	/*
	451	* This is used to enable optimisations that avoid method calls
	452	* by knowing how they would resolve. False negatives, disabling
	453	* the optimisation where it would actually behave correctly, are
	454	* acceptable.
	455	*/
	456	return SvPOK(invocant) && SvCUR(invocant) == 16 &&
	457	!memcmp(SvPVX(invocant), "File::Spec::Unix", 16);
	458	}
	459
	460	#define unix_canonpath(p) THX_unix_canonpath(aTHX_ p)
	461	static
	462	SV *
	463	THX_unix_canonpath(pTHX_ SV *path)
	464	{
	465	SV *retval;
	466	char const p, pe, *q;
	467	STRLEN l;
	468	char *o;
	469	STRLEN plen;
	470	SvGETMAGIC(path);
	471	if(!SvOK(path)) return &PL_sv_undef;
	472	p = SvPV_nomg(path, plen);
	473	if(plen == 0) return newSVpvs("");
	474	pe = p + plen;
	475	retval = newSV(plen);
	476	#ifdef SvUTF8
	477	if(SvUTF8(path)) SvUTF8_on(retval);
	478	#endif
	479	o = SvPVX(retval);
	480	if(DOUBLE_SLASHES_SPECIAL && p[0] == '/' && p[1] == '/' && p[2] != '/') {
b1cb0d6f	481	q = (const char *) memchr(p+2, '/', pe-(p+2));
07f43755 Z	482	if(!q) q = pe;
	483	l = q - p;
	484	memcpy(o, p, l);
	485	p = q;
	486	o += l;
	487	}
	488	/*
	489	* The transformations performed here are:
	490	* . squeeze multiple slashes
	491	* . eliminate "." segments, except one if that's all there is
	492	* . eliminate leading ".." segments
	493	* . eliminate trailing slash, unless it's all there is
	494	*/
	495	if(p[0] == '/') {
	496	*o++ = '/';
	497	while(1) {
	498	do { p++; } while(p[0] == '/');
	499	if(p[0] == '.' && p[1] == '.' && (p+2 == pe \|\| p[2] == '/')) {
	500	p++;
	501	/* advance past second "." next time round loop */
	502	} else if(p[0] == '.' && (p+1 == pe \|\| p[1] == '/')) {
	503	/* advance past "." next time round loop */
	504	} else {
	505	break;
	506	}
	507	}
	508	} else if(p[0] == '.' && p[1] == '/') {
	509	do {
	510	p++;
	511	do { p++; } while(p[0] == '/');
	512	} while(p[0] == '.' && p[1] == '/');
	513	if(p == pe) *o++ = '.';
	514	}
	515	if(p == pe) goto end;
	516	while(1) {
b1cb0d6f	517	q = (const char *) memchr(p, '/', pe-p);
07f43755 Z	518	if(!q) q = pe;
	519	l = q - p;
	520	memcpy(o, p, l);
	521	p = q;
	522	o += l;
	523	if(p == pe) goto end;
	524	while(1) {
	525	do { p++; } while(p[0] == '/');
	526	if(p == pe) goto end;
	527	if(p[0] != '.') break;
	528	if(p+1 == pe) goto end;
	529	if(p[1] != '/') break;
	530	p++;
	531	}
	532	*o++ = '/';
	533	}
	534	end: ;
	535	*o = 0;
	536	SvPOK_on(retval);
	537	SvCUR_set(retval, o - SvPVX(retval));
	538	return retval;
	539	}
a9939470	540
f22d8e4b	541	MODULE = Cwd PACKAGE = Cwd
0d2079fa	542
1d0561d5	543	PROTOTYPES: DISABLE
0d2079fa	544
07f43755 Z	545	BOOT:
	546	#if USE_MY_CXT
	547	{
	548	MY_CXT_INIT;
	549	POPULATE_MY_CXT;
	550	}
	551	#endif
	552
	553	#if USE_MY_CXT
	554
	555	void
	556	CLONE(...)
	557	CODE:
	558	PERL_UNUSED_VAR(items);
	559	{ MY_CXT_CLONE; POPULATE_MY_CXT; }
	560
	561	#endif
	562
f22d8e4b	563	void
23bb49fa	564	getcwd(...)
2cdb8b94 NC	565	ALIAS:
2cdb8b94 NC	566	fastcwd=1
fa52125f SP	567	PPCODE:
	568	{
	569	dXSTARG;
2cdb8b94 NC	570	/* fastcwd takes zero parameters: */
	571	if (ix == 1 && items != 0)
	572	croak_xs_usage(cv, "");
fa52125f SP	573	getcwd_sv(TARG);
fa52125f SP	574	XSprePUSH; PUSHTARG;
fa52125f	575	SvTAINTED_on(TARG);
fa52125f SP	576	}
	577
	578	void
03d70c89 JH	579	abs_path(pathsv=Nullsv)
03d70c89 JH	580	SV *pathsv
f22d8e4b	581	PPCODE:
2ae52c40	582	{
f22d8e4b	583	dXSTARG;
66a378bd	584	char const path = pathsv ? SvPV_nolen(pathsv) : (char )".";
00536bfc	585	char buf[MAXPATHLEN];
03d70c89	586
66a378bd NC	587	if (
	588	#ifdef VMS
	589	Perl_rmsexpand(aTHX_ path, buf, NULL, 0)
	590	#else
	591	bsd_realpath(path, buf)
	592	#endif
	593	) {
	594	sv_setpv_mg(TARG, buf);
00536bfc	595	SvPOK_only(TARG);
ea715489	596	SvTAINTED_on(TARG);
2ae52c40	597	}
03d70c89	598	else
ea715489	599	sv_setsv(TARG, &PL_sv_undef);
2ae52c40	600
66a378bd	601	XSprePUSH; PUSHs(TARG);
ea715489	602	SvTAINTED_on(TARG);
2ae52c40	603	}
09122b95	604
42d1cefd	605	#if defined(WIN32) && !defined(UNDER_CE)
09122b95 RGS	606
	607	void
	608	getdcwd(...)
1d0561d5	609	PROTOTYPE: ENABLE
09122b95 RGS	610	PPCODE:
	611	{
	612	dXSTARG;
	613	int drive;
	614	char *dir;
	615
	616	/* Drive 0 is the current drive, 1 is A:, 2 is B:, 3 is C: and so on. */
	617	if ( items == 0 \|\|
	618	(items == 1 && (!SvOK(ST(0)) \|\| (SvPOK(ST(0)) && !SvCUR(ST(0))))))
	619	drive = 0;
	620	else if (items == 1 && SvPOK(ST(0)) && SvCUR(ST(0)) &&
	621	isALPHA(SvPVX(ST(0))[0]))
	622	drive = toUPPER(SvPVX(ST(0))[0]) - 'A' + 1;
	623	else
	624	croak("Usage: getdcwd(DRIVE)");
	625
275e8705 RGS	626	New(0,dir,MAXPATHLEN,char);
275e8705 RGS	627	if (_getdcwd(drive, dir, MAXPATHLEN)) {
66a378bd	628	sv_setpv_mg(TARG, dir);
09122b95 RGS	629	SvPOK_only(TARG);
	630	}
	631	else
	632	sv_setsv(TARG, &PL_sv_undef);
	633
99f36a73 RGS	634	Safefree(dir);
99f36a73 RGS	635
66a378bd	636	XSprePUSH; PUSHs(TARG);
09122b95	637	SvTAINTED_on(TARG);
09122b95 RGS	638	}
	639
	640	#endif
07f43755 Z	641
	642	MODULE = Cwd PACKAGE = File::Spec::Unix
	643
	644	SV *
	645	canonpath(SV self, SV path = &PL_sv_undef, ...)
	646	CODE:
	647	PERL_UNUSED_VAR(self);
	648	RETVAL = unix_canonpath(path);
	649	OUTPUT:
	650	RETVAL
	651
	652	SV *
	653	_fn_canonpath(SV *path = &PL_sv_undef, ...)
	654	CODE:
	655	RETVAL = unix_canonpath(path);
	656	OUTPUT:
	657	RETVAL
	658
	659	SV *
	660	catdir(SV *self, ...)
	661	PREINIT:
	662	dUSE_MY_CXT;
	663	SV *joined;
	664	CODE:
	665	EXTEND(SP, items+1);
	666	ST(items) = EMPTY_STRING_SV;
	667	joined = sv_newmortal();
	668	do_join(joined, SLASH_STRING_SV, &ST(0), &ST(items));
	669	if(invocant_is_unix(self)) {
	670	RETVAL = unix_canonpath(joined);
	671	} else {
	672	ENTER;
	673	PUSHMARK(SP);
	674	EXTEND(SP, 2);
	675	PUSHs(self);
	676	PUSHs(joined);
	677	PUTBACK;
	678	call_method("canonpath", G_SCALAR);
	679	SPAGAIN;
	680	RETVAL = POPs;
	681	LEAVE;
	682	SvREFCNT_inc(RETVAL);
	683	}
	684	OUTPUT:
	685	RETVAL
	686
	687	SV *
	688	_fn_catdir(...)
	689	PREINIT:
	690	dUSE_MY_CXT;
	691	SV *joined;
	692	CODE:
	693	EXTEND(SP, items+1);
	694	ST(items) = EMPTY_STRING_SV;
	695	joined = sv_newmortal();
	696	do_join(joined, SLASH_STRING_SV, &ST(-1), &ST(items));
	697	RETVAL = unix_canonpath(joined);
	698	OUTPUT:
	699	RETVAL
	700
	701	SV *
	702	catfile(SV *self, ...)
	703	PREINIT:
	704	dUSE_MY_CXT;
705	CODE:
706	if(invocant_is_unix(self)) {
707	if(items == 1) {
708	RETVAL = &PL_sv_undef;
709	} else {
710	SV *file = unix_canonpath(ST(items-1));
711	if(items == 2) {
712	RETVAL = file;
713	} else {
714	SV *dir = sv_newmortal();
715	sv_2mortal(file);
716	ST(items-1) = EMPTY_STRING_SV;
717	do_join(dir, SLASH_STRING_SV, &ST(0), &ST(items-1));
718	RETVAL = unix_canonpath(dir);
719	if(SvCUR(RETVAL) == 0 \|\| SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
720	sv_catsv(RETVAL, SLASH_STRING_SV);
721	sv_catsv(RETVAL, file);
722	}
723	}
724	} else {
725	SV file, dir;
726	ENTER;
727	PUSHMARK(SP);
728	EXTEND(SP, 2);
729	PUSHs(self);
730	PUSHs(items == 1 ? &PL_sv_undef : ST(items-1));
731	PUTBACK;
732	call_method("canonpath", G_SCALAR);
733	SPAGAIN;
734	file = POPs;
735	LEAVE;
736	if(items <= 2) {
737	RETVAL = SvREFCNT_inc(file);
738	} else {
739	char const *pv;
740	STRLEN len;
741	bool need_slash;
742	SP--;
743	ENTER;
744	PUSHMARK(&ST(-1));
745	PUTBACK;
746	call_method("catdir", G_SCALAR);
747	SPAGAIN;
748	dir = POPs;
749	LEAVE;
750	pv = SvPV(dir, len);
751	need_slash = len == 0 \|\| pv[len-1] != '/';
752	RETVAL = newSVsv(dir);
753	if(need_slash) sv_catsv(RETVAL, SLASH_STRING_SV);
754	sv_catsv(RETVAL, file);
755	}
756	}
757	OUTPUT:
758	RETVAL
759
760	SV *
761	_fn_catfile(...)
762	PREINIT:
763	dUSE_MY_CXT;
764	CODE:
765	if(items == 0) {
766	RETVAL = &PL_sv_undef;
767	} else {
768	SV *file = unix_canonpath(ST(items-1));
769	if(items == 1) {
770	RETVAL = file;
771	} else {
772	SV *dir = sv_newmortal();
773	sv_2mortal(file);
774	ST(items-1) = EMPTY_STRING_SV;
775	do_join(dir, SLASH_STRING_SV, &ST(-1), &ST(items-1));
776	RETVAL = unix_canonpath(dir);
777	if(SvCUR(RETVAL) == 0 \|\| SvPVX(RETVAL)[SvCUR(RETVAL)-1] != '/')
778	sv_catsv(RETVAL, SLASH_STRING_SV);
779	sv_catsv(RETVAL, file);
780	}
781	}
782	OUTPUT:
783	RETVAL