The R Project SVN R

Rev

Rev 85648 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
9920 ripley 1 
/*
2 
 *  R : A Computer Language for Statistical Data Analysis
3 
 *  file extra.c
23257 ripley 4 
 *  Copyright (C) 1998--2003  Guido Masarotto and Brian Ripley
28130 murdoch 5 
 *  Copyright (C) 2004	      The R Foundation
86967 kalibera 6 
 *  Copyright (C) 2005--2024  The R Core Team
9920 ripley 7 
 *
8 
 *  This program is free software; you can redistribute it and/or modify
9 
 *  it under the terms of the GNU General Public License as published by
10 
 *  the Free Software Foundation; either version 2 of the License, or
11 
 *  (at your option) any later version.
12 
 *
13 
 *  This program is distributed in the hope that it will be useful,
14 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
15 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 
 *  GNU General Public License for more details.
17 
 *
18 
 *  You should have received a copy of the GNU General Public License
42300 ripley 19 
 *  along with this program; if not, a copy is available at
68956 ripley 20 
 *  https://www.R-project.org/Licenses/
9920 ripley 21 
 */
22 
 
23 
 
24 
/* extra commands for R */
25 
 
26 
#ifdef HAVE_CONFIG_H
27 
#include <config.h>
28 
#endif
29 
 
33901 ripley 30 
#include "win-nls.h"
31 
 
84681 kalibera 32 
#include <float.h>
9920 ripley 33 
#include <stdio.h>
77324 kalibera 34 
#include <string.h>
57540 ripley 35 
#include <time.h>
9920 ripley 36 
#include "Defn.h"
60667 ripley 37 
#include <Internal.h>
9920 ripley 38 
#include "Fileio.h"
39 
#include <direct.h>
44008 ripley 40 
#include "graphapp/ga.h"
77324 kalibera 41 
#include "rlocale.h"
9920 ripley 42 
#include <windows.h>
43 
#include "rui.h"
45005 ripley 44 
#undef ERROR
81491 ripley 45 
#include <R_ext/RS.h> /* formerly for Calloc */
9920 ripley 46 
 
47 
#include <winbase.h>
43328 ripley 48 
 
9920 ripley 49 
 
55471 murdoch 50 
/* used in rui.c */
41783 ripley 51 
void internal_shellexec(const char * file)
9920 ripley 52 
{
41783 ripley 53 
    const char *home;
55458 ripley 54 
    char home2[10000], *p;
42244 ripley 55 
    uintptr_t ret;
9920 ripley 56 
 
57 
    home = getenv("R_HOME");
58 
    if (home == NULL)
32888 ripley 59 
	error(_("R_HOME not set"));
77919 kalibera 60 
    strncpy(home2, home, 10000 - 1);
61 
    home2[10000 - 1] = '\0';
55458 ripley 62 
    for(p = home2; *p; p++) if(*p == '/') *p = '\\';
63 
    ret = (uintptr_t) ShellExecute(NULL, "open", file, NULL, home2, SW_SHOW);
39991 ripley 64 
    if(ret <= 32) { /* an error condition */
65 
	if(ret == ERROR_FILE_NOT_FOUND  || ret == ERROR_PATH_NOT_FOUND
66 
	   || ret == SE_ERR_FNF || ret == SE_ERR_PNF)
67 
	    error(_("'%s' not found"), file);
68 
	if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
43323 ripley 69 
	    error(_("file association for '%s' not available or invalid"),
39991 ripley 70 
		  file);
71 
	if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
72 
	    error(_("access to '%s' denied"), file);
73 
	error(_("problem in displaying '%s'"), file);
74 
    }
9920 ripley 75 
}
76 
 
55471 murdoch 77 
/* used by shell.exec() with rhome=FALSE.  2.13.0 and earlier were
78 
   like rhome=TRUE, but without fixing the path */
79 
static void internal_shellexecW(const wchar_t * file, Rboolean rhome)
44008 ripley 80 
{
81 
    const wchar_t *home;
55471 murdoch 82 
    wchar_t home2[10000], *p;
44008 ripley 83 
    uintptr_t ret;
55471 murdoch 84 
 
85 
    if (rhome) {
86 
    	home = _wgetenv(L"R_HOME");
87 
    	if (home == NULL)
88 
	    error(_("R_HOME not set"));
89 
    	wcsncpy(home2, home, 10000);
90 
    	for(p = home2; *p; p++) if(*p == L'/') *p = L'\\';
91 
	home = home2;
92 
    } else home = NULL;
93 
 
44008 ripley 94 
    ret = (uintptr_t) ShellExecuteW(NULL, L"open", file, NULL, home, SW_SHOW);
95 
    if(ret <= 32) { /* an error condition */
96 
	if(ret == ERROR_FILE_NOT_FOUND  || ret == ERROR_PATH_NOT_FOUND
97 
	   || ret == SE_ERR_FNF || ret == SE_ERR_PNF)
48339 murdoch 98 
	    error(_("'%ls' not found"), file);
44008 ripley 99 
	if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
48339 murdoch 100 
	    error(_("file association for '%ls' not available or invalid"),
44008 ripley 101 
		  file);
102 
	if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
48339 murdoch 103 
	    error(_("access to '%ls' denied"), file);
104 
	error(_("problem in displaying '%ls'"), file);
44008 ripley 105 
    }
106 
}
107 
 
9920 ripley 108 
SEXP do_shellexec(SEXP call, SEXP op, SEXP args, SEXP env)
109 
{
110 
    SEXP file;
111 
 
112 
    checkArity(op, args);
113 
    file = CAR(args);
114 
    if (!isString(file) || length(file) != 1)
35264 ripley 115 
	errorcall(call, _("invalid '%s' argument"), "file");
55471 murdoch 116 
    internal_shellexecW(filenameToWchar(STRING_ELT(file, 0), FALSE), FALSE);
9920 ripley 117 
    return R_NilValue;
118 
}
119 
 
83772 kalibera 120 
int check_doc_file(const char *file)
9920 ripley 121 
{
41783 ripley 122 
    const char *home;
83772 kalibera 123 
    char *path;
9920 ripley 124 
 
125 
    home = getenv("R_HOME");
126 
    if (home == NULL)
32888 ripley 127 
	error(_("R_HOME not set"));
83772 kalibera 128 
    path = (char *) malloc(strlen(home) + 1 + strlen(file) + 1);
129 
    if (!path)
130 
	return 0; /* treat error as no access, used in GUI */
9920 ripley 131 
    strcpy(path, home);
132 
    strcat(path, "/");
133 
    strcat(path, file);
83772 kalibera 134 
    int res = (access(path, 4) == 0); /* read access is granted */
135 
    free(path);
136 
    return res;
9920 ripley 137 
}
138 
 
139 
#include "Startup.h"
140 
 
44201 ripley 141 
void Rwin_fpset(void)
9920 ripley 142 
{
37410 ripley 143 
    /* Under recent MinGW this is what fpreset does.  It sets the
144 
       control word to 0x37f which corresponds to 0x8001F as used by
145 
       _controlfp.  That is all errors are masked, 64-bit mantissa and
84681 kalibera 146 
       rounding are selected:
37410 ripley 147 
 
84681 kalibera 148 
       __asm__ ( "fninit" ) ;
149 
    */
150 
    _fpreset();
9920 ripley 151 
}
152 
 
