The R Project SVN R

/*
  R : A Computer Language for Statistical Data Analysis
  Copyright (C) 1995-1996   Robert Gentleman and Ross Ihaka
  Copyright (C) 1997-2004   Robert Gentleman, Ross Ihaka
                            and the R Development Core Team

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or (at
  your option) any later version.

  This program is distributed in the hope that it will be useful, but
  WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307,
  U.S.A.
 */


#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <Defn.h>

/*
  See ../unix/system.txt for a description of some of these functions.
  Formally part of ../unix/sys-common.c.
 */

/* The __APPLE__ and __APPLE_CC__ defines are for OS X */

/*
 * FILESYSTEM INTERACTION
 */

/*
 * This call provides a simple interface to the "stat" system call.
 */

#ifdef HAVE_STAT
#include <sys/types.h>
#ifdef HAVE_SYS_STAT_H
# include <sys/stat.h>
#endif

Rboolean R_FileExists(char *path)
{
    struct stat sb;
    return stat(R_ExpandFileName(path), &sb) == 0;
}

double R_FileMtime(char *path)
{
    struct stat sb;
    if (stat(R_ExpandFileName(path), &sb) != 0)
    error("cannot determine file modification time of %s", path);
    return sb.st_mtime;
}
#else
Rboolean R_FileExists(char *path)
{
    error("file existence is not available on this system");
}

double R_FileMtime(char *path)
{
    error("file modification time is not available on this system");
    return 0.0; /* not reached */
}
#endif

    /*
     *  Unix file names which begin with "." are invisible.
     */

Rboolean R_HiddenFile(char *name)
{
    if (name && name[0] != '.') return 0;
    else return 1;
}


FILE *R_fopen(const char *filename, const char *mode)
{
    return(filename ? fopen(filename, mode) : NULL );
}

/*
 *  SYSTEM INFORMATION
 */

          /* The location of the R system files */

char *R_HomeDir()
{
    return getenv("R_HOME");
}


SEXP do_interactive(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP rval;

    rval=allocVector(LGLSXP, 1);
    LOGICAL(rval)[0]= (R_Interactive) ? 1 : 0;
    return rval;
}

SEXP do_tempdir(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP  ans;

    PROTECT(ans = allocVector(STRSXP, 1));
    SET_STRING_ELT(ans, 0, mkChar(R_TempDir));
    UNPROTECT(1);
    return (ans);
}


SEXP do_tempfile(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP  ans, pattern, tempdir;
    char *tn, *td, *tm;
    int i, n1, n2, slen;

    checkArity(op, args);
    pattern = CAR(args); n1 = length(pattern);
    tempdir = CADR(args); n2 = length(tempdir);
    if (!isString(pattern))
        errorcall(call, "invalid filename pattern");
    if (!isString(tempdir))
        errorcall(call, "invalid tempdir");
    if (n1 < 1)
    errorcall(call, "no patterns");
    if (n2 < 1)
    errorcall(call, "no tempdir");
    slen = (n1 > n2) ? n1 : n2;
    PROTECT(ans = allocVector(STRSXP, slen));
    for(i = 0; i < slen; i++) {
    tn = CHAR( STRING_ELT( pattern , i%n1 ) );
    td = CHAR( STRING_ELT( tempdir , i%n2 ) );
    /* try to get a new file name */
    tm = R_tmpnam(tn, td);
    SET_STRING_ELT(ans, i, mkChar(tm));
    if(tm) free(tm);
    }
    UNPROTECT(1);
    return (ans);
}

#ifdef HAVE_POPEN
FILE *R_popen(char *command, char *type)
{
    FILE *fp;
#ifdef __APPLE_CC__
    /* Luke recommends this to fix PR#1140 */
    sigset_t ss;
    sigaddset(&ss, SIGPROF);
    sigprocmask(SIG_BLOCK, &ss,  NULL);
    fp = popen(command, type);
    sigprocmask(SIG_UNBLOCK, &ss, NULL);
#else
    fp = popen(command, type);
#endif
    return fp;
}
#endif /* HAVE_POPEN */

int R_system(char *command)
{
    int val;
#ifdef __APPLE_CC__
    /* Luke recommends this to fix PR#1140 */
    sigset_t ss;
    sigaddset(&ss, SIGPROF);
    sigprocmask(SIG_BLOCK, &ss,  NULL);
    val = system(command);
    sigprocmask(SIG_UNBLOCK, &ss, NULL);
#else
    val = system(command);
#endif
    return val;
}

#ifdef Win32
# include <windows.h>
#elif defined(__APPLE__)
# include <crt_externs.h>
# define environ (*_NSGetEnviron())
#else
extern char ** environ;
#endif

SEXP do_getenv(SEXP call, SEXP op, SEXP args, SEXP env)
{
    int i, j;
    char *s;
    SEXP ans;

    checkArity(op, args);

    if (!isString(CAR(args)))
    errorcall(call, "wrong type for argument");

    i = LENGTH(CAR(args));
    if (i == 0) {
#ifdef Win32
    char *envir, *e;
    envir = (char *) GetEnvironmentStrings();
    for (i = 0, e = envir; strlen(e) > 0; i++, e += strlen(e)+1);
    PROTECT(ans = allocVector(STRSXP, i));
    for (i = 0, e = envir; strlen(e) > 0; i++, e += strlen(e)+1)
        SET_STRING_ELT(ans, i, mkChar(e));
    FreeEnvironmentStrings(envir);
#else
    char **e;
    for (i = 0, e = environ; *e != NULL; i++, e++);
    PROTECT(ans = allocVector(STRSXP, i));
    for (i = 0, e = environ; *e != NULL; i++, e++)
        SET_STRING_ELT(ans, i, mkChar(*e));
#endif
    } else {
    PROTECT(ans = allocVector(STRSXP, i));
    for (j = 0; j < i; j++) {
        s = getenv(CHAR(STRING_ELT(CAR(args), j)));
        if (s == NULL)
        SET_STRING_ELT(ans, j, mkChar(""));
        else
        SET_STRING_ELT(ans, j, mkChar(s));
    }
    }
    UNPROTECT(1);
    return (ans);
}

#ifdef HAVE_PUTENV
static int Rputenv(char *str)
{
    char *buf;
    buf = (char *) malloc((strlen(str) + 1) * sizeof(char));
    if(!buf) return 1;
    strcpy(buf, str);
    putenv(buf);
    /* no free here: storage remains in use */
    return 0;
}
#endif


SEXP do_putenv(SEXP call, SEXP op, SEXP args, SEXP env)
{
#ifdef HAVE_PUTENV
    int i, n;
    SEXP ans, vars;

    checkArity(op, args);

    if (!isString(vars =CAR(args)))
    errorcall(call, "wrong type for argument");

    n = LENGTH(vars);
    PROTECT(ans = allocVector(LGLSXP, n));
    for (i = 0; i < n; i++) {
    LOGICAL(ans)[i] = Rputenv(CHAR(STRING_ELT(vars, i))) == 0;
    }
    UNPROTECT(1);
    return ans;
#else
    error("`putenv' is not available on this system");
    return R_NilValue; /* -Wall */
#endif
}