| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka |
| * Copyright (C) 1998--2019 The R 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, a copy is available at |
| * https://www.R-project.org/Licenses/ |
| */ |
| |
| |
| /* Notes on so-called 'Large File Support' |
| |
| The 'stat' structure returns a file size as 'off_t'. On some |
| 32-bit systems this will fail if called on a file > 2GB. On |
| systems with LFS selected (see the notes in connections.c) the call |
| is re-mapped to *stat64, which uses off64_t for the file size. |
| |
| file.info() returns file sizes as an R double. |
| |
| On Windows we need to remap for ourselves. There are various |
| versions of the 'stat' structure (some with 64-bit times and not |
| available in the original MSVCRT.dll): we use _stati64 that simply |
| replaces off_t by __int64_t. |
| */ |
| |
| #ifdef HAVE_CONFIG_H |
| # include <config.h> |
| #endif |
| |
| #include <Defn.h> |
| #include <Internal.h> |
| #include <Rinterface.h> |
| #include <Fileio.h> |
| #include <ctype.h> /* toupper */ |
| #include <limits.h> |
| #include <string.h> |
| #include <stdlib.h> /* for realpath */ |
| #include <time.h> /* for ctime */ |
| |
| # include <errno.h> |
| |
| /* Machine Constants */ |
| |
| static void |
| machar(int *ibeta, int *it, int *irnd, int *ngrd, int *machep, int *negep, |
| int *iexp, int *minexp, int *maxexp, double *eps, |
| double *epsneg, double *xmin, double *xmax); |
| |
| static void Init_R_Machine(SEXP rho) |
| { |
| SEXP ans, nms; |
| |
| machar(&R_AccuracyInfo.ibeta, |
| &R_AccuracyInfo.it, |
| &R_AccuracyInfo.irnd, |
| &R_AccuracyInfo.ngrd, |
| &R_AccuracyInfo.machep, |
| &R_AccuracyInfo.negep, |
| &R_AccuracyInfo.iexp, |
| &R_AccuracyInfo.minexp, |
| &R_AccuracyInfo.maxexp, |
| &R_AccuracyInfo.eps, |
| &R_AccuracyInfo.epsneg, |
| &R_AccuracyInfo.xmin, |
| &R_AccuracyInfo.xmax); |
| |
| R_dec_min_exponent = (int) floor(log10(R_AccuracyInfo.xmin)); /* smallest decimal exponent */ |
| PROTECT(ans = allocVector(VECSXP, 18)); |
| PROTECT(nms = allocVector(STRSXP, 18)); |
| SET_STRING_ELT(nms, 0, mkChar("double.eps")); |
| SET_VECTOR_ELT(ans, 0, ScalarReal(R_AccuracyInfo.eps)); |
| |
| SET_STRING_ELT(nms, 1, mkChar("double.neg.eps")); |
| SET_VECTOR_ELT(ans, 1, ScalarReal(R_AccuracyInfo.epsneg)); |
| |
| SET_STRING_ELT(nms, 2, mkChar("double.xmin")); |
| SET_VECTOR_ELT(ans, 2, ScalarReal(R_AccuracyInfo.xmin)); |
| |
| SET_STRING_ELT(nms, 3, mkChar("double.xmax")); |
| SET_VECTOR_ELT(ans, 3, ScalarReal(R_AccuracyInfo.xmax)); |
| |
| SET_STRING_ELT(nms, 4, mkChar("double.base")); |
| SET_VECTOR_ELT(ans, 4, ScalarInteger(R_AccuracyInfo.ibeta)); |
| |
| SET_STRING_ELT(nms, 5, mkChar("double.digits")); |
| SET_VECTOR_ELT(ans, 5, ScalarInteger(R_AccuracyInfo.it)); |
| |
| SET_STRING_ELT(nms, 6, mkChar("double.rounding")); |
| SET_VECTOR_ELT(ans, 6, ScalarInteger(R_AccuracyInfo.irnd)); |
| |
| SET_STRING_ELT(nms, 7, mkChar("double.guard")); |
| SET_VECTOR_ELT(ans, 7, ScalarInteger(R_AccuracyInfo.ngrd)); |
| |
| SET_STRING_ELT(nms, 8, mkChar("double.ulp.digits")); |
| SET_VECTOR_ELT(ans, 8, ScalarInteger(R_AccuracyInfo.machep)); |
| |
| SET_STRING_ELT(nms, 9, mkChar("double.neg.ulp.digits")); |
| SET_VECTOR_ELT(ans, 9, ScalarInteger(R_AccuracyInfo.negep)); |
| |
| SET_STRING_ELT(nms, 10, mkChar("double.exponent")); |
| SET_VECTOR_ELT(ans, 10, ScalarInteger(R_AccuracyInfo.iexp)); |
| |
| SET_STRING_ELT(nms, 11, mkChar("double.min.exp")); |
| SET_VECTOR_ELT(ans, 11, ScalarInteger(R_AccuracyInfo.minexp)); |
| |
| SET_STRING_ELT(nms, 12, mkChar("double.max.exp")); |
| SET_VECTOR_ELT(ans, 12, ScalarInteger(R_AccuracyInfo.maxexp)); |
| |
| SET_STRING_ELT(nms, 13, mkChar("integer.max")); |
| SET_VECTOR_ELT(ans, 13, ScalarInteger(INT_MAX)); |
| |
| SET_STRING_ELT(nms, 14, mkChar("sizeof.long")); |
| SET_VECTOR_ELT(ans, 14, ScalarInteger(SIZEOF_LONG)); |
| |
| SET_STRING_ELT(nms, 15, mkChar("sizeof.longlong")); |
| SET_VECTOR_ELT(ans, 15, ScalarInteger(SIZEOF_LONG_LONG)); |
| |
| SET_STRING_ELT(nms, 16, mkChar("sizeof.longdouble")); |
| #ifdef HAVE_LONG_DOUBLE |
| SET_VECTOR_ELT(ans, 16, ScalarInteger(SIZEOF_LONG_DOUBLE)); |
| #else |
| SET_VECTOR_ELT(ans, 16, ScalarInteger(0)); |
| #endif |
| |
| SET_STRING_ELT(nms, 17, mkChar("sizeof.pointer")); |
| SET_VECTOR_ELT(ans, 17, ScalarInteger(sizeof(SEXP))); |
| setAttrib(ans, R_NamesSymbol, nms); |
| defineVar(install(".Machine"), ans, rho); |
| UNPROTECT(2); |
| } |
| |
| |
| /* 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 const char * const R_OSType = OSTYPE; |
| static const char * const R_FileSep = FILESEP; |
| |
| static void Init_R_Platform(SEXP rho) |
| { |
| SEXP value, names; |
| |
| PROTECT(value = allocVector(VECSXP, 8)); |
| PROTECT(names = allocVector(STRSXP, 8)); |
| 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_STRING_ELT(names, 5, mkChar("pkgType")); |
| SET_STRING_ELT(names, 6, mkChar("path.sep")); |
| SET_STRING_ELT(names, 7, mkChar("r_arch")); |
| SET_VECTOR_ELT(value, 0, mkString(R_OSType)); |
| SET_VECTOR_ELT(value, 1, mkString(R_FileSep)); |
| SET_VECTOR_ELT(value, 2, mkString(SHLIB_EXT)); |
| SET_VECTOR_ELT(value, 3, mkString(R_GUIType)); |
| #ifdef WORDS_BIGENDIAN |
| SET_VECTOR_ELT(value, 4, mkString("big")); |
| #else |
| SET_VECTOR_ELT(value, 4, mkString("little")); |
| #endif |
| /* pkgType should be "mac.binary" for CRAN build *only*, not for all |
| AQUA builds. Also we want to be able to use "mac.binary.mavericks", |
| "mac.binary.el-capitan" and similar. */ |
| #ifdef PLATFORM_PKGTYPE |
| SET_VECTOR_ELT(value, 5, mkString(PLATFORM_PKGTYPE)); |
| #else /* unix default */ |
| SET_VECTOR_ELT(value, 5, mkString("source")); |
| #endif |
| #ifdef Win32 |
| SET_VECTOR_ELT(value, 6, mkString(";")); |
| #else /* not Win32 */ |
| SET_VECTOR_ELT(value, 6, mkString(":")); |
| #endif |
| #ifdef R_ARCH |
| SET_VECTOR_ELT(value, 7, mkString(R_ARCH)); |
| #else |
| SET_VECTOR_ELT(value, 7, mkString("")); |
| #endif |
| setAttrib(value, R_NamesSymbol, names); |
| defineVar(install(".Platform"), value, rho); |
| UNPROTECT(2); |
| } |
| |
| void attribute_hidden Init_R_Variables(SEXP rho) |
| { |
| Init_R_Machine(rho); |
| Init_R_Platform(rho); |
| } |
| |
| #ifdef HAVE_LANGINFO_CODESET |
| /* case-insensitive string comparison (needed for locale check) */ |
| int static R_strieql(const char *a, const char *b) |
| { |
| while (*a && *b && toupper(*a) == toupper(*b)) { a++; b++; } |
| return (*a == 0 && *b == 0); |
| } |
| #endif |
| |
| #include <locale.h> |
| #ifdef HAVE_LANGINFO_CODESET |
| # include <langinfo.h> |
| #endif |
| |
| static char native_enc[R_CODESET_MAX + 1]; |
| const char attribute_hidden *R_nativeEncoding(void) |
| { |
| return native_enc; |
| } |
| |
| /* retrieves information about the current locale and |
| sets the corresponding variables (known_to_be_utf8, |
| known_to_be_latin1, utf8locale, latin1locale and mbcslocale) */ |
| void attribute_hidden R_check_locale(void) |
| { |
| known_to_be_utf8 = utf8locale = FALSE; |
| known_to_be_latin1 = latin1locale = FALSE; |
| mbcslocale = FALSE; |
| strcpy(native_enc, "ASCII"); |
| #ifdef HAVE_LANGINFO_CODESET |
| /* not on Windows */ |
| { |
| char *p = nl_langinfo(CODESET); |
| /* more relaxed due to Darwin: CODESET is case-insensitive and |
| latin1 is ISO8859-1 */ |
| if (R_strieql(p, "UTF-8")) known_to_be_utf8 = utf8locale = TRUE; |
| if (streql(p, "ISO-8859-1")) known_to_be_latin1 = latin1locale = TRUE; |
| if (R_strieql(p, "ISO8859-1")) known_to_be_latin1 = latin1locale = TRUE; |
| # if __APPLE__ |
| /* On Darwin 'regular' locales such as 'en_US' are UTF-8 (hence |
| MB_CUR_MAX == 6), but CODESET is "" */ |
| if (*p == 0 && MB_CUR_MAX == 6) |
| known_to_be_utf8 = utf8locale = TRUE; |
| # endif |
| if (utf8locale) |
| strcpy(native_enc, "UTF-8"); |
| else if (latin1locale) |
| strcpy(native_enc, "ISO-8859-1"); |
| else { |
| strncpy(native_enc, p, R_CODESET_MAX); |
| native_enc[R_CODESET_MAX] = 0; |
| } |
| } |
| #endif |
| mbcslocale = MB_CUR_MAX > 1; |
| #ifdef Win32 |
| { |
| char *ctype = setlocale(LC_CTYPE, NULL), *p; |
| p = strrchr(ctype, '.'); |
| if (p && isdigit(p[1])) localeCP = atoi(p+1); else localeCP = 0; |
| /* Not 100% correct, but CP1252 is a superset */ |
| known_to_be_latin1 = latin1locale = (localeCP == 1252); |
| if (localeCP) { |
| /* CP1252 when latin1locale is true */ |
| snprintf(native_enc, R_CODESET_MAX, "CP%d", localeCP); |
| native_enc[R_CODESET_MAX] = 0; |
| } |
| } |
| #endif |
| #if defined(SUPPORT_UTF8_WIN32) /* never at present */ |
| utf8locale = mbcslocale = TRUE; |
| strcpy(native_enc, "UTF-8"); |
| #endif |
| } |
| |
| /* 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. |
| */ |
| static char *R_Date(void) |
| { |
| 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 attribute_hidden do_date(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| return mkString(R_Date()); |
| } |
| |
| /* file.show |
| * |
| * Display file(s) so that a user can view it. The function calls |
| * "R_ShowFiles" which is a platform-dependent hook that arranges |
| * for the file(s) to be displayed. |
| */ |
| |
| // .Internal so manages R_alloc stack used by acopy_string |
| SEXP attribute_hidden do_fileshow(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP fn, tl, hd, pg; |
| const char **f, **h, *t, *pager = NULL /* -Wall */; |
| Rboolean dl; |
| int i, n; |
| |
| checkArity(op, args); |
| fn = CAR(args); args = CDR(args); |
| hd = CAR(args); args = CDR(args); |
| tl = CAR(args); args = CDR(args); |
| dl = (Rboolean) asLogical(CAR(args)); args = CDR(args); |
| pg = CAR(args); |
| n = 0; /* -Wall */ |
| if (!isString(fn) || (n = LENGTH(fn)) < 1) |
| error(_("invalid filename specification")); |
| if (!isString(hd) || LENGTH(hd) != n) |
| error(_("invalid '%s' argument"), "headers"); |
| if (!isString(tl)) |
| error(_("invalid '%s' argument"), "title"); |
| if (!isString(pg)) |
| error(_("invalid '%s' argument"), "pager"); |
| f = (const char**) R_alloc(n, sizeof(char*)); |
| h = (const char**) R_alloc(n, sizeof(char*)); |
| for (i = 0; i < n; i++) { |
| SEXP el = STRING_ELT(fn, i); |
| if (!isNull(el) && el != NA_STRING) |
| #ifdef Win32 |
| f[i] = acopy_string(reEnc(CHAR(el), getCharCE(el), CE_UTF8, 1)); |
| #else |
| f[i] = acopy_string(translateChar(el)); |
| #endif |
| else |
| error(_("invalid filename specification")); |
| if (STRING_ELT(hd, i) != NA_STRING) |
| h[i] = acopy_string(translateChar(STRING_ELT(hd, i))); |
| else |
| error(_("invalid '%s' argument"), "headers"); |
| } |
| if (isValidStringF(tl)) |
| t = acopy_string(translateChar(STRING_ELT(tl, 0))); |
| else |
| t = ""; |
| if (isValidStringF(pg)) { |
| SEXP pg0 = STRING_ELT(pg, 0); |
| if (pg0 != NA_STRING) |
| pager = acopy_string(CHAR(pg0)); |
| else |
| error(_("invalid '%s' argument"), "pager"); |
| } else |
| pager = ""; |
| R_ShowFiles(n, f, h, t, dl, pager); |
| return R_NilValue; |
| } |
| |
| /* file.append |
| * |
| * Given two vectors of file names as arguments and arranges for |
| * the second set of files to be appended to the first. |
| */ |
| |
| #if defined(BUFSIZ) && (BUFSIZ > 512) |
| /* OS's buffer size in stdio.h, probably. |
| Windows has 512, Solaris 1024, glibc 8192 |
| */ |
| # define APPENDBUFSIZE BUFSIZ |
| #else |
| # define APPENDBUFSIZE 512 |
| #endif |
| |
| static int R_AppendFile(SEXP file1, SEXP file2) |
| { |
| FILE *fp1, *fp2; |
| char buf[APPENDBUFSIZE]; |
| size_t nchar; |
| int status = 0; |
| if ((fp1 = RC_fopen(file1, "ab", TRUE)) == NULL) return 0; |
| if ((fp2 = RC_fopen(file2, "rb", TRUE)) == 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 attribute_hidden do_fileappend(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP f1, f2, ans; |
| int n, n1, n2; |
| |
| checkArity(op, args); |
| f1 = CAR(args); |
| f2 = CADR(args); |
| if (!isString(f1)) |
| error(_("invalid '%s' argument"), "file1"); |
| if (!isString(f2)) |
| error(_("invalid '%s' argument"), "file2"); |
| n1 = LENGTH(f1); n2 = LENGTH(f2); |
| if (n1 < 1) |
| error(_("nothing to append to")); |
| if (n2 < 1) |
| return allocVector(LGLSXP, 0); |
| n = (n1 > n2) ? n1 : n2; |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (int i = 0; i < n; i++) LOGICAL(ans)[i] = 0; /* all FALSE */ |
| if (n1 == 1) { /* common case */ |
| FILE *fp1, *fp2; |
| char buf[APPENDBUFSIZE]; |
| int status = 0; |
| size_t nchar; |
| if (STRING_ELT(f1, 0) == NA_STRING || |
| !(fp1 = RC_fopen(STRING_ELT(f1, 0), "ab", TRUE))) |
| goto done; |
| for (int i = 0; i < n; i++) { |
| status = 0; |
| if (STRING_ELT(f2, i) == NA_STRING || |
| !(fp2 = RC_fopen(STRING_ELT(f2, i), "rb", TRUE))) continue; |
| 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")); |
| LOGICAL(ans)[i] = status; |
| fclose(fp2); |
| } |
| fclose(fp1); |
| } else { |
| for (int i = 0; i < n; i++) { |
| if (STRING_ELT(f1, i%n1) == R_NilValue || |
| STRING_ELT(f2, i%n2) == R_NilValue) |
| LOGICAL(ans)[i] = 0; |
| else |
| LOGICAL(ans)[i] = |
| R_AppendFile(STRING_ELT(f1, i%n1), STRING_ELT(f2, i%n2)); |
| } |
| } |
| done: |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| SEXP attribute_hidden do_filecreate(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP fn, ans; |
| FILE *fp; |
| int i, n, show; |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| if (!isString(fn)) |
| error(_("invalid filename argument")); |
| show = asLogical(CADR(args)); |
| if (show == NA_LOGICAL) show = 0; |
| n = LENGTH(fn); |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (i = 0; i < n; i++) { |
| LOGICAL(ans)[i] = 0; |
| if (STRING_ELT(fn, i) == NA_STRING) continue; |
| if ((fp = RC_fopen(STRING_ELT(fn, i), "w", TRUE)) != NULL) { |
| LOGICAL(ans)[i] = 1; |
| fclose(fp); |
| } else if (show) { |
| warning(_("cannot create file '%s', reason '%s'"), |
| translateChar(STRING_ELT(fn, i)), strerror(errno)); |
| } |
| } |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| SEXP attribute_hidden 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)) |
| error(_("invalid first filename")); |
| n = LENGTH(f); |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (i = 0; i < n; i++) { |
| if (STRING_ELT(f, i) != NA_STRING) { |
| LOGICAL(ans)[i] = |
| #ifdef Win32 |
| (_wremove(filenameToWchar(STRING_ELT(f, i), TRUE)) == 0); |
| #else |
| (remove(R_ExpandFileName(translateChar(STRING_ELT(f, i)))) == 0); |
| #endif |
| if(!LOGICAL(ans)[i]) |
| warning(_("cannot remove file '%s', reason '%s'"), |
| translateChar(STRING_ELT(f, i)), strerror(errno)); |
| } else LOGICAL(ans)[i] = FALSE; |
| } |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| #ifdef HAVE_UNISTD_H |
| #include <unistd.h> /* for symlink, getpid */ |
| #endif |
| |
| #ifdef HAVE_SYS_TYPES_H |
| # include <sys/types.h> |
| #endif |
| #ifdef HAVE_SYS_STAT_H |
| # include <sys/stat.h> |
| #endif |
| |
| #ifdef Win32 |
| /* Mingw-w64 defines this to be 0x0502 */ |
| #ifndef _WIN32_WINNT |
| # define _WIN32_WINNT 0x0500 /* for CreateHardLink */ |
| #endif |
| #include <windows.h> |
| typedef BOOLEAN (WINAPI *PCSL)(LPWSTR, LPWSTR, DWORD); |
| static PCSL pCSL = NULL; |
| const char *formatError(DWORD res); /* extra.c */ |
| /* Windows does not have link(), but it does have CreateHardLink() on NTFS */ |
| #undef HAVE_LINK |
| #define HAVE_LINK 1 |
| /* Windows does not have symlink(), but >= Vista does have |
| CreateSymbolicLink() on NTFS */ |
| #undef HAVE_SYMLINK |
| #define HAVE_SYMLINK 1 |
| #endif |
| |
| /* the Win32 stuff here is not ready for release: |
| |
| (i) It needs Windows >= Vista |
| (ii) It matters whether 'from' is a file or a dir, and we could only |
| know if it exists already. |
| (iii) This needs specific privileges which in general only Adminstrators |
| have, and which many people report granting in the Policy Editor |
| fails to work. |
| */ |
| SEXP attribute_hidden do_filesymlink(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP f1, f2; |
| int n, n1, n2; |
| #ifdef HAVE_SYMLINK |
| SEXP ans; |
| int i; |
| #endif |
| checkArity(op, args); |
| f1 = CAR(args); |
| f2 = CADR(args); |
| if (!isString(f1)) |
| error(_("invalid first filename")); |
| if (!isString(f2)) |
| error(_("invalid second filename")); |
| n1 = LENGTH(f1); n2 = LENGTH(f2); |
| if (n1 < 1) |
| error(_("nothing to link")); |
| if (n2 < 1) |
| return allocVector(LGLSXP, 0); |
| n = (n1 > n2) ? n1 : n2; |
| |
| #ifdef Win32 |
| // Vista, Server 2008 and later |
| pCSL = (PCSL) GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")), |
| "CreateSymbolicLinkW"); |
| if(!pCSL) |
| error(_("symbolic links are not supported on this version of Windows")); |
| #endif |
| |
| #ifdef HAVE_SYMLINK |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (i = 0; i < n; i++) { |
| if (STRING_ELT(f1, i%n1) == NA_STRING || |
| STRING_ELT(f2, i%n2) == NA_STRING) |
| LOGICAL(ans)[i] = 0; |
| else { |
| #ifdef Win32 |
| wchar_t from[PATH_MAX+1], *to, *p; |
| struct _stati64 sb; |
| from[PATH_MAX] = L'\0'; |
| p = filenameToWchar(STRING_ELT(f1, i%n1), TRUE); |
| if (wcslen(p) >= PATH_MAX) |
| error(_("'%s' path too long"), "from"); |
| wcsncpy(from, p, PATH_MAX); |
| /* This Windows system call does not accept slashes */ |
| for (wchar_t *p = from; *p; p++) if (*p == L'/') *p = L'\\'; |
| to = filenameToWchar(STRING_ELT(f2, i%n2), TRUE); |
| _wstati64(from, &sb); |
| int isDir = (sb.st_mode & S_IFDIR) > 0; |
| LOGICAL(ans)[i] = pCSL(to, from, isDir) != 0; |
| if(!LOGICAL(ans)[i]) |
| warning(_("cannot symlink '%ls' to '%ls', reason '%s'"), |
| from, to, formatError(GetLastError())); |
| #else |
| char from[PATH_MAX], to[PATH_MAX]; |
| const char *p; |
| p = R_ExpandFileName(translateChar(STRING_ELT(f1, i%n1))); |
| if (strlen(p) >= PATH_MAX - 1) { |
| LOGICAL(ans)[i] = 0; |
| continue; |
| } |
| strcpy(from, p); |
| p = R_ExpandFileName(translateChar(STRING_ELT(f2, i%n2))); |
| if (strlen(p) >= PATH_MAX - 1) { |
| LOGICAL(ans)[i] = 0; |
| continue; |
| } |
| strcpy(to, p); |
| /* Rprintf("linking %s to %s\n", from, to); */ |
| LOGICAL(ans)[i] = symlink(from, to) == 0; |
| if(!LOGICAL(ans)[i]) |
| warning(_("cannot symlink '%s' to '%s', reason '%s'"), |
| from, to, strerror(errno)); |
| #endif |
| } |
| } |
| UNPROTECT(1); |
| return ans; |
| #else |
| warning(_("symbolic links are not supported on this platform")); |
| return allocVector(LGLSXP, n); |
| #endif |
| } |
| |
| |
| SEXP attribute_hidden do_filelink(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP f1, f2; |
| int n, n1, n2; |
| #ifdef HAVE_LINK |
| SEXP ans; |
| int i; |
| #endif |
| checkArity(op, args); |
| f1 = CAR(args); |
| f2 = CADR(args); |
| if (!isString(f1)) |
| error(_("invalid first filename")); |
| if (!isString(f2)) |
| error(_("invalid second filename")); |
| n1 = LENGTH(f1); n2 = LENGTH(f2); |
| if (n1 < 1) |
| error(_("nothing to link")); |
| if (n2 < 1) |
| return allocVector(LGLSXP, 0); |
| n = (n1 > n2) ? n1 : n2; |
| #ifdef HAVE_LINK |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (i = 0; i < n; i++) { |
| if (STRING_ELT(f1, i%n1) == NA_STRING || |
| STRING_ELT(f2, i%n2) == NA_STRING) |
| LOGICAL(ans)[i] = 0; |
| else { |
| #ifdef Win32 |
| wchar_t from[PATH_MAX+1], *to, *p; |
| p = filenameToWchar(STRING_ELT(f1, i%n1), TRUE); |
| if (wcslen(p) >= PATH_MAX) |
| error(_("'%s' path too long"), "from"); |
| wcscpy(from, p); |
| to = filenameToWchar(STRING_ELT(f2, i%n2), TRUE); |
| LOGICAL(ans)[i] = CreateHardLinkW(to, from, NULL) != 0; |
| if(!LOGICAL(ans)[i]) { |
| warning(_("cannot link '%ls' to '%ls', reason '%s'"), |
| from, to, formatError(GetLastError())); |
| } |
| #else |
| char from[PATH_MAX], to[PATH_MAX]; |
| const char *p; |
| p = R_ExpandFileName(translateChar(STRING_ELT(f1, i%n1))); |
| if (strlen(p) >= PATH_MAX - 1) { |
| LOGICAL(ans)[i] = 0; |
| continue; |
| } |
| strcpy(from, p); |
| p = R_ExpandFileName(translateChar(STRING_ELT(f2, i%n2))); |
| if (strlen(p) >= PATH_MAX - 1) { |
| LOGICAL(ans)[i] = 0; |
| continue; |
| } |
| strcpy(to, p); |
| LOGICAL(ans)[i] = link(from, to) == 0; |
| if(!LOGICAL(ans)[i]) { |
| warning(_("cannot link '%s' to '%s', reason '%s'"), |
| from, to, strerror(errno)); |
| } |
| #endif |
| } |
| } |
| UNPROTECT(1); |
| return ans; |
| #else |
| warning(_("(hard) links are not supported on this platform")); |
| return allocVector(LGLSXP, n); |
| #endif |
| } |
| |
| #ifdef Win32 |
| int Rwin_rename(char *from, char *to); /* in src/gnuwin32/extra.c */ |
| int Rwin_wrename(const wchar_t *from, const wchar_t *to); |
| #endif |
| |
| SEXP attribute_hidden do_filerename(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP f1, f2, ans; |
| int i, n1, n2; |
| #ifdef Win32 |
| wchar_t from[PATH_MAX], to[PATH_MAX]; |
| const wchar_t *w; |
| #else |
| char from[PATH_MAX], to[PATH_MAX]; |
| const char *p; |
| int res; |
| #endif |
| |
| checkArity(op, args); |
| f1 = CAR(args); |
| f2 = CADR(args); |
| if (!isString(f1)) |
| error(_("invalid '%s' argument"), "from"); |
| if (!isString(f2)) |
| error(_("invalid '%s' argument"), "to"); |
| n1 = LENGTH(f1); n2 = LENGTH(f2); |
| if (n2 != n1) |
| error(_("'from' and 'to' are of different lengths")); |
| PROTECT(ans = allocVector(LGLSXP, n1)); |
| for (i = 0; i < n1; i++) { |
| if (STRING_ELT(f1, i) == NA_STRING || |
| STRING_ELT(f2, i) == NA_STRING) { |
| LOGICAL(ans)[i] = 0; |
| continue; |
| } |
| #ifdef Win32 |
| w = filenameToWchar(STRING_ELT(f1, i), TRUE); |
| if (wcslen(w) >= PATH_MAX - 1) |
| error(_("expanded 'from' name too long")); |
| wcsncpy(from, w, PATH_MAX - 1); |
| w = filenameToWchar(STRING_ELT(f2, i), TRUE); |
| if (wcslen(w) >= PATH_MAX - 1) |
| error(_("expanded 'to' name too long")); |
| wcsncpy(to, w, PATH_MAX - 1); |
| LOGICAL(ans)[i] = (Rwin_wrename(from, to) == 0); |
| #else |
| p = R_ExpandFileName(translateChar(STRING_ELT(f1, i))); |
| if (strlen(p) >= PATH_MAX - 1) |
| error(_("expanded 'from' name too long")); |
| strncpy(from, p, PATH_MAX - 1); |
| p = R_ExpandFileName(translateChar(STRING_ELT(f2, i))); |
| if (strlen(p) >= PATH_MAX - 1) |
| error(_("expanded 'to' name too long")); |
| strncpy(to, p, PATH_MAX - 1); |
| res = rename(from, to); |
| if(res) { |
| warning(_("cannot rename file '%s' to '%s', reason '%s'"), |
| from, to, strerror(errno)); |
| } |
| LOGICAL(ans)[i] = (res == 0); |
| #endif |
| } |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| # 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 |
| # endif |
| |
| #ifdef Win32 |
| # ifndef SCS_64BIT_BINARY |
| # define SCS_64BIT_BINARY 6 |
| # endif |
| #endif |
| |
| #if defined HAVE_STRUCT_STAT_ST_ATIM_TV_NSEC |
| # ifdef TYPEOF_STRUCT_STAT_ST_ATIM_IS_STRUCT_TIMESPEC |
| # define STAT_TIMESPEC(st, st_xtim) ((st).st_xtim) |
| # else |
| # define STAT_TIMESPEC_NS(st, st_xtim) ((st).st_xtim.tv_nsec) |
| # endif |
| #elif defined HAVE_STRUCT_STAT_ST_ATIMESPEC_TV_NSEC |
| # define STAT_TIMESPEC(st, st_xtim) ((st).st_xtim##espec) |
| #elif defined HAVE_STRUCT_STAT_ST_ATIMENSEC |
| # define STAT_TIMESPEC_NS(st, st_xtim) ((st).st_xtim##ensec) |
| #elif defined HAVE_STRUCT_STAT_ST_ATIM_ST__TIM_TV_NSEC |
| # define STAT_TIMESPEC_NS(st, st_xtim) ((st).st_xtim.st__tim.tv_nsec) |
| #endif |
| |
| SEXP attribute_hidden do_fileinfo(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP fn, ans, ansnames, fsize, mtime, ctime, atime, isdir, |
| mode, xxclass; |
| #ifdef UNIX_EXTRAS |
| SEXP uid = R_NilValue, gid = R_NilValue, |
| uname = R_NilValue, grname = R_NilValue; // silence -Wall |
| #endif |
| #ifdef Win32 |
| SEXP exe = R_NilValue; |
| struct _stati64 sb; |
| #else |
| struct stat sb; |
| #endif |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| if (!isString(fn)) |
| error(_("invalid filename argument")); |
| int extras = asInteger(CADR(args)); |
| if(extras == NA_INTEGER) |
| error(_("invalid '%s' argument"), "extra_cols"); |
| int n = LENGTH(fn), ncols = 6; |
| if(extras) { |
| #ifdef UNIX_EXTRAS |
| ncols = 10; |
| #elif defined(Win32) |
| ncols = 7; |
| #endif |
| } |
| PROTECT(ans = allocVector(VECSXP, ncols)); |
| PROTECT(ansnames = allocVector(STRSXP, ncols)); |
| fsize = SET_VECTOR_ELT(ans, 0, allocVector(REALSXP, 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")); |
| if (extras) { |
| #ifdef UNIX_EXTRAS |
| uid = 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")); |
| #endif |
| #ifdef Win32 |
| exe = SET_VECTOR_ELT(ans, 6, allocVector(STRSXP, n)); |
| SET_STRING_ELT(ansnames, 6, mkChar("exe")); |
| #endif |
| } |
| for (int i = 0; i < n; i++) { |
| #ifdef Win32 |
| wchar_t *wfn = filenameToWchar(STRING_ELT(fn, i), TRUE); |
| /* trailing \ is not valid on Windows except for the |
| root directory on a drive, specified as "\", or "D:\", |
| or "\\?\D:\", etc. We remove it in other cases, |
| to help those who think they're on Unix. */ |
| size_t len = wcslen(wfn); |
| if (len) { |
| wchar_t *p = wfn + (len - 1); |
| if (len > 1 && (*p == L'/' || *p == L'\\') && |
| *(p-1) != L':') *p = 0; |
| } |
| #else |
| const char *efn = R_ExpandFileName(translateChar(STRING_ELT(fn, i))); |
| #endif |
| if (STRING_ELT(fn, i) != NA_STRING && |
| #ifdef Win32 |
| _wstati64(wfn, &sb) |
| #else |
| /* Target not link */ |
| stat(efn, &sb) |
| #endif |
| == 0) { |
| REAL(fsize)[i] = (double) sb.st_size; |
| LOGICAL(isdir)[i] = (sb.st_mode & S_IFDIR) > 0; |
| INTEGER(mode)[i] = (int) sb.st_mode & 0007777; |
| |
| #if defined STAT_TIMESPEC |
| /* POSIX 2008 changed this to a struct timespec st_mtim etc |
| Not all OSes (e.g. Darwin) agree on this. */ |
| REAL(mtime)[i] = (double) STAT_TIMESPEC(sb, st_mtim).tv_sec |
| + 1e-9 * (double) STAT_TIMESPEC(sb, st_mtim).tv_nsec; |
| REAL(ctime)[i] = (double) STAT_TIMESPEC(sb, st_ctim).tv_sec |
| + 1e-9 * (double) STAT_TIMESPEC(sb, st_ctim).tv_nsec; |
| REAL(atime)[i] = (double) STAT_TIMESPEC(sb, st_atim).tv_sec |
| + 1e-9 * (double) STAT_TIMESPEC(sb, st_atim).tv_nsec; |
| #else |
| #ifdef Win32 |
| #define WINDOWS_TICK 10000000 |
| #define SEC_TO_UNIX_EPOCH 11644473600LL |
| { |
| FILETIME c_ft, a_ft, m_ft; |
| HANDLE h; |
| int success = 0; |
| h = CreateFileW(wfn, 0, |
| FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE, |
| NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); |
| if (h != INVALID_HANDLE_VALUE) { |
| int res = GetFileTime(h, &c_ft, &a_ft, &m_ft); |
| CloseHandle(h); |
| if (res) { |
| ULARGE_INTEGER time; |
| time.LowPart = m_ft.dwLowDateTime; |
| time.HighPart = m_ft.dwHighDateTime; |
| REAL(mtime)[i] = (((double) time.QuadPart) / WINDOWS_TICK - SEC_TO_UNIX_EPOCH); |
| time.LowPart = c_ft.dwLowDateTime; |
| time.HighPart = c_ft.dwHighDateTime; |
| REAL(ctime)[i] = (((double) time.QuadPart) / WINDOWS_TICK - SEC_TO_UNIX_EPOCH); |
| time.LowPart = a_ft.dwLowDateTime; |
| time.HighPart = a_ft.dwHighDateTime; |
| REAL(atime)[i] = (((double) time.QuadPart) / WINDOWS_TICK - SEC_TO_UNIX_EPOCH); |
| success = 1; |
| } |
| } else |
| warning(_("cannot open file '%ls': %s"), |
| wfn, formatError(GetLastError())); |
| if (!success) { |
| REAL(mtime)[i] = NA_REAL; |
| REAL(ctime)[i] = NA_REAL; |
| REAL(atime)[i] = NA_REAL; |
| } |
| } |
| #else |
| REAL(mtime)[i] = (double) sb.st_mtime; |
| REAL(ctime)[i] = (double) sb.st_ctime; |
| REAL(atime)[i] = (double) sb.st_atime; |
| # ifdef STAT_TIMESPEC_NS |
| REAL(mtime)[i] += STAT_TIMESPEC_NS (sb, st_mtim); |
| REAL(ctime)[i] += STAT_TIMESPEC_NS (sb, st_ctim); |
| REAL(atime)[i] += STAT_TIMESPEC_NS (sb, st_atim); |
| # endif |
| #endif |
| #endif |
| if (extras) { |
| #ifdef UNIX_EXTRAS |
| INTEGER(uid)[i] = (int) sb.st_uid; |
| INTEGER(gid)[i] = (int) sb.st_gid; |
| |
| /* Usually all of the uid and gid values in a list of |
| * files are the same so we can avoid most of the calls |
| * to getpwuid() and getgrgid(), which can be quite slow |
| * on some systems. (PR#15804) |
| */ |
| if (i && INTEGER(uid)[i - 1] == (int) sb.st_uid) |
| SET_STRING_ELT(uname, i, STRING_ELT(uname, i - 1)); |
| else { |
| struct passwd *stpwd = getpwuid(sb.st_uid); |
| SET_STRING_ELT(uname, i, |
| stpwd ? mkChar(stpwd->pw_name): NA_STRING); |
| } |
| |
| if (i && INTEGER(gid)[i - 1] == (int) sb.st_gid) |
| SET_STRING_ELT(grname, i, STRING_ELT(grname, i - 1)); |
| else { |
| struct group *stgrp = getgrgid(sb.st_gid); |
| SET_STRING_ELT(grname, i, |
| stgrp ? mkChar(stgrp->gr_name): NA_STRING); |
| } |
| #endif |
| #ifdef Win32 |
| { |
| char *s="no"; |
| DWORD type; |
| if (GetBinaryTypeW(wfn, &type)) |
| switch(type) { |
| case SCS_64BIT_BINARY: |
| s = "win64"; |
| break; |
| case SCS_32BIT_BINARY: |
| s = "win32"; |
| break; |
| case SCS_DOS_BINARY: |
| case SCS_PIF_BINARY: |
| s = "msdos"; |
| break; |
| case SCS_WOW_BINARY: |
| s = "win16"; |
| break; |
| default: |
| s = "unknown"; |
| } |
| SET_STRING_ELT(exe, i, mkChar(s)); |
| } |
| #endif |
| } |
| } else { |
| REAL(fsize)[i] = NA_REAL; |
| 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; |
| if (extras) { |
| #ifdef UNIX_EXTRAS |
| INTEGER(uid)[i] = NA_INTEGER; |
| INTEGER(gid)[i] = NA_INTEGER; |
| SET_STRING_ELT(uname, i, NA_STRING); |
| SET_STRING_ELT(grname, i, NA_STRING); |
| #endif |
| #ifdef Win32 |
| SET_STRING_ELT(exe, i, NA_STRING); |
| #endif |
| } |
| } |
| } |
| setAttrib(ans, R_NamesSymbol, ansnames); |
| PROTECT(xxclass = mkString("octmode")); |
| classgets(mode, xxclass); |
| UNPROTECT(3); |
| return ans; |
| } |
| |
| SEXP attribute_hidden do_direxists(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP fn, ans; |
| |
| #ifdef Win32 |
| struct _stati64 sb; |
| #else |
| struct stat sb; |
| #endif |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| if (!isString(fn)) |
| error(_("invalid filename argument")); |
| int n = LENGTH(fn); |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (int i = 0; i < n; i++) { |
| #ifdef Win32 |
| wchar_t *wfn = filenameToWchar(STRING_ELT(fn, i), TRUE); |
| /* trailing \ is not valid on Windows except for the |
| root directory on a drive, specified as "\", or "D:\", |
| or "\\?\D:\", etc. We remove it in other cases, |
| to help those who think they're on Unix. */ |
| size_t len = wcslen(wfn); |
| if (len) { |
| wchar_t *p = wfn + (len - 1); |
| if (len > 1 && (*p == L'/' || *p == L'\\') && |
| *(p-1) != L':') *p = 0; |
| } |
| #else |
| const char *efn = R_ExpandFileName(translateChar(STRING_ELT(fn, i))); |
| #endif |
| if (STRING_ELT(fn, i) != NA_STRING && |
| #ifdef Win32 |
| _wstati64(wfn, &sb) |
| #else |
| /* Target not link */ |
| stat(efn, &sb) |
| #endif |
| == 0) { |
| LOGICAL(ans)[i] = (sb.st_mode & S_IFDIR) > 0; |
| |
| } else LOGICAL(ans)[i] = 0; |
| } |
| // copy names? |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| /* No longer required by POSIX, but maybe on earlier OSes */ |
| #ifdef HAVE_SYS_TYPES_H |
| # 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 |
| |
| #define CBUFSIZE 2*PATH_MAX+1 |
| static SEXP filename(const char *dir, const char *file) |
| { |
| SEXP ans; |
| char cbuf[CBUFSIZE]; |
| if (dir) { |
| #ifdef Win32 |
| if ((strlen(dir) == 2 && dir[1] == ':') || |
| dir[strlen(dir) - 1] == '/' || dir[strlen(dir) - 1] == '\\') |
| snprintf(cbuf, CBUFSIZE, "%s%s", dir, file); |
| else |
| snprintf(cbuf, CBUFSIZE, "%s%s%s", dir, R_FileSep, file); |
| #else |
| snprintf(cbuf, CBUFSIZE, "%s%s%s", dir, R_FileSep, file); |
| #endif |
| ans = mkChar(cbuf); |
| } else { |
| snprintf(cbuf, CBUFSIZE, "%s", file); |
| ans = mkChar(cbuf); |
| } |
| return ans; |
| } |
| |
| #include <tre/tre.h> |
| |
| static void |
| list_files(const char *dnp, const char *stem, int *count, SEXP *pans, |
| Rboolean allfiles, Rboolean recursive, |
| const regex_t *reg, int *countmax, PROTECT_INDEX idx, |
| Rboolean idirs, Rboolean allowdots) |
| { |
| DIR *dir; |
| struct dirent *de; |
| char p[PATH_MAX], stem2[PATH_MAX]; |
| #ifdef Windows |
| /* > 2GB files might be skipped otherwise */ |
| struct _stati64 sb; |
| #else |
| struct stat sb; |
| #endif |
| R_CheckUserInterrupt(); // includes stack check |
| if ((dir = opendir(dnp)) != NULL) { |
| while ((de = readdir(dir))) { |
| if (allfiles || !R_HiddenFile(de->d_name)) { |
| Rboolean not_dot = strcmp(de->d_name, ".") && strcmp(de->d_name, ".."); |
| if (recursive) { |
| #ifdef Win32 |
| if (strlen(dnp) == 2 && dnp[1] == ':') // e.g. "C:" |
| snprintf(p, PATH_MAX, "%s%s", dnp, de->d_name); |
| else |
| #endif |
| snprintf(p, PATH_MAX, "%s%s%s", dnp, R_FileSep, de->d_name); |
| |
| #ifdef Windows |
| _stati64(p, &sb); |
| #else |
| stat(p, &sb); |
| #endif |
| if ((sb.st_mode & S_IFDIR) > 0) { |
| if (not_dot) { |
| if (idirs) { |
| #define IF_MATCH_ADD_TO_ANS \ |
| if (!reg || tre_regexec(reg, de->d_name, 0, NULL, 0) == 0) { \ |
| if (*count == *countmax - 1) { \ |
| *countmax *= 2; \ |
| REPROTECT(*pans = lengthgets(*pans, *countmax), idx); \ |
| } \ |
| SET_STRING_ELT(*pans, (*count)++, \ |
| filename(stem, de->d_name)); \ |
| } |
| IF_MATCH_ADD_TO_ANS |
| } |
| if (stem) { |
| #ifdef Win32 |
| if(strlen(stem) == 2 && stem[1] == ':') |
| snprintf(stem2, PATH_MAX, "%s%s", stem, |
| de->d_name); |
| else |
| #endif |
| snprintf(stem2, PATH_MAX, "%s%s%s", stem, |
| R_FileSep, de->d_name); |
| } else |
| strcpy(stem2, de->d_name); |
| |
| list_files(p, stem2, count, pans, allfiles, |
| recursive, reg, countmax, idx, idirs, |
| allowdots); |
| } |
| continue; |
| } |
| } // end if(recursive) |
| |
| if (not_dot || allowdots) |
| IF_MATCH_ADD_TO_ANS |
| } |
| |
| } // end while() |
| closedir(dir); |
| } |
| } |
| #undef IF_MATCH_ADD_TO_ANS |
| |
| SEXP attribute_hidden do_listfiles(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int countmax = 128; |
| |
| checkArity(op, args); |
| SEXP d = CAR(args); args = CDR(args); // d := directory = path |
| if (!isString(d)) error(_("invalid '%s' argument"), "path"); |
| SEXP p = CAR(args); args = CDR(args); |
| Rboolean pattern = FALSE; |
| if (isString(p) && LENGTH(p) >= 1 && STRING_ELT(p, 0) != NA_STRING) |
| pattern = TRUE; |
| else if (!isNull(p) && !(isString(p) && LENGTH(p) < 1)) |
| error(_("invalid '%s' argument"), "pattern"); |
| int allfiles = asLogical(CAR(args)); args = CDR(args); |
| if (allfiles == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "all.files"); |
| int fullnames = asLogical(CAR(args)); args = CDR(args); |
| if (fullnames == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "full.names"); |
| int recursive = asLogical(CAR(args)); args = CDR(args); |
| if (recursive == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "recursive"); |
| int igcase = asLogical(CAR(args)); args = CDR(args); |
| if (igcase == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "ignore.case"); |
| int idirs = asLogical(CAR(args)); args = CDR(args); |
| if (idirs == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "include.dirs"); |
| int nodots = asLogical(CAR(args)); |
| if (nodots == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "no.."); |
| |
| int flags = REG_EXTENDED; |
| if (igcase) flags |= REG_ICASE; |
| regex_t reg; |
| if (pattern && tre_regcomp(®, translateChar(STRING_ELT(p, 0)), flags)) |
| error(_("invalid 'pattern' regular expression")); |
| PROTECT_INDEX idx; |
| SEXP ans; |
| PROTECT_WITH_INDEX(ans = allocVector(STRSXP, countmax), &idx); |
| int count = 0; |
| for (int i = 0; i < LENGTH(d) ; i++) { |
| if (STRING_ELT(d, i) == NA_STRING) continue; |
| const char *dnp = R_ExpandFileName(translateChar(STRING_ELT(d, i))); |
| list_files(dnp, fullnames ? dnp : NULL, &count, &ans, allfiles, |
| recursive, pattern ? ® : NULL, &countmax, idx, |
| idirs, /* allowdots = */ !nodots); |
| } |
| REPROTECT(ans = lengthgets(ans, count), idx); |
| if (pattern) tre_regfree(®); |
| ssort(STRING_PTR(ans), count); |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| static void list_dirs(const char *dnp, const char *nm, |
| Rboolean full, int *count, |
| SEXP *pans, int *countmax, PROTECT_INDEX idx, |
| Rboolean recursive) |
| { |
| DIR *dir; |
| struct dirent *de; |
| char p[PATH_MAX]; |
| #ifdef Windows |
| /* > 2GB files might be skipped otherwise */ |
| struct _stati64 sb; |
| #else |
| struct stat sb; |
| #endif |
| R_CheckUserInterrupt(); // includes stack check |
| |
| if ((dir = opendir(dnp)) != NULL) { |
| if (recursive) { |
| if (*count == *countmax - 1) { |
| *countmax *= 2; |
| REPROTECT(*pans = lengthgets(*pans, *countmax), idx); |
| } |
| SET_STRING_ELT(*pans, (*count)++, mkChar(full ? dnp : nm)); |
| } |
| while ((de = readdir(dir))) { |
| #ifdef Win32 |
| if (strlen(dnp) == 2 && dnp[1] == ':') |
| snprintf(p, PATH_MAX, "%s%s", dnp, de->d_name); |
| else |
| snprintf(p, PATH_MAX, "%s%s%s", dnp, R_FileSep, de->d_name); |
| #else |
| snprintf(p, PATH_MAX, "%s%s%s", dnp, R_FileSep, de->d_name); |
| #endif |
| #ifdef Windows |
| _stati64(p, &sb); |
| #else |
| stat(p, &sb); |
| #endif |
| if ((sb.st_mode & S_IFDIR) > 0) { |
| if (strcmp(de->d_name, ".") && strcmp(de->d_name, "..")) { |
| if(recursive) { |
| char nm2[PATH_MAX]; |
| snprintf(nm2, PATH_MAX, "%s%s%s", nm, R_FileSep, |
| de->d_name); |
| list_dirs(p, nm[0] ? nm2 : de->d_name, full, count, |
| pans, countmax, idx, recursive); |
| |
| } else { |
| if (*count == *countmax - 1) { |
| *countmax *= 2; |
| REPROTECT(*pans = lengthgets(*pans, *countmax), idx); |
| } |
| SET_STRING_ELT(*pans, (*count)++, |
| mkChar(full ? p : de->d_name)); |
| } |
| } |
| } |
| } |
| closedir(dir); |
| } |
| } |
| |
| SEXP attribute_hidden do_listdirs(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| PROTECT_INDEX idx; |
| SEXP d, ans; |
| int fullnames, count, i, recursive; |
| const char *dnp; |
| int countmax = 128; |
| |
| checkArity(op, args); |
| d = CAR(args); args = CDR(args); |
| if (!isString(d)) error(_("invalid '%s' argument"), "directory"); |
| fullnames = asLogical(CAR(args)); args = CDR(args); |
| if (fullnames == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "full.names"); |
| recursive = asLogical(CAR(args)); args = CDR(args); |
| if (recursive == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "recursive"); |
| |
| PROTECT_WITH_INDEX(ans = allocVector(STRSXP, countmax), &idx); |
| count = 0; |
| for (i = 0; i < LENGTH(d) ; i++) { |
| if (STRING_ELT(d, i) == NA_STRING) continue; |
| dnp = R_ExpandFileName(translateChar(STRING_ELT(d, i))); |
| list_dirs(dnp, "", fullnames, &count, &ans, &countmax, idx, recursive); |
| } |
| REPROTECT(ans = lengthgets(ans, count), idx); |
| ssort(STRING_PTR(ans), count); |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| SEXP attribute_hidden 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); |
| } |
| |
| #ifdef Win32 |
| static Rboolean attribute_hidden R_WFileExists(const wchar_t *path) |
| { |
| struct _stati64 sb; |
| return _wstati64(path, &sb) == 0; |
| } |
| #endif |
| |
| SEXP attribute_hidden do_fileexists(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP file, ans; |
| int i, nfile; |
| checkArity(op, args); |
| if (!isString(file = CAR(args))) |
| error(_("invalid '%s' argument"), "file"); |
| nfile = LENGTH(file); |
| ans = PROTECT(allocVector(LGLSXP, nfile)); |
| for (i = 0; i < nfile; i++) { |
| LOGICAL(ans)[i] = 0; |
| if (STRING_ELT(file, i) != NA_STRING) { |
| #ifdef Win32 |
| /* Package XML sends arbitrarily long strings to file.exists! */ |
| size_t len = strlen(CHAR(STRING_ELT(file, i))); |
| if (len > MAX_PATH) |
| LOGICAL(ans)[i] = FALSE; |
| else |
| LOGICAL(ans)[i] = |
| R_WFileExists(filenameToWchar(STRING_ELT(file, i), TRUE)); |
| #else |
| LOGICAL(ans)[i] = R_FileExists(translateChar(STRING_ELT(file, i))); |
| #endif |
| } else LOGICAL(ans)[i] = FALSE; |
| } |
| UNPROTECT(1); /* ans */ |
| return ans; |
| } |
| |
| #define CHOOSEBUFSIZE 1024 |
| |
| #ifndef Win32 |
| SEXP attribute_hidden 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) |
| error(_("file name too long")); |
| return mkString(R_ExpandFileName(buf)); |
| } |
| #endif |
| |
| /* needed for access, and perhaps for realpath */ |
| #ifdef HAVE_UNISTD_H |
| # include <unistd.h> |
| #endif |
| |
| #ifdef Win32 |
| extern int winAccessW(const wchar_t *path, int mode); |
| #endif |
| |
| /* we require 'access' as from 2.12.0 */ |
| SEXP attribute_hidden 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)) |
| error(_("invalid '%s' argument"), "names"); |
| n = LENGTH(fn); |
| mode = asInteger(CADR(args)); |
| if (mode < 0 || mode > 7) error(_("invalid '%s' argument"), "mode"); |
| 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++) |
| if (STRING_ELT(fn, i) != NA_STRING) { |
| INTEGER(ans)[i] = |
| #ifdef Win32 |
| winAccessW(filenameToWchar(STRING_ELT(fn, i), TRUE), modemask); |
| #else |
| access(R_ExpandFileName(translateChar(STRING_ELT(fn, i))), |
| modemask); |
| #endif |
| } else INTEGER(ans)[i] = -1; /* treat NA as non-existent file */ |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| #ifdef Win32 |
| |
| static int R_rmdir(const wchar_t *dir) |
| { |
| wchar_t tmp[MAX_PATH]; |
| GetShortPathNameW(dir, tmp, MAX_PATH); |
| //printf("removing directory %ls\n", tmp); |
| return _wrmdir(tmp); |
| } |
| |
| /* Junctions and symbolic links are fundamentally reparse points, so |
| apparently this is the way to detect them. */ |
| static int isReparsePoint(const wchar_t *name) |
| { |
| DWORD res = GetFileAttributesW(name); |
| if(res == INVALID_FILE_ATTRIBUTES) { |
| warning("cannot get info on '%ls', reason '%s'", |
| name, formatError(GetLastError())); |
| return 0; |
| } |
| // printf("%ls: %x\n", name, res); |
| return res & FILE_ATTRIBUTE_REPARSE_POINT; |
| } |
| |
| static int delReparsePoint(const wchar_t *name) |
| { |
| HANDLE hd = |
| CreateFileW(name, GENERIC_READ | GENERIC_WRITE, 0, 0, OPEN_EXISTING, |
| FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, |
| 0); |
| if(hd == INVALID_HANDLE_VALUE) { |
| warning("cannot open reparse point '%ls', reason '%s'", |
| name, formatError(GetLastError())); |
| return 1; |
| } |
| REPARSE_GUID_DATA_BUFFER rgdb = {0}; |
| rgdb.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; |
| DWORD dwBytes; |
| BOOL res = DeviceIoControl(hd, FSCTL_DELETE_REPARSE_POINT, &rgdb, |
| REPARSE_GUID_DATA_BUFFER_HEADER_SIZE, |
| NULL, 0, &dwBytes, 0); |
| CloseHandle(hd); |
| if(res == 0) |
| warning("cannot delete reparse point '%ls', reason '%s'", |
| name, formatError(GetLastError())); |
| else /* This may leave an empty dir behind */ |
| R_rmdir(name); |
| return res == 0; |
| } |
| |
| static int R_unlink(wchar_t *name, int recursive, int force) |
| { |
| R_CheckStack(); // called recursively |
| if (wcscmp(name, L".") == 0 || wcscmp(name, L"..") == 0) return 0; |
| //printf("R_unlink(%ls)\n", name); |
| if (!R_WFileExists(name)) return 0; |
| if (force) _wchmod(name, _S_IWRITE); |
| |
| if (recursive) { |
| _WDIR *dir; |
| struct _wdirent *de; |
| wchar_t p[PATH_MAX]; |
| struct _stati64 sb; |
| int n, ans = 0; |
| |
| _wstati64(name, &sb); |
| /* We need to test for a junction first, as junctions |
| are detected as directories. */ |
| if (isReparsePoint(name)) ans += delReparsePoint(name); |
| else if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */ |
| if ((dir = _wopendir(name)) != NULL) { |
| while ((de = _wreaddir(dir))) { |
| if (!wcscmp(de->d_name, L".") || !wcscmp(de->d_name, L"..")) |
| continue; |
| /* On Windows we need to worry about trailing seps */ |
| n = wcslen(name); |
| if (name[n] == L'/' || name[n] == L'\\') { |
| wcscpy(p, name); wcscat(p, de->d_name); |
| } else { |
| wcscpy(p, name); wcscat(p, L"/"); wcscat(p, de->d_name); |
| } |
| /* printf("stat-ing %ls\n", p); */ |
| _wstati64(p, &sb); |
| if (isReparsePoint(name)) ans += delReparsePoint(name); |
| else if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */ |
| /* printf("is a directory\n"); */ |
| if (force) _wchmod(p, _S_IWRITE); |
| ans += R_unlink(p, recursive, force); |
| } else { |
| if (force) _wchmod(p, _S_IWRITE); |
| ans += (_wunlink(p) == 0) ? 0 : 1; |
| } |
| } |
| _wclosedir(dir); |
| } else { /* we were unable to read a dir */ |
| ans++; |
| } |
| ans += (R_rmdir(name) == 0) ? 0 : 1; |
| return ans; |
| } |
| /* drop through */ |
| } else if (isReparsePoint(name)) return delReparsePoint(name); |
| |
| return _wunlink(name) == 0 ? 0 : 1; |
| } |
| |
| void R_CleanTempDir(void) |
| { |
| if (Sys_TempDir) { |
| size_t n = strlen(Sys_TempDir); |
| /* Windows cannot delete the current working directory */ |
| SetCurrentDirectory(R_HomeDir()); |
| wchar_t w[2*(n+1)]; |
| mbstowcs(w, Sys_TempDir, n+1); |
| R_unlink(w, 1, 1); /* recursive=TRUE, force=TRUE */ |
| } |
| } |
| #else |
| static int R_unlink(const char *name, int recursive, int force) |
| { |
| R_CheckStack(); // called recursively |
| struct stat sb; |
| int res, res2; |
| |
| if (streql(name, ".") || streql(name, "..")) return 0; |
| /* We cannot use R_FileExists here since it is false for broken |
| symbolic links |
| if (!R_FileExists(name)) return 0; */ |
| res = lstat(name, &sb); /* better to be lstat */ |
| if (!res && force) chmod(name, sb.st_mode | S_IWUSR); |
| |
| if (!res && recursive) { |
| DIR *dir; |
| struct dirent *de; |
| char p[PATH_MAX]; |
| int ans = 0; |
| |
| if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */ |
| if ((dir = opendir(name)) != NULL) { |
| while ((de = readdir(dir))) { |
| if (streql(de->d_name, ".") || streql(de->d_name, "..")) |
| continue; |
| size_t n = strlen(name); |
| if (name[n] == R_FileSep[0]) |
| snprintf(p, PATH_MAX, "%s%s", name, de->d_name); |
| else |
| snprintf(p, PATH_MAX, "%s%s%s", name, R_FileSep, |
| de->d_name); |
| lstat(p, &sb); |
| if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */ |
| if (force) chmod(p, sb.st_mode | S_IWUSR | S_IXUSR); |
| ans += R_unlink(p, recursive, force); |
| } else { |
| if (force) chmod(p, sb.st_mode | S_IWUSR); |
| ans += (unlink(p) == 0) ? 0 : 1; |
| } |
| } |
| closedir(dir); |
| } else { /* we were unable to read a dir */ |
| ans++; |
| } |
| ans += (rmdir(name) == 0) ? 0 : 1; |
| return ans; |
| } |
| /* drop through */ |
| } |
| res2 = unlink(name); |
| /* We want to return 0 if either unlink succeeded or 'name' did not exist */ |
| return (res2 == 0 || res != 0) ? 0 : 1; |
| } |
| |
| #endif |
| |
| |
| /* Note that wildcards are allowed in 'names' */ |
| #ifdef Win32 |
| # include <dos_wglob.h> |
| SEXP attribute_hidden do_unlink(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP fn; |
| int i, j, nfiles, res, failures = 0, recursive, force; |
| const wchar_t *names; |
| wglob_t globbuf; |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| nfiles = length(fn); |
| if (nfiles > 0) { |
| if (!isString(fn)) |
| error(_("invalid '%s' argument"), "x"); |
| recursive = asLogical(CADR(args)); |
| if (recursive == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "recursive"); |
| force = asLogical(CADDR(args)); |
| if (force == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "force"); |
| for (i = 0; i < nfiles; i++) { |
| if (STRING_ELT(fn, i) != NA_STRING) { |
| names = filenameToWchar(STRING_ELT(fn, i), TRUE); |
| //Rprintf("do_unlink(%ls)\n", names); |
| res = dos_wglob(names, GLOB_NOCHECK, NULL, &globbuf); |
| if (res == GLOB_NOSPACE) |
| error(_("internal out-of-memory condition")); |
| for (j = 0; j < globbuf.gl_pathc; j++) |
| failures += R_unlink(globbuf.gl_pathv[j], recursive, force); |
| dos_wglobfree(&globbuf); |
| } else failures++; |
| } |
| } |
| return ScalarInteger(failures ? 1 : 0); |
| } |
| #else |
| # if defined(HAVE_GLOB) && defined(HAVE_GLOB_H) |
| # include <glob.h> |
| # endif |
| |
| SEXP attribute_hidden do_unlink(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP fn; |
| int i, nfiles, failures = 0, recursive, force; |
| const char *names; |
| #if defined(HAVE_GLOB) |
| int j, res; |
| glob_t globbuf; |
| #endif |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| nfiles = length(fn); |
| if (nfiles > 0) { |
| if (!isString(fn)) |
| error(_("invalid '%s' argument"), "x"); |
| recursive = asLogical(CADR(args)); |
| if (recursive == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "recursive"); |
| force = asLogical(CADDR(args)); |
| if (force == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "force"); |
| for (i = 0; i < nfiles; i++) { |
| if (STRING_ELT(fn, i) != NA_STRING) { |
| names = R_ExpandFileName(translateChar(STRING_ELT(fn, i))); |
| #if defined(HAVE_GLOB) |
| res = glob(names, GLOB_NOCHECK, NULL, &globbuf); |
| # ifdef GLOB_ABORTED |
| if (res == GLOB_ABORTED) |
| warning(_("read error on '%s'"), names); |
| # endif |
| # ifdef GLOB_NOSPACE |
| if (res == GLOB_NOSPACE) |
| error(_("internal out-of-memory condition")); |
| # endif |
| for (j = 0; j < globbuf.gl_pathc; j++) |
| failures += R_unlink(globbuf.gl_pathv[j], recursive, force); |
| globfree(&globbuf); |
| } else failures++; |
| #else /* HAVE_GLOB */ |
| failures += R_unlink(names, recursive, force); |
| } else failures++; |
| #endif |
| } |
| } |
| return ScalarInteger(failures ? 1 : 0); |
| } |
| #endif |
| |
| SEXP attribute_hidden do_getlocale(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| int cat; |
| char *p = NULL; |
| |
| checkArity(op, args); |
| cat = asInteger(CAR(args)); |
| if (cat == NA_INTEGER || cat < 0) |
| error(_("invalid '%s' argument"), "category"); |
| switch(cat) { |
| case 1: cat = LC_ALL; break; |
| case 2: cat = LC_COLLATE; break; |
| case 3: cat = LC_CTYPE; break; |
| case 4: cat = LC_MONETARY; break; |
| case 5: cat = LC_NUMERIC; break; |
| case 6: cat = LC_TIME; break; |
| #ifdef LC_MESSAGES |
| case 7: cat = LC_MESSAGES; break; |
| #endif |
| #ifdef LC_PAPER |
| case 8: cat = LC_PAPER; break; |
| #endif |
| #ifdef LC_MEASUREMENT |
| case 9: cat = LC_MEASUREMENT; break; |
| #endif |
| default: cat = NA_INTEGER; |
| } |
| if (cat != NA_INTEGER) p = setlocale(cat, NULL); |
| return mkString(p ? p : ""); |
| } |
| |
| /* Locale specs are always ASCII */ |
| SEXP attribute_hidden do_setlocale(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP locale = CADR(args), ans; |
| int cat; |
| const char *p; |
| |
| checkArity(op, args); |
| cat = asInteger(CAR(args)); |
| if (cat == NA_INTEGER || cat < 0) |
| error(_("invalid '%s' argument"), "category"); |
| if (!isString(locale) || LENGTH(locale) != 1) |
| error(_("invalid '%s' argument"), "locale"); |
| switch(cat) { |
| case 1: |
| { |
| const char *l = CHAR(STRING_ELT(locale, 0)); |
| cat = LC_ALL; |
| /* assume we can set LC_CTYPE iff we can set the rest */ |
| if ((p = setlocale(LC_CTYPE, l))) { |
| setlocale(LC_COLLATE, l); |
| /* disable the collator when setting to C to take |
| precedence over R_ICU_LOCALE */ |
| resetICUcollator(!strcmp(l, "C")); |
| setlocale(LC_MONETARY, l); |
| setlocale(LC_TIME, l); |
| dt_invalidate_locale(); |
| /* Need to return value of LC_ALL */ |
| p = setlocale(cat, NULL); |
| } |
| break; |
| } |
| case 2: |
| { |
| const char *l = CHAR(STRING_ELT(locale, 0)); |
| cat = LC_COLLATE; |
| p = setlocale(cat, l); |
| /* disable the collator when setting to C to take |
| precedence over R_ICU_LOCALE */ |
| resetICUcollator(!strcmp(l, "C")); |
| break; |
| } |
| case 3: |
| cat = LC_CTYPE; |
| p = setlocale(cat, CHAR(STRING_ELT(locale, 0))); |
| break; |
| case 4: |
| cat = LC_MONETARY; |
| p = setlocale(cat, CHAR(STRING_ELT(locale, 0))); |
| break; |
| case 5: |
| cat = LC_NUMERIC; |
| { |
| const char *new_lc_num = CHAR(STRING_ELT(locale, 0)); |
| if (strcmp(new_lc_num, "C")) /* do not complain about C locale - that's the only |
| reliable way to restore sanity */ |
| warning(_("setting 'LC_NUMERIC' may cause R to function strangely")); |
| p = setlocale(cat, new_lc_num); |
| } |
| break; |
| case 6: |
| cat = LC_TIME; |
| p = setlocale(cat, CHAR(STRING_ELT(locale, 0))); |
| dt_invalidate_locale(); |
| break; |
| #if defined LC_MESSAGES |
| case 7: |
| cat = LC_MESSAGES; |
| #ifdef Win32 |
| /* this seems to exist in MinGW, but it does not work in Windows */ |
| warning(_("LC_MESSAGES exists on Windows but is not operational")); |
| p = NULL; |
| #else |
| p = setlocale(cat, CHAR(STRING_ELT(locale, 0))); |
| #endif |
| break; |
| #endif |
| #ifdef LC_PAPER |
| case 8: |
| cat = LC_PAPER; |
| p = setlocale(cat, CHAR(STRING_ELT(locale, 0))); |
| break; |
| #endif |
| #ifdef LC_MEASUREMENT |
| case 9: |
| cat = LC_MEASUREMENT; |
| p = setlocale(cat, CHAR(STRING_ELT(locale, 0))); |
| break; |
| #endif |
| default: |
| p = NULL; /* -Wall */ |
| error(_("invalid '%s' argument"), "category"); |
| } |
| PROTECT(ans = allocVector(STRSXP, 1)); |
| if (p) SET_STRING_ELT(ans, 0, mkChar(p)); |
| else { |
| SET_STRING_ELT(ans, 0, mkChar("")); |
| warning(_("OS reports request to set locale to \"%s\" cannot be honored"), |
| CHAR(STRING_ELT(locale, 0))); |
| } |
| UNPROTECT(1); |
| R_check_locale(); |
| invalidate_cached_recodings(); |
| return ans; |
| } |
| |
| |
| |
| SEXP attribute_hidden do_localeconv(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP ans, ansnames; |
| struct lconv *lc = localeconv(); |
| int i = 0; |
| char buff[20]; |
| |
| checkArity(op, args); |
| PROTECT(ans = allocVector(STRSXP, 18)); |
| PROTECT(ansnames = allocVector(STRSXP, 18)); |
| SET_STRING_ELT(ans, i, mkChar(lc->decimal_point)); |
| SET_STRING_ELT(ansnames, i++, mkChar("decimal_point")); |
| SET_STRING_ELT(ans, i, mkChar(lc->thousands_sep)); |
| SET_STRING_ELT(ansnames, i++, mkChar("thousands_sep")); |
| SET_STRING_ELT(ans, i, mkChar(lc->grouping)); |
| SET_STRING_ELT(ansnames, i++, mkChar("grouping")); |
| SET_STRING_ELT(ans, i, mkChar(lc->int_curr_symbol)); |
| SET_STRING_ELT(ansnames, i++, mkChar("int_curr_symbol")); |
| SET_STRING_ELT(ans, i, mkChar(lc->currency_symbol)); |
| SET_STRING_ELT(ansnames, i++, mkChar("currency_symbol")); |
| SET_STRING_ELT(ans, i, mkChar(lc->mon_decimal_point)); |
| SET_STRING_ELT(ansnames, i++, mkChar("mon_decimal_point")); |
| SET_STRING_ELT(ans, i, mkChar(lc->mon_thousands_sep)); |
| SET_STRING_ELT(ansnames, i++, mkChar("mon_thousands_sep")); |
| SET_STRING_ELT(ans, i, mkChar(lc->mon_grouping)); |
| SET_STRING_ELT(ansnames, i++, mkChar("mon_grouping")); |
| SET_STRING_ELT(ans, i, mkChar(lc->positive_sign)); |
| SET_STRING_ELT(ansnames, i++, mkChar("positive_sign")); |
| SET_STRING_ELT(ans, i, mkChar(lc->negative_sign)); |
| SET_STRING_ELT(ansnames, i++, mkChar("negative_sign")); |
| sprintf(buff, "%d", (int)lc->int_frac_digits); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("int_frac_digits")); |
| sprintf(buff, "%d", (int)lc->frac_digits); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("frac_digits")); |
| sprintf(buff, "%d", (int)lc->p_cs_precedes); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("p_cs_precedes")); |
| sprintf(buff, "%d", (int)lc->p_sep_by_space); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("p_sep_by_space")); |
| sprintf(buff, "%d", (int)lc->n_cs_precedes); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("n_cs_precedes")); |
| sprintf(buff, "%d", (int)lc->n_sep_by_space); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("n_sep_by_space")); |
| sprintf(buff, "%d", (int)lc->p_sign_posn); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("p_sign_posn")); |
| sprintf(buff, "%d", (int)lc->n_sign_posn); |
| SET_STRING_ELT(ans, i, mkChar(buff)); |
| SET_STRING_ELT(ansnames, i++, mkChar("n_sign_posn")); |
| setAttrib(ans, R_NamesSymbol, ansnames); |
| UNPROTECT(2); |
| return ans; |
| } |
| |
| /* .Internal function for path.expand */ |
| SEXP attribute_hidden do_pathexpand(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP fn, ans; |
| int i, n; |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| if (!isString(fn)) |
| error(_("invalid '%s' argument"), "path"); |
| n = LENGTH(fn); |
| PROTECT(ans = allocVector(STRSXP, n)); |
| for (i = 0; i < n; i++) { |
| SEXP tmp = STRING_ELT(fn, i); |
| if (tmp != NA_STRING) { |
| #ifndef Win32 |
| tmp = markKnown(R_ExpandFileName(translateChar(tmp)), tmp); |
| #else |
| /* Windows can have files and home directories that aren't representable in the native encoding (e.g. latin1), so |
| we need to translate everything to UTF8. */ |
| tmp = mkCharCE(R_ExpandFileNameUTF8(translateCharUTF8(tmp)), CE_UTF8); |
| #endif |
| } |
| SET_STRING_ELT(ans, i, tmp); |
| } |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| #ifdef Unix |
| static int var_R_can_use_X11 = -1; |
| |
| extern Rboolean R_access_X11(void); /* from src/unix/X11.c */ |
| |
| static Rboolean R_can_use_X11(void) |
| { |
| if (var_R_can_use_X11 < 0) { |
| #ifdef HAVE_X11 |
| if (strcmp(R_GUIType, "none") != 0) { |
| /* At this point we have permission to use the module, so try it */ |
| var_R_can_use_X11 = R_access_X11(); |
| } else { |
| var_R_can_use_X11 = 0; |
| } |
| #else |
| var_R_can_use_X11 = 0; |
| #endif |
| } |
| |
| return var_R_can_use_X11 > 0; |
| } |
| #endif |
| |
| /* only actually used on Unix */ |
| SEXP attribute_hidden do_capabilitiesX11(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| #ifdef Unix |
| return ScalarLogical(R_can_use_X11()); |
| #else |
| return ScalarLogical(FALSE); |
| #endif |
| } |
| |
| SEXP attribute_hidden do_capabilities(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP ans, ansnames; |
| int i = 0; |
| #ifdef Unix |
| # ifdef HAVE_X11 |
| int X11 = NA_LOGICAL; |
| # else |
| int X11 = FALSE; |
| # endif |
| #endif |
| |
| checkArity(op, args); |
| |
| PROTECT(ans = allocVector(LGLSXP, 18)); |
| PROTECT(ansnames = allocVector(STRSXP, 18)); |
| |
| SET_STRING_ELT(ansnames, i, mkChar("jpeg")); |
| #ifdef HAVE_JPEG |
| # if defined Unix && !defined HAVE_WORKING_CAIRO |
| LOGICAL(ans)[i++] = X11; |
| # else |
| LOGICAL(ans)[i++] = TRUE; |
| # endif |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("png")); |
| #ifdef HAVE_PNG |
| # if defined Unix && !defined HAVE_WORKING_CAIRO |
| LOGICAL(ans)[i++] = X11; |
| # else /* Windows */ |
| LOGICAL(ans)[i++] = TRUE; |
| # endif |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("tiff")); |
| #ifdef HAVE_TIFF |
| # if defined Unix && !defined HAVE_WORKING_CAIRO |
| LOGICAL(ans)[i++] = X11; |
| # else /* Windows */ |
| LOGICAL(ans)[i++] = TRUE; |
| # endif |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("tcltk")); |
| #ifdef HAVE_TCLTK |
| LOGICAL(ans)[i++] = TRUE; |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("X11")); |
| #ifdef HAVE_X11 |
| # if defined(Unix) |
| LOGICAL(ans)[i++] = X11; |
| # else |
| LOGICAL(ans)[i++] = TRUE; |
| # endif |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("aqua")); |
| #ifdef HAVE_AQUA |
| LOGICAL(ans)[i++] = TRUE; |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("http/ftp")); |
| LOGICAL(ans)[i++] = TRUE; |
| |
| SET_STRING_ELT(ansnames, i, mkChar("sockets")); |
| LOGICAL(ans)[i++] = TRUE; |
| |
| SET_STRING_ELT(ansnames, i, mkChar("libxml")); |
| LOGICAL(ans)[i++] = TRUE; |
| |
| SET_STRING_ELT(ansnames, i, mkChar("fifo")); |
| #if (defined(HAVE_MKFIFO) && defined(HAVE_FCNTL_H)) || defined(_WIN32) |
| LOGICAL(ans)[i++] = TRUE; |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| /* This one is complex. Set it to be true only in interactive use, |
| with the Windows and GNOME GUIs (but not Tk GUI) or under Unix |
| if readline is available and in use. */ |
| SET_STRING_ELT(ansnames, i, mkChar("cledit")); |
| LOGICAL(ans)[i] = FALSE; |
| #if defined(Win32) |
| if (R_Interactive) LOGICAL(ans)[i] = TRUE; |
| #endif |
| #ifdef Unix |
| if (strcmp(R_GUIType, "GNOME") == 0) { /* always interactive */ |
| LOGICAL(ans)[i] = TRUE; /* also AQUA ? */ |
| } else { |
| #if defined(HAVE_LIBREADLINE) && defined(HAVE_READLINE_HISTORY_H) |
| extern Rboolean UsingReadline; |
| if (R_Interactive && UsingReadline) LOGICAL(ans)[i] = TRUE; |
| #endif |
| } |
| #endif |
| i++; |
| |
| /* always true as from R 2.10.0 */ |
| SET_STRING_ELT(ansnames, i, mkChar("iconv")); |
| LOGICAL(ans)[i++] = TRUE; |
| |
| SET_STRING_ELT(ansnames, i, mkChar("NLS")); |
| #ifdef ENABLE_NLS |
| LOGICAL(ans)[i++] = TRUE; |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("profmem")); |
| #ifdef R_MEMORY_PROFILING |
| LOGICAL(ans)[i++] = TRUE; |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("cairo")); |
| #ifdef HAVE_WORKING_CAIRO |
| LOGICAL(ans)[i++] = TRUE; |
| #elif defined(Win32) |
| { |
| /* This is true iff winCairo.dll is available */ |
| struct stat sb; |
| char path[1000]; |
| snprintf(path, 1000, "%s/library/grDevices/libs/%s/winCairo.dll", |
| R_HomeDir(), R_ARCH); |
| LOGICAL(ans)[i++] = stat(path, &sb) == 0; |
| } |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("ICU")); |
| #ifdef USE_ICU |
| LOGICAL(ans)[i++] = TRUE; |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| SET_STRING_ELT(ansnames, i, mkChar("long.double")); |
| LOGICAL(ans)[i++] = sizeof(LDOUBLE) > sizeof(double); |
| |
| SET_STRING_ELT(ansnames, i, mkChar("libcurl")); |
| #ifdef HAVE_LIBCURL |
| LOGICAL(ans)[i++] = TRUE; |
| #else |
| LOGICAL(ans)[i++] = FALSE; |
| #endif |
| |
| |
| setAttrib(ans, R_NamesSymbol, ansnames); |
| UNPROTECT(2); |
| return ans; |
| } |
| |
| SEXP attribute_hidden do_sysgetpid(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| return ScalarInteger(getpid()); |
| } |
| |
| |
| /* NB: we save errno immediately after the call here. This should not |
| be necessary on a POSIX OS, but it is on Windows, where it seems |
| that on some versions strerror itself changes errno (something |
| allowed in C99 but disallowed in POSIX). Also, something under |
| warning() might set errno in a future version. |
| */ |
| #ifndef Win32 |
| /* mkdir is defined in <sys/stat.h> */ |
| SEXP attribute_hidden do_dircreate(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP path; |
| int res, show, recursive, mode, serrno = 0; |
| char *p, dir[PATH_MAX]; |
| |
| checkArity(op, args); |
| path = CAR(args); |
| if (!isString(path) || LENGTH(path) != 1) |
| error(_("invalid '%s' argument"), "path"); |
| if (STRING_ELT(path, 0) == NA_STRING) return ScalarLogical(FALSE); |
| show = asLogical(CADR(args)); |
| if (show == NA_LOGICAL) show = 0; |
| recursive = asLogical(CADDR(args)); |
| if (recursive == NA_LOGICAL) recursive = 0; |
| mode = asInteger(CADDDR(args)); |
| if (mode == NA_LOGICAL) mode = 0777; |
| strcpy(dir, R_ExpandFileName(translateChar(STRING_ELT(path, 0)))); |
| /* remove trailing slashes */ |
| p = dir + strlen(dir) - 1; |
| while (*p == '/' && strlen(dir) > 1) *p-- = '\0'; |
| if (recursive) { |
| p = dir; |
| while ((p = Rf_strchr(p+1, '/'))) { |
| *p = '\0'; |
| struct stat sb; |
| res = stat(dir, &sb); |
| if (res == 0) { |
| if (! S_ISDIR (sb.st_mode)) { |
| /* file already exists but is not a directory */ |
| res = -1; |
| serrno = ENOTDIR; |
| goto end; |
| } |
| } else if (errno != ENOENT || !*dir) { |
| serrno = errno; |
| goto end; |
| } else |
| res = mkdir(dir, (mode_t) mode); |
| |
| /* Solaris 10 returns ENOSYS on automount, PR#13834 |
| EROFS is allowed by POSIX, so we skip that too */ |
| serrno = errno; |
| if (res && serrno != EEXIST && serrno != ENOSYS && serrno != EROFS) |
| goto end; |
| *p = '/'; |
| } |
| } |
| res = mkdir(dir, (mode_t) mode); |
| serrno = errno; |
| if (show && res && serrno == EEXIST) |
| warning(_("'%s' already exists"), dir); |
| end: |
| if (show && res && serrno != EEXIST) |
| warning(_("cannot create dir '%s', reason '%s'"), dir, |
| strerror(serrno)); |
| return ScalarLogical(res == 0); |
| } |
| #else /* Win32 */ |
| #include <io.h> /* mkdir is defined here */ |
| SEXP attribute_hidden do_dircreate(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP path; |
| wchar_t *p, dir[MAX_PATH]; |
| int res, show, recursive, serrno = 0, maybeshare; |
| |
| checkArity(op, args); |
| path = CAR(args); |
| if (!isString(path) || LENGTH(path) != 1) |
| error(_("invalid '%s' argument"), "path"); |
| if (STRING_ELT(path, 0) == NA_STRING) return ScalarLogical(FALSE); |
| show = asLogical(CADR(args)); |
| if (show == NA_LOGICAL) show = 0; |
| recursive = asLogical(CADDR(args)); |
| if (recursive == NA_LOGICAL) recursive = 0; |
| p = filenameToWchar(STRING_ELT(path, 0), TRUE); |
| if (wcslen(p) >= MAX_PATH) |
| error(_("'%s' too long"), "path"); |
| wcsncpy(dir, p, MAX_PATH); |
| for (p = dir; *p; p++) if (*p == L'/') *p = L'\\'; |
| /* remove trailing slashes */ |
| p = dir + wcslen(dir) - 1; |
| while (*p == L'\\' && wcslen(dir) > 1 && *(p-1) != L':') *p-- = L'\0'; |
| if (recursive) { |
| p = dir; |
| maybeshare = 0; |
| /* skip leading \\server\\share, \\share */ |
| /* FIXME: is \\share (still) possible? */ |
| if (*p == L'\\' && *(p+1) == L'\\') { |
| p += 2; |
| p = wcschr(p, L'\\'); |
| maybeshare = 1; /* the next element may be a share name */ |
| } |
| while ((p = wcschr(p+1, L'\\'))) { |
| *p = L'\0'; |
| if (*(p-1) != L':') { |
| res = _wmkdir(dir); |
| serrno = errno; |
| if (res && serrno != EEXIST && !maybeshare) goto end; |
| } |
| maybeshare = 0; |
| *p = L'\\'; |
| } |
| } |
| res = _wmkdir(dir); |
| serrno = errno; |
| if (show && res) { |
| if (serrno == EEXIST) |
| warning(_("'%ls' already exists"), dir); |
| else |
| warning(_("cannot create dir '%ls', reason '%s'"), dir, |
| strerror(serrno)); |
| } |
| return ScalarLogical(res == 0); |
| end: |
| if (show && res && serrno != EEXIST) |
| warning(_("cannot create dir '%ls', reason '%s'"), dir, |
| strerror(serrno)); |
| return ScalarLogical(res == 0); |
| } |
| #endif |
| |
| /* take file/dir 'name' in dir 'from' and copy it to 'to' |
| 'from', 'to' should have trailing path separator if needed. |
| */ |
| #ifdef Win32 |
| static void copyFileTime(const wchar_t *from, const wchar_t * to) |
| { |
| HANDLE hFrom, hTo; |
| FILETIME modft; |
| |
| hFrom = CreateFileW(from, GENERIC_READ, 0, NULL, OPEN_EXISTING, |
| FILE_FLAG_BACKUP_SEMANTICS, NULL); |
| if (hFrom == INVALID_HANDLE_VALUE) return; |
| int res = GetFileTime(hFrom, NULL, NULL, &modft); |
| CloseHandle(hFrom); |
| if(!res) return; |
| |
| hTo = CreateFileW(to, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, |
| FILE_FLAG_BACKUP_SEMANTICS, NULL); |
| if (hTo == INVALID_HANDLE_VALUE) return; |
| SetFileTime(hTo, NULL, NULL, &modft); |
| CloseHandle(hTo); |
| } |
| |
| static int do_copy(const wchar_t* from, const wchar_t* name, const wchar_t* to, |
| int over, int recursive, int perms, int dates, int depth) |
| { |
| R_CheckUserInterrupt(); // includes stack check |
| if(depth > 100) { |
| warning(_("too deep nesting")); |
| return 1; |
| } |
| struct _stati64 sb; |
| int nc, nfail = 0, res; |
| wchar_t dest[PATH_MAX + 1], this[PATH_MAX + 1]; |
| |
| if (wcslen(from) + wcslen(name) >= PATH_MAX) { |
| warning(_("over-long path")); |
| return 1; |
| } |
| wsprintfW(this, L"%ls%ls", from, name); |
| _wstati64(this, &sb); |
| if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */ |
| _WDIR *dir; |
| struct _wdirent *de; |
| wchar_t p[PATH_MAX + 1]; |
| |
| if (!recursive) return 1; |
| nc = wcslen(to); |
| if (wcslen(to) + wcslen(name) >= PATH_MAX) { |
| warning(_("over-long path")); |
| return 1; |
| } |
| wsprintfW(dest, L"%ls%ls", to, name); |
| /* We could set the mode (only the 200 part matters) later */ |
| res = _wmkdir(dest); |
| if (res) { |
| if (errno == EEXIST) { |
| struct _stati64 dsb; |
| if (over && _wstati64(dest, &dsb) == 0 && |
| (dsb.st_mode & S_IFDIR) == 0) { |
| |
| warning(_("cannot overwrite non-directory %ls with directory %ls"), |
| dest, this); |
| return 1; |
| } |
| } else { |
| warning(_("problem creating directory %ls: %s"), |
| dest, strerror(errno)); |
| return 1; |
| } |
| } |
| // NB Windows' mkdir appears to require \ not /. |
| if ((dir = _wopendir(this)) != NULL) { |
| depth++; |
| while ((de = _wreaddir(dir))) { |
| if (!wcscmp(de->d_name, L".") || !wcscmp(de->d_name, L"..")) |
| continue; |
| if (wcslen(name) + wcslen(de->d_name) + 1 >= PATH_MAX) { |
| warning(_("over-long path")); |
| return 1; |
| } |
| wsprintfW(p, L"%ls%\\%ls", name, de->d_name); |
| nfail += do_copy(from, p, to, over, recursive, |
| perms, dates, depth); |
| } |
| _wclosedir(dir); |
| } else { |
| warning(_("problem reading dir %ls: %s"), this, strerror(errno)); |
| nfail++; /* we were unable to read a dir */ |
| } |
| if(dates) copyFileTime(this, dest); |
| } else { /* a file */ |
| FILE *fp1 = NULL, *fp2 = NULL; |
| wchar_t buf[APPENDBUFSIZE]; |
| |
| nfail = 0; |
| nc = wcslen(to); |
| if (nc + wcslen(name) >= PATH_MAX) { |
| warning(_("over-long path length")); |
| nfail++; |
| goto copy_error; |
| } |
| wsprintfW(dest, L"%ls%ls", to, name); |
| if (over || !R_WFileExists(dest)) { /* FIXME */ |
| if ((fp1 = _wfopen(this, L"rb")) == NULL || |
| (fp2 = _wfopen(dest, L"wb")) == NULL) { |
| warning(_("problem copying %ls to %ls: %s"), |
| this, dest, strerror(errno)); |
| nfail++; |
| goto copy_error; |
| } |
| while ((nc = fread(buf, 1, APPENDBUFSIZE, fp1)) == APPENDBUFSIZE) |
| if (fwrite(buf, 1, APPENDBUFSIZE, fp2) != APPENDBUFSIZE) { |
| nfail++; |
| goto copy_error; |
| } |
| if (fwrite(buf, 1, nc, fp2) != nc) { |
| nfail++; |
| goto copy_error; |
| } |
| } else if (!over) { |
| nfail++; |
| goto copy_error; |
| } |
| if(fp1) fclose(fp1); |
| fp1 = NULL; |
| if(fp2) fclose(fp2); |
| fp2 = NULL; |
| /* FIXME: perhaps manipulate mode as we do in Sys.chmod? */ |
| if(perms) _wchmod(dest, sb.st_mode & 0777); |
| if(dates) copyFileTime(this, dest); |
| copy_error: |
| if(fp2) fclose(fp2); |
| if(fp1) fclose(fp1); |
| } |
| return nfail; |
| } |
| |
| /* file.copy(files, dir, over, recursive=TRUE, perms), only */ |
| SEXP attribute_hidden do_filecopy(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP fn, to, ans; |
| wchar_t *p, dir[PATH_MAX], from[PATH_MAX], name[PATH_MAX]; |
| int i, nfiles, over, recursive, perms, dates, nfail; |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| nfiles = length(fn); |
| PROTECT(ans = allocVector(LGLSXP, nfiles)); |
| if (nfiles > 0) { |
| args = CDR(args); |
| if (!isString(fn)) |
| error(_("invalid '%s' argument"), "from"); |
| to = CAR(args); args = CDR(args); |
| if (!isString(to) || LENGTH(to) != 1) |
| error(_("invalid '%s' argument"), "to"); |
| over = asLogical(CAR(args)); args = CDR(args); |
| if (over == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "overwrite"); |
| recursive = asLogical(CAR(args)); args = CDR(args); |
| if (recursive == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "recursive"); |
| perms = asLogical(CAR(args)); args = CDR(args); |
| if (perms == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "copy.mode"); |
| dates = asLogical(CAR(args)); |
| if (dates == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "copy.dates"); |
| p = filenameToWchar(STRING_ELT(to, 0), TRUE); |
| if (wcslen(p) >= PATH_MAX) |
| error(_("'%s' path too long"), "to"); |
| wcsncpy(dir, p, PATH_MAX); |
| dir[PATH_MAX - 1] = L'\0'; |
| if (*(dir + (wcslen(dir) - 1)) != L'\\') |
| wcsncat(dir, L"\\", PATH_MAX); |
| for (i = 0; i < nfiles; i++) { |
| if (STRING_ELT(fn, i) != NA_STRING) { |
| p = filenameToWchar(STRING_ELT(fn, i), TRUE); |
| if (wcslen(p) >= PATH_MAX) |
| error(_("'%s' path too long"), "from"); |
| wcsncpy(from, p, PATH_MAX); |
| from[PATH_MAX - 1] = L'\0'; |
| if(wcslen(from)) { |
| /* If there was a trailing sep, this is a mistake */ |
| p = from + (wcslen(from) - 1); |
| if(*p == L'\\') *p = L'\0'; |
| p = wcsrchr(from, L'\\') ; |
| if (p) { |
| wcsncpy(name, p+1, PATH_MAX); |
| name[PATH_MAX - 1] = L'\0'; |
| *(p+1) = L'\0'; |
| } else { |
| if(wcslen(from) > 2 && from[1] == L':') { |
| wcsncpy(name, from+2, PATH_MAX); |
| name[PATH_MAX - 1] = L'\0'; |
| from[2] = L'\0'; |
| } else { |
| wcsncpy(name, from, PATH_MAX); |
| name[PATH_MAX - 1] = L'\0'; |
| wcsncpy(from, L".\\", PATH_MAX); |
| } |
| } |
| nfail = do_copy(from, name, dir, over, recursive, |
| perms, dates, 1); |
| } else nfail = 1; |
| } else nfail = 1; |
| LOGICAL(ans)[i] = (nfail == 0); |
| } |
| } |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| #else |
| |
| /* Only 10.13 (High Sierra) has this, but the headers in Xcode 9 on 10.12 |
| declare it, for some people. */ |
| #if defined(__APPLE__) && defined(MACOS_SIERRA) |
| # undef HAVE_UTIMENSAT |
| #endif |
| |
| #if defined(HAVE_UTIMENSAT) |
| # include <fcntl.h> |
| # include <sys/stat.h> |
| #elif defined(HAVE_UTIMES) |
| # include <sys/time.h> |
| #elif defined(HAVE_UTIME) |
| # include <utime.h> |
| #endif |
| |
| static void copyFileTime(const char *from, const char * to) |
| { |
| struct stat sb; |
| if(stat(from, &sb)) return; |
| double ftime; |
| |
| #ifdef STAT_TIMESPEC |
| ftime = (double) STAT_TIMESPEC(sb, st_mtim).tv_sec |
| + 1e-9 * (double) STAT_TIMESPEC(sb, st_mtim).tv_nsec; |
| #elif defined STAT_TIMESPEC_NS |
| ftime = STAT_TIMESPEC_NS (sb, st_mtim); |
| #else |
| ftime = (double) sb.st_mtime; |
| #endif |
| |
| #if defined(HAVE_UTIMENSAT) |
| struct timespec times[2]; |
| |
| times[0].tv_sec = times[1].tv_sec = (int)ftime; |
| times[0].tv_nsec = times[1].tv_nsec = (int)(1e9*(ftime - (int)ftime)); |
| utimensat(AT_FDCWD, to, times, 0); |
| #elif defined(HAVE_UTIMES) |
| struct timeval times[2]; |
| |
| times[0].tv_sec = times[1].tv_sec = (int)ftime; |
| times[0].tv_usec = times[1].tv_usec = (int)(1e6*(ftime - (int)ftime)); |
| utimes(to, times); |
| #elif defined(HAVE_UTIME) |
| struct utimbuf settime; |
| |
| settime.actime = settime.modtime = (int)ftime; |
| utime(to, &settime); |
| #endif |
| } |
| |
| static int do_copy(const char* from, const char* name, const char* to, |
| int over, int recursive, int perms, int dates, int depth) |
| { |
| R_CheckUserInterrupt(); // includes stack check |
| if(depth > 100) { |
| warning(_("too deep nesting")); |
| return 1; |
| } |
| |
| struct stat sb; |
| int nfail = 0, res, mask; |
| char dest[PATH_MAX+1], this[PATH_MAX+1]; |
| |
| #ifdef HAVE_UMASK |
| int um = umask(0); umask((mode_t) um); |
| mask = 0777 & ~um; |
| #else |
| mask = 0777; |
| #endif |
| /* REprintf("from: %s, name: %s, to: %s\n", from, name, to); */ |
| if (strlen(from) + strlen(name) >= PATH_MAX) { |
| warning(_("over-long path length")); |
| return 1; |
| } |
| snprintf(this, PATH_MAX+1, "%s%s", from, name); |
| /* Here we want the target not the link */ |
| stat(this, &sb); |
| if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */ |
| DIR *dir; |
| struct dirent *de; |
| char p[PATH_MAX+1]; |
| |
| if (!recursive) return 1; |
| if (strlen(to) + strlen(name) >= PATH_MAX) { |
| warning(_("over-long path length")); |
| return 1; |
| } |
| snprintf(dest, PATH_MAX+1, "%s%s", to, name); |
| /* If a directory does not have write permission for the user, |
| we will fail to create files in that directory, so defer |
| setting mode */ |
| res = mkdir(dest, 0700); |
| if (res) { |
| if (errno == EEXIST) { |
| struct stat dsb; |
| if (over && stat(dest, &dsb) == 0 && |
| (dsb.st_mode & S_IFDIR) == 0) { |
| |
| warning(_("cannot overwrite non-directory %s with directory %s"), |
| dest, this); |
| return 1; |
| } |
| } else { |
| warning(_("problem creating directory %s: %s"), |
| this, strerror(errno)); |
| return 1; |
| } |
| } |
| strcat(dest, "/"); |
| if ((dir = opendir(this)) != NULL) { |
| depth++; |
| while ((de = readdir(dir))) { |
| if (streql(de->d_name, ".") || streql(de->d_name, "..")) |
| continue; |
| if (strlen(name) + strlen(de->d_name) + 1 >= PATH_MAX) { |
| warning(_("over-long path length")); |
| closedir(dir); |
| return 1; |
| } |
| snprintf(p, PATH_MAX+1, "%s/%s", name, de->d_name); |
| nfail += do_copy(from, p, to, over, recursive, |
| perms, dates, depth); |
| } |
| closedir(dir); |
| } else { |
| warning(_("problem reading directory %s: %s"), |
| this, strerror(errno)); |
| nfail++; /* we were unable to read a dir */ |
| } |
| chmod(dest, (mode_t) (perms ? (sb.st_mode & mask): mask)); |
| if(dates) copyFileTime(this, dest); |
| } else { /* a file */ |
| FILE *fp1 = NULL, *fp2 = NULL; |
| char buf[APPENDBUFSIZE]; |
| |
| nfail = 0; |
| size_t nc = strlen(to); |
| if (strlen(to) + strlen(name) >= PATH_MAX) { |
| warning(_("over-long path length")); |
| nfail++; |
| goto copy_error; |
| } |
| snprintf(dest, PATH_MAX+1, "%s%s", to, name); |
| if (over || !R_FileExists(dest)) { |
| /* REprintf("copying %s to %s\n", this, dest); */ |
| if ((fp1 = R_fopen(this, "rb")) == NULL || |
| (fp2 = R_fopen(dest, "wb")) == NULL) { |
| warning(_("problem copying %s to %s: %s"), |
| this, dest, strerror(errno)); |
| nfail++; |
| goto copy_error; |
| } |
| while ((nc = fread(buf, 1, APPENDBUFSIZE, fp1)) == APPENDBUFSIZE) |
| if (fwrite(buf, 1, APPENDBUFSIZE, fp2) != APPENDBUFSIZE) { |
| nfail++; |
| goto copy_error; |
| } |
| if (fwrite(buf, 1, nc, fp2) != nc) { |
| nfail++; |
| goto copy_error; |
| } |
| if(fp2) {fclose(fp2); fp2 = NULL;} |
| if(perms) chmod(dest, sb.st_mode & mask); |
| if(dates) copyFileTime(this, dest); |
| } else if (!over) |
| nfail++; |
| copy_error: |
| if(fp2) fclose(fp2); |
| if(fp1) fclose(fp1); |
| } |
| return nfail; |
| } |
| |
| /* file.copy(files, dir, recursive), only */ |
| SEXP attribute_hidden do_filecopy(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP fn, to, ans; |
| char *p, dir[PATH_MAX], from[PATH_MAX], name[PATH_MAX]; |
| int i, nfiles, over, recursive, perms, dates, nfail; |
| |
| checkArity(op, args); |
| fn = CAR(args); |
| nfiles = length(fn); |
| PROTECT(ans = allocVector(LGLSXP, nfiles)); |
| if (nfiles > 0) { |
| args = CDR(args); |
| if (!isString(fn)) |
| error(_("invalid '%s' argument"), "from"); |
| to = CAR(args); args = CDR(args); |
| if (!isString(to) || LENGTH(to) != 1) |
| error(_("invalid '%s' argument"), "to"); |
| over = asLogical(CAR(args)); args = CDR(args); |
| if (over == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "overwrite"); |
| recursive = asLogical(CAR(args)); args = CDR(args); |
| if (recursive == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "recursive"); |
| perms = asLogical(CAR(args)); args = CDR(args); |
| if (perms == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "copy.mode"); |
| dates = asLogical(CAR(args)); |
| if (dates == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "copy.dates"); |
| const char* q = R_ExpandFileName(translateChar(STRING_ELT(to, 0))); |
| if(strlen(q) > PATH_MAX - 2) // allow for '/' and terminator |
| error(_("invalid '%s' argument"), "to"); |
| strncpy(dir, q, PATH_MAX); |
| dir[PATH_MAX - 1] = '\0'; |
| if (*(dir + (strlen(dir) - 1)) != '/') |
| strcat(dir, "/"); |
| for (i = 0; i < nfiles; i++) { |
| if (STRING_ELT(fn, i) != NA_STRING) { |
| strncpy(from, |
| R_ExpandFileName(translateChar(STRING_ELT(fn, i))), |
| PATH_MAX - 1); |
| from[PATH_MAX - 1] = '\0'; |
| size_t ll = strlen(from); |
| if (ll) { // people do pass "" |
| /* If there is a trailing sep, this is a mistake */ |
| p = from + (ll - 1); |
| if(*p == '/') *p = '\0'; |
| p = strrchr(from, '/') ; |
| if (p) { |
| strncpy(name, p+1, PATH_MAX - 1); |
| name[PATH_MAX - 1] = '\0'; |
| *(p+1) = '\0'; |
| } else { |
| strncpy(name, from, PATH_MAX); |
| name[PATH_MAX - 1] = '\0'; |
| strncpy(from, "./", PATH_MAX); |
| } |
| nfail = do_copy(from, name, dir, over, recursive, |
| perms, dates, 1); |
| } else nfail = 1; |
| } else nfail = 1; |
| LOGICAL(ans)[i] = (nfail == 0); |
| } |
| } |
| UNPROTECT(1); |
| return ans; |
| } |
| #endif |
| |
| SEXP attribute_hidden do_l10n_info(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| #ifdef Win32 |
| int len = 4; |
| #else |
| int len = 3; |
| #endif |
| SEXP ans, names; |
| checkArity(op, args); |
| PROTECT(ans = allocVector(VECSXP, len)); |
| PROTECT(names = allocVector(STRSXP, len)); |
| SET_STRING_ELT(names, 0, mkChar("MBCS")); |
| SET_STRING_ELT(names, 1, mkChar("UTF-8")); |
| SET_STRING_ELT(names, 2, mkChar("Latin-1")); |
| SET_VECTOR_ELT(ans, 0, ScalarLogical(mbcslocale)); |
| SET_VECTOR_ELT(ans, 1, ScalarLogical(utf8locale)); |
| SET_VECTOR_ELT(ans, 2, ScalarLogical(latin1locale)); |
| #ifdef Win32 |
| SET_STRING_ELT(names, 3, mkChar("codepage")); |
| SET_VECTOR_ELT(ans, 3, ScalarInteger(localeCP)); |
| #endif |
| setAttrib(ans, R_NamesSymbol, names); |
| UNPROTECT(2); |
| return ans; |
| } |
| |
| /* do_normalizepath moved to util.c in R 2.13.0 */ |
| |
| SEXP attribute_hidden do_syschmod(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| #ifdef HAVE_CHMOD |
| SEXP paths, smode, ans; |
| int i, m, n, *modes, res; |
| mode_t um = 0; |
| |
| checkArity(op, args); |
| paths = CAR(args); |
| if (!isString(paths)) |
| error(_("invalid '%s' argument"), "paths"); |
| n = LENGTH(paths); |
| PROTECT(smode = coerceVector(CADR(args), INTSXP)); |
| modes = INTEGER(smode); |
| m = LENGTH(smode); |
| if(!m && n) error(_("'mode' must be of length at least one")); |
| int useUmask = asLogical(CADDR(args)); |
| if (useUmask == NA_LOGICAL) |
| error(_("invalid '%s' argument"), "use_umask"); |
| #ifdef HAVE_UMASK |
| um = umask(0); umask(um); |
| #endif |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (i = 0; i < n; i++) { |
| mode_t mode = (mode_t) modes[i % m]; |
| if (mode == NA_INTEGER) mode = 0777; |
| #ifdef HAVE_UMASK |
| if(useUmask) mode = mode & ~um; |
| #endif |
| #ifdef Win32 |
| /* Windows' _[w]chmod seems only to support read access |
| or read-write access. _S_IWRITE is 0200. |
| */ |
| mode = (mode & 0200) ? (_S_IWRITE | _S_IREAD): _S_IREAD; |
| #endif |
| if (STRING_ELT(paths, i) != NA_STRING) { |
| #ifdef Win32 |
| res = _wchmod(filenameToWchar(STRING_ELT(paths, i), TRUE), mode); |
| #else |
| res = chmod(R_ExpandFileName(translateChar(STRING_ELT(paths, i))), |
| mode); |
| #endif |
| } else res = 1; |
| LOGICAL(ans)[i] = (res == 0); |
| } |
| UNPROTECT(2); |
| return ans; |
| #else |
| SEXP paths, ans; |
| int i, n; |
| |
| checkArity(op, args); |
| paths = CAR(args); |
| if (!isString(paths)) |
| error(_("invalid '%s' argument"), "paths"); |
| n = LENGTH(paths); |
| warning("insufficient OS support on this platform"); |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| for (i = 0; i < n; i++) LOGICAL(ans)[i] = 0; |
| UNPROTECT(1); |
| return ans; |
| #endif |
| } |
| |
| SEXP attribute_hidden do_sysumask(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| SEXP ans; |
| int mode; |
| mode_t res = 0; |
| |
| checkArity(op, args); |
| mode = asInteger(CAR(args)); |
| #ifdef HAVE_UMASK |
| if (mode == NA_INTEGER) { |
| res = umask(0); |
| umask(res); |
| R_Visible = TRUE; |
| } else { |
| res = umask((mode_t) mode); |
| R_Visible = FALSE; |
| } |
| #else |
| warning(_("insufficient OS support on this platform")); |
| R_Visible = FALSE; |
| #endif |
| PROTECT(ans = ScalarInteger(res)); |
| setAttrib(ans, R_ClassSymbol, mkString("octmode")); |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| SEXP attribute_hidden do_readlink(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| checkArity(op, args); |
| SEXP paths = CAR(args); |
| if(!isString(paths)) |
| error(_("invalid '%s' argument"), "paths"); |
| int n = LENGTH(paths); |
| SEXP ans = PROTECT(allocVector(STRSXP, n)); |
| #ifdef HAVE_READLINK |
| char buf[PATH_MAX+1]; |
| for (int i = 0; i < n; i++) { |
| memset(buf, 0, PATH_MAX+1); |
| ssize_t res = |
| readlink(R_ExpandFileName(translateChar(STRING_ELT(paths, i))), |
| buf, PATH_MAX); |
| if (res == PATH_MAX) { |
| SET_STRING_ELT(ans, i, mkChar(buf)); |
| warning("possible truncation of value for element %d", i + 1); |
| } else if (res >= 0) SET_STRING_ELT(ans, i, mkChar(buf)); |
| else if (errno == EINVAL) SET_STRING_ELT(ans, i, mkChar("")); |
| else SET_STRING_ELT(ans, i, NA_STRING); |
| } |
| #endif |
| UNPROTECT(1); |
| return ans; |
| } |
| |
| |
| SEXP attribute_hidden do_Cstack_info(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP ans, nms; |
| |
| checkArity(op, args); |
| PROTECT(ans = allocVector(INTSXP, 4)); |
| PROTECT(nms = allocVector(STRSXP, 4)); |
| /* FIXME: could be out of range */ |
| INTEGER(ans)[0] = (R_CStackLimit == -1) ? NA_INTEGER : (int) R_CStackLimit; |
| INTEGER(ans)[1] = (R_CStackLimit == -1) ? NA_INTEGER : (int) |
| (R_CStackDir * (R_CStackStart - (uintptr_t) &ans)); |
| INTEGER(ans)[2] = R_CStackDir; |
| INTEGER(ans)[3] = R_EvalDepth; |
| SET_STRING_ELT(nms, 0, mkChar("size")); |
| SET_STRING_ELT(nms, 1, mkChar("current")); |
| SET_STRING_ELT(nms, 2, mkChar("direction")); |
| SET_STRING_ELT(nms, 3, mkChar("eval_depth")); |
| |
| UNPROTECT(2); |
| setAttrib(ans, R_NamesSymbol, nms); |
| return ans; |
| } |
| |
| #ifdef Win32 |
| static int winSetFileTime(const char *fn, double ftime) |
| { |
| SYSTEMTIME st; |
| FILETIME modft; |
| struct tm *utctm; |
| HANDLE hFile; |
| time_t ftimei = (time_t) ftime; |
| |
| utctm = gmtime(&ftimei); |
| if (!utctm) return 0; |
| |
| st.wYear = (WORD) utctm->tm_year + 1900; |
| st.wMonth = (WORD) utctm->tm_mon + 1; |
| st.wDayOfWeek = (WORD) utctm->tm_wday; |
| st.wDay = (WORD) utctm->tm_mday; |
| st.wHour = (WORD) utctm->tm_hour; |
| st.wMinute = (WORD) utctm->tm_min; |
| st.wSecond = (WORD) utctm->tm_sec; |
| st.wMilliseconds = (WORD) 1000*(ftime - ftimei); |
| if (!SystemTimeToFileTime(&st, &modft)) return 0; |
| |
| hFile = CreateFile(fn, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, |
| FILE_FLAG_BACKUP_SEMANTICS, NULL); |
| if (hFile == INVALID_HANDLE_VALUE) return 0; |
| int res = SetFileTime(hFile, NULL, NULL, &modft); |
| CloseHandle(hFile); |
| return res != 0; /* success is non-zero */ |
| } |
| #endif |
| |
| SEXP attribute_hidden |
| do_setFileTime(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| const char *fn; |
| double ftime; |
| int res; |
| R_xlen_t n, m; |
| SEXP paths, times, ans; |
| const void *vmax; |
| |
| paths = CAR(args); |
| if (!isString(paths)) |
| error(_("invalid '%s' argument"), "path"); |
| n = XLENGTH(paths); |
| PROTECT(times = coerceVector(CADR(args), REALSXP)); |
| m = XLENGTH(times); |
| if (!m && n) error(_("'%s' must be of length at least one"), "time"); |
| |
| PROTECT(ans = allocVector(LGLSXP, n)); |
| vmax = vmaxget(); |
| for(R_xlen_t i = 0; i < n; i++) { |
| fn = translateChar(STRING_ELT(paths, i)); |
| ftime = REAL(times)[i % m]; |
| #ifdef Win32 |
| res = winSetFileTime(fn, ftime); |
| #elif defined(HAVE_UTIMENSAT) |
| struct timespec times[2]; |
| |
| times[0].tv_sec = times[1].tv_sec = (int)ftime; |
| times[0].tv_nsec = times[1].tv_nsec = (int)(1e9*(ftime - (int)ftime)); |
| |
| res = utimensat(AT_FDCWD, fn, times, 0) == 0; |
| #elif defined(HAVE_UTIMES) |
| struct timeval times[2]; |
| |
| times[0].tv_sec = times[1].tv_sec = (int)ftime; |
| times[0].tv_usec = times[1].tv_usec = (int)(1e6*(ftime - (int)ftime)); |
| |
| res = utimes(fn, times) == 0; |
| #elif defined(HAVE_UTIME) |
| struct utimbuf settime; |
| |
| settime.actime = settime.modtime = (int)ftime; |
| res = utime(fn, &settime) == 0; |
| #endif |
| LOGICAL(ans)[i] = (res == 0) ? FALSE : TRUE; |
| fn = NULL; |
| vmaxset(vmax); // throws away result of translateChar |
| } |
| UNPROTECT(2); /* times, ans */ |
| return ans; |
| } |
| |
| #ifdef Win32 |
| /* based on ideas in |
| http://www.codeproject.com/KB/winsdk/junctionpoints.aspx |
| */ |
| typedef struct TMN_REPARSE_DATA_BUFFER |
| { |
| DWORD ReparseTag; |
| WORD ReparseDataLength; |
| WORD Reserved; |
| WORD SubstituteNameOffset; |
| WORD SubstituteNameLength; |
| WORD PrintNameOffset; |
| WORD PrintNameLength; |
| WCHAR PathBuffer[1024]; |
| } TMN_REPARSE_DATA_BUFFER; |
| |
| SEXP attribute_hidden do_mkjunction(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| wchar_t from[10000]; |
| const wchar_t *to; |
| |
| checkArity(op, args); |
| /* from and to are both directories: and to exists */ |
| wcscpy(from, filenameToWchar(STRING_ELT(CAR(args), 0), FALSE)); |
| to = filenameToWchar(STRING_ELT(CADR(args), 0), TRUE); |
| // printf("ln %ls %ls\n", from, to); |
| |
| HANDLE hd = |
| CreateFileW(to, GENERIC_READ | GENERIC_WRITE, 0, 0, OPEN_EXISTING, |
| FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, |
| 0); |
| if(hd == INVALID_HANDLE_VALUE) { |
| warning("cannot open reparse point '%ls', reason '%s'", |
| to, formatError(GetLastError())); |
| return ScalarLogical(1); |
| } |
| TMN_REPARSE_DATA_BUFFER rdb; |
| const size_t nbytes = wcslen(from) * 2; |
| rdb.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; |
| rdb.ReparseDataLength = nbytes + 12; |
| wcscpy(rdb.PathBuffer, from); |
| rdb.Reserved = 0; |
| rdb.SubstituteNameOffset = 0; |
| rdb.SubstituteNameLength = nbytes; |
| rdb.PrintNameOffset = nbytes + 2; |
| rdb.PrintNameLength = 0; |
| DWORD dwBytes; |
| const BOOL bOK = |
| DeviceIoControl(hd, FSCTL_SET_REPARSE_POINT, &rdb, |
| 8 /* header */ + rdb.ReparseDataLength, |
| NULL, 0, &dwBytes, 0); |
| CloseHandle(hd); |
| if(!bOK) |
| warning("cannot set reparse point '%ls', reason '%s'", |
| to, formatError(GetLastError())); |
| return ScalarLogical(bOK != 0); |
| } |
| #endif |
| |
| #include <zlib.h> |
| #include <bzlib.h> |
| #include <lzma.h> |
| #ifdef HAVE_PCRE_PCRE_H |
| # include <pcre/pcre.h> |
| #else |
| # include <pcre.h> |
| #endif |
| |
| #ifdef USE_ICU |
| # ifndef USE_ICU_APPLE |
| # include <unicode/uversion.h> |
| # else |
| # define U_MAX_VERSION_LENGTH 4 |
| # define U_MAX_VERSION_STRING_LENGTH 20 |
| typedef uint8_t UVersionInfo[U_MAX_VERSION_LENGTH]; |
| void u_versionToString(const UVersionInfo versionArray, char *versionString); |
| void u_getVersion(UVersionInfo versionArray); |
| # endif |
| #endif |
| |
| #include <iconv.h> |
| #if defined(__GLIBC__) |
| # include <gnu/libc-version.h> |
| #endif |
| |
| #ifdef HAVE_LIBREADLINE |
| // that ensures we have this header |
| # include <readline/readline.h> |
| #endif |
| |
| #if defined(HAVE_REALPATH) && defined(HAVE_DECL_REALPATH) && !HAVE_DECL_REALPATH |
| extern char *realpath(const char *path, char *resolved_path); |
| #endif |
| |
| #ifdef HAVE_DLFCN_H |
| #include <dlfcn.h> /* for dladdr, dlsym */ |
| #endif |
| |
| #if defined(HAVE_DLADDR) && defined(HAVE_DECL_DLADDR) && !HAVE_DECL_DLADDR |
| extern int dladdr(void *addr, Dl_info *info); |
| #endif |
| |
| #if defined(HAVE_DLSYM) && defined(HAVE_DECL_DLSYM) && !HAVE_DECL_DLSYM |
| extern void *dlsym(void *handle, const char *symbol); |
| #endif |
| |
| /* extSoftVersion only detects versions of libraries that are available |
| without loading any modules; libraries available via modules are |
| treated individually (libcurlVersion(), La_version(), etc) |
| */ |
| SEXP attribute_hidden |
| do_eSoftVersion(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| SEXP ans = PROTECT(allocVector(STRSXP, 9)); |
| SEXP nms = PROTECT(allocVector(STRSXP, 9)); |
| setAttrib(ans, R_NamesSymbol, nms); |
| unsigned int i = 0; |
| char p[256]; |
| snprintf(p, 256, "%s", zlibVersion()); |
| SET_STRING_ELT(ans, i, mkChar(p)); |
| SET_STRING_ELT(nms, i++, mkChar("zlib")); |
| snprintf(p, 256, "%s", BZ2_bzlibVersion()); |
| SET_STRING_ELT(ans, i, mkChar(p)); |
| SET_STRING_ELT(nms, i++, mkChar("bzlib")); |
| snprintf(p, 256, "%s", lzma_version_string()); |
| SET_STRING_ELT(ans, i, mkChar(p)); |
| SET_STRING_ELT(nms, i++, mkChar("xz")); |
| snprintf(p, 256, "%s", pcre_version()); |
| SET_STRING_ELT(ans, i, mkChar(p)); |
| SET_STRING_ELT(nms, i++, mkChar("PCRE")); |
| #ifdef USE_ICU |
| UVersionInfo icu; |
| char pu[U_MAX_VERSION_STRING_LENGTH]; |
| u_getVersion(icu); |
| u_versionToString(icu, pu); |
| SET_STRING_ELT(ans, i, mkChar(pu)); |
| #else |
| SET_STRING_ELT(ans, i, mkChar("")); |
| #endif |
| SET_STRING_ELT(nms, i++, mkChar("ICU")); |
| snprintf(p, 256, "%s", tre_version()); |
| SET_STRING_ELT(ans, i, mkChar(p)); |
| SET_STRING_ELT(nms, i++, mkChar("TRE")); |
| #ifdef _LIBICONV_VERSION |
| { |
| int ver = _libiconv_version; |
| snprintf(p, 256, "GNU libiconv %d.%d", ver/0x0100, ver%0x0100); |
| } |
| #elif defined(_WIN32) |
| snprintf(p, 256, "%s", "win_iconv"); |
| #elif defined(__GLIBC__) |
| snprintf(p, 256, "glibc %s", gnu_get_libc_version()); |
| #else |
| snprintf(p, 256, "%s", "unknown"); |
| #endif |
| SET_STRING_ELT(ans, i, mkChar(p)); |
| SET_STRING_ELT(nms, i++, mkChar("iconv")); |
| #ifdef HAVE_LIBREADLINE |
| SET_STRING_ELT(ans, i, mkChar(rl_library_version)); |
| #else |
| SET_STRING_ELT(ans, i, mkChar("")); |
| #endif |
| SET_STRING_ELT(nms, i++, mkChar("readline")); |
| |
| SET_STRING_ELT(ans, i, mkChar("")); |
| |
| #if defined(HAVE_DLADDR) && defined(HAVE_REALPATH) && defined(HAVE_DLSYM) \ |
| && defined(HAVE_DECL_RTLD_DEFAULT) && HAVE_DECL_RTLD_DEFAULT \ |
| && defined(HAVE_DECL_RTLD_NEXT) && HAVE_DECL_RTLD_NEXT |
| |
| /* Look for blas function dgemm and try to figure out in which |
| binary/shared library is it defined. This is based on experimentation |
| and heuristics, and depends on implementation details |
| of dynamic linkers. |
| */ |
| #ifdef HAVE_F77_UNDERSCORE |
| char *dgemm_name = "dgemm_"; |
| #else |
| char *dgemm_name = "dgemm"; |
| #endif |
| |
| Rboolean ok = TRUE; |
| |
| void *dgemm_addr = dlsym(RTLD_DEFAULT, dgemm_name); |
| |
| Dl_info dl_info1, dl_info2; |
| |
| if (!dladdr((void *)do_eSoftVersion, &dl_info1)) ok = FALSE; |
| if (!dladdr((void *)dladdr, &dl_info2)) ok = FALSE; |
| |
| if (ok && !strcmp(dl_info1.dli_fname, dl_info2.dli_fname)) { |
| |
| /* dladdr is not inside R, hence we probably have the PLT for |
| dynamically linked symbols; lets use dlsym(RTLD_NEXT) to |
| get the real address for dgemm. |
| |
| PLT is used on Linux and on Solaris when the main binary |
| is _not_ position independent. PLT is not used on macOS. |
| */ |
| if (dgemm_addr != NULL) { |
| |
| /* If dgemm_addr is NULL, dgemm is statically linked and |
| we are on Linux. On Solaris, dgemm_addr is never NULL. |
| */ |
| void *dgemm_next_addr = dlsym(RTLD_NEXT, dgemm_name); |
| if (dgemm_next_addr != NULL) |
| |
| /* If dgemm_next_addr is NULL, dgemm is statically linked. |
| Otherwise, it is linked dynamically and dgemm_next_addr |
| is its true address (dgemm points to PLT). |
| |
| On Linux, dgemm_next_addr is only NULL here when |
| dgemm is export-dynamic (yet statically linked). |
| */ |
| dgemm_addr = dgemm_next_addr; |
| } |
| } |
| |
| char buf[PATH_MAX+1]; |
| if (ok && dladdr(dgemm_addr, &dl_info1)) { |
| char *res = realpath(dl_info1.dli_fname, buf); |
| if (res) |
| SET_STRING_ELT(ans, i, mkChar(res)); |
| } |
| #endif |
| SET_STRING_ELT(nms, i++, mkChar("BLAS")); |
| |
| UNPROTECT(2); |
| return ans; |
| } |
| |
| /* platform-specific */ |
| extern void Rsleep(double timeint); |
| |
| SEXP attribute_hidden do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| checkArity(op, args); |
| double time = asReal(CAR(args)); |
| if (ISNAN(time) || time < 0.) |
| error(_("invalid '%s' value"), "time"); |
| Rsleep(time); |
| return R_NilValue; |
| } |
| |
| |
| /* Formerly src/appl/machar.c: |
| * void machar() -- computes ALL `machine constants' at once. |
| * ------------- -- compare with ../nmath/i1mach.c & ../nmath/d1mach.c |
| * which use the C <float.h> constants ! |
| * algorithm 665, collected algorithms from acm. |
| * this work published in transactions on mathematical software, |
| * vol. 14, no. 4, pp. 303-311. |
| * |
| * this fortran 77 subroutine is intended to determine the parameters |
| * of the floating-point arithmetic system specified below. the |
| * determination of the first three uses an extension of an algorithm |
| * due to m. malcolm, cacm 15 (1972), pp. 949-951, incorporating some, |
| * but not all, of the improvements suggested by m. gentleman and s. |
| * marovich, cacm 17 (1974), pp. 276-277. an earlier version of this |
| * program was published in the book software manual for the |
| * elementary functions by w. j. cody and w. waite, prentice-hall, |
| * englewood cliffs, nj, 1980. |
| * |
| * the program as given here must be modified before compiling. if |
| * a single (double) precision version is desired, change all |
| * occurrences of cs ( ) in columns 1 and 2 to blanks. |
| * |
| * parameter values reported are as follows: |
| * |
| * ibeta - the radix for the floating-point representation |
| * it - the number of base ibeta digits in the floating-point |
| * significand |
| * irnd - 0 if floating-point addition chops |
| * 1 if floating-point addition rounds, but not in the |
| * ieee style |
| * 2 if floating-point addition rounds in the ieee style |
| * 3 if floating-point addition chops, and there is |
| * partial underflow |
| * 4 if floating-point addition rounds, but not in the |
| * ieee style, and there is partial underflow |
| * 5 if floating-point addition rounds in the ieee style, |
| * and there is partial underflow |
| * ngrd - the number of guard digits for multiplication with |
| * truncating arithmetic. it is |
| * 0 if floating-point arithmetic rounds, or if it |
| * truncates and only it base ibeta digits |
| * participate in the post-normalization shift of the |
| * floating-point significand in multiplication; |
| * 1 if floating-point arithmetic truncates and more |
| * than it base ibeta digits participate in the |
| * post-normalization shift of the floating-point |
| * significand in multiplication. |
| * machep - the largest negative integer such that |
| * 1.0+float(ibeta)**machep .ne. 1.0, except that |
| * machep is bounded below by -(it+3) |
| * negeps - the largest negative integer such that |
| * 1.0-float(ibeta)**negeps .ne. 1.0, except that |
| * negeps is bounded below by -(it+3) |
| * iexp - the number of bits (decimal places if ibeta = 10) |
| * reserved for the representation of the exponent |
| * (including the bias or sign) of a floating-point |
| * number |
| * minexp - the largest in magnitude negative integer such that |
| * float(ibeta)**minexp is positive and normalized |
| * maxexp - the smallest positive power of beta that overflows |
| * eps - the smallest positive floating-point number such |
| * that 1.0+eps .ne. 1.0. in particular, if either |
| * ibeta = 2 or irnd = 0, eps = float(ibeta)**machep. |
| * otherwise, eps = (float(ibeta)**machep)/2 |
| * epsneg - a small positive floating-point number such that |
| * 1.0-epsneg .ne. 1.0. in particular, if ibeta = 2 |
| * or irnd = 0, epsneg = float(ibeta)**negeps. |
| * otherwise, epsneg = (ibeta**negeps)/2. because |
| * negeps is bounded below by -(it+3), epsneg may not |
| * be the smallest number that can alter 1.0 by |
| * subtraction. |
| * xmin - the smallest non-vanishing normalized floating-point |
| * power of the radix, i.e., xmin = float(ibeta)**minexp |
| * xmax - the largest finite floating-point number. in |
| * particular xmax = (1.0-epsneg)*float(ibeta)**maxexp |
| * note - on some machines xmax will be only the |
| * second, or perhaps third, largest number, being |
| * too small by 1 or 2 units in the last digit of |
| * the significand. |
| * |
| * latest revision - april 20, 1987 |
| * |
| * author - w. j. cody |
| * argonne national laboratory |
| * |
| */ |
| |
| |
| static void |
| machar(int *ibeta, int *it, int *irnd, int *ngrd, int *machep, int *negep, |
| int *iexp, int *minexp, int *maxexp, double *eps, |
| double *epsneg, double *xmin, double *xmax) |
| { |
| volatile double a, b, beta, betain, betah, one, |
| t, temp, tempa, temp1, two, y, z, zero; |
| int i, itemp, iz, j, k, mx, nxres; |
| |
| one = 1; |
| two = one+one; |
| zero = one-one; |
| |
| /* determine ibeta, beta ala malcolm. */ |
| |
| a = one; |
| do { |
| a = a + a; |
| temp = a + one; |
| temp1 = temp - a; |
| } |
| while(temp1 - one == zero); |
| b = one; |
| do { |
| b = b + b; |
| temp = a + b; |
| itemp = (int)(temp - a); |
| } |
| while (itemp == 0); |
| *ibeta = itemp; |
| beta = *ibeta; |
| |
| /* determine it, irnd */ |
| |
| *it = 0; |
| b = one; |
| do { |
| *it = *it + 1; |
| b = b * beta; |
| temp = b + one; |
| temp1 = temp - b; |
| } |
| while(temp1 - one == zero); |
| *irnd = 0; |
| betah = beta / two; |
| temp = a + betah; |
| if (temp - a != zero) |
| *irnd = 1; |
| tempa = a + beta; |
| temp = tempa + betah; |
| if (*irnd == 0 && temp - tempa != zero) |
| *irnd = 2; |
| |
| /* determine negep, epsneg */ |
| |
| *negep = *it + 3; |
| betain = one / beta; |
| a = one; |
| for(i=1 ; i<=*negep ; i++) |
| a = a * betain; |
| b = a; |
| for(;;) { |
| temp = one - a; |
| if (temp - one != zero) |
| break; |
| a = a * beta; |
| *negep = *negep - 1; |
| } |
| *negep = -*negep; |
| *epsneg = a; |
| if (*ibeta != 2 && *irnd != 0) { |
| a = (a * (one + a)) / two; |
| temp = one - a; |
| if (temp - one != zero) |
| *epsneg = a; |
| } |
| |
| /* determine machep, eps */ |
| |
| *machep = -*it - 3; |
| a = b; |
| for(;;) { |
| temp = one + a; |
| if (temp - one != zero) |
| break; |
| a = a * beta; |
| *machep = *machep + 1; |
| } |
| *eps = a; |
| temp = tempa + beta * (one + *eps); |
| if (*ibeta != 2 && *irnd != 0) { |
| a = (a * (one + a)) / two; |
| temp = one + a; |
| if (temp - one != zero) |
| *eps = a; |
| } |
| |
| /* determine ngrd */ |
| |
| *ngrd = 0; |
| temp = one + *eps; |
| if (*irnd == 0 && temp * one - one != zero) |
| *ngrd = 1; |
| |
| /* determine iexp, minexp, xmin */ |
| |
| /* loop to determine largest i and k = 2**i such that */ |
| /* (1/beta) ** (2**(i)) */ |
| /* does not underflow. */ |
| /* exit from loop is signaled by an underflow. */ |
| |
| i = 0; |
| k = 1; |
| z = betain; |
| t = one + *eps; |
| nxres = 0; |
| for(;;) { |
| y = z; |
| z = y * y; |
| |
| /* check for underflow here */ |
| |
| a = z * one; |
| temp = z * t; |
| if (a+a == zero || fabs(z) >= y) |
| break; |
| temp1 = temp * betain; |
| if (temp1 * beta == z) |
| break; |
| i = i+1; |
| k = k+k; |
| } |
| if (*ibeta != 10) { |
| *iexp = i + 1; |
| mx = k + k; |
| } |
| else { |
| /* this segment is for decimal machines only */ |
| |
| *iexp = 2; |
| iz = *ibeta; |
| while (k >= iz) { |
| iz = iz * *ibeta; |
| iexp = iexp + 1; |
| } |
| mx = iz + iz - 1; |
| } |
| do { |
| /* loop to determine minexp, xmin */ |
| /* exit from loop is signaled by an underflow */ |
| |
| *xmin = y; |
| y = y * betain; |
| |
| /* check for underflow here */ |
| |
| a = y * one; |
| temp = y * t; |
| if (a+a == zero || fabs(y) >= *xmin) |
| goto L10; |
| k = k + 1; |
| temp1 = temp * betain; |
| } |
| while(temp1 * beta != y); |
| nxres = 3; |
| *xmin = y; |
| L10: *minexp = -k; |
| |
| /* determine maxexp, xmax */ |
| |
| if (mx <= k + k - 3 && *ibeta != 10) { |
| mx = mx + mx; |
| *iexp = *iexp + 1; |
| } |
| *maxexp = mx + *minexp; |
| |
| /* adjust irnd to reflect partial underflow */ |
| |
| *irnd = *irnd + nxres; |
| |
| /* adjust for ieee-style machines */ |
| |
| if (*irnd == 2 || *irnd == 5) |
| *maxexp = *maxexp - 2; |
| |
| /* adjust for non-ieee machines with partial underflow */ |
| |
| if (*irnd == 3 || *irnd == 4) |
| *maxexp = *maxexp - *it; |
| |
| /* adjust for machines with implicit leading bit in binary */ |
| /* significand, and machines with radix point at extreme */ |
| /* right of significand. */ |
| |
| i = *maxexp + *minexp; |
| if (*ibeta == 2 && i == 0) |
| *maxexp = *maxexp - 1; |
| if (i > 20) |
| *maxexp = *maxexp - 1; |
| if (a != y) |
| *maxexp = *maxexp - 2; |
| *xmax = one - *epsneg; |
| if (*xmax * one != *xmax) |
| *xmax = one - beta * *epsneg; |
| *xmax = *xmax / (beta * beta * beta * *xmin); |
| i = *maxexp + *minexp + 3; |
| if (i>0) |
| for(j=1 ; j<=i ; j++) { |
| if (*ibeta == 2) |
| *xmax = *xmax + *xmax; |
| if (*ibeta != 2) |
| *xmax = *xmax * beta; |
| } |
| } |