19940 ripley 153 
 
37626 murdoch 154 
#include <preferences.h>
155 
 
60690 ripley 156 
/* utils::loadRconsole */
60717 ripley 157 
SEXP in_loadRconsole(SEXP sfile)
37626 murdoch 158 
{
159 
    struct structGUI gui;
63181 ripley 160 
    const void *vmax = vmaxget();
37626 murdoch 161 
 
162 
    if (!isString(sfile) || LENGTH(sfile) < 1)
60717 ripley 163 
	error(_("invalid '%s' argument"), "file");
43958 murdoch 164 
    getActive(&gui);  /* Will get defaults if there's no active console */
44008 ripley 165 
    if (loadRconsole(&gui, translateChar(STRING_ELT(sfile, 0)))) applyGUI(&gui);
85614 kalibera 166 
    if (strlen(gui.warning)) warning("%s", gui.warning);
63181 ripley 167 
    vmaxset(vmax);
37626 murdoch 168 
    return R_NilValue;
169 
}
43323 ripley 170 
 
86967 kalibera 171 
/* returns R_alloc'd results */
172 
static int getCurrentUserAndDomain(char **user, char **domain)
173 
{
174 
    int ok = 0;
175 
    HANDLE h = INVALID_HANDLE_VALUE;
176 
    DWORD err;
177 
    DWORD tilen = 0;
178 
    PTOKEN_USER t = NULL;
179 
    char *ubuf = NULL;
180 
    DWORD ulen = 0;
181 
    char *dbuf = NULL;
182 
    DWORD dlen = 0;
183 
    SID_NAME_USE suse = SidTypeUnknown;
184 
 
185 
    ok = OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, TRUE, &h);
186 
    if (!ok) {
187 
	err = GetLastError();
188 
	if (err == ERROR_NO_TOKEN || err == ERROR_NO_IMPERSONATION_TOKEN)
189 
	    ok = OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &h);
190 
    }
191 
 
192 
    ok = ok && !GetTokenInformation(h, TokenUser, NULL, 0, &tilen)
193 
	 && GetLastError() == ERROR_INSUFFICIENT_BUFFER;
194 
 
195 
    if (ok) {
196 
	t = (PTOKEN_USER) R_alloc(tilen, 1);
197 
	ok = GetTokenInformation(h, TokenUser, t, tilen, &tilen);
198 
    }
199 
 
200 
    if (ok) {
201 
	ok = !LookupAccountSid(NULL, t->User.Sid, ubuf, &ulen, dbuf, &dlen,
202 
	                       &suse)
203 
	     && GetLastError() == ERROR_INSUFFICIENT_BUFFER;
204 
 
205 
	if (ok) {
206 
	    ubuf = R_alloc(ulen, 1);
207 
	    dbuf = R_alloc(dlen, 1);
208 
	    ok = LookupAccountSid(NULL, t->User.Sid, ubuf, &ulen, dbuf, &dlen,
209 
	                          &suse);
210 
	}
211 
    }
212 
 
213 
    if (!ok)
214 
	err = GetLastError();
215 
 
216 
    if (h != INVALID_HANDLE_VALUE)
217 
	CloseHandle(h);
218 
 
219 
    if (ok) {
220 
	if (user)
221 
	    *user = ubuf;
222 
	if (domain)
223 
	    *domain = dbuf;
224 
	return 1;
225 
    } else {
226 
	if (user)
227 
	    *user = NULL;
228 
	if (domain)
229 
	    *domain = NULL;
230 
	SetLastError(err);
231 
	return 0;
232 
    }
233 
}
234 
 
235 
 
9920 ripley 236 
#include <lmcons.h>
60688 ripley 237 
typedef void (WINAPI *PGNSI)(LPSYSTEM_INFO);
9920 ripley 238 
 
86967 kalibera 239 
const char *formatError(DWORD res);
240 
 
60690 ripley 241 
/* base::Sys.info */
69039 ripley 242 
// keep in step with src/library/utils/src/windows/util.c
9920 ripley 243 
SEXP do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
244 
{
245 
    SEXP ans, ansnames;
43328 ripley 246 
    OSVERSIONINFOEX osvi;
45070 ripley 247 
    char ver[256], buf[1000];
86967 kalibera 248 
    wchar_t name[MAX_COMPUTERNAME_LENGTH + 1];
249 
    DWORD namelen = MAX_COMPUTERNAME_LENGTH + 1;
250 
    const void *vmax = vmaxget();
251 
    char *uname;
252 
    char *udomain;
9920 ripley 253 
 
254 
    checkArity(op, args);
86967 kalibera 255 
    PROTECT(ans = allocVector(STRSXP, 9));
43328 ripley 256 
    osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX);
257 
    if(!GetVersionEx((OSVERSIONINFO *)&osvi))
258 
	error(_("unsupported version of Windows"));
9920 ripley 259 
 
10172 luke 260 
    SET_STRING_ELT(ans, 0, mkChar("Windows"));
43326 ripley 261 
 
43328 ripley 262 
    /* Here for unknown future versions */
62583 ripley 263 
    snprintf(ver, 256, "%d.%d",
264 
	     (int)osvi.dwMajorVersion, (int)osvi.dwMinorVersion);
43328 ripley 265 
 
43323 ripley 266 
    if((int)osvi.dwMajorVersion >= 5) {
267 
	PGNSI pGNSI;
268 
	SYSTEM_INFO si;
69050 ripley 269 
	if(osvi.dwMajorVersion == 10 && osvi.dwMinorVersion == 0) {
270 
	    if(osvi.wProductType == VER_NT_WORKSTATION) strcpy(ver, "10");
271 
	    else strcpy(ver, "Server");
272 
	}
43323 ripley 273 
	if(osvi.dwMajorVersion == 6) {
69040 ripley 274 
	    char *desc = "";
52150 ripley 275 
	    if(osvi.wProductType == VER_NT_WORKSTATION) {
69039 ripley 276 
		if(osvi.dwMinorVersion == 0) desc = "Vista";
277 
		else if(osvi.dwMinorVersion == 1) desc = "7";
278 
		else if(osvi.dwMinorVersion == 2) desc = ">= 8";
69050 ripley 279 
		else if(osvi.dwMinorVersion == 3) desc = "8.1";
280 
		else desc = "> 8.1";
69039 ripley 281 
	    } else {
282 
		if(osvi.dwMinorVersion == 0) desc = "Server 2008";
283 
		else if(osvi.dwMinorVersion == 1) desc = "Server 2008 R2";
284 
		else if(osvi.dwMinorVersion == 2) desc = "Server >= 2012";
69050 ripley 285 
		else if(osvi.dwMinorVersion == 3) desc = "Server 2012 R2";
69039 ripley 286 
		else desc = "Server > 2012";
287 
	    }
288 
	    strcpy(ver, desc);
43323 ripley 289 
	}
290 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 0)
291 
	    strcpy(ver, "2000");
292 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 1)
293 
	    strcpy(ver, "XP");
294 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 2) {
43328 ripley 295 
	    if(osvi.wProductType == VER_NT_WORKSTATION)
43323 ripley 296 
		strcpy(ver, "XP Professional");
297 
	    else strcpy(ver, "Server 2003");
298 
	}
