The R Project SVN
R
(root)/branches/R-GenGC/src/main/platform.c – Rev 10108
Rev 9642 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
/** R : A Computer Language for Statistical Data Analysis* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka* Copyright (C) 1998, 2000 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 USA*/#ifdef HAVE_CONFIG_H#include <config.h>#endif#include "Defn.h"#include "Fileio.h"#include <time.h>/* Platform** Return various platform dependent strings. This is similar to* "Machine", but for strings rather than numerical values. These* two functions should probably be amalgamated.*/static char *R_OSType = OSTYPE;static char *R_FileSep = FILESEP;static char *R_DynLoadExt = DYNLOADEXT;SEXP do_Platform(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP value, names;checkArity(op, args);PROTECT(value = allocVector(VECSXP, 5));PROTECT(names = allocVector(STRSXP, 5));SET_STRING_ELT(names, 0, mkChar("OS.type"));SET_STRING_ELT(names, 1, mkChar("file.sep"));SET_STRING_ELT(names, 2, mkChar("dynlib.ext"));SET_STRING_ELT(names, 3, mkChar("GUI"));SET_STRING_ELT(names, 4, mkChar("endian"));SET_VECTOR_ELT(value, 0, mkString(R_OSType));SET_VECTOR_ELT(value, 1, mkString(R_FileSep));SET_VECTOR_ELT(value, 2, mkString(R_DynLoadExt));SET_VECTOR_ELT(value, 3, mkString(R_GUIType));#ifdef WORDS_BIGENDIANSET_VECTOR_ELT(value, 4, mkString("big"));#elseSET_VECTOR_ELT(value, 4, mkString("little"));#endifsetAttrib(value, R_NamesSymbol, names);UNPROTECT(2);return value;}/* date** Return the current date in a standard format. This uses standard* POSIX calls which should be available on each platform. We should* perhaps check this in the configure script.*//* BDR 2000/7/20.* time and ctime are in fact ANSI C calls, so we don't check them.*/char *R_Date(){time_t t;static char s[26];/* own space */time(&t);strcpy(s, ctime(&t));s[24] = '\0'; /* overwriting the final \n */return s;}SEXP do_date(SEXP call, SEXP op, SEXP args, SEXP rho){checkArity(op, args);return mkString(R_Date());}/* show.file** Display a file so that a user can view it. The function calls* "R_ShowFile" which is a platform dependent hook that arranges* for the file to be displayed. A reasonable approach would be to* open a read-only edit window with the file displayed in it.** FIXME : this should in fact take a vector of filenames and titles* and display them concatenated in a window. For a pure console* version, write down a pipe to a pager.*/#ifdef OLDSEXP do_fileshow(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP fn, tl;checkArity(op, args);fn = CAR(args);tl = CADR(args);if (!isString(fn) || length(fn) < 1 || STRING_ELT(fn, 0) == R_NilValue)errorcall(call, "invalid filename");if (!isString(tl) || length(tl) < 1 || STRING_ELT(tl, 0) == R_NilValue)errorcall(call, "invalid filename");if (!R_ShowFile(R_ExpandFileName(CHAR(STRING_ELT(fn, 0))),CHAR(STRING_ELT(tl, 0))))error("unable to display file \"%s\"", CHAR(STRING_ELT(fn, 0)));return R_NilValue;}#elseSEXP do_fileshow(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP fn, tl, hd, pg;char **f, **h, *t, *vm, *pager;int i, n, dl;checkArity(op, args);vm = vmaxget();fn = CAR(args); args = CDR(args);hd = CAR(args); args = CDR(args);tl = CAR(args); args = CDR(args);dl = asLogical(CAR(args)); args = CDR(args);pg = CAR(args);n = 0; /* -Wall */if (!isString(fn) || (n = length(fn)) < 1)errorcall(call, "invalid filename specification");if (!isString(hd) || length(hd) != n)errorcall(call, "invalid headers");if (!isString(tl))errorcall(call, "invalid title");if (!isString(pg))errorcall(call, "invalid pager specification");f = (char**)R_alloc(n, sizeof(char*));h = (char**)R_alloc(n, sizeof(char*));for (i = 0; i < n; i++) {if (!isNull(STRING_ELT(fn, i)))f[i] = CHAR(STRING_ELT(fn, i));elsef[i] = CHAR(R_BlankString);if (!isNull(STRING_ELT(hd, i)))h[i] = CHAR(STRING_ELT(hd, i));elseh[i] = CHAR(R_BlankString);}if (length(tl) >= 1 || !isNull(STRING_ELT(tl, 0)))t = CHAR(STRING_ELT(tl, 0));elset = CHAR(R_BlankString);if (length(pg) >= 1 || !isNull(STRING_ELT(pg, 0)))pager = CHAR(STRING_ELT(pg, 0));elsepager = CHAR(R_BlankString);R_ShowFiles(n, f, h, t, dl, pager);vmaxset(vm);return R_NilValue;}#endif/* append.file** Given two file names as arguments and arranges for* the second file to be appended to the second.*/#define APPENDBUFSIZE 512static int R_AppendFile(char *file1, char *file2){FILE *fp1, *fp2;char buf[APPENDBUFSIZE];int nchar, status = 0;if((fp1 = R_fopen(R_ExpandFileName(file1), "a")) == NULL) {return 0;}if((fp2 = R_fopen(R_ExpandFileName(file2), "r")) == NULL) {fclose(fp1);return 0;}while((nchar = fread(buf, 1, APPENDBUFSIZE, fp2)) == APPENDBUFSIZE)if(fwrite(buf, 1, APPENDBUFSIZE, fp1) != APPENDBUFSIZE) {goto append_error;}if(fwrite(buf, 1, nchar, fp1) != nchar) {goto append_error;}status = 1;append_error:if (status == 0)warning("write error during file append!");fclose(fp1);fclose(fp2);return status;}SEXP do_fileappend(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP f1, f2, ans;int i, n, n1, n2;checkArity(op, args);f1 = CAR(args); n1 = length(f1);f2 = CADR(args); n2 = length(f2);if (!isString(f1))errorcall(call, "invalid first filename");if (!isString(f2))errorcall(call, "invalid second filename");if (n1 < 1)errorcall(call, "nothing to append to");if (n2 < 1)return allocVector(LGLSXP, 0);n = (n1 > n2) ? n1 : n2;PROTECT(ans = allocVector(LGLSXP, n));for(i = 0; i < n; i++) {if (STRING_ELT(f1, i%n1) == R_NilValue || STRING_ELT(f2, i%n2) == R_NilValue)LOGICAL(ans)[i] = 0;elseLOGICAL(ans)[i] =R_AppendFile(CHAR(STRING_ELT(f1, i%n1)),CHAR(STRING_ELT(f2, i%n2)));}UNPROTECT(1);return ans;}SEXP do_filecreate(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP fn, ans;FILE *fp;int i, n;checkArity(op, args);fn = CAR(args);if (!isString(fn))errorcall(call, "invalid filename argument");n = length(fn);PROTECT(ans = allocVector(LGLSXP, n));for (i = 0; i < n; i++) {LOGICAL(ans)[i] = 0;if (STRING_ELT(fn, i) != R_NilValue &&(fp = R_fopen(R_ExpandFileName(CHAR(STRING_ELT(fn, i))), "w"))!= NULL) {LOGICAL(ans)[i] = 1;fclose(fp);}}UNPROTECT(1);return ans;}SEXP do_fileremove(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP f, ans;int i, n;checkArity(op, args);f = CAR(args);if (!isString(f))errorcall(call, "invalid first filename");n = length(f);PROTECT(ans = allocVector(LGLSXP, n));for (i = 0; i < n; i++) {if (STRING_ELT(f, i) != R_NilValue)LOGICAL(ans)[i] =(remove(R_ExpandFileName(CHAR(STRING_ELT(f, i)))) == 0);}UNPROTECT(1);return ans;}#ifndef Macintosh#include <sys/types.h>#endif#if HAVE_DIRENT_H# include <dirent.h>#elif HAVE_SYS_NDIR_H# include <sys/ndir.h>#elif HAVE_SYS_DIR_H# include <sys/dir.h>#elif HAVE_NDIR_H# include <ndir.h>#endif#ifdef USE_SYSTEM_REGEX#include <regex.h>#else#include "Rregex.h"#endifstatic SEXP filename(char *dir, char *file){SEXP ans;if (dir) {ans = allocString(strlen(dir) + strlen(R_FileSep) + strlen(file));sprintf(CHAR(ans), "%s%s%s", dir, R_FileSep, file);}else {ans = allocString(strlen(file));sprintf(CHAR(ans), "%s", file);}return ans;}SEXP do_listfiles(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP d, p, ans;DIR *dir;struct dirent *de;int allfiles, fullnames, count, pattern;int i, ndir;char *dnp, dirname[PATH_MAX];regex_t reg;checkArity(op, args);d = CAR(args); args = CDR(args);if (!isString(d))errorcall(call, "invalid directory argument");p = CAR(args); args = CDR(args);pattern = 0;if (isString(p) && length(p) >= 1 && STRING_ELT(p, 0) != R_NilValue)pattern = 1;else if (!isNull(p) && !(isString(p) && length(p) < 1))errorcall(call, "invalid pattern argument");allfiles = asLogical(CAR(args)); args = CDR(args);fullnames = asLogical(CAR(args));ndir = length(d);if (pattern && regcomp(®, CHAR(STRING_ELT(p, 0)), REG_EXTENDED))errorcall(call, "invalid pattern regular expression");count = 0;for (i = 0; i < ndir ; i++) {dnp = R_ExpandFileName(CHAR(STRING_ELT(d, i)));if (strlen(dnp) >= PATH_MAX) /* should not happen! */error("directory/folder path name too long");strcpy(dirname, dnp);if ((dir = opendir(dirname)) == NULL) {/* errorcall(call, "invalid directory/folder name");*/warning("list.files: %s is not a readable directory", dirname);} else {while ((de = readdir(dir))) {if (allfiles || !R_HiddenFile(de->d_name)) {if (pattern) {if(regexec(®, de->d_name, 0, NULL, 0) == 0)count++;}elsecount++;}}closedir(dir);}}PROTECT(ans = allocVector(STRSXP, count));count = 0;for (i = 0; i < ndir ; i++) {dnp = R_ExpandFileName(CHAR(STRING_ELT(d, i)));/* if (strlen(dnp) >= PATH_MAX) We've already checked!error("directory/folder path name too long"); */strcpy(dirname, dnp);if (fullnames)dnp = dirname;elsednp = NULL;if ((dir = opendir(dirname)) != NULL) {while ((de = readdir(dir))) {if (allfiles || !R_HiddenFile(de->d_name)) {if (pattern) {if (regexec(®, de->d_name, 0, NULL, 0) == 0)SET_STRING_ELT(ans, count++, filename(dnp, de->d_name));}elseSET_STRING_ELT(ans, count++, filename(dnp, de->d_name));}}closedir(dir);}}if (pattern)regfree(®);ssort(STRING_PTR(ans), count);UNPROTECT(1);return ans;}SEXP do_Rhome(SEXP call, SEXP op, SEXP args, SEXP rho){char *path;checkArity(op, args);if (!(path = R_HomeDir()))error("unable to determine R home location");return mkString(path);}SEXP do_fileexists(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP file, ans;int i, nfile;checkArity(op, args);if (!isString(file = CAR(args)))errorcall(call, "invalid file argument");nfile = length(file);ans = allocVector(LGLSXP, nfile);for(i = 0; i < nfile; i++) {LOGICAL(ans)[i] = 0;if (STRING_ELT(file, i) != R_NilValue)LOGICAL(ans)[i] = R_FileExists(CHAR(STRING_ELT(file, i)));}return ans;}static int filbuf(char *buf, FILE *fp){int c;while((c = fgetc(fp)) != EOF) {if (c == '\n' || c == '\r') {*buf = '\0';return 1;}*buf++ = c;}return 0;}SEXP do_indexsearch(SEXP call, SEXP op, SEXP args, SEXP rho){/* index.search(topic, path, file, .Platform$file.sep, type) */SEXP topic, path, indexname, sep, type;char linebuf[256], topicbuf[256], *p, ctype[256];int i, npath, ltopicbuf;FILE *fp;checkArity(op, args);topic = CAR(args); args = CDR(args);if(!isString(topic) || length(topic) < 1 || isNull(topic))error("invalid \"topic\" argument");path = CAR(args); args = CDR(args);if(!isString(path) || length(path) < 1 || isNull(path))error("invalid \"path\" argument");indexname = CAR(args); args = CDR(args);if(!isString(indexname) || length(indexname) < 1 || isNull(indexname))error("invalid \"indexname\" argument");sep = CAR(args); args = CDR(args);if(!isString(sep) || length(sep) < 1 || isNull(sep))error("invalid \"sep\" argument");type = CAR(args);if(!isString(type) || length(type) < 1 || isNull(type))error("invalid \"type\" argument");strcpy(ctype, CHAR(STRING_ELT(type, 0)));sprintf(topicbuf, "%s\t", CHAR(STRING_ELT(topic, 0)));ltopicbuf = strlen(topicbuf);npath = length(path);for (i = 0; i < npath; i++) {sprintf(linebuf, "%s%s%s%s%s",CHAR(STRING_ELT(path, i)),CHAR(STRING_ELT(sep, 0)),"help", CHAR(STRING_ELT(sep, 0)),CHAR(STRING_ELT(indexname, 0)));if ((fp = R_fopen(R_ExpandFileName(linebuf), "rt")) != NULL){while (filbuf(linebuf, fp)) {if(strncmp(linebuf, topicbuf, ltopicbuf) == 0) {p = &linebuf[ltopicbuf - 1];while(isspace((int)*p)) p++;fclose(fp);if (!strcmp(ctype, "html"))sprintf(topicbuf, "%s%s%s%s%s%s",CHAR(STRING_ELT(path, i)),CHAR(STRING_ELT(sep, 0)),"html", CHAR(STRING_ELT(sep, 0)),p, ".html");else if (!strcmp(ctype, "R-ex"))sprintf(topicbuf, "%s%s%s%s%s%s",CHAR(STRING_ELT(path, i)),CHAR(STRING_ELT(sep, 0)),"R-ex", CHAR(STRING_ELT(sep, 0)),p, ".R");else if (!strcmp(ctype, "latex"))sprintf(topicbuf, "%s%s%s%s%s%s",CHAR(STRING_ELT(path, i)),CHAR(STRING_ELT(sep, 0)),"latex", CHAR(STRING_ELT(sep, 0)),p, ".tex");else /* type = "help" */sprintf(topicbuf, "%s%s%s%s%s",CHAR(STRING_ELT(path, i)),CHAR(STRING_ELT(sep, 0)),ctype, CHAR(STRING_ELT(sep, 0)), p);return mkString(topicbuf);}}fclose(fp);}}return mkString("");}#define CHOOSEBUFSIZE 1024SEXP do_filechoose(SEXP call, SEXP op, SEXP args, SEXP rho){int new, len;char buf[CHOOSEBUFSIZE];checkArity(op, args);new = asLogical(CAR(args));if ((len = R_ChooseFile(new, buf, CHOOSEBUFSIZE)) == 0)error("file choice cancelled");if (len >= CHOOSEBUFSIZE - 1)errorcall(call, "file name too long");return mkString(R_ExpandFileName(buf));}#ifdef HAVE_STAT#include <sys/types.h>#include <sys/stat.h>#if defined(Unix) && defined(HAVE_PWD_H) && defined(HAVE_GRP_H) \&& defined(HAVE_GETPWUID) && defined(HAVE_GETGRGID)#include <pwd.h>#include <grp.h>#define UNIX_EXTRAS 1#endifSEXP do_fileinfo(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP fn, ans, ansnames, fsize, mtime, ctime, atime, isdir,mode, xxclass;#ifdef UNIX_EXTRASSEXP uid, gid, uname, grname;struct passwd *stpwd;struct group *stgrp;#endifint i, n;struct stat sb;checkArity(op, args);fn = CAR(args);if (!isString(fn))errorcall(call, "invalid filename argument");n = length(fn);#ifdef UNIX_EXTRASPROTECT(ans = allocVector(VECSXP, 10));PROTECT(ansnames = allocVector(STRSXP, 10));#elsePROTECT(ans = allocVector(VECSXP, 6));PROTECT(ansnames = allocVector(STRSXP, 6));#endiffsize = SET_VECTOR_ELT(ans, 0, allocVector(INTSXP, n));SET_STRING_ELT(ansnames, 0, mkChar("size"));isdir = SET_VECTOR_ELT(ans, 1, allocVector(LGLSXP, n));SET_STRING_ELT(ansnames, 1, mkChar("isdir"));mode = SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, n));SET_STRING_ELT(ansnames, 2, mkChar("mode"));mtime = SET_VECTOR_ELT(ans, 3, allocVector(REALSXP, n));SET_STRING_ELT(ansnames, 3, mkChar("mtime"));ctime = SET_VECTOR_ELT(ans, 4, allocVector(REALSXP, n));SET_STRING_ELT(ansnames, 4, mkChar("ctime"));atime = SET_VECTOR_ELT(ans, 5, allocVector(REALSXP, n));SET_STRING_ELT(ansnames, 5, mkChar("atime"));#ifdef UNIX_EXTRASuid = SET_VECTOR_ELT(ans, 6, allocVector(INTSXP, n));SET_STRING_ELT(ansnames, 6, mkChar("uid"));gid = SET_VECTOR_ELT(ans, 7, allocVector(INTSXP, n));SET_STRING_ELT(ansnames, 7, mkChar("gid"));uname = SET_VECTOR_ELT(ans, 8, allocVector(STRSXP, n));SET_STRING_ELT(ansnames, 8, mkChar("uname"));grname = SET_VECTOR_ELT(ans, 9, allocVector(STRSXP, n));SET_STRING_ELT(ansnames, 9, mkChar("grname"));#endiffor (i = 0; i < n; i++) {if (STRING_ELT(fn, i) != R_NilValue &&stat(R_ExpandFileName(CHAR(STRING_ELT(fn, i))), &sb) == 0) {INTEGER(fsize)[i] = (int) sb.st_size;LOGICAL(isdir)[i] = (int) sb.st_mode & S_IFDIR;INTEGER(mode)[i] = (int) sb.st_mode & 0007777;REAL(mtime)[i] = (double) sb.st_mtime;REAL(ctime)[i] = (double) sb.st_ctime;REAL(atime)[i] = (double) sb.st_atime;#ifdef UNIX_EXTRASINTEGER(uid)[i] = (int) sb.st_uid;INTEGER(gid)[i] = (int) sb.st_gid;stpwd = getpwuid(sb.st_uid);if(stpwd) SET_STRING_ELT(uname, i, mkChar(stpwd->pw_name));else SET_STRING_ELT(uname, i, NA_STRING);stgrp = getgrgid(sb.st_gid);if(stgrp) SET_STRING_ELT(grname, i, mkChar(stgrp->gr_name));else SET_STRING_ELT(grname, i, NA_STRING);#endif} else {INTEGER(fsize)[i] = NA_INTEGER;LOGICAL(isdir)[i] = NA_INTEGER;INTEGER(mode)[i] = NA_INTEGER;REAL(mtime)[i] = NA_REAL;REAL(ctime)[i] = NA_REAL;REAL(atime)[i] = NA_REAL;#ifdef UNIX_EXTRASINTEGER(uid)[i] = NA_INTEGER;INTEGER(gid)[i] = NA_INTEGER;SET_STRING_ELT(uname, i, NA_STRING);SET_STRING_ELT(grname, i, NA_STRING);#endif}}setAttrib(ans, R_NamesSymbol, ansnames);PROTECT(xxclass = allocVector(STRSXP, 1));SET_STRING_ELT(xxclass, 0, mkChar("octmode"));classgets(mode, xxclass);UNPROTECT(3);return ans;}#elseSEXP do_fileinfo(SEXP call, SEXP op, SEXP args, SEXP rho){error("file.info is not implemented on this system");return R_NilValue; /* -Wall */}#endif#ifdef HAVE_ACCESS#ifdef HAVE_UNISTD_H#include <unistd.h>#endifSEXP do_fileaccess(SEXP call, SEXP op, SEXP args, SEXP rho){SEXP fn, ans;int i, n, mode, modemask;checkArity(op, args);fn = CAR(args);if (!isString(fn))errorcall(call, "invalid names argument");n = length(fn);mode = asInteger(CADR(args));if(mode < 0 || mode > 7) error("invalid mode value");modemask = 0;if (mode & 1) modemask |= X_OK;if (mode & 2) modemask |= W_OK;if (mode & 4) modemask |= R_OK;PROTECT(ans = allocVector(INTSXP, n));for (i = 0; i < n; i++)INTEGER(ans)[i] = access(R_ExpandFileName(CHAR(STRING_ELT(fn, i))),modemask);UNPROTECT(1);return ans;}#elseSEXP do_fileaccess(SEXP call, SEXP op, SEXP args, SEXP rho){error("file.access is not implemented on this system");return R_NilValue; /* -Wall */}#endif