FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand) { wchar_t wmode[10]; if(fn == NA_STRING) return NULL; mbstowcs(wmode, fixmode(mode), 10); return _wfopen(filenameToWchar(fn, expand), wmode); }
SEXP do_shellexec(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP file; checkArity(op, args); file = CAR(args); if (!isString(file) || length(file) != 1) errorcall(call, _("invalid '%s' argument"), "file"); internal_shellexecW(filenameToWchar(STRING_ELT(file, 0), FALSE), FALSE); return R_NilValue; }
SEXP loadhistory(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP sfile; args = CDR(args); sfile = CAR(args); if (!isString(sfile) || LENGTH(sfile) < 1) errorcall(call, _("invalid '%s' argument"), "file"); if (CharacterMode == RGui) wgl_loadhistoryW(filenameToWchar(STRING_ELT(sfile, 0), 0)); else if (R_Interactive && CharacterMode == RTerm) gl_loadhistory(translateChar(STRING_ELT(sfile, 0))); else errorcall(call, _("'loadhistory' can only be used in Rgui and Rterm")); return R_NilValue; }
SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP path = R_NilValue, ans; const wchar_t *dll; DWORD dwVerInfoSize; DWORD dwVerHnd; checkArity(op, args); path = CAR(args); if(!isString(path) || LENGTH(path) != 1) errorcall(call, _("invalid '%s' argument"), "path"); dll = filenameToWchar(STRING_ELT(path, 0), FALSE); dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd); PROTECT(ans = allocVector(STRSXP, 2)); SET_STRING_ELT(ans, 0, mkChar("")); SET_STRING_ELT(ans, 1, mkChar("")); if (dwVerInfoSize) { BOOL fRet; LPSTR lpstrVffInfo; LPSTR lszVer = NULL; UINT cchVer = 0; lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize); if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) { fRet = VerQueryValue(lpstrVffInfo, TEXT("\\StringFileInfo\\040904E4\\FileVersion"), (LPVOID)&lszVer, &cchVer); if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer)); fRet = VerQueryValue(lpstrVffInfo, TEXT("\\StringFileInfo\\040904E4\\R Version"), (LPVOID)&lszVer, &cchVer); if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer)); else { fRet = VerQueryValue(lpstrVffInfo, TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"), (LPVOID)&lszVer, &cchVer); if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer)); } } else ans = R_NilValue; free(lpstrVffInfo); } else ans = R_NilValue; UNPROTECT(1); return ans; }
/* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 2000-2013 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/ */ #ifdef HAVE_CONFIG_H #include <config.h> #endif #include <Defn.h> /* for checkArity */ #include <Internal.h> #undef _ #ifdef ENABLE_NLS #include <libintl.h> #define _(String) dgettext ("utils", String) #else #define _(String) (String) #endif #ifdef Win32 # include "Startup.h" # include "getline/getline.h" /* for gl_load/savehistory */ # include "getline/wc_history.h" /* for wgl_load/savehistory */ SEXP savehistory(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP sfile; args = CDR(args); sfile = CAR(args); if (!isString(sfile) || LENGTH(sfile) < 1) errorcall(call, _("invalid '%s' argument"), "file"); if (CharacterMode == RGui) { R_setupHistory(); /* re-read the history size */ wgl_savehistoryW(filenameToWchar(STRING_ELT(sfile, 0), 0), R_HistorySize); } else if (R_Interactive && CharacterMode == RTerm) { R_setupHistory(); /* re-read the history size */ gl_savehistory(translateChar(STRING_ELT(sfile, 0)), R_HistorySize); } else errorcall(call, _("'savehistory' can only be used in Rgui and Rterm")); return R_NilValue; }
/* utils::shortPathName */ SEXP in_shortpath(SEXP paths) { SEXP ans, el; int i, n = LENGTH(paths); char tmp[MAX_PATH]; wchar_t wtmp[32768]; DWORD res; const void *vmax = vmaxget(); if(!isString(paths)) error(_("'path' must be a character vector")); PROTECT(ans = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { el = STRING_ELT(paths, i); if(getCharCE(el) == CE_UTF8) { res = GetShortPathNameW(filenameToWchar(el, FALSE), wtmp, 32768); if (res && res <= 32768) wcstoutf8(tmp, wtmp, wcslen(wtmp)+1); else strcpy(tmp, translateChar(el)); /* documented to return paths using \, which the API call does not necessarily do */ R_fixbackslash(tmp); SET_STRING_ELT(ans, i, mkCharCE(tmp, CE_UTF8)); } else { res = GetShortPathName(translateChar(el), tmp, MAX_PATH); if (res == 0 || res > MAX_PATH) strcpy(tmp, translateChar(el)); /* documented to return paths using \, which the API call does not necessarily do */ R_fixbackslash(tmp); SET_STRING_ELT(ans, i, mkChar(tmp)); } } UNPROTECT(1); vmaxset(vmax); return ans; }
SEXP readRegistry(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP ans; HKEY hive, hkey; LONG res; const wchar_t *key; int maxdepth, view; REGSAM acc = KEY_READ; args = CDR(args); if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1) error(_("invalid '%s' value"), "key"); key = filenameToWchar(STRING_ELT(CAR(args), 0), 0); if(!isString(CADR(args)) || LENGTH(CADR(args)) != 1) error(_("invalid '%s' value"), "hive"); maxdepth = asInteger(CADDR(args)); if(maxdepth == NA_INTEGER || maxdepth < 1) error(_("invalid '%s' value"), "maxdepth"); hive = find_hive(CHAR(STRING_ELT(CADR(args), 0))); view = asInteger(CADDDR(args)); /* Or KEY_READ with KEY_WOW64_64KEY or KEY_WOW64_32KEY to explicitly access the 64- or 32- bit registry view. See http://msdn.microsoft.com/en-us/library/aa384129(VS.85).aspx */ if(view == 2) acc |= KEY_WOW64_32KEY; else if(view == 3) acc |= KEY_WOW64_64KEY; res = RegOpenKeyExW(hive, key, 0, acc, &hkey); if (res == ERROR_FILE_NOT_FOUND) error(_("Registry key '%ls' not found"), key); if (res != ERROR_SUCCESS) error("RegOpenKeyEx error code %d: '%s'", (int) res, formatError(res)); ans = readRegistryKey(hkey, maxdepth, view); RegCloseKey(hkey); return ans; }
/* GetNativeSystemInfo is XP or later */ pGNSI = (PGNSI) GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")), "GetNativeSystemInfo"); if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si); if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64) strcat(ver, " x64"); } SET_STRING_ELT(ans, 1, mkChar(ver)); if((int)osvi.dwMajorVersion >= 5) { if(osvi.wServicePackMajor > 0) snprintf(ver, 256, "build %d, Service Pack %d", LOWORD(osvi.dwBuildNumber), (int) osvi.wServicePackMajor); else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber)); } else snprintf(ver, 256, "build %d, %s", LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion); SET_STRING_ELT(ans, 2, mkChar(ver)); GetComputerNameW(name, &namelen); wcstoutf8(buf, name, 1000); SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8)); #ifdef WIN64 SET_STRING_ELT(ans, 4, mkChar("x86-64")); #else SET_STRING_ELT(ans, 4, mkChar("x86")); #endif GetUserNameW(user, &userlen); wcstoutf8(buf, user, 1000); SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8)); SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5)); SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5)); PROTECT(ansnames = allocVector(STRSXP, 8)); SET_STRING_ELT(ansnames, 0, mkChar("sysname")); SET_STRING_ELT(ansnames, 1, mkChar("release")); SET_STRING_ELT(ansnames, 2, mkChar("version")); SET_STRING_ELT(ansnames, 3, mkChar("nodename")); SET_STRING_ELT(ansnames, 4, mkChar("machine")); SET_STRING_ELT(ansnames, 5, mkChar("login")); SET_STRING_ELT(ansnames, 6, mkChar("user")); SET_STRING_ELT(ansnames, 7, mkChar("effective_user")); setAttrib(ans, R_NamesSymbol, ansnames); UNPROTECT(2); return ans; } SEXP do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho) { DWORD mtime; int ntime; double time; checkArity(op, args); time = asReal(CAR(args)); if (ISNAN(time) || time < 0) errorcall(call, _("invalid '%s' value"), "time"); ntime = 1000*(time) + 0.5; while (ntime > 0) { mtime = min(500, ntime); ntime -= mtime; Sleep(mtime); R_ProcessEvents(); } return R_NilValue; } #ifdef LEA_MALLOC #define MALLINFO_FIELD_TYPE size_t struct mallinfo { MALLINFO_FIELD_TYPE arena; /* non-mmapped space allocated from system */ MALLINFO_FIELD_TYPE ordblks; /* number of free chunks */ MALLINFO_FIELD_TYPE smblks; /* number of fastbin blocks */ MALLINFO_FIELD_TYPE hblks; /* number of mmapped regions */ MALLINFO_FIELD_TYPE hblkhd; /* space in mmapped regions */ MALLINFO_FIELD_TYPE usmblks; /* maximum total allocated space */ MALLINFO_FIELD_TYPE fsmblks; /* space available in freed fastbin blocks */ MALLINFO_FIELD_TYPE uordblks; /* total allocated space */ MALLINFO_FIELD_TYPE fordblks; /* total free space */ MALLINFO_FIELD_TYPE keepcost; /* top-most, releasable (via malloc_trim) space */ }; extern R_size_t R_max_memory; struct mallinfo mallinfo(void); #endif SEXP in_memsize(SEXP ssize) { SEXP ans; int maxmem = NA_LOGICAL; if(isLogical(ssize)) maxmem = asLogical(ssize); else if(isReal(ssize)) { R_size_t newmax; double mem = asReal(ssize); if (!R_FINITE(mem)) error(_("incorrect argument")); #ifdef LEA_MALLOC #ifndef WIN64 if(mem >= 4096) error(_("don't be silly!: your machine has a 4Gb address limit")); #endif newmax = mem * 1048576.0; if (newmax < R_max_memory) warning(_("cannot decrease memory limit: ignored")); else R_max_memory = newmax; #endif } else error(_("incorrect argument")); PROTECT(ans = allocVector(REALSXP, 1)); #ifdef LEA_MALLOC if(maxmem == NA_LOGICAL) REAL(ans)[0] = R_max_memory; else if(maxmem) REAL(ans)[0] = mallinfo().usmblks; else REAL(ans)[0] = mallinfo().uordblks; REAL(ans)[0] /= 1048576.0; #else REAL(ans)[0] = NA_REAL; #endif UNPROTECT(1); return ans; } SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP path = R_NilValue, ans; const wchar_t *dll; DWORD dwVerInfoSize; DWORD dwVerHnd; checkArity(op, args); path = CAR(args); if(!isString(path) || LENGTH(path) != 1) errorcall(call, _("invalid '%s' argument"), "path"); dll = filenameToWchar(STRING_ELT(path, 0), FALSE); dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd); PROTECT(ans = allocVector(STRSXP, 2)); SET_STRING_ELT(ans, 0, mkChar("")); SET_STRING_ELT(ans, 1, mkChar("")); if (dwVerInfoSize) { BOOL fRet; LPSTR lpstrVffInfo; LPSTR lszVer = NULL; UINT cchVer = 0; lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize); if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) { fRet = VerQueryValue(lpstrVffInfo, TEXT("\\StringFileInfo\\040904E4\\FileVersion"), (LPVOID)&lszVer, &cchVer); if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer)); fRet = VerQueryValue(lpstrVffInfo, TEXT("\\StringFileInfo\\040904E4\\R Version"), (LPVOID)&lszVer, &cchVer); if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer)); else { fRet = VerQueryValue(lpstrVffInfo, TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"), (LPVOID)&lszVer, &cchVer); if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer)); } } else ans = R_NilValue; free(lpstrVffInfo); } else ans = R_NilValue; UNPROTECT(1); return ans; } int Rwin_rename(const char *from, const char *to) { return (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0); } int Rwin_wrename(const wchar_t *from, const wchar_t *to) { return (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0); } const char *formatError(DWORD res) { static char buf[1000], *p; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, res, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), buf, 1000, NULL); p = buf+strlen(buf) -1; if(*p == '\n') *p = '\0'; p = buf+strlen(buf) -1; if(*p == '\r') *p = '\0'; p = buf+strlen(buf) -1; if(*p == '.') *p = '\0'; return buf; } void R_UTF8fixslash(char *s); /* from main/util.c */ SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP ans, paths = CAR(args), el, slash; int i, n = LENGTH(paths), res; char tmp[MAX_PATH], longpath[MAX_PATH], *tmp2; wchar_t wtmp[32768], wlongpath[32768], *wtmp2; int mustWork, fslash = 0; checkArity(op, args); if(!isString(paths)) errorcall(call, _("'path' must be a character vector")); slash = CADR(args); if(!isString(slash) || LENGTH(slash) != 1) errorcall(call, "'winslash' must be a character string"); const char *sl = CHAR(STRING_ELT(slash, 0)); if (strcmp(sl, "/") && strcmp(sl, "\\")) errorcall(call, "'winslash' must be '/' or '\\\\'"); if (strcmp(sl, "/") == 0) fslash = 1; mustWork = asLogical(CADDR(args)); PROTECT(ans = allocVector(STRSXP, n)); for (i = 0; i < n; i++) { int warn = 0; SEXP result; el = STRING_ELT(paths, i); result = el; if(getCharCE(el) == CE_UTF8) { if ((res = GetFullPathNameW(filenameToWchar(el, FALSE), 32768, wtmp, &wtmp2)) && res <= 32768) { if ((res = GetLongPathNameW(wtmp, wlongpath, 32768)) && res <= 32768) { wcstoutf8(longpath, wlongpath, wcslen(wlongpath)+1); if(fslash) R_UTF8fixslash(longpath); result = mkCharCE(longpath, CE_UTF8); } else if(mustWork == 1) { errorcall(call, "path[%d]=\"%s\": %s", i+1, translateChar(el), formatError(GetLastError())); } else { wcstoutf8(tmp, wtmp, wcslen(wtmp)+1); if(fslash) R_UTF8fixslash(tmp); result = mkCharCE(tmp, CE_UTF8); warn = 1; } } else if(mustWork == 1) { errorcall(call, "path[%d]=\"%s\": %s", i+1, translateChar(el), formatError(GetLastError())); } else { if (fslash) { strcpy(tmp, translateCharUTF8(el)); R_UTF8fixslash(tmp); result = mkCharCE(tmp, CE_UTF8); } warn = 1; } if (warn && (mustWork == NA_LOGICAL)) warningcall(call, "path[%d]=\"%ls\": %s", i+1, filenameToWchar(el,FALSE), formatError(GetLastError())); } else { if ((res = GetFullPathName(translateChar(el), MAX_PATH, tmp, &tmp2)) && res <= MAX_PATH) { if ((res = GetLongPathName(tmp, longpath, MAX_PATH)) && res <= MAX_PATH) { if(fslash) R_fixslash(longpath); result = mkChar(longpath); } else if(mustWork == 1) { errorcall(call, "path[%d]=\"%s\": %s", i+1, translateChar(el), formatError(GetLastError())); } else { if(fslash) R_fixslash(tmp); result = mkChar(tmp); warn = 1; } } else if(mustWork == 1) { errorcall(call, "path[%d]=\"%s\": %s", i+1, translateChar(el), formatError(GetLastError())); } else { if (fslash) { strcpy(tmp, translateChar(el)); R_fixslash(tmp); result = mkChar(tmp); } warn = 1; } if (warn && (mustWork == NA_LOGICAL)) warningcall(call, "path[%d]=\"%s\": %s", i+1, translateChar(el), formatError(GetLastError())); } SET_STRING_ELT(ans, i, result); } UNPROTECT(1); return ans; }
SEXP chooseFiles(SEXP def, SEXP caption, SEXP smulti, SEXP filters, SEXP sindex) { wchar_t *temp, *res, *cfilters; const wchar_t *p; wchar_t path[32768], filename[32768]; int multi, filterindex, i, count, lfilters, pathlen; multi = asLogical(smulti); filterindex = asInteger(sindex); if(length(def) != 1 ) error(_("'default' must be a character string")); p = filenameToWchar(STRING_ELT(def, 0), 1); if(wcslen(p) >= 32768) error(_("'default' is overlong")); wcscpy(path, p); for(temp = path; *temp; temp++) if(*temp == L'/') *temp = L'\\'; if(length(caption) != 1 ) error(_("'caption' must be a character string")); if(multi == NA_LOGICAL) error(_("'multi' must be a logical value")); if(filterindex == NA_INTEGER) error(_("'filterindex' must be an integer value")); lfilters = 1 + length(filters); for (i = 0; i < length(filters); i++) lfilters += wcslen(filenameToWchar(STRING_ELT(filters, i), 0)); cfilters = (wchar_t *) R_alloc(lfilters, sizeof(wchar_t)); temp = cfilters; for (i = 0; i < length(filters)/2; i++) { wcscpy(temp, filenameToWchar(STRING_ELT(filters, i), 0)); temp += wcslen(temp)+1; wcscpy(temp, filenameToWchar(STRING_ELT(filters, i+length(filters)/2), 0)); temp += wcslen(temp)+1; } *temp = 0; res = askfilenamesW(filenameToWchar(STRING_ELT(caption, 0), 0), path, multi, cfilters, filterindex, NULL); count = countFilenamesW(res); SEXP ans; if (count < 2) PROTECT(ans = allocVector(STRSXP, count)); else PROTECT(ans = allocVector(STRSXP, count-1)); switch (count) { case 0: break; case 1: SET_STRING_ELT(ans, 0, mkCharUTF8(res)); break; default: wcsncpy(path, res, 32768); pathlen = wcslen(path); if (path[pathlen-1] == L'\\') path[--pathlen] = L'\0'; temp = res; for (i = 0; i < count-1; i++) { temp += wcslen(temp) + 1; if (wcschr(temp,L':') || *temp == L'\\' || *temp == L'/') SET_STRING_ELT(ans, i, mkCharUTF8(temp)); else { wcsncpy(filename, path, 32768); filename[pathlen] = L'\\'; wcsncpy(filename+pathlen+1, temp, 32768-pathlen-1); SET_STRING_ELT(ans, i, mkCharUTF8(filename)); } } } UNPROTECT(1); return ans; }