43328 ripley 299 
	/* GetNativeSystemInfo is XP or later */
43323 ripley 300 
	pGNSI = (PGNSI)
301 
	    GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
302 
			   "GetNativeSystemInfo");
303 
	if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
304 
	if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
305 
	    strcat(ver, " x64");
84681 kalibera 306 
	else if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_ARM64)
307 
	    strcat(ver, " arm64");
43326 ripley 308 
    }
10172 luke 309 
    SET_STRING_ELT(ans, 1, mkChar(ver));
43323 ripley 310 
 
311 
    if((int)osvi.dwMajorVersion >= 5) {
43328 ripley 312 
	if(osvi.wServicePackMajor > 0)
62583 ripley 313 
	    snprintf(ver, 256, "build %d, Service Pack %d",
314 
		     LOWORD(osvi.dwBuildNumber),
315 
		     (int) osvi.wServicePackMajor);
316 
	else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
43323 ripley 317 
    } else
62583 ripley 318 
	snprintf(ver, 256, "build %d, %s",
319 
		 LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
10172 luke 320 
    SET_STRING_ELT(ans, 2, mkChar(ver));
44059 ripley 321 
    GetComputerNameW(name, &namelen);
72714 murdoch 322 
    wcstoutf8(buf, name, sizeof(buf));
44986 ripley 323 
    SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
84681 kalibera 324 
#ifdef __aarch64__
325 
    SET_STRING_ELT(ans, 4, mkChar("aarch64"));
326 
#elif defined(_WIN64)
52152 ripley 327 
    SET_STRING_ELT(ans, 4, mkChar("x86-64"));
328 
#else
10172 luke 329 
    SET_STRING_ELT(ans, 4, mkChar("x86"));
52152 ripley 330 
#endif
86967 kalibera 331 
    if (!getCurrentUserAndDomain(&uname, &udomain)) {
332 
	SET_STRING_ELT(ans, 5, mkChar("unknown"));
333 
	SET_STRING_ELT(ans, 8, mkChar("unknown"));
334 
	warning(_("cannot resolve current user or domain: '%s'"),
335 
	       formatError(GetLastError()));
336 
    } else {
337 
	SET_STRING_ELT(ans, 5, mkChar(uname));
338 
	SET_STRING_ELT(ans, 8, mkChar(udomain));
339 
    }
10172 luke 340 
    SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
56204 ripley 341 
    SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
86967 kalibera 342 
    PROTECT(ansnames = allocVector(STRSXP, 9));
10172 luke 343 
    SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
344 
    SET_STRING_ELT(ansnames, 1, mkChar("release"));
345 
    SET_STRING_ELT(ansnames, 2, mkChar("version"));
346 
    SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
347 
    SET_STRING_ELT(ansnames, 4, mkChar("machine"));
348 
    SET_STRING_ELT(ansnames, 5, mkChar("login"));
349 
    SET_STRING_ELT(ansnames, 6, mkChar("user"));
56204 ripley 350 
    SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
86967 kalibera 351 
    SET_STRING_ELT(ansnames, 8, mkChar("udomain"));
9920 ripley 352 
    setAttrib(ans, R_NamesSymbol, ansnames);
86967 kalibera 353 
    vmaxset(vmax);
9920 ripley 354 
    UNPROTECT(2);
355 
    return ans;
356 
}
357 
 
67451 ripley 358 
void Rsleep(double timeint)
19940 ripley 359 
{
67451 ripley 360 
    int ntime = 1000*timeint + 0.5;
13548 ripley 361 
    DWORD mtime;
9934 ripley 362 
    while (ntime > 0) {
363 
	mtime = min(500, ntime);
364 
	ntime -= mtime;
365 
	Sleep(mtime);
366 
	R_ProcessEvents();
367 
    }
67451 ripley 368 
 
9934 ripley 369 
}
10365 ripley 370 
 
371 
SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho)
372 
{
60688 ripley 373 
    SEXP path = R_NilValue, ans;
44008 ripley 374 
    const wchar_t *dll;
10365 ripley 375 
    DWORD dwVerInfoSize;
376 
    DWORD dwVerHnd;
19940 ripley 377 
 
10365 ripley 378 
    checkArity(op, args);
379 
    path = CAR(args);
380 
    if(!isString(path) || LENGTH(path) != 1)
35264 ripley 381 
	errorcall(call, _("invalid '%s' argument"), "path");
44008 ripley 382 
    dll = filenameToWchar(STRING_ELT(path, 0), FALSE);
383 
    dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd);
10365 ripley 384 
    PROTECT(ans = allocVector(STRSXP, 2));
10377 ripley 385 
    SET_STRING_ELT(ans, 0, mkChar(""));
386 
    SET_STRING_ELT(ans, 1, mkChar(""));
10365 ripley 387 
    if (dwVerInfoSize) {
388 
	BOOL  fRet;
389 
	LPSTR lpstrVffInfo;
390 
	LPSTR lszVer = NULL;
391 
	UINT  cchVer = 0;
392 
 
393 
	lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize);
60690 ripley 394 
	if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) {
19940 ripley 395 
 
10365 ripley 396 
	    fRet = VerQueryValue(lpstrVffInfo,
397 
				 TEXT("\\StringFileInfo\\040904E4\\FileVersion"),
398 
				 (LPVOID)&lszVer, &cchVer);
10377 ripley 399 
	    if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer));
10365 ripley 400 
 
401 
	    fRet = VerQueryValue(lpstrVffInfo,
402 
				 TEXT("\\StringFileInfo\\040904E4\\R Version"),
403 
				 (LPVOID)&lszVer, &cchVer);
10377 ripley 404 
	    if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
10365 ripley 405 
	    else {
406 
		fRet = VerQueryValue(lpstrVffInfo,
407 
				     TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"),
408 
				     (LPVOID)&lszVer, &cchVer);
10377 ripley 409 
		if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
10365 ripley 410 
	    }
19940 ripley 411 
 
10365 ripley 412 
	} else ans = R_NilValue;
413 
	free(lpstrVffInfo);
414 
    } else ans = R_NilValue;
415 
    UNPROTECT(1);
416 
    return ans;
417 
}
418 
 
73329 kalibera 419 
/* Retry renaming a few times to recover from possible anti-virus interference,
420 
   which has been reported e.g. during installation of packages. */
13548 ripley 421 
 
41783 ripley 422 
int Rwin_rename(const char *from, const char *to)
19531 ripley 423 
{
73308 kalibera 424 
    for(int retries = 0; retries < 10; retries++) {
76170 kalibera 425 
	/* coreutils first call MoveFileEx without flags; only if it fails
426 
	   with ERROR_FILE_EXISTS or ERROR_ALREADY_EXISTING, they call again
427 
	   with MOVEFILE_REPLACE_EXISTING */
73308 kalibera 428 
	if (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH))
429 
	    return 0;
73329 kalibera 430 
	DWORD err = GetLastError();
431 
	if (err != ERROR_SHARING_VIOLATION && err != ERROR_ACCESS_DENIED)
73308 kalibera 432 
	    return 1;
433 
	Sleep(500);
73323 kalibera 434 
	R_ProcessEvents();
73308 kalibera 435 
    }
