Google Git
Sign in
third-party-mirror / R / refs/heads/main / . / src / gnuwin32 / extra.c
blob: fddc6d4893fd8fbd5e20d888413e9e1217d775da [file] [log] [blame]
/*
* R : A Computer Language for Statistical Data Analysis
* file extra.c
* Copyright (C) 1998--2003 Guido Masarotto and Brian Ripley
* Copyright (C) 2004 The R Foundation
* Copyright (C) 2005--2021 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/
*/
/* extra commands for R */
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include "win-nls.h"
#include <stdio.h>
#include <string.h>
#include <time.h>
#include "Defn.h"
#include <Internal.h>
#include "Fileio.h"
#include <direct.h>
#include "graphapp/ga.h"
#include "rlocale.h"
/* Mingw-w64 defines this to be 0x0502 */
#ifndef _WIN32_WINNT
# define _WIN32_WINNT 0x0502 /* for GetLongPathName, KEY_WOW64_64KEY */
#endif
#include <windows.h>
#include "rui.h"
#undef ERROR
#include <R_ext/RS.h> /* formerly for Calloc */
#include <winbase.h>
/* used in rui.c */
void internal_shellexec(const char * file)
{
const char *home;
char home2[10000], *p;
uintptr_t ret;
home = getenv("R_HOME");
if (home == NULL)
error(_("R_HOME not set"));
strncpy(home2, home, 10000 - 1);
home2[10000 - 1] = '\0';
for(p = home2; *p; p++) if(*p == '/') *p = '\\';
ret = (uintptr_t) ShellExecute(NULL, "open", file, NULL, home2, SW_SHOW);
if(ret <= 32) { /* an error condition */
if(ret == ERROR_FILE_NOT_FOUND || ret == ERROR_PATH_NOT_FOUND
|| ret == SE_ERR_FNF || ret == SE_ERR_PNF)
error(_("'%s' not found"), file);
if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
error(_("file association for '%s' not available or invalid"),
file);
if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
error(_("access to '%s' denied"), file);
error(_("problem in displaying '%s'"), file);
}
}
/* used by shell.exec() with rhome=FALSE. 2.13.0 and earlier were
like rhome=TRUE, but without fixing the path */
static void internal_shellexecW(const wchar_t * file, Rboolean rhome)
{
const wchar_t *home;
wchar_t home2[10000], *p;
uintptr_t ret;
if (rhome) {
home = _wgetenv(L"R_HOME");
if (home == NULL)
error(_("R_HOME not set"));
wcsncpy(home2, home, 10000);
for(p = home2; *p; p++) if(*p == L'/') *p = L'\\';
home = home2;
} else home = NULL;
ret = (uintptr_t) ShellExecuteW(NULL, L"open", file, NULL, home, SW_SHOW);
if(ret <= 32) { /* an error condition */
if(ret == ERROR_FILE_NOT_FOUND || ret == ERROR_PATH_NOT_FOUND
|| ret == SE_ERR_FNF || ret == SE_ERR_PNF)
error(_("'%ls' not found"), file);
if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
error(_("file association for '%ls' not available or invalid"),
file);
if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
error(_("access to '%ls' denied"), file);
error(_("problem in displaying '%ls'"), file);
}
}
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;
}
int check_doc_file(const char * file)
{
const char *home;
char path[MAX_PATH];
home = getenv("R_HOME");
if (home == NULL)
error(_("R_HOME not set"));
if(strlen(home) + strlen(file) + 1 >= MAX_PATH) return(1); /* cannot exist */
strcpy(path, home);
strcat(path, "/");
strcat(path, file);
return access(path, 4) == 0; /* read access */
}
#include "Startup.h"
void Rwin_fpset(void)
{
/* Under recent MinGW this is what fpreset does. It sets the
control word to 0x37f which corresponds to 0x8001F as used by
_controlfp. That is all errors are masked, 64-bit mantissa and
rounding are selected. */
__asm__ ( "fninit" ) ;
}
#include <preferences.h>
/* utils::loadRconsole */
SEXP in_loadRconsole(SEXP sfile)
{
struct structGUI gui;
const void *vmax = vmaxget();
if (!isString(sfile) || LENGTH(sfile) < 1)
error(_("invalid '%s' argument"), "file");
getActive(&gui); /* Will get defaults if there's no active console */
if (loadRconsole(&gui, translateChar(STRING_ELT(sfile, 0)))) applyGUI(&gui);
if (strlen(gui.warning)) warning(gui.warning);
vmaxset(vmax);
return R_NilValue;
}
#include <lmcons.h>
typedef void (WINAPI *PGNSI)(LPSYSTEM_INFO);
/* base::Sys.info */
// keep in step with src/library/utils/src/windows/util.c
SEXP do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ansnames;
OSVERSIONINFOEX osvi;
char ver[256], buf[1000];
wchar_t name[MAX_COMPUTERNAME_LENGTH + 1], user[UNLEN+1];
DWORD namelen = MAX_COMPUTERNAME_LENGTH + 1, userlen = UNLEN+1;
checkArity(op, args);
PROTECT(ans = allocVector(STRSXP, 8));
osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX);
if(!GetVersionEx((OSVERSIONINFO *)&osvi))
error(_("unsupported version of Windows"));
SET_STRING_ELT(ans, 0, mkChar("Windows"));
/* Here for unknown future versions */
snprintf(ver, 256, "%d.%d",
(int)osvi.dwMajorVersion, (int)osvi.dwMinorVersion);
if((int)osvi.dwMajorVersion >= 5) {
PGNSI pGNSI;
SYSTEM_INFO si;
if(osvi.dwMajorVersion == 10 && osvi.dwMinorVersion == 0) {
if(osvi.wProductType == VER_NT_WORKSTATION) strcpy(ver, "10");
else strcpy(ver, "Server");
}
if(osvi.dwMajorVersion == 6) {
char *desc = "";
if(osvi.wProductType == VER_NT_WORKSTATION) {
if(osvi.dwMinorVersion == 0) desc = "Vista";
else if(osvi.dwMinorVersion == 1) desc = "7";
else if(osvi.dwMinorVersion == 2) desc = ">= 8";
else if(osvi.dwMinorVersion == 3) desc = "8.1";
else desc = "> 8.1";
} else {
if(osvi.dwMinorVersion == 0) desc = "Server 2008";
else if(osvi.dwMinorVersion == 1) desc = "Server 2008 R2";
else if(osvi.dwMinorVersion == 2) desc = "Server >= 2012";
else if(osvi.dwMinorVersion == 3) desc = "Server 2012 R2";
else desc = "Server > 2012";
}
strcpy(ver, desc);
}
if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 0)
strcpy(ver, "2000");
if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 1)
strcpy(ver, "XP");
if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 2) {
if(osvi.wProductType == VER_NT_WORKSTATION)
strcpy(ver, "XP Professional");
else strcpy(ver, "Server 2003");
}
/* 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, sizeof(buf));
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, sizeof(buf));
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;
}
void Rsleep(double timeint)
{
int ntime = 1000*timeint + 0.5;
DWORD mtime;
while (ntime > 0) {
mtime = min(500, ntime);
ntime -= mtime;
Sleep(mtime);
R_ProcessEvents();
}
}
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;
}
/* Retry renaming a few times to recover from possible anti-virus interference,
which has been reported e.g. during installation of packages. */
int Rwin_rename(const char *from, const char *to)
{
for(int retries = 0; retries < 10; retries++) {
/* coreutils first call MoveFileEx without flags; only if it fails
with ERROR_FILE_EXISTS or ERROR_ALREADY_EXISTING, they call again
with MOVEFILE_REPLACE_EXISTING */
if (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH))
return 0;
DWORD err = GetLastError();
if (err != ERROR_SHARING_VIOLATION && err != ERROR_ACCESS_DENIED)
return 1;
Sleep(500);
R_ProcessEvents();
}
return 1;
}
int Rwin_wrename(const wchar_t *from, const wchar_t *to)
{
for(int retries = 0; retries < 10; retries++) {
if (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH))
return 0;
DWORD err = GetLastError();
if (err != ERROR_SHARING_VIOLATION && err != ERROR_ACCESS_DENIED)
return 1;
Sleep(500);
R_ProcessEvents();
}
return 1;
}
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;
}
#if _WIN32_WINNT < 0x0600
/* FIXME: also used in sysutils.c */
/* available from Windows Vista */
typedef enum _FILE_INFO_BY_HANDLE_CLASS {
FileBasicInfo,
FileStandardInfo,
FileNameInfo,
FileRenameInfo,
FileDispositionInfo,
FileAllocationInfo,
FileEndOfFileInfo,
FileStreamInfo,
FileCompressionInfo,
FileAttributeTagInfo,
FileIdBothDirectoryInfo,
FileIdBothDirectoryRestartInfo,
FileIoPriorityHintInfo,
FileRemoteProtocolInfo,
FileFullDirectoryInfo,
FileFullDirectoryRestartInfo,
FileStorageInfo,
FileAlignmentInfo,
FileIdInfo,
FileIdExtdDirectoryInfo,
FileIdExtdDirectoryRestartInfo,
FileDispositionInfoEx,
FileRenameInfoEx,
MaximumFileInfoByHandleClass,
FileCaseSensitiveInfo,
FileNormalizedNameInfo
} FILE_INFO_BY_HANDLE_CLASS, *PFILE_INFO_BY_HANDLE_CLASS;
/* MinGW defines this structure even for Vista. Older versions of MinGW
define it differently from Windows (two ULONGLONG fields). Newer
versions and Windows use
typedef struct _FILE_ID_128 {
BYTE Identifier[16];
} FILE_ID_128, *PFILE_ID_128;
*/
#elif _WIN32_WINNT < 0x0602
/* These constants were added to FILE_INFO_BY_HANDLE_CLASS in Windows 8 */
enum {
FileStorageInfo = FileFullDirectoryRestartInfo + 1,
FileAlignmentInfo,
FileIdInfo,
FileIdExtdDirectoryInfo,
FileIdExtdDirectoryRestartInfo
};
#endif
#if _WIN32_WINNT < 0x602 || !defined(__MINGW32__)
/* Available in Windows Server 2012, but also in MinGW from Windows 8. */
typedef struct _FILE_ID_INFO {
ULONGLONG VolumeSerialNumber;
FILE_ID_128 FileId;
} FILE_ID_INFO, *PFILE_ID_INFO;
#endif
typedef BOOL (WINAPI *LPFN_GFIBH_EX) (HANDLE, FILE_INFO_BY_HANDLE_CLASS,
LPVOID, DWORD);
static int isSameFile(HANDLE a, HANDLE b)
{
static LPFN_GFIBH_EX gfibh = NULL;
static Rboolean initialized = FALSE;
FILE_ID_INFO aid, bid;
if (!initialized) {
initialized = TRUE;
gfibh = (LPFN_GFIBH_EX) GetProcAddress(
GetModuleHandle(TEXT("kernel32")),
"GetFileInformationByHandleEx");
}
if (gfibh == NULL)
return -1;
memset(&aid, 0, sizeof(FILE_ID_INFO));
memset(&bid, 0, sizeof(FILE_ID_INFO));
if (!gfibh(a, FileIdInfo, &aid, sizeof(FILE_ID_INFO)) ||
!gfibh(b, FileIdInfo, &bid, sizeof(FILE_ID_INFO)))
/* on Vista and Win7 it is expected to fail because FileIdInfo
is not supported */
return -1;
if (aid.VolumeSerialNumber == bid.VolumeSerialNumber &&
!memcmp(&aid.FileId, &bid.FileId, sizeof(FILE_ID_128)))
return 1;
else
return 0;
}
#if _WIN32_WINNT < 0x0600
/* available from Windows Vista */
typedef DWORD (WINAPI *LPFN_GFPNBH) (HANDLE, LPSTR, DWORD, DWORD);
typedef DWORD (WINAPI *LPFN_GFPNBHW) (HANDLE, LPWSTR, DWORD, DWORD);
/*
DWORD GetFinalPathNameByHandle(
HANDLE hFile,
LPSTR lpszFilePath,
DWORD cchFilePath,
DWORD dwFlags);
DWORD GetFinalPathNameByHandleW(
HANDLE hFile,
LPWSTR lpszFilePath,
DWORD cchFilePath,
DWORD dwFlags
);
*/
#endif
/*
Returns TRUE on success. On failure, "res" may be modified but not useful.
*/
static Rboolean getFinalPathName(const char *orig, char *res)
{
HANDLE horig, hres;
int ret;
#if _WIN32_WINNT < 0x0600
static LPFN_GFPNBH gfpnbh = NULL;
static Rboolean initialized = FALSE;
if (!initialized) {
initialized = TRUE;
gfpnbh = (LPFN_GFPNBH) GetProcAddress(
GetModuleHandle(TEXT("kernel32")),
"GetFinalPathNameByHandleA");
}
if (gfpnbh == NULL)
return FALSE;
#endif
/* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
horig = CreateFile(orig, 0,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
NULL);
if (horig == INVALID_HANDLE_VALUE)
return FALSE;
#if _WIN32_WINNT < 0x0600
ret = gfpnbh(horig, res, MAX_PATH, VOLUME_NAME_DOS);
#else
ret = GetFinalPathNameByHandle(horig, res, MAX_PATH, VOLUME_NAME_DOS);
#endif
if (!ret || ret > MAX_PATH) {
CloseHandle(horig);
return FALSE;
}
/* get rid of the \\?\ prefix */
int len = strlen(res);
int strip = 0;
if (len < 4 || strncmp("\\\\?\\", res, 4)) {
/* res should start with \\?\ */
CloseHandle(horig);
return FALSE;
}
if (len > 8 && !strncmp("UNC\\", res+4, 4)) {
/* UNC path \\?\UNC */
res[6] = '\\'; /* replace the "C" in "UNC" to get "\\" prefix */
strip = 6;
} else if (len >= 6 && isalpha(res[4]) && res[5] == ':' && res[6] == '\\')
/* \\?\D: */
strip = 4;
else {
CloseHandle(horig);
return FALSE;
}
memmove(res, res+strip, len-strip+1);
/* sanity check if the file exists using the normalized path, a normalized
path to an existing file should still be working */
/* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
hres = CreateFile(res, 0,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
NULL);
if (hres == INVALID_HANDLE_VALUE) {
CloseHandle(horig);
return FALSE;
}
/* check that the handles point to the same file, which may not be
always the case because of silent best-fit encoding conversion
done by Windows */
ret = isSameFile(horig, hres);
CloseHandle(horig);
CloseHandle(hres);
return (ret == 1) ? TRUE : FALSE;
}
/*
Returns TRUE on success. On failure, "res" may be modified but not useful.
*/
static Rboolean getFinalPathNameW(const wchar_t *orig, wchar_t *res)
{
HANDLE horig, hres;
int ret;
#if _WIN32_WINNT < 0x0600
static LPFN_GFPNBHW gfpnbhw = NULL;
static Rboolean initialized = FALSE;
if (!initialized) {
initialized = TRUE;
gfpnbhw = (LPFN_GFPNBHW) GetProcAddress(
GetModuleHandle(TEXT("kernel32")),
"GetFinalPathNameByHandleW");
}
if (gfpnbhw == NULL)
return FALSE;
#endif
/* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
horig = CreateFileW(orig, 0,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
NULL);
if (horig == INVALID_HANDLE_VALUE)
return FALSE;
#if _WIN32_WINNT < 0x0600
ret = gfpnbhw(horig, res, 32767, VOLUME_NAME_DOS);
#else
ret = GetFinalPathNameByHandleW(horig, res, 32767, VOLUME_NAME_DOS);
#endif
if (!ret || ret > 32768) {
CloseHandle(horig);
return FALSE;
}
/* get rid of the \\?\ prefix */
size_t len = wcslen(res);
int strip = 0;
if (len < 4 || wcsncmp(L"\\\\?\\", res, 4)) {
/* res should start with \\?\ */
CloseHandle(horig);
return FALSE;
}
if (len > 8 && !wcsncmp(L"UNC\\", res+4, 4)) {
/* UNC path \\?\UNC */
res[6] = L'\\';
strip = 6;
} else if (len >= 6 && Ri18n_iswctype(res[4], Ri18n_wctype("alpha"))
&& res[5] == L':' && res[6] == L'\\')
/* \\?\D: */
strip = 4;
else {
CloseHandle(horig);
return FALSE;
}
wmemmove(res, res+strip, len-strip+1);
/* sanity check if the file exists using the normalized path, a normalized
path to an existing file should still be working */
/* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
hres = CreateFileW(res, 0,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
NULL);
if (hres == INVALID_HANDLE_VALUE) {
CloseHandle(horig);
return FALSE;
}
/* sanity check that the handles point to the same file; they should, but
better be safe wrt to undocumented features/changes of gfpnbhw */
ret = isSameFile(horig, hres);
CloseHandle(horig);
CloseHandle(hres);
return ret ? TRUE : FALSE; /* return TRUE when isSameFile fails with -1 */
}
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[4*MAX_PATH+1], longpath[4*MAX_PATH+1], *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++) {
SEXP result;
Rboolean ok = FALSE;
el = STRING_ELT(paths, i);
result = el;
if (el == NA_STRING) {
result = NA_STRING;
if(mustWork == 1)
errorcall(call, "path[%d]=NA", i+1);
else if(mustWork == NA_LOGICAL)
warningcall(call, "path[%d]=NA", i+1);
} else if(getCharCE(el) == CE_UTF8) {
wchar_t *norm = NULL;
const wchar_t* wel = filenameToWchar(el, FALSE);
if (getFinalPathNameW(wel, wtmp)) {
norm = wtmp;
ok = TRUE;
/* if normalized to UNC path but full path is D:..., fall back
to GetLongPathName */
if (norm[0] == L'\\' && norm[1] == L'\\') {
res = GetFullPathNameW(wel, 32768, wlongpath, &wtmp2);
if (res && res <= 32768 &&
Ri18n_iswctype(wlongpath[0], Ri18n_wctype("alpha")) &&
wlongpath[1] == L':') {
ok = FALSE;
norm = NULL;
/* NOTE: GetFullPathName is called twice */
}
}
}
if (!ok) {
/* silently fall back to GetFullPathNameW/GetLongPathNameW */
res = GetFullPathNameW(wel, 32768, wtmp, &wtmp2);
if (res && res <= 32768) {
norm = wtmp;
res = GetLongPathNameW(wtmp, wlongpath, 32768);
if (res && res <= 32768) {
norm = wlongpath;
ok = TRUE;
}
}
}
if (!ok) {
if (mustWork == 1) {
errorcall(call, "path[%d]=\"%ls\": %s", i+1,
wel, formatError(GetLastError()));
} else if (mustWork == NA_LOGICAL) {
warningcall(call, "path[%d]=\"%ls\": %s", i+1,
wel, formatError(GetLastError()));
}
}
char *normutf8 = tmp;
if (norm)
wcstoutf8(tmp, norm, sizeof(tmp));
else if (fslash)
strcpy(tmp, translateCharUTF8(el));
else
normutf8 = (char *)translateCharUTF8(el);
if (fslash) R_UTF8fixslash(normutf8);
result = mkCharCE(normutf8, CE_UTF8);
} else {
char *norm = NULL;
const char *tel = translateChar(el);
if (getFinalPathName(tel, tmp)) {
norm = tmp;
ok = TRUE;
/* if normalized to UNC path but full path is D:..., fall back
to GetLongPathName */
if (norm[0] == '\\' && norm[1] == '\\') {
res = GetFullPathName(tel, MAX_PATH, longpath, &tmp2);
if (res && res <= MAX_PATH &&
isalpha(longpath[0]) && longpath[1] == ':') {
ok = FALSE;
norm = NULL;
/* NOTE: GetFullPathName is called twice */
}
}
}
if (!ok) {
/* silently fall back to GetFullPathName/GetLongPathName */
res = GetFullPathName(tel, MAX_PATH, tmp, &tmp2);
if (res && res <= MAX_PATH) {
norm = tmp;
res = GetLongPathName(tmp, longpath, MAX_PATH);
if (res && res <= MAX_PATH) {
norm = longpath;
ok = TRUE;
}
}
}
if (!ok) {
if (mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
tel, formatError(GetLastError()));
} else if (mustWork == NA_LOGICAL) {
warningcall(call, "path[%d]=\"%s\": %s", i+1,
tel, formatError(GetLastError()));
}
if (!norm) {
if (fslash) {
strcpy(tmp, tel);
norm = tmp;
} else
norm = (char *)tel;
}
}
if (fslash) R_fixslash(norm);
result = mkChar(norm);
}
SET_STRING_ELT(ans, i, result);
}
UNPROTECT(1);
return ans;
}
/* utils::shortPathName */
SEXP in_shortpath(SEXP paths)
{
SEXP ans, el;
int i, n = LENGTH(paths);
char tmp[4*MAX_PATH+1];
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, sizeof(tmp));
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;
}
#include "devWindows.h"
#include <R_ext/GraphicsEngine.h> /* GEgetDevice */
/* grDevices::bringToTop */
SEXP bringtotop(SEXP sdev, SEXP sstay)
{
int dev, stay;
pGEDevDesc gdd;
gadesc *xd;
dev = asInteger(sdev);
stay = asInteger(sstay);
if(dev == -1) { /* console */
if(CharacterMode == RGui) BringToTop(RConsole, stay);
} else {
if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
gdd = GEgetDevice(dev - 1);
if(!gdd) error(_("invalid device"));
xd = (gadesc *) gdd->dev->deviceSpecific;
if(!xd) error(_("invalid device"));
if(stay && ismdi()) error(_("requires SDI mode"));
BringToTop(xd->gawin, stay);
}
return R_NilValue;
}
/* grDevices::msgWindow */
SEXP msgwindow(SEXP sdev, SEXP stype)
{
int dev, type;
pGEDevDesc gdd;
gadesc *xd;
dev = asInteger(sdev);
type = asInteger(stype);
if(dev == -1) { /* console */
if(CharacterMode == RGui) GA_msgWindow(RConsole, type);
} else {
if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
error(_("invalid '%s' argument"), "which");
gdd = GEgetDevice(dev - 1);
if(!gdd) error(_("invalid device"));
xd = (gadesc *) gdd->dev->deviceSpecific;
if(!xd) error(_("invalid device"));
if(type == 5) {
xd->recording = TRUE;
check(xd->mrec);
} else if(type == 6) {
xd-> recording = FALSE;
uncheck(xd->mrec);
} else
GA_msgWindow(xd->gawin, type);
}
return R_NilValue;
}
/* This assumes a menuname of the form
$Graph<nn>Main, $Graph<nn>Popup, $Graph<nn>LocMain,
or $Graph<nn>LocPopup where <nn> is the
device number. We've already checked the $Graph prefix. */
/* called from rui.c, only */
menu getGraphMenu(const char* menuname)
{
int devnum;
pGEDevDesc gdd;
gadesc *xd;
menuname = menuname + 6;
devnum = atoi(menuname);
if(devnum < 1 || devnum > R_MaxDevices)
error(_("invalid graphical device number"));
while (('0' <= *menuname) && (*menuname <= '9')) menuname++;
gdd = GEgetDevice(devnum - 1);
if(!gdd) error(_("invalid device"));
xd = (gadesc *) gdd->dev->deviceSpecific;
if(!xd || xd->kind != SCREEN) error(_("bad device"));
if (strcmp(menuname, "Main") == 0) return(xd->mbar);
else if (strcmp(menuname, "Popup") == 0) return(xd->grpopup);
else return(NULL);
}
/*
Replacement for MSVCRT's access.
Coded looking at tcl's tclWinFile.c
*/
int winAccessW(const wchar_t *path, int mode)
{
DWORD attr = GetFileAttributesW(path);
if(attr == INVALID_FILE_ATTRIBUTES)
/* file does not exist or may be locked */
return -1;
if(mode == F_OK) return 0;
if ((mode & W_OK)
&& !(attr & FILE_ATTRIBUTE_DIRECTORY)
&& (attr & FILE_ATTRIBUTE_READONLY)) return -1;
if(mode & X_OK)
if(!(attr & FILE_ATTRIBUTE_DIRECTORY)) { /* Directory, so OK */
/* Look at extension for executables */
wchar_t *p = wcsrchr(path, '.');
if(p == NULL ||
!((wcsicmp(p, L".exe") == 0) || (wcsicmp(p, L".com") == 0) ||
(wcsicmp(p, L".bat") == 0) || (wcsicmp(p, L".cmd") == 0)) )
return -1;
}
{
/* Now look for file security info */
SECURITY_DESCRIPTOR *sdPtr = NULL;
DWORD size = 0;
PSID sid = 0;
BOOL sidDefaulted;
SID_IDENTIFIER_AUTHORITY samba_unmapped = {{0, 0, 0, 0, 0, 22}};
GENERIC_MAPPING genMap;
HANDLE hToken = NULL;
DWORD desiredAccess = 0;
DWORD grantedAccess = 0;
BOOL accessYesNo = FALSE;
PRIVILEGE_SET privSet;
DWORD privSetSize = sizeof(PRIVILEGE_SET);
int error;
/* get size */
GetFileSecurityW(path,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION,
0, 0, &size);
error = GetLastError();
if (error == ERROR_NOT_SUPPORTED)
/* happens for some remote shares */
return _waccess(path, mode);
if (error != ERROR_INSUFFICIENT_BUFFER)
return -1;
sdPtr = (SECURITY_DESCRIPTOR *) alloca(size);
if(!GetFileSecurityW(path,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, sdPtr, size, &size))
return -1;
/* rely on attrib checks for unmapped samba owners and groups */
if (!GetSecurityDescriptorOwner(sdPtr, &sid, &sidDefaulted))
return 0;
if (IsValidSid(sid) &&
!memcmp(GetSidIdentifierAuthority(sid), &samba_unmapped, sizeof(SID_IDENTIFIER_AUTHORITY)))
return 0;
/*
* Perform security impersonation of the user and open the
* resulting thread token.
*/
if(!ImpersonateSelf(SecurityImpersonation)) return -1;
if(!OpenThreadToken(GetCurrentThread (),
TOKEN_DUPLICATE | TOKEN_QUERY, FALSE,
&hToken)) return -1;
if (mode & R_OK) desiredAccess |= FILE_GENERIC_READ;
if (mode & W_OK) desiredAccess |= FILE_GENERIC_WRITE;
if (mode & X_OK) desiredAccess |= FILE_GENERIC_EXECUTE;
memset(&genMap, 0x0, sizeof (GENERIC_MAPPING));
genMap.GenericRead = FILE_GENERIC_READ;
genMap.GenericWrite = FILE_GENERIC_WRITE;
genMap.GenericExecute = FILE_GENERIC_EXECUTE;
genMap.GenericAll = FILE_ALL_ACCESS;
if(!AccessCheck(sdPtr, hToken, desiredAccess, &genMap, &privSet,
&privSetSize, &grantedAccess, &accessYesNo)) {
CloseHandle(hToken);
return -1;
}
CloseHandle(hToken);
if (!accessYesNo) return -1;
}
return 0;
}
#include <Rversion.h>
char *getDLLVersion(void)
{
static char DLLversion[25];
OSVERSIONINFO osvi;
osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
GetVersionEx(&osvi);
/* 95, 98, ME are 4.x */
if(osvi.dwMajorVersion < 5)
R_Suicide("Windows 2000 or later is required");
snprintf(DLLversion, 25, "%s.%s", R_MAJOR, R_MINOR);
return (DLLversion);
}
/* base::file.choose */
SEXP attribute_hidden do_filechoose(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
wchar_t *fn;
char str[4*MAX_PATH+1];
checkArity(op, args);
setuserfilterW(L"All files (*.*)\0*.*\0\0");
fn = askfilenameW(G_("Select file"), "");
if (!fn)
error(_("file choice cancelled"));
wcstoutf8(str, fn, sizeof(str));
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharCE(str, CE_UTF8));
UNPROTECT(1);
return ans;
}
const char *getTZinfo(void); // src/extra/tzone/registryTZ.c
SEXP attribute_hidden do_tzone_name(SEXP call, SEXP op, SEXP args, SEXP rho)
{
return mkString(getTZinfo());
}