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