436 
    return 1;
44008 ripley 437 
}
19531 ripley 438 
 
44008 ripley 439 
int Rwin_wrename(const wchar_t *from, const wchar_t *to)
440 
{
73308 kalibera 441 
    for(int retries = 0; retries < 10; retries++) {
442 
	if (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH))
443 
	    return 0;
73329 kalibera 444 
	DWORD err = GetLastError();
73323 kalibera 445 
	if (err != ERROR_SHARING_VIOLATION && err != ERROR_ACCESS_DENIED)
73308 kalibera 446 
	    return 1;
447 
	Sleep(500);
73323 kalibera 448 
	R_ProcessEvents();
73308 kalibera 449 
    }
450 
    return 1;
19531 ripley 451 
}
20669 ripley 452 
 
43323 ripley 453 
 
60686 ripley 454 
const char *formatError(DWORD res)
455 
{
456 
    static char buf[1000], *p;
457 
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
458 
		  NULL, res,
459 
		  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
460 
		  buf, 1000, NULL);
461 
    p = buf+strlen(buf) -1;
462 
    if(*p == '\n') *p = '\0';
463 
    p = buf+strlen(buf) -1;
464 
    if(*p == '\r') *p = '\0';
465 
    p = buf+strlen(buf) -1;
466 
    if(*p == '.') *p = '\0';
467 
    return buf;
468 
}
46777 murdoch 469 
 
83954 kalibera 470 
#if _WIN32_WINNT < 0x0602
78140 kalibera 471 
/* These constants were added to FILE_INFO_BY_HANDLE_CLASS in Windows 8 */
472 
enum {
473 
  FileStorageInfo = FileFullDirectoryRestartInfo + 1,
474 
  FileAlignmentInfo,
475 
  FileIdInfo,
476 
  FileIdExtdDirectoryInfo,
477 
  FileIdExtdDirectoryRestartInfo
478 
};
479 
#endif
78069 kalibera 480 
 
80707 kalibera 481 
#if _WIN32_WINNT < 0x602 || !defined(__MINGW32__)
78140 kalibera 482 
/* Available in Windows Server 2012, but also in MinGW from Windows 8.  */
78069 kalibera 483 
typedef struct _FILE_ID_INFO {
484 
  ULONGLONG   VolumeSerialNumber;
485 
  FILE_ID_128 FileId;
486 
} FILE_ID_INFO, *PFILE_ID_INFO;
487 
#endif
488 
 
489 
typedef BOOL (WINAPI *LPFN_GFIBH_EX) (HANDLE, FILE_INFO_BY_HANDLE_CLASS,
490 
                                      LPVOID, DWORD);
491 
 
492 
static int isSameFile(HANDLE a, HANDLE b)
493 
{
494 
    FILE_ID_INFO aid, bid;
495 
 
496 
    memset(&aid, 0, sizeof(FILE_ID_INFO));
497 
    memset(&bid, 0, sizeof(FILE_ID_INFO));
83954 kalibera 498 
    if (!GetFileInformationByHandleEx(a, FileIdInfo, &aid, sizeof(FILE_ID_INFO)) ||
499 
        !GetFileInformationByHandleEx(b, FileIdInfo, &bid, sizeof(FILE_ID_INFO)))
78140 kalibera 500 
	/* on Vista and Win7 it is expected to fail because FileIdInfo
501 
	   is not supported */
78069 kalibera 502 
	return -1;
503 
 
504 
    if (aid.VolumeSerialNumber == bid.VolumeSerialNumber &&
505 
	!memcmp(&aid.FileId, &bid.FileId, sizeof(FILE_ID_128)))
506 
 
507 
	return 1;
508 
    else
509 
	return 0;
510 
}
511 
 
83772 kalibera 512 
/* returns R_alloc'd result */
513 
static char *getFinalPathName(const char *orig)
77324 kalibera 514 
{
78069 kalibera 515 
    HANDLE horig, hres;
83772 kalibera 516 
    int ret, ret1;
77324 kalibera 517 
 
78069 kalibera 518 
    /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
519 
    horig = CreateFile(orig, 0,
520 
                       FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
521 
                       NULL, OPEN_EXISTING,
522 
	               FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
523 
                       NULL);
524 
    if (horig == INVALID_HANDLE_VALUE)
83772 kalibera 525 
	return NULL;
526 
 
527 
    ret = GetFinalPathNameByHandle(horig, NULL, 0, VOLUME_NAME_DOS);
528 
    if (ret <= 0) {
78069 kalibera 529 
	CloseHandle(horig);
83772 kalibera 530 
	return NULL;
78069 kalibera 531 
    }
83772 kalibera 532 
    /* while the documentation says that "ret" shall include the size needed
533 
       including the terminator, apparently it does not include the terminator.
534 
       (seen on Windows 10, build 19045), so increase the size. */
535 
    ret++;
536 
 
537 
    char *res = R_alloc(ret, 1);
538 
    ret1 = GetFinalPathNameByHandle(horig, res, ret, VOLUME_NAME_DOS);
539 
    if (ret1 <= 0 || ret1 >= ret) {
540 
	CloseHandle(horig);
541 
	return NULL;
542 
    }
77324 kalibera 543 
 
544 
    /* get rid of the \\?\ prefix */
83772 kalibera 545 
    int len = ret;
77324 kalibera 546 
    int strip = 0;
78069 kalibera 547 
    if (len < 4 || strncmp("\\\\?\\", res, 4)) {
77324 kalibera 548 
	/* res should start with \\?\ */
78069 kalibera 549 
	CloseHandle(horig);
83772 kalibera 550 
	return NULL;
78069 kalibera 551 
    }
77324 kalibera 552 
 
77458 kalibera 553 
    if (len > 8 && !strncmp("UNC\\", res+4, 4)) {
77324 kalibera 554 
	/* UNC path \\?\UNC */
77458 kalibera 555 
	res[6] = '\\'; /* replace the "C" in "UNC" to get "\\" prefix */
556 
	strip = 6;
557 
    } else if (len >= 6 && isalpha(res[4]) && res[5] == ':' && res[6] == '\\')
77324 kalibera 558 
	/* \\?\D: */
559 
	strip = 4;
78069 kalibera 560 
    else {
561 
	CloseHandle(horig);
83772 kalibera 562 
	return NULL;
78069 kalibera 563 
    }
77324 kalibera 564 
    memmove(res, res+strip, len-strip+1);
565 
 
566 
    /* sanity check if the file exists using the normalized path, a normalized
567 
       path to an existing file should still be working */
78069 kalibera 568 
    /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
569 
    hres = CreateFile(res, 0,
570 
                      FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
571 
                      NULL, OPEN_EXISTING,
572 
                      FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
573 
                      NULL);
574 
    if (hres == INVALID_HANDLE_VALUE) {
575 
	CloseHandle(horig);
83772 kalibera 576 
	return NULL;
78069 kalibera 577 
    }
77324 kalibera 578 
 
78069 kalibera 579 
    /* check that the handles point to the same file, which may not be
580 
       always the case because of silent best-fit encoding conversion
581 
       done by Windows */
582 
    ret = isSameFile(horig, hres);
583 
    CloseHandle(horig);
584 
    CloseHandle(hres);
585 
 
83772 kalibera 586 
    return (ret == 1) ? res : NULL;
77324 kalibera 587 
}
588 
 
83772 kalibera 589 
/* returns R_alloc'd result */
590 
static wchar_t *getFinalPathNameW(const wchar_t *orig)
77324 kalibera 591 
{
78069 kalibera 592 
    HANDLE horig, hres;
83772 kalibera 593 
    int ret, ret1;
77324 kalibera 594 
 
78069 kalibera 595 
    /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
596 
    horig = CreateFileW(orig, 0,
597 
                        FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
598 
                        NULL, OPEN_EXISTING,
599 
                        FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
600 
                        NULL);
601 
    if (horig == INVALID_HANDLE_VALUE)
83772 kalibera 602 
	return NULL;
77324 kalibera 603 
 
83772 kalibera 604 
    ret = GetFinalPathNameByHandleW(horig, NULL, 0, VOLUME_NAME_DOS);
605 
    if (ret <= 0) {
606 
	CloseHandle(horig);
607 
	return NULL;
608 
    }
77324 kalibera 609 
 
83772 kalibera 610 
    wchar_t *wres = (wchar_t *)R_alloc(ret, sizeof(wchar_t));
611 
    ret1 = GetFinalPathNameByHandleW(horig, wres, ret, VOLUME_NAME_DOS);
612 
    if (ret1 <= 0 || ret1 >= ret) {
78069 kalibera 613 
	CloseHandle(horig);
83772 kalibera 614 
	return NULL;
78069 kalibera 615 
    }
77324 kalibera 616 
 
617 
    /* get rid of the \\?\ prefix */
83772 kalibera 618 
    size_t len = ret;
77324 kalibera 619 
    int strip = 0;
83772 kalibera 620 
    if (len < 4 || wcsncmp(L"\\\\?\\", wres, 4)) {
77324 kalibera 621 
	/* res should start with \\?\ */
78069 kalibera 622 
	CloseHandle(horig);
83772 kalibera 623 
	return NULL;
78069 kalibera 624 
    }
77324 kalibera 625 
 
83772 kalibera 626 
    if (len > 8 && !wcsncmp(L"UNC\\", wres+4, 4)) {
77324 kalibera 627 
	/* UNC path \\?\UNC */
83772 kalibera 628 
	wres[6] = L'\\';
77459 kalibera 629 
	strip = 6;
83772 kalibera 630 
    } else if (len >= 6 && Ri18n_iswctype(wres[4], Ri18n_wctype("alpha"))
631 
	     && wres[5] == L':' && wres[6] == L'\\')
77324 kalibera 632 
	/* \\?\D: */
633 
	strip = 4;
78069 kalibera 634 
    else {
635 
	CloseHandle(horig);
83772 kalibera 636 
	return NULL;
78069 kalibera 637 
    }
83772 kalibera 638 
    wmemmove(wres, wres+strip, len-strip+1);
77324 kalibera 639 
 
640 
    /* sanity check if the file exists using the normalized path, a normalized
641 
       path to an existing file should still be working */
78069 kalibera 642 
    /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
83772 kalibera 643 
    hres = CreateFileW(wres, 0,
78069 kalibera 644 
                       FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
645 
                       NULL, OPEN_EXISTING,
646 
                       FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS,
647 
                       NULL);
648 
    if (hres == INVALID_HANDLE_VALUE) {
649 
	CloseHandle(horig);
83772 kalibera 650 
	return NULL;
78069 kalibera 651 
    }
77324 kalibera 652 
 
78069 kalibera 653 
    /* sanity check that the handles point to the same file; they should, but
654 
       better be safe wrt to undocumented features/changes of gfpnbhw */
655 
    ret = isSameFile(horig, hres);
656 
    CloseHandle(horig);
657 
    CloseHandle(hres);
658 
 
83772 kalibera 659 
    /* return wres elso when isSameFile fails with -1 */
660 
    return ret ? wres : NULL;
77324 kalibera 661 
}
662 
 
83772 kalibera 663 
/* returns R_alloc'd result */
83897 kalibera 664 
attribute_hidden wchar_t *R_getFullPathNameW(const wchar_t *orig)
83772 kalibera 665 
{
666 
    DWORD ret, ret1;
667 
 
668 
    ret = GetFullPathNameW(orig, 0, NULL, NULL);
669 
    if (ret <= 0)
670 
	return NULL;
671 
    wchar_t *wres = (wchar_t*)R_alloc(ret, sizeof(wchar_t));
672 
    ret1 = GetFullPathNameW(orig, ret, wres, NULL);
673 
    if (ret1 <= 0 || ret1 >= ret)
674 
	return NULL;
675 
    else
676 
	return wres;
677 
}
678 
 
679 
/* returns R_alloc'd result */
83897 kalibera 680 
attribute_hidden char *R_getFullPathName(const char *orig)
83772 kalibera 681 
{
682 
    DWORD ret, ret1;
683 
 
684 
    ret = GetFullPathName(orig, 0, NULL, NULL);
685 
    if (ret == 0 && GetLastError() == ERROR_FILENAME_EXCED_RANGE) {
686 
	/* GetFullPathNameA unfortunately does not work with long paths
687 
	   (tested on Windows 10 19045), it fails with
688 
	   ERROR_FILENAME_EXCED_RANGE even when long paths are enabled. */
83775 kalibera 689 
	size_t cnt = mbstowcs(NULL, orig, 0);
83772 kalibera 690 
	if (cnt != (size_t)-1) {
83775 kalibera 691 
	    cnt++;
83772 kalibera 692 
	    wchar_t *worig = (wchar_t*) R_alloc(cnt, sizeof(wchar_t));
693 
	    mbstowcs(worig, orig, cnt);
83897 kalibera 694 
	    wchar_t *wres = R_getFullPathNameW(worig);
83772 kalibera 695 
	    if (wres) {
696 
		cnt = wcstombs(NULL, wres, 0) + 1;
697 
		if (cnt != (size_t)-1) {
698 
		    char *res = R_alloc(cnt, 1);
699 
		    wcstombs(res, wres, cnt);
700 
		    return res;
701 
		}
702 
	    }
703 
	}
704 
    }
705 
    if (ret <= 0)
706 
	return NULL;
707 
    char *res = R_alloc(ret, 1);
708 
    ret1 = GetFullPathName(orig, ret, res, NULL);
709 
    if (ret1 <= 0 || ret1 >= ret)
710 
	return NULL;
711 
    else
712 
	return res;
713 
}
714 
 
715 
/* returns R_alloc'd result */
716 
static wchar_t *getLongPathNameW(const wchar_t *orig)
717 
{
718 
    DWORD ret, ret1;
719 
 
720 
    ret = GetLongPathNameW(orig, NULL, 0);
721 
    if (ret <= 0)
722 
	return NULL;
723 
    wchar_t *wres = (wchar_t*)R_alloc(ret, sizeof(wchar_t));
724 
    ret1 = GetLongPathNameW(orig, wres, ret);
725 
    if (ret1 <= 0 || ret1 >= ret)
726 
	return NULL;
727 
    else
728 
	return wres;
729 
}
730 
 
731 
/* returns R_alloc'd result */
732 
static char *getLongPathName(const char *orig)
733 
{
734 
    DWORD ret, ret1;
735 
 
736 
    ret = GetLongPathName(orig, NULL, 0);
737 
    if (ret <= 0)
738 
	return NULL;
739 
    char *res = R_alloc(ret, 1);
740 
    ret1 = GetLongPathName(orig, res, ret);
741 
    if (ret1 <= 0 || ret1 >= ret)
742 
	return NULL;
743 
    else
744 
	return res;
745 
}
746 
 
53131 ripley 747 
void R_UTF8fixslash(char *s); /* from main/util.c */
33233 ripley 748 
SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho)
749 
{
53131 ripley 750 
    SEXP ans, paths = CAR(args), el, slash;
83772 kalibera 751 
    int i, n = LENGTH(paths);
53131 ripley 752 
    int mustWork, fslash = 0;
85648 kalibera 753 
    const void *vmax = vmaxget();
43323 ripley 754 
 
33233 ripley 755 
    checkArity(op, args);
33266 ripley 756 
    if(!isString(paths))
45070 ripley 757 
	errorcall(call, _("'path' must be a character vector"));
33266 ripley 758 
 
53131 ripley 759 
    slash = CADR(args);
760 
    if(!isString(slash) || LENGTH(slash) != 1)
761 
	errorcall(call, "'winslash' must be a character string");
85648 kalibera 762 
    const char *sl = translateCharFP(STRING_ELT(slash, 0));
53131 ripley 763 
    if (strcmp(sl, "/") && strcmp(sl, "\\"))
764 
	errorcall(call, "'winslash' must be '/' or '\\\\'");
765 
    if (strcmp(sl, "/") == 0) fslash = 1;
766 
 
767 
    mustWork = asLogical(CADDR(args));
768 
 
33233 ripley 769 
    PROTECT(ans = allocVector(STRSXP, n));
770 
    for (i = 0; i < n; i++) {
51977 murdoch 771 
    	SEXP result;
44008 ripley 772 
	el = STRING_ELT(paths, i);
53131 ripley 773 
	result = el;
75971 kalibera 774 
	if (el == NA_STRING) {
75835 kalibera 775 
	    result = NA_STRING;
75971 kalibera 776 
	    if(mustWork == 1)
777 
		errorcall(call, "path[%d]=NA", i+1);
778 
	    else if(mustWork == NA_LOGICAL)
779 
		warningcall(call, "path[%d]=NA", i+1);
780 
	} else if(getCharCE(el) == CE_UTF8) {
83772 kalibera 781 
	    const wchar_t *wel = filenameToWchar(el, FALSE);
83897 kalibera 782 
	    wchar_t *wfull = R_getFullPathNameW(wel);
83772 kalibera 783 
	    wchar_t *wnorm = getFinalPathNameW(wel);
77324 kalibera 784 
 
83772 kalibera 785 
	    /* if normalized to UNC path but full path is D:..., fall back
786 
	       to GetLongPathName */
787 
	    if (wnorm && wnorm[0] == L'\\' && wnorm[1] == L'\\' &&
788 
		wfull && Ri18n_iswctype(wfull[0], Ri18n_wctype("alpha")) &&
789 
	        wfull[1] == L':') wnorm = NULL;
790 
	    if (!wnorm && wfull)
791 
		/* silently fall back to GetFullPathName/GetLongPathName */
83911 kalibera 792 
		/* getLongPathName will fail for non-existent paths */
83772 kalibera 793 
		wnorm = getLongPathNameW(wfull);
794 
	    if (wnorm) {
795 
		if (fslash)
796 
		    R_wfixslash(wnorm);
797 
		result = mkCharWUTF8(wnorm);
798 
	    } else {
77324 kalibera 799 
		if (mustWork == 1) {
800 
		    errorcall(call, "path[%d]=\"%ls\": %s", i+1,
801 
			      wel, formatError(GetLastError()));
802 
		} else if (mustWork == NA_LOGICAL) {
803 
		    warningcall(call, "path[%d]=\"%ls\": %s", i+1,
804 
				wel, formatError(GetLastError()));
805 
		}
83911 kalibera 806 
		if (wfull) {
807 
		    if (fslash)
808 
			R_wfixslash(wfull);
809 
		    result = mkCharWUTF8(wfull);
810 
		} else {
811 
		    const char *elutf8 = translateCharUTF8(el);
812 
		    if (fslash) {
813 
			char *normutf8 = R_alloc(strlen(elutf8) + 1, 1);
814 
			strcpy(normutf8, elutf8);
815 
			R_UTF8fixslash(normutf8);
816 
			result = mkCharCE(normutf8, CE_UTF8);
817 
		    } else
818 
			result = mkCharCE(elutf8, CE_UTF8);
819 
		}
77324 kalibera 820 
	    }
44008 ripley 821 
	} else {
77324 kalibera 822 
	    const char *tel = translateChar(el);
83897 kalibera 823 
	    char *full = R_getFullPathName(tel);
83772 kalibera 824 
	    char *norm = getFinalPathName(tel);
77460 kalibera 825 
 
83772 kalibera 826 
	    /* if normalized to UNC path but full path is D:..., fall back
827 
	       to GetLongPathName */
828 
	    if (norm && norm[0] == '\\' && norm[1] == '\\' &&
829 
		full && isalpha(full[0]) && full[1] == ':') norm = NULL;
830 
	    if (!norm && full)
77324 kalibera 831 
		/* silently fall back to GetFullPathName/GetLongPathName */
83911 kalibera 832 
		/* getLongPathName will fail for non-existent paths */
83772 kalibera 833 
		norm = getLongPathName(full);
834 
	    if (norm) {
835 
		if (fslash)
836 
		    R_fixslash(norm);
837 
		result = mkChar(norm);
838 
	    } else {
77324 kalibera 839 
		if (mustWork == 1) {
840 
		    errorcall(call, "path[%d]=\"%s\": %s", i+1,
841 
			      tel, formatError(GetLastError()));
842 
		} else if (mustWork == NA_LOGICAL) {
843 
		    warningcall(call, "path[%d]=\"%s\": %s", i+1,
844 
				tel, formatError(GetLastError()));
845 
		}
83911 kalibera 846 
		if (full) {
847 
		    if (fslash)
848 
			R_fixslash(full);
849 
		    result = mkChar(full);
850 
		} else if (fslash) {
83772 kalibera 851 
		    norm = R_alloc(strlen(tel) + 1, 1);
852 
		    strcpy(norm, tel);
853 
		    R_fixslash(norm);
854 
		    result = mkChar(norm);
855 
		} else
856 
		    result = mkChar(tel);
77324 kalibera 857 
	    }
44008 ripley 858 
	}
51977 murdoch 859 
	SET_STRING_ELT(ans, i, result);
33233 ripley 860 
    }
85648 kalibera 861 
    vmaxset(vmax);
33233 ripley 862 
    UNPROTECT(1);
863 
    return ans;
864 
}
865 
 
60690 ripley 866 
/* utils::shortPathName */
60717 ripley 867 
SEXP in_shortpath(SEXP paths)
35920 ripley 868 
{
60717 ripley 869 
    SEXP ans, el;
35920 ripley 870 
    int i, n = LENGTH(paths);
44906 ripley 871 
    DWORD res;
63181 ripley 872 
    const void *vmax = vmaxget();
43323 ripley 873 
 
60717 ripley 874 
    if(!isString(paths)) error(_("'path' must be a character vector"));
35920 ripley 875 
 
876 
    PROTECT(ans = allocVector(STRSXP, n));
877 
    for (i = 0; i < n; i++) {
44008 ripley 878 
	el = STRING_ELT(paths, i);
44986 ripley 879 
	if(getCharCE(el) == CE_UTF8) {
83772 kalibera 880 
	    wchar_t *wfn = filenameToWchar(el, FALSE);
881 
	    res = GetShortPathNameW(wfn, NULL, 0);
882 
	    if (res > 0) {
883 
		wchar_t *wsfn = (wchar_t*)R_alloc(res, sizeof(wchar_t));
884 
		DWORD res1 = GetShortPathNameW(wfn, wsfn, res);
885 
		if (res1 > 0 && res1 < res) {
886 
		    /* documented to return paths using \, which the API call
887 
		       does not necessarily do */
888 
		    R_wfixbackslash(wsfn);
889 
		    SET_STRING_ELT(ans, i, mkCharWUTF8(wsfn));
890 
		    continue;
891 
		}
892 
	    }
44008 ripley 893 
	} else {
83772 kalibera 894 
	    const char *fn = translateChar(el);
895 
	    res = GetShortPathName(fn, NULL, 0);
896 
	    if (res > 0) {
897 
		char *sfn = R_alloc(res, 1);
898 
		DWORD res1 = GetShortPathName(fn, sfn, res);
899 
		if (res1 > 0 && res1 < res) {
900 
		    /* documented to return paths using \, which the API call
901 
		       does not necessarily do */
902 
		    R_fixbackslash(sfn);
903 
		    SET_STRING_ELT(ans, i, mkChar(sfn));
904 
		    continue;
905 
		}
906 
	    }
44008 ripley 907 
	}
83772 kalibera 908 
	/* we didn't get a short name, so return the original with
909 
	   backslashes as separators (as documented) */
910 
	const char *fn = translateChar(el);
911 
	char *ffn = R_alloc(strlen(fn) + 1, 1);
912 
	strcpy(ffn, fn);
913 
	R_fixbackslash(ffn);
914 
	SET_STRING_ELT(ans, i, mkChar(ffn));
35920 ripley 915 
    }
916 
    UNPROTECT(1);
63181 ripley 917 
    vmaxset(vmax);
35920 ripley 918 
    return ans;
919 
}
49479 murdoch 920 
 
32311 ripley 921 
#include "devWindows.h"
44412 ripley 922 
#include <R_ext/GraphicsEngine.h> /* GEgetDevice */
32260 ripley 923 
 
60690 ripley 924 
/* grDevices::bringToTop */
60717 ripley 925 
SEXP bringtotop(SEXP sdev, SEXP sstay)
32260 ripley 926 
{
927 
    int dev, stay;
44500 ripley 928 
    pGEDevDesc gdd;
32260 ripley 929 
    gadesc *xd;
930 
 
60717 ripley 931 
    dev = asInteger(sdev);
932 
    stay = asInteger(sstay);
32260 ripley 933 
 
934 
    if(dev == -1) { /* console */
935 
	if(CharacterMode == RGui) BringToTop(RConsole, stay);
936 
    } else {
937 
	if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
60717 ripley 938 
	    error(_("invalid '%s' argument"), "which");
44412 ripley 939 
	gdd = GEgetDevice(dev - 1);
60717 ripley 940 
	if(!gdd) error(_("invalid device"));
32260 ripley 941 
	xd = (gadesc *) gdd->dev->deviceSpecific;
60717 ripley 942 
	if(!xd) error(_("invalid device"));
32888 ripley 943 
	if(stay && ismdi()) error(_("requires SDI mode"));
32260 ripley 944 
	BringToTop(xd->gawin, stay);
945 
    }
946 
    return R_NilValue;
947 
}
948 
 
60690 ripley 949 
/* grDevices::msgWindow */
60717 ripley 950 
SEXP msgwindow(SEXP sdev, SEXP stype)
47352 ripley 951 
{
952 
    int dev, type;
953 
    pGEDevDesc gdd;
954 
    gadesc *xd;
955 
 
60717 ripley 956 
    dev = asInteger(sdev);
957 
    type = asInteger(stype);
47352 ripley 958 
 
959 
    if(dev == -1) { /* console */
960 
	if(CharacterMode == RGui) GA_msgWindow(RConsole, type);
961 
    } else {
962 
	if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
60717 ripley 963 
	    error(_("invalid '%s' argument"), "which");
47352 ripley 964 
	gdd = GEgetDevice(dev - 1);
60717 ripley 965 
	if(!gdd) error(_("invalid device"));
47352 ripley 966 
	xd = (gadesc *) gdd->dev->deviceSpecific;
60717 ripley 967 
	if(!xd) error(_("invalid device"));
47352 ripley 968 
	if(type == 5) {
969 
	    xd->recording = TRUE;
970 
	    check(xd->mrec);
971 
	} else if(type == 6) {
972 
	    xd-> recording = FALSE;
973 
	    uncheck(xd->mrec);
974 
	} else
975 
	    GA_msgWindow(xd->gawin, type);
976 
    }
977 
    return R_NilValue;
978 
}
979 
 
32260 ripley 980 
 
52804 ripley 981 
/* This assumes a menuname of the form
982 
   $Graph<nn>Main, $Graph<nn>Popup, $Graph<nn>LocMain,
32260 ripley 983 
   or $Graph<nn>LocPopup where <nn> is the
984 
   device number.  We've already checked the $Graph prefix. */
985 
 
60690 ripley 986 
/* called from rui.c, only */
41793 ripley 987 
menu getGraphMenu(const char* menuname)
32260 ripley 988 
{
989 
    int devnum;
44500 ripley 990 
    pGEDevDesc gdd;
32260 ripley 991 
    gadesc *xd;
992 
 
993 
    menuname = menuname + 6;
994 
    devnum = atoi(menuname);
995 
    if(devnum < 1 || devnum > R_MaxDevices)
45070 ripley 996 
	error(_("invalid graphical device number"));
32260 ripley 997 
 
998 
    while (('0' <= *menuname) && (*menuname <= '9')) menuname++;
999 
 
44412 ripley 1000 
    gdd = GEgetDevice(devnum - 1);
32260 ripley 1001 
 
32888 ripley 1002 
    if(!gdd) error(_("invalid device"));
32260 ripley 1003 
 
1004 
    xd = (gadesc *) gdd->dev->deviceSpecific;
1005 
 
32888 ripley 1006 
    if(!xd || xd->kind != SCREEN) error(_("bad device"));
32260 ripley 1007 
 
1008 
    if (strcmp(menuname, "Main") == 0) return(xd->mbar);
1009 
    else if (strcmp(menuname, "Popup") == 0) return(xd->grpopup);
1010 
    else return(NULL);
1011 
}
1012 
 
43323 ripley 1013 
/*
41206 ripley 1014 
   Replacement for MSVCRT's access.
1015 
   Coded looking at tcl's tclWinFile.c
1016 
*/
32787 ripley 1017 
 
44008 ripley 1018 
int winAccessW(const wchar_t *path, int mode)
41206 ripley 1019 
{
44008 ripley 1020 
    DWORD attr = GetFileAttributesW(path);
43323 ripley 1021 
 
75482 kalibera 1022 
    if(attr == INVALID_FILE_ATTRIBUTES)
1023 
	/* file does not exist or may be locked */
1024 
	return -1;
1025 
 
41206 ripley 1026 
    if(mode == F_OK) return 0;
75482 kalibera 1027 
 
1028 
    if ((mode & W_OK)
1029 
	&& !(attr & FILE_ATTRIBUTE_DIRECTORY)
1030 
	&& (attr & FILE_ATTRIBUTE_READONLY)) return -1;
41206 ripley 1031 
 
1032 
    if(mode & X_OK)
1033 
	if(!(attr & FILE_ATTRIBUTE_DIRECTORY)) { /* Directory, so OK */
1034 
	    /* Look at extension for executables */
44008 ripley 1035 
	    wchar_t *p = wcsrchr(path, '.');
43323 ripley 1036 
	    if(p == NULL ||
44008 ripley 1037 
	       !((wcsicmp(p, L".exe") == 0) || (wcsicmp(p, L".com") == 0) ||
1038 
		 (wcsicmp(p, L".bat") == 0) || (wcsicmp(p, L".cmd") == 0)) )
41228 ripley 1039 
		return -1;
41206 ripley 1040 
	}
43328 ripley 1041 
    {
1042 
	/* Now look for file security info */
41206 ripley 1043 
	SECURITY_DESCRIPTOR *sdPtr = NULL;
42242 ripley 1044 
	DWORD size = 0;
75482 kalibera 1045 
	PSID sid = 0;
1046 
	BOOL sidDefaulted;
1047 
	SID_IDENTIFIER_AUTHORITY samba_unmapped = {{0, 0, 0, 0, 0, 22}};
41206 ripley 1048 
	GENERIC_MAPPING genMap;
1049 
	HANDLE hToken = NULL;
1050 
	DWORD desiredAccess = 0;
1051 
	DWORD grantedAccess = 0;
1052 
	BOOL accessYesNo = FALSE;
1053 
	PRIVILEGE_SET privSet;
1054 
	DWORD privSetSize = sizeof(PRIVILEGE_SET);
1055 
	int error;
1056 
 
1057 
	/* get size */
44008 ripley 1058 
	GetFileSecurityW(path,
45070 ripley 1059 
			 OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
75482 kalibera 1060 
			 | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION,
1061 
			 0, 0, &size);
41206 ripley 1062 
	error = GetLastError();
75785 kalibera 1063 
	if (error == ERROR_NOT_SUPPORTED)
75482 kalibera 1064 
	    /* happens for some remote shares */
1065 
	    return _waccess(path, mode);
75785 kalibera 1066 
	if (error != ERROR_INSUFFICIENT_BUFFER)
75482 kalibera 1067 
	    return -1;
41206 ripley 1068 
	sdPtr = (SECURITY_DESCRIPTOR *) alloca(size);
44008 ripley 1069 
	if(!GetFileSecurityW(path,
45070 ripley 1070 
			     OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
75482 kalibera 1071 
			     | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, sdPtr, size, &size))
41206 ripley 1072 
	    return -1;
75482 kalibera 1073 
	/* rely on attrib checks for unmapped samba owners and groups */
1074 
	if (!GetSecurityDescriptorOwner(sdPtr, &sid, &sidDefaulted))
1075 
	    return 0;
1076 
	if (IsValidSid(sid) &&
1077 
	    !memcmp(GetSidIdentifierAuthority(sid), &samba_unmapped, sizeof(SID_IDENTIFIER_AUTHORITY)))
1078 
	    return 0;
41206 ripley 1079 
	/*
1080 
	 * Perform security impersonation of the user and open the
1081 
	 * resulting thread token.
1082 
	 */
1083 
	if(!ImpersonateSelf(SecurityImpersonation)) return -1;
1084 
	if(!OpenThreadToken(GetCurrentThread (),
1085 
			    TOKEN_DUPLICATE | TOKEN_QUERY, FALSE,
1086 
			    &hToken)) return -1;
1087 
	if (mode & R_OK) desiredAccess |= FILE_GENERIC_READ;
1088 
	if (mode & W_OK) desiredAccess |= FILE_GENERIC_WRITE;
1089 
	if (mode & X_OK) desiredAccess |= FILE_GENERIC_EXECUTE;
1090 
 
1091 
	memset(&genMap, 0x0, sizeof (GENERIC_MAPPING));
1092 
	genMap.GenericRead = FILE_GENERIC_READ;
1093 
	genMap.GenericWrite = FILE_GENERIC_WRITE;
1094 
	genMap.GenericExecute = FILE_GENERIC_EXECUTE;
1095 
	genMap.GenericAll = FILE_ALL_ACCESS;
1096 
	if(!AccessCheck(sdPtr, hToken, desiredAccess, &genMap, &privSet,
1097 
			&privSetSize, &grantedAccess, &accessYesNo)) {
1098 
	    CloseHandle(hToken);
1099 
	    return -1;
1100 
	}
1101 
	CloseHandle(hToken);
1102 
	if (!accessYesNo) return -1;
1103 
 
1104 
    }
1105 
    return 0;
1106 
}
1107 
 
43331 ripley 1108 
#include <Rversion.h>
44201 ripley 1109 
char *getDLLVersion(void)
43331 ripley 1110 
{
1111 
    static char DLLversion[25];
1112 
    OSVERSIONINFO osvi;
1113 
    osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
1114 
    GetVersionEx(&osvi);
1115 
    /* 95, 98, ME are 4.x */
1116 
    if(osvi.dwMajorVersion < 5)
1117 
	R_Suicide("Windows 2000 or later is required");
62583 ripley 1118 
    snprintf(DLLversion, 25, "%s.%s", R_MAJOR, R_MINOR);
43331 ripley 1119 
    return (DLLversion);
1120 
}
41206 ripley 1121 
 
60688 ripley 1122 
/* base::file.choose */
46842 ripley 1123 
SEXP attribute_hidden do_filechoose(SEXP call, SEXP op, SEXP args, SEXP rho)
1124 
{
1125 
    SEXP ans;
1126 
    wchar_t *fn;
1127 
 
1128 
    checkArity(op, args);
48428 murdoch 1129 
    setuserfilterW(L"All files (*.*)\0*.*\0\0");
46842 ripley 1130 
    fn = askfilenameW(G_("Select file"), "");
1131 
    if (!fn)
1132 
	error(_("file choice cancelled"));
1133 
    PROTECT(ans = allocVector(STRSXP, 1));
83772 kalibera 1134 
    SET_STRING_ELT(ans, 0, mkCharWUTF8(fn));
46842 ripley 1135 
    UNPROTECT(1);
1136 
    return ans;
1137 
}
64308 ripley 1138 
 
1139 
const char *getTZinfo(void);  // src/extra/tzone/registryTZ.c
1140 
 
1141 
SEXP attribute_hidden do_tzone_name(SEXP call, SEXP op, SEXP args, SEXP rho)
1142 
{
1143 
    return mkString(getTZinfo());
1144 
}
1145