The R Project SVN R

Rev

Rev 77324 | Rev 77459 | Go to most recent revision | 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
75971 kalibera 6 
 *  Copyright (C) 2005--2019  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 
 
44008 ripley 32 
 
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"
58001 ripley 42 
/* Mingw-w64 defines this to be 0x0502 */
44720 ripley 43 
#ifndef _WIN32_WINNT
51502 ripley 44 
# define _WIN32_WINNT 0x0502 /* for GetLongPathName, KEY_WOW64_64KEY */
44720 ripley 45 
#endif
9920 ripley 46 
#include <windows.h>
47 
#include "rui.h"
45005 ripley 48 
#undef ERROR
49 
#include <R_ext/RS.h> /* for Calloc */
9920 ripley 50 
 
51 
#include <winbase.h>
43328 ripley 52 
 
9920 ripley 53 
 
55471 murdoch 54 
/* used in rui.c */
41783 ripley 55 
void internal_shellexec(const char * file)
9920 ripley 56 
{
41783 ripley 57 
    const char *home;
55458 ripley 58 
    char home2[10000], *p;
42244 ripley 59 
    uintptr_t ret;
9920 ripley 60 
 
61 
    home = getenv("R_HOME");
62 
    if (home == NULL)
32888 ripley 63 
	error(_("R_HOME not set"));
55458 ripley 64 
    strncpy(home2, home, 10000);
65 
    for(p = home2; *p; p++) if(*p == '/') *p = '\\';
66 
    ret = (uintptr_t) ShellExecute(NULL, "open", file, NULL, home2, SW_SHOW);
39991 ripley 67 
    if(ret <= 32) { /* an error condition */
68 
	if(ret == ERROR_FILE_NOT_FOUND  || ret == ERROR_PATH_NOT_FOUND
69 
	   || ret == SE_ERR_FNF || ret == SE_ERR_PNF)
70 
	    error(_("'%s' not found"), file);
71 
	if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
43323 ripley 72 
	    error(_("file association for '%s' not available or invalid"),
39991 ripley 73 
		  file);
74 
	if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
75 
	    error(_("access to '%s' denied"), file);
76 
	error(_("problem in displaying '%s'"), file);
77 
    }
9920 ripley 78 
}
79 
 
55471 murdoch 80 
/* used by shell.exec() with rhome=FALSE.  2.13.0 and earlier were
81 
   like rhome=TRUE, but without fixing the path */
82 
static void internal_shellexecW(const wchar_t * file, Rboolean rhome)
44008 ripley 83 
{
84 
    const wchar_t *home;
55471 murdoch 85 
    wchar_t home2[10000], *p;
44008 ripley 86 
    uintptr_t ret;
55471 murdoch 87 
 
88 
    if (rhome) {
89 
    	home = _wgetenv(L"R_HOME");
90 
    	if (home == NULL)
91 
	    error(_("R_HOME not set"));
92 
    	wcsncpy(home2, home, 10000);
93 
    	for(p = home2; *p; p++) if(*p == L'/') *p = L'\\';
94 
	home = home2;
95 
    } else home = NULL;
96 
 
44008 ripley 97 
    ret = (uintptr_t) ShellExecuteW(NULL, L"open", file, NULL, home, SW_SHOW);
98 
    if(ret <= 32) { /* an error condition */
99 
	if(ret == ERROR_FILE_NOT_FOUND  || ret == ERROR_PATH_NOT_FOUND
100 
	   || ret == SE_ERR_FNF || ret == SE_ERR_PNF)
48339 murdoch 101 
	    error(_("'%ls' not found"), file);
44008 ripley 102 
	if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
48339 murdoch 103 
	    error(_("file association for '%ls' not available or invalid"),
44008 ripley 104 
		  file);
105 
	if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
48339 murdoch 106 
	    error(_("access to '%ls' denied"), file);
107 
	error(_("problem in displaying '%ls'"), file);
44008 ripley 108 
    }
109 
}
110 
 
9920 ripley 111 
SEXP do_shellexec(SEXP call, SEXP op, SEXP args, SEXP env)
112 
{
113 
    SEXP file;
114 
 
115 
    checkArity(op, args);
116 
    file = CAR(args);
117 
    if (!isString(file) || length(file) != 1)
35264 ripley 118 
	errorcall(call, _("invalid '%s' argument"), "file");
55471 murdoch 119 
    internal_shellexecW(filenameToWchar(STRING_ELT(file, 0), FALSE), FALSE);
9920 ripley 120 
    return R_NilValue;
121 
}
122 
 
41783 ripley 123 
int check_doc_file(const char * file)
9920 ripley 124 
{
41783 ripley 125 
    const char *home;
126 
    char path[MAX_PATH];
9920 ripley 127 
 
128 
    home = getenv("R_HOME");
129 
    if (home == NULL)
32888 ripley 130 
	error(_("R_HOME not set"));
28888 ripley 131 
    if(strlen(home) + strlen(file) + 1 >= MAX_PATH) return(1); /* cannot exist */
9920 ripley 132 
    strcpy(path, home);
133 
    strcat(path, "/");
134 
    strcat(path, file);
44008 ripley 135 
    return access(path, 4) == 0; /* read access */
9920 ripley 136 
}
137 
 
138 
#include "Startup.h"
139 
 
44201 ripley 140 
void Rwin_fpset(void)
9920 ripley 141 
{
37410 ripley 142 
    /* Under recent MinGW this is what fpreset does.  It sets the
143 
       control word to 0x37f which corresponds to 0x8001F as used by
144 
       _controlfp.  That is all errors are masked, 64-bit mantissa and
145 
       rounding are selected. */
146 
 
37409 ripley 147 
    __asm__ ( "fninit" ) ;
9920 ripley 148 
}
149 
 
19940 ripley 150 
 
37626 murdoch 151 
#include <preferences.h>
152 
 
60690 ripley 153 
/* utils::loadRconsole */
60717 ripley 154 
SEXP in_loadRconsole(SEXP sfile)
37626 murdoch 155 
{
156 
    struct structGUI gui;
63181 ripley 157 
    const void *vmax = vmaxget();
37626 murdoch 158 
 
159 
    if (!isString(sfile) || LENGTH(sfile) < 1)
60717 ripley 160 
	error(_("invalid '%s' argument"), "file");
43958 murdoch 161 
    getActive(&gui);  /* Will get defaults if there's no active console */
44008 ripley 162 
    if (loadRconsole(&gui, translateChar(STRING_ELT(sfile, 0)))) applyGUI(&gui);
52072 murdoch 163 
    if (strlen(gui.warning)) warning(gui.warning);
63181 ripley 164 
    vmaxset(vmax);
37626 murdoch 165 
    return R_NilValue;
166 
}
43323 ripley 167 
 
9920 ripley 168 
#include <lmcons.h>
60688 ripley 169 
typedef void (WINAPI *PGNSI)(LPSYSTEM_INFO);
9920 ripley 170 
 
60690 ripley 171 
/* base::Sys.info */
69039 ripley 172 
// keep in step with src/library/utils/src/windows/util.c
9920 ripley 173 
SEXP do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
174 
{
175 
    SEXP ans, ansnames;
43328 ripley 176 
    OSVERSIONINFOEX osvi;
45070 ripley 177 
    char ver[256], buf[1000];
44059 ripley 178 
    wchar_t name[MAX_COMPUTERNAME_LENGTH + 1], user[UNLEN+1];
9920 ripley 179 
    DWORD namelen = MAX_COMPUTERNAME_LENGTH + 1, userlen = UNLEN+1;
180 
 
181 
    checkArity(op, args);
56204 ripley 182 
    PROTECT(ans = allocVector(STRSXP, 8));
43328 ripley 183 
    osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX);
184 
    if(!GetVersionEx((OSVERSIONINFO *)&osvi))
185 
	error(_("unsupported version of Windows"));
9920 ripley 186 
 
10172 luke 187 
    SET_STRING_ELT(ans, 0, mkChar("Windows"));
43326 ripley 188 
 
43328 ripley 189 
    /* Here for unknown future versions */
62583 ripley 190 
    snprintf(ver, 256, "%d.%d",
191 
	     (int)osvi.dwMajorVersion, (int)osvi.dwMinorVersion);
43328 ripley 192 
 
43323 ripley 193 
    if((int)osvi.dwMajorVersion >= 5) {
194 
	PGNSI pGNSI;
195 
	SYSTEM_INFO si;
69050 ripley 196 
	if(osvi.dwMajorVersion == 10 && osvi.dwMinorVersion == 0) {
197 
	    if(osvi.wProductType == VER_NT_WORKSTATION) strcpy(ver, "10");
198 
	    else strcpy(ver, "Server");
199 
	}
43323 ripley 200 
	if(osvi.dwMajorVersion == 6) {
69040 ripley 201 
	    char *desc = "";
52150 ripley 202 
	    if(osvi.wProductType == VER_NT_WORKSTATION) {
69039 ripley 203 
		if(osvi.dwMinorVersion == 0) desc = "Vista";
204 
		else if(osvi.dwMinorVersion == 1) desc = "7";
205 
		else if(osvi.dwMinorVersion == 2) desc = ">= 8";
69050 ripley 206 
		else if(osvi.dwMinorVersion == 3) desc = "8.1";
207 
		else desc = "> 8.1";
69039 ripley 208 
	    } else {
209 
		if(osvi.dwMinorVersion == 0) desc = "Server 2008";
210 
		else if(osvi.dwMinorVersion == 1) desc = "Server 2008 R2";
211 
		else if(osvi.dwMinorVersion == 2) desc = "Server >= 2012";
69050 ripley 212 
		else if(osvi.dwMinorVersion == 3) desc = "Server 2012 R2";
69039 ripley 213 
		else desc = "Server > 2012";
214 
	    }
215 
	    strcpy(ver, desc);
43323 ripley 216 
	}
217 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 0)
218 
	    strcpy(ver, "2000");
219 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 1)
220 
	    strcpy(ver, "XP");
221 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 2) {
43328 ripley 222 
	    if(osvi.wProductType == VER_NT_WORKSTATION)
43323 ripley 223 
		strcpy(ver, "XP Professional");
224 
	    else strcpy(ver, "Server 2003");
225 
	}
43328 ripley 226 
	/* GetNativeSystemInfo is XP or later */
43323 ripley 227 
	pGNSI = (PGNSI)
228 
	    GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
229 
			   "GetNativeSystemInfo");
230 
	if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
231 
	if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
232 
	    strcat(ver, " x64");
43326 ripley 233 
    }
10172 luke 234 
    SET_STRING_ELT(ans, 1, mkChar(ver));
43323 ripley 235 
 
236 
    if((int)osvi.dwMajorVersion >= 5) {
43328 ripley 237 
	if(osvi.wServicePackMajor > 0)
62583 ripley 238 
	    snprintf(ver, 256, "build %d, Service Pack %d",
239 
		     LOWORD(osvi.dwBuildNumber),
240 
		     (int) osvi.wServicePackMajor);
241 
	else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
43323 ripley 242 
    } else
62583 ripley 243 
	snprintf(ver, 256, "build %d, %s",
244 
		 LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
10172 luke 245 
    SET_STRING_ELT(ans, 2, mkChar(ver));
44059 ripley 246 
    GetComputerNameW(name, &namelen);
72714 murdoch 247 
    wcstoutf8(buf, name, sizeof(buf));
44986 ripley 248 
    SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
65805 ripley 249 
#ifdef _WIN64
52152 ripley 250 
    SET_STRING_ELT(ans, 4, mkChar("x86-64"));
251 
#else
10172 luke 252 
    SET_STRING_ELT(ans, 4, mkChar("x86"));
52152 ripley 253 
#endif
44059 ripley 254 
    GetUserNameW(user, &userlen);
72714 murdoch 255 
    wcstoutf8(buf, user, sizeof(buf));
44986 ripley 256 
    SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
10172 luke 257 
    SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
56204 ripley 258 
    SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
259 
    PROTECT(ansnames = allocVector(STRSXP, 8));
10172 luke 260 
    SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
261 
    SET_STRING_ELT(ansnames, 1, mkChar("release"));
262 
    SET_STRING_ELT(ansnames, 2, mkChar("version"));
263 
    SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
264 
    SET_STRING_ELT(ansnames, 4, mkChar("machine"));
265 
    SET_STRING_ELT(ansnames, 5, mkChar("login"));
266 
    SET_STRING_ELT(ansnames, 6, mkChar("user"));
56204 ripley 267 
    SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
9920 ripley 268 
    setAttrib(ans, R_NamesSymbol, ansnames);
269 
    UNPROTECT(2);
270 
    return ans;
271 
}
272 
 
67451 ripley 273 
void Rsleep(double timeint)
19940 ripley 274 
{
67451 ripley 275 
    int ntime = 1000*timeint + 0.5;
13548 ripley 276 
    DWORD mtime;
9934 ripley 277 
    while (ntime > 0) {
278 
	mtime = min(500, ntime);
279 
	ntime -= mtime;
280 
	Sleep(mtime);
281 
	R_ProcessEvents();
282 
    }
67451 ripley 283 
 
9934 ripley 284 
}
10365 ripley 285 
 
67451 ripley 286 
 
45865 ripley 287 
#define MALLINFO_FIELD_TYPE size_t
10365 ripley 288 
struct mallinfo {
45865 ripley 289 
    MALLINFO_FIELD_TYPE arena;    /* non-mmapped space allocated from system */
290 
    MALLINFO_FIELD_TYPE ordblks;  /* number of free chunks */
291 
    MALLINFO_FIELD_TYPE smblks;   /* number of fastbin blocks */
292 
    MALLINFO_FIELD_TYPE hblks;    /* number of mmapped regions */
293 
    MALLINFO_FIELD_TYPE hblkhd;   /* space in mmapped regions */
294 
    MALLINFO_FIELD_TYPE usmblks;  /* maximum total allocated space */
295 
    MALLINFO_FIELD_TYPE fsmblks;  /* space available in freed fastbin blocks */
296 
    MALLINFO_FIELD_TYPE uordblks; /* total allocated space */
297 
    MALLINFO_FIELD_TYPE fordblks; /* total free space */
298 
    MALLINFO_FIELD_TYPE keepcost; /* top-most, releasable (via malloc_trim) space */
10365 ripley 299 
};
50907 ripley 300 
extern R_size_t R_max_memory;
10365 ripley 301 
 
44201 ripley 302 
struct mallinfo mallinfo(void);
10365 ripley 303 
 
60717 ripley 304 
SEXP in_memsize(SEXP ssize)
10365 ripley 305 
{
306 
    SEXP ans;
48394 murdoch 307 
    int maxmem = NA_LOGICAL;
19940 ripley 308 
 
60717 ripley 309 
    if(isLogical(ssize))
310 
	maxmem = asLogical(ssize);
311 
    else if(isReal(ssize)) {
52886 murdoch 312 
	R_size_t newmax;
60717 ripley 313 
	double mem = asReal(ssize);
15848 ripley 314 
	if (!R_FINITE(mem))
60717 ripley 315 
	    error(_("incorrect argument"));
65805 ripley 316 
#ifndef _WIN64
32478 ripley 317 
	if(mem >= 4096)
60717 ripley 318 
	    error(_("don't be silly!: your machine has a 4Gb address limit"));
50961 ripley 319 
#endif
15848 ripley 320 
	newmax = mem * 1048576.0;
321 
	if (newmax < R_max_memory)
60717 ripley 322 
	    warning(_("cannot decrease memory limit: ignored"));
42236 ripley 323 
	else
324 
	    R_max_memory = newmax;
15848 ripley 325 
    } else
60717 ripley 326 
	error(_("incorrect argument"));
48390 murdoch 327 
 
328 
    PROTECT(ans = allocVector(REALSXP, 1));
329 
    if(maxmem == NA_LOGICAL)
330 
	REAL(ans)[0] = R_max_memory;
331 
    else if(maxmem)
332 
	REAL(ans)[0] = mallinfo().usmblks;
333 
    else
334 
	REAL(ans)[0] = mallinfo().uordblks;
335 
    REAL(ans)[0] /= 1048576.0;
336 
    UNPROTECT(1);
337 
    return ans;
10365 ripley 338 
}
339 
 
340 
SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho)
341 
{
60688 ripley 342 
    SEXP path = R_NilValue, ans;
44008 ripley 343 
    const wchar_t *dll;
10365 ripley 344 
    DWORD dwVerInfoSize;
345 
    DWORD dwVerHnd;
19940 ripley 346 
 
10365 ripley 347 
    checkArity(op, args);
348 
    path = CAR(args);
349 
    if(!isString(path) || LENGTH(path) != 1)
35264 ripley 350 
	errorcall(call, _("invalid '%s' argument"), "path");
44008 ripley 351 
    dll = filenameToWchar(STRING_ELT(path, 0), FALSE);
352 
    dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd);
10365 ripley 353 
    PROTECT(ans = allocVector(STRSXP, 2));
10377 ripley 354 
    SET_STRING_ELT(ans, 0, mkChar(""));
355 
    SET_STRING_ELT(ans, 1, mkChar(""));
10365 ripley 356 
    if (dwVerInfoSize) {
357 
	BOOL  fRet;
358 
	LPSTR lpstrVffInfo;
359 
	LPSTR lszVer = NULL;
360 
	UINT  cchVer = 0;
361 
 
362 
	lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize);
60690 ripley 363 
	if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) {
19940 ripley 364 
 
10365 ripley 365 
	    fRet = VerQueryValue(lpstrVffInfo,
366 
				 TEXT("\\StringFileInfo\\040904E4\\FileVersion"),
367 
				 (LPVOID)&lszVer, &cchVer);
10377 ripley 368 
	    if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer));
10365 ripley 369 
 
370 
	    fRet = VerQueryValue(lpstrVffInfo,
371 
				 TEXT("\\StringFileInfo\\040904E4\\R Version"),
372 
				 (LPVOID)&lszVer, &cchVer);
10377 ripley 373 
	    if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
10365 ripley 374 
	    else {
375 
		fRet = VerQueryValue(lpstrVffInfo,
376 
				     TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"),
377 
				     (LPVOID)&lszVer, &cchVer);
10377 ripley 378 
		if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
10365 ripley 379 
	    }
19940 ripley 380 
 
10365 ripley 381 
	} else ans = R_NilValue;
382 
	free(lpstrVffInfo);
383 
    } else ans = R_NilValue;
384 
    UNPROTECT(1);
385 
    return ans;
386 
}
387 
 
73329 kalibera 388 
/* Retry renaming a few times to recover from possible anti-virus interference,
389 
   which has been reported e.g. during installation of packages. */
13548 ripley 390 
 
41783 ripley 391 
int Rwin_rename(const char *from, const char *to)
19531 ripley 392 
{
73308 kalibera 393 
    for(int retries = 0; retries < 10; retries++) {
76170 kalibera 394 
	/* coreutils first call MoveFileEx without flags; only if it fails
395 
	   with ERROR_FILE_EXISTS or ERROR_ALREADY_EXISTING, they call again
396 
	   with MOVEFILE_REPLACE_EXISTING */
73308 kalibera 397 
	if (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH))
398 
	    return 0;
73329 kalibera 399 
	DWORD err = GetLastError();
400 
	if (err != ERROR_SHARING_VIOLATION && err != ERROR_ACCESS_DENIED)
73308 kalibera 401 
	    return 1;
402 
	Sleep(500);
73323 kalibera 403 
	R_ProcessEvents();
73308 kalibera 404 
    }
405 
    return 1;
44008 ripley 406 
}
19531 ripley 407 
 
44008 ripley 408 
int Rwin_wrename(const wchar_t *from, const wchar_t *to)
409 
{
73308 kalibera 410 
    for(int retries = 0; retries < 10; retries++) {
411 
	if (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH))
412 
	    return 0;
73329 kalibera 413 
	DWORD err = GetLastError();
73323 kalibera 414 
	if (err != ERROR_SHARING_VIOLATION && err != ERROR_ACCESS_DENIED)
73308 kalibera 415 
	    return 1;
416 
	Sleep(500);
73323 kalibera 417 
	R_ProcessEvents();
73308 kalibera 418 
    }
419 
    return 1;
19531 ripley 420 
}
20669 ripley 421 
 
43323 ripley 422 
 
60686 ripley 423 
const char *formatError(DWORD res)
424 
{
425 
    static char buf[1000], *p;
426 
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
427 
		  NULL, res,
428 
		  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
429 
		  buf, 1000, NULL);
430 
    p = buf+strlen(buf) -1;
431 
    if(*p == '\n') *p = '\0';
432 
    p = buf+strlen(buf) -1;
433 
    if(*p == '\r') *p = '\0';
434 
    p = buf+strlen(buf) -1;
435 
    if(*p == '.') *p = '\0';
436 
    return buf;
437 
}
46777 murdoch 438 
 
77324 kalibera 439 
#if _WIN32_WINNT < 0x0600
440 
/* available from Windows Vista */
441 
typedef DWORD (WINAPI *LPFN_GFPNBH) (HANDLE, LPSTR, DWORD, DWORD);
442 
typedef DWORD (WINAPI *LPFN_GFPNBHW) (HANDLE, LPWSTR, DWORD, DWORD);
443 
/*
444 
DWORD GetFinalPathNameByHandle(
445 
    HANDLE hFile,
446 
    LPSTR lpszFilePath,
447 
    DWORD cchFilePath,
448 
    DWORD dwFlags);
53131 ripley 449 
 
77324 kalibera 450 
DWORD GetFinalPathNameByHandleW(
451 
    HANDLE hFile,
452 
    LPWSTR lpszFilePath,
453 
    DWORD  cchFilePath,
454 
    DWORD  dwFlags
455 
);
456 
*/
457 
#endif
458 
 
459 
/*
460 
   Returns TRUE on success. On failure, "res" may be modified but not useful.
461 
*/
462 
static Rboolean getFinalPathName(const char *orig, char *res)
463 
{
464 
    HANDLE h;
465 
    int ret;
466 
    static LPFN_GFPNBH gfpnbh = NULL;
467 
    static Rboolean initialized = FALSE;
468 
 
469 
    if (!initialized) {
470 
	initialized = TRUE;
471 
	gfpnbh = (LPFN_GFPNBH) GetProcAddress(
472 
	    GetModuleHandle(TEXT("kernel32")),
473 
	    "GetFinalPathNameByHandleA");
474 
    }
475 
    if (gfpnbh == NULL)
476 
	return FALSE;
477 
 
478 
    h = CreateFile(orig, 0,
479 
                   FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
480 
		   NULL, OPEN_EXISTING,
481 
                   /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
482 
		   FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS, NULL);
483 
    if (h == INVALID_HANDLE_VALUE)
484 
	return FALSE;
485 
 
486 
    ret = gfpnbh(h, res, MAX_PATH, VOLUME_NAME_DOS);
487 
    CloseHandle(h);
488 
 
489 
    if (!ret || ret > MAX_PATH)
490 
	return FALSE;
491 
 
492 
    /* get rid of the \\?\ prefix */
493 
    int len = strlen(res);
494 
    int strip = 0;
495 
    if (len < 4 || strncmp("\\\\?\\", res, 4))
496 
	/* res should start with \\?\ */
497 
	return FALSE;
498 
 
77458 kalibera 499 
    if (len > 8 && !strncmp("UNC\\", res+4, 4)) {
77324 kalibera 500 
	/* UNC path \\?\UNC */
77458 kalibera 501 
	res[6] = '\\'; /* replace the "C" in "UNC" to get "\\" prefix */
502 
	strip = 6;
503 
    } else if (len >= 6 && isalpha(res[4]) && res[5] == ':' && res[6] == '\\')
77324 kalibera 504 
	/* \\?\D: */
505 
	strip = 4;
506 
    else
507 
	return FALSE;
508 
    memmove(res, res+strip, len-strip+1);
509 
 
510 
    /* sanity check if the file exists using the normalized path, a normalized
511 
       path to an existing file should still be working */
512 
    h = CreateFile(orig, 0,
513 
                   FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
514 
		   NULL, OPEN_EXISTING,
515 
                   /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
516 
		   FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS, NULL);
517 
    if (h == INVALID_HANDLE_VALUE)
518 
	return FALSE;
519 
    CloseHandle(h);
520 
 
521 
    return TRUE;
522 
}
523 
 
524 
/*
525 
   Returns TRUE on success. On failure, "res" may be modified but not useful.
526 
*/
527 
static Rboolean getFinalPathNameW(const wchar_t *orig, wchar_t *res)
528 
{
529 
    HANDLE h;
530 
    int ret;
531 
    static LPFN_GFPNBHW gfpnbhw = NULL;
532 
    static Rboolean initialized = FALSE;
533 
 
534 
    if (!initialized) {
535 
	initialized = TRUE;
536 
	gfpnbhw = (LPFN_GFPNBHW) GetProcAddress(
537 
	    GetModuleHandle(TEXT("kernel32")),
538 
	    "GetFinalPathNameByHandleW");
539 
    }
540 
    if (gfpnbhw == NULL)
541 
	return FALSE;
542 
 
543 
    h = CreateFileW(orig, 0,
544 
                   FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
545 
		   NULL, OPEN_EXISTING,
546 
                   /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
547 
		   FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS, NULL);
548 
    if (h == INVALID_HANDLE_VALUE)
549 
	return FALSE;
550 
 
551 
    ret = gfpnbhw(h, res, 32767, VOLUME_NAME_DOS);
552 
    CloseHandle(h);
553 
 
554 
    if (!ret || ret > 32768)
555 
	return FALSE;
556 
 
557 
    /* get rid of the \\?\ prefix */
558 
    size_t len = wcslen(res);
559 
    int strip = 0;
560 
    if (len < 4 || wcsncmp(L"\\\\?\\", res, 4))
561 
	/* res should start with \\?\ */
562 
	return FALSE;
563 
 
564 
    if (len > 8 && !wcsncmp(L"UNC\\", res+4, 4))
565 
	/* UNC path \\?\UNC */
566 
	strip = 7;
567 
    else if (len >= 6 && Ri18n_iswctype(res[4], Ri18n_wctype("alpha"))
568 
	     && res[5] == L':' && res[6] == L'\\')
569 
	/* \\?\D: */
570 
	strip = 4;
571 
    else
572 
	return FALSE;
573 
    wmemmove(res, res+strip, len-strip+1);
574 
 
575 
    /* sanity check if the file exists using the normalized path, a normalized
576 
       path to an existing file should still be working */
577 
    h = CreateFileW(orig, 0,
578 
                   FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
579 
		   NULL, OPEN_EXISTING,
580 
                   /* FILE_FLAG_BACKUP_SEMANTICS needed to open a directory */
581 
		   FILE_ATTRIBUTE_HIDDEN | FILE_FLAG_BACKUP_SEMANTICS, NULL);
582 
    if (h == INVALID_HANDLE_VALUE)
583 
	return FALSE;
584 
    CloseHandle(h);
585 
 
586 
    return TRUE;
587 
}
588 
 
589 
 
590 
 
53131 ripley 591 
void R_UTF8fixslash(char *s); /* from main/util.c */
33233 ripley 592 
SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho)
593 
{
53131 ripley 594 
    SEXP ans, paths = CAR(args), el, slash;
53238 ripley 595 
    int i, n = LENGTH(paths), res;
72714 murdoch 596 
    char tmp[4*MAX_PATH+1], longpath[4*MAX_PATH+1], *tmp2;
53238 ripley 597 
    wchar_t wtmp[32768], wlongpath[32768], *wtmp2;
53131 ripley 598 
    int mustWork, fslash = 0;
43323 ripley 599 
 
33233 ripley 600 
    checkArity(op, args);
33266 ripley 601 
    if(!isString(paths))
45070 ripley 602 
	errorcall(call, _("'path' must be a character vector"));
33266 ripley 603 
 
53131 ripley 604 
    slash = CADR(args);
605 
    if(!isString(slash) || LENGTH(slash) != 1)
606 
	errorcall(call, "'winslash' must be a character string");
607 
    const char *sl = CHAR(STRING_ELT(slash, 0));
608 
    if (strcmp(sl, "/") && strcmp(sl, "\\"))
609 
	errorcall(call, "'winslash' must be '/' or '\\\\'");
610 
    if (strcmp(sl, "/") == 0) fslash = 1;
611 
 
612 
    mustWork = asLogical(CADDR(args));
613 
 
33233 ripley 614 
    PROTECT(ans = allocVector(STRSXP, n));
615 
    for (i = 0; i < n; i++) {
51977 murdoch 616 
    	SEXP result;
77324 kalibera 617 
	Rboolean ok = FALSE;
44008 ripley 618 
	el = STRING_ELT(paths, i);
53131 ripley 619 
	result = el;
75971 kalibera 620 
	if (el == NA_STRING) {
75835 kalibera 621 
	    result = NA_STRING;
75971 kalibera 622 
	    if(mustWork == 1)
623 
		errorcall(call, "path[%d]=NA", i+1);
624 
	    else if(mustWork == NA_LOGICAL)
625 
		warningcall(call, "path[%d]=NA", i+1);
626 
	} else if(getCharCE(el) == CE_UTF8) {
77324 kalibera 627 
	    wchar_t *norm = NULL;
628 
	    const wchar_t* wel = filenameToWchar(el, FALSE);
629 
 
630 
	    if (getFinalPathNameW(wel, wtmp)) {
631 
		norm = wtmp;
632 
		ok = TRUE;
51977 murdoch 633 
	    } else {
77324 kalibera 634 
		/* silently fall back to GetFullPathNameW/GetLongPathNameW */
635 
		res = GetFullPathNameW(wel, 32768, wtmp, &wtmp2);
636 
		if (res && res <= 32768) {
637 
		    norm = wtmp;
638 
		    res = GetLongPathNameW(wtmp, wlongpath, 32768);
639 
		    if (res && res <= 32768) {
640 
			norm = wlongpath;
641 
			ok = TRUE;
642 
		    }
53131 ripley 643 
		}
51977 murdoch 644 
	    }
77324 kalibera 645 
	    if (!ok) {
646 
		if (mustWork == 1) {
647 
		    errorcall(call, "path[%d]=\"%ls\": %s", i+1,
648 
			      wel, formatError(GetLastError()));
649 
		} else if (mustWork == NA_LOGICAL) {
650 
		    warningcall(call, "path[%d]=\"%ls\": %s", i+1,
651 
				wel, formatError(GetLastError()));
652 
		}
653 
	    }
654 
 
655 
	    char *normutf8 = tmp;
656 
	    if (norm)
657 
		wcstoutf8(tmp, norm, sizeof(tmp));
658 
	    else if (fslash)
659 
		strcpy(tmp, translateCharUTF8(el));
660 
	    else
661 
		normutf8 = (char *)translateCharUTF8(el);
662 
 
663 
	    if (fslash) R_UTF8fixslash(normutf8);
664 
	    result = mkCharCE(normutf8, CE_UTF8);
44008 ripley 665 
	} else {
77324 kalibera 666 
	    char *norm = NULL;
667 
	    const char *tel = translateChar(el);
668 
	    if (getFinalPathName(tel, tmp)) {
669 
		norm = tmp;
670 
		ok = TRUE;
51977 murdoch 671 
	    } else {
77324 kalibera 672 
		/* silently fall back to GetFullPathName/GetLongPathName */
673 
		res = GetFullPathName(tel, MAX_PATH, tmp, &tmp2);
674 
		if (res && res <= MAX_PATH) {
675 
		    norm = tmp;
676 
		    res = GetLongPathName(tmp, longpath, MAX_PATH);
677 
		    if (res && res <= MAX_PATH) {
678 
			norm = longpath;
679 
			ok = TRUE;
680 
		    }
53131 ripley 681 
		}
51977 murdoch 682 
	    }
77324 kalibera 683 
	    if (!ok) {
684 
		if (mustWork == 1) {
685 
		    errorcall(call, "path[%d]=\"%s\": %s", i+1,
686 
			      tel, formatError(GetLastError()));
687 
		} else if (mustWork == NA_LOGICAL) {
688 
		    warningcall(call, "path[%d]=\"%s\": %s", i+1,
689 
				tel, formatError(GetLastError()));
690 
		}
691 
		if (!norm) {
692 
		    if (fslash) {
693 
			strcpy(tmp, tel);
694 
			norm = tmp;
695 
		    } else
696 
			norm = (char *)tel;
697 
		}
698 
	    }
699 
	    if (fslash) R_fixslash(norm);
700 
	    result = mkChar(norm);
44008 ripley 701 
	}
51977 murdoch 702 
	SET_STRING_ELT(ans, i, result);
33233 ripley 703 
    }
704 
    UNPROTECT(1);
705 
    return ans;
706 
}
707 
 
60690 ripley 708 
/* utils::shortPathName */
60717 ripley 709 
SEXP in_shortpath(SEXP paths)
35920 ripley 710 
{
60717 ripley 711 
    SEXP ans, el;
35920 ripley 712 
    int i, n = LENGTH(paths);
72714 murdoch 713 
    char tmp[4*MAX_PATH+1];
53238 ripley 714 
    wchar_t wtmp[32768];
44906 ripley 715 
    DWORD res;
63181 ripley 716 
    const void *vmax = vmaxget();
43323 ripley 717 
 
60717 ripley 718 
    if(!isString(paths)) error(_("'path' must be a character vector"));
35920 ripley 719 
 
720 
    PROTECT(ans = allocVector(STRSXP, n));
721 
    for (i = 0; i < n; i++) {
44008 ripley 722 
	el = STRING_ELT(paths, i);
44986 ripley 723 
	if(getCharCE(el) == CE_UTF8) {
53238 ripley 724 
	    res = GetShortPathNameW(filenameToWchar(el, FALSE), wtmp, 32768);
725 
	    if (res && res <= 32768)
72714 murdoch 726 
		wcstoutf8(tmp, wtmp, sizeof(tmp));
45070 ripley 727 
	    else
44906 ripley 728 
		strcpy(tmp, translateChar(el));
44008 ripley 729 
	    /* documented to return paths using \, which the API call does
730 
	       not necessarily do */
731 
	    R_fixbackslash(tmp);
44986 ripley 732 
	    SET_STRING_ELT(ans, i, mkCharCE(tmp, CE_UTF8));
44008 ripley 733 
	} else {
44906 ripley 734 
	    res = GetShortPathName(translateChar(el), tmp, MAX_PATH);
53238 ripley 735 
	    if (res == 0 || res > MAX_PATH) strcpy(tmp, translateChar(el));
44008 ripley 736 
	    /* documented to return paths using \, which the API call does
737 
	       not necessarily do */
738 
	    R_fixbackslash(tmp);
739 
	    SET_STRING_ELT(ans, i, mkChar(tmp));
740 
	}
35920 ripley 741 
    }
742 
    UNPROTECT(1);
63181 ripley 743 
    vmaxset(vmax);
35920 ripley 744 
    return ans;
745 
}
49479 murdoch 746 
 
32311 ripley 747 
#include "devWindows.h"
44412 ripley 748 
#include <R_ext/GraphicsEngine.h> /* GEgetDevice */
32260 ripley 749 
 
60690 ripley 750 
/* grDevices::bringToTop */
60717 ripley 751 
SEXP bringtotop(SEXP sdev, SEXP sstay)
32260 ripley 752 
{
753 
    int dev, stay;
44500 ripley 754 
    pGEDevDesc gdd;
32260 ripley 755 
    gadesc *xd;
756 
 
60717 ripley 757 
    dev = asInteger(sdev);
758 
    stay = asInteger(sstay);
32260 ripley 759 
 
760 
    if(dev == -1) { /* console */
761 
	if(CharacterMode == RGui) BringToTop(RConsole, stay);
762 
    } else {
763 
	if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
60717 ripley 764 
	    error(_("invalid '%s' argument"), "which");
44412 ripley 765 
	gdd = GEgetDevice(dev - 1);
60717 ripley 766 
	if(!gdd) error(_("invalid device"));
32260 ripley 767 
	xd = (gadesc *) gdd->dev->deviceSpecific;
60717 ripley 768 
	if(!xd) error(_("invalid device"));
32888 ripley 769 
	if(stay && ismdi()) error(_("requires SDI mode"));
32260 ripley 770 
	BringToTop(xd->gawin, stay);
771 
    }
772 
    return R_NilValue;
773 
}
774 
 
60690 ripley 775 
/* grDevices::msgWindow */
60717 ripley 776 
SEXP msgwindow(SEXP sdev, SEXP stype)
47352 ripley 777 
{
778 
    int dev, type;
779 
    pGEDevDesc gdd;
780 
    gadesc *xd;
781 
 
60717 ripley 782 
    dev = asInteger(sdev);
783 
    type = asInteger(stype);
47352 ripley 784 
 
785 
    if(dev == -1) { /* console */
786 
	if(CharacterMode == RGui) GA_msgWindow(RConsole, type);
787 
    } else {
788 
	if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
60717 ripley 789 
	    error(_("invalid '%s' argument"), "which");
47352 ripley 790 
	gdd = GEgetDevice(dev - 1);
60717 ripley 791 
	if(!gdd) error(_("invalid device"));
47352 ripley 792 
	xd = (gadesc *) gdd->dev->deviceSpecific;
60717 ripley 793 
	if(!xd) error(_("invalid device"));
47352 ripley 794 
	if(type == 5) {
795 
	    xd->recording = TRUE;
796 
	    check(xd->mrec);
797 
	} else if(type == 6) {
798 
	    xd-> recording = FALSE;
799 
	    uncheck(xd->mrec);
800 
	} else
801 
	    GA_msgWindow(xd->gawin, type);
802 
    }
803 
    return R_NilValue;
804 
}
805 
 
32260 ripley 806 
 
52804 ripley 807 
/* This assumes a menuname of the form
808 
   $Graph<nn>Main, $Graph<nn>Popup, $Graph<nn>LocMain,
32260 ripley 809 
   or $Graph<nn>LocPopup where <nn> is the
810 
   device number.  We've already checked the $Graph prefix. */
811 
 
60690 ripley 812 
/* called from rui.c, only */
41793 ripley 813 
menu getGraphMenu(const char* menuname)
32260 ripley 814 
{
815 
    int devnum;
44500 ripley 816 
    pGEDevDesc gdd;
32260 ripley 817 
    gadesc *xd;
818 
 
819 
    menuname = menuname + 6;
820 
    devnum = atoi(menuname);
821 
    if(devnum < 1 || devnum > R_MaxDevices)
45070 ripley 822 
	error(_("invalid graphical device number"));
32260 ripley 823 
 
824 
    while (('0' <= *menuname) && (*menuname <= '9')) menuname++;
825 
 
44412 ripley 826 
    gdd = GEgetDevice(devnum - 1);
32260 ripley 827 
 
32888 ripley 828 
    if(!gdd) error(_("invalid device"));
32260 ripley 829 
 
830 
    xd = (gadesc *) gdd->dev->deviceSpecific;
831 
 
32888 ripley 832 
    if(!xd || xd->kind != SCREEN) error(_("bad device"));
32260 ripley 833 
 
834 
    if (strcmp(menuname, "Main") == 0) return(xd->mbar);
835 
    else if (strcmp(menuname, "Popup") == 0) return(xd->grpopup);
836 
    else return(NULL);
837 
}
838 
 
43323 ripley 839 
/*
41206 ripley 840 
   Replacement for MSVCRT's access.
841 
   Coded looking at tcl's tclWinFile.c
842 
*/
32787 ripley 843 
 
44008 ripley 844 
int winAccessW(const wchar_t *path, int mode)
41206 ripley 845 
{
44008 ripley 846 
    DWORD attr = GetFileAttributesW(path);
43323 ripley 847 
 
75482 kalibera 848 
    if(attr == INVALID_FILE_ATTRIBUTES)
849 
	/* file does not exist or may be locked */
850 
	return -1;
851 
 
41206 ripley 852 
    if(mode == F_OK) return 0;
75482 kalibera 853 
 
854 
    if ((mode & W_OK)
855 
	&& !(attr & FILE_ATTRIBUTE_DIRECTORY)
856 
	&& (attr & FILE_ATTRIBUTE_READONLY)) return -1;
41206 ripley 857 
 
858 
    if(mode & X_OK)
859 
	if(!(attr & FILE_ATTRIBUTE_DIRECTORY)) { /* Directory, so OK */
860 
	    /* Look at extension for executables */
44008 ripley 861 
	    wchar_t *p = wcsrchr(path, '.');
43323 ripley 862 
	    if(p == NULL ||
44008 ripley 863 
	       !((wcsicmp(p, L".exe") == 0) || (wcsicmp(p, L".com") == 0) ||
864 
		 (wcsicmp(p, L".bat") == 0) || (wcsicmp(p, L".cmd") == 0)) )
41228 ripley 865 
		return -1;
41206 ripley 866 
	}
43328 ripley 867 
    {
868 
	/* Now look for file security info */
41206 ripley 869 
	SECURITY_DESCRIPTOR *sdPtr = NULL;
42242 ripley 870 
	DWORD size = 0;
75482 kalibera 871 
	PSID sid = 0;
872 
	BOOL sidDefaulted;
873 
	SID_IDENTIFIER_AUTHORITY samba_unmapped = {{0, 0, 0, 0, 0, 22}};
41206 ripley 874 
	GENERIC_MAPPING genMap;
875 
	HANDLE hToken = NULL;
876 
	DWORD desiredAccess = 0;
877 
	DWORD grantedAccess = 0;
878 
	BOOL accessYesNo = FALSE;
879 
	PRIVILEGE_SET privSet;
880 
	DWORD privSetSize = sizeof(PRIVILEGE_SET);
881 
	int error;
882 
 
883 
	/* get size */
44008 ripley 884 
	GetFileSecurityW(path,
45070 ripley 885 
			 OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
75482 kalibera 886 
			 | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION,
887 
			 0, 0, &size);
41206 ripley 888 
	error = GetLastError();
75785 kalibera 889 
	if (error == ERROR_NOT_SUPPORTED)
75482 kalibera 890 
	    /* happens for some remote shares */
891 
	    return _waccess(path, mode);
75785 kalibera 892 
	if (error != ERROR_INSUFFICIENT_BUFFER)
75482 kalibera 893 
	    return -1;
41206 ripley 894 
	sdPtr = (SECURITY_DESCRIPTOR *) alloca(size);
44008 ripley 895 
	if(!GetFileSecurityW(path,
45070 ripley 896 
			     OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
75482 kalibera 897 
			     | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, sdPtr, size, &size))
41206 ripley 898 
	    return -1;
75482 kalibera 899 
	/* rely on attrib checks for unmapped samba owners and groups */
900 
	if (!GetSecurityDescriptorOwner(sdPtr, &sid, &sidDefaulted))
901 
	    return 0;
902 
	if (IsValidSid(sid) &&
903 
	    !memcmp(GetSidIdentifierAuthority(sid), &samba_unmapped, sizeof(SID_IDENTIFIER_AUTHORITY)))
904 
	    return 0;
41206 ripley 905 
	/*
906 
	 * Perform security impersonation of the user and open the
907 
	 * resulting thread token.
908 
	 */
909 
	if(!ImpersonateSelf(SecurityImpersonation)) return -1;
910 
	if(!OpenThreadToken(GetCurrentThread (),
911 
			    TOKEN_DUPLICATE | TOKEN_QUERY, FALSE,
912 
			    &hToken)) return -1;
913 
	if (mode & R_OK) desiredAccess |= FILE_GENERIC_READ;
914 
	if (mode & W_OK) desiredAccess |= FILE_GENERIC_WRITE;
915 
	if (mode & X_OK) desiredAccess |= FILE_GENERIC_EXECUTE;
916 
 
917 
	memset(&genMap, 0x0, sizeof (GENERIC_MAPPING));
918 
	genMap.GenericRead = FILE_GENERIC_READ;
919 
	genMap.GenericWrite = FILE_GENERIC_WRITE;
920 
	genMap.GenericExecute = FILE_GENERIC_EXECUTE;
921 
	genMap.GenericAll = FILE_ALL_ACCESS;
922 
	if(!AccessCheck(sdPtr, hToken, desiredAccess, &genMap, &privSet,
923 
			&privSetSize, &grantedAccess, &accessYesNo)) {
924 
	    CloseHandle(hToken);
925 
	    return -1;
926 
	}
927 
	CloseHandle(hToken);
928 
	if (!accessYesNo) return -1;
929 
 
930 
    }
931 
    return 0;
932 
}
933 
 
43331 ripley 934 
#include <Rversion.h>
44201 ripley 935 
char *getDLLVersion(void)
43331 ripley 936 
{
937 
    static char DLLversion[25];
938 
    OSVERSIONINFO osvi;
939 
    osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
940 
    GetVersionEx(&osvi);
941 
    /* 95, 98, ME are 4.x */
942 
    if(osvi.dwMajorVersion < 5)
943 
	R_Suicide("Windows 2000 or later is required");
62583 ripley 944 
    snprintf(DLLversion, 25, "%s.%s", R_MAJOR, R_MINOR);
43331 ripley 945 
    return (DLLversion);
946 
}
41206 ripley 947 
 
948 
 
45070 ripley 949 
 
32721 ripley 950 
/* UTF-8 support ----------------------------------------------- */
951 
 
44091 ripley 952 
#ifdef SUPPORT_UTF8_WIN32
953 
/* This is currently unused: for faking UTF-8 locale conversions */
954 
 
955 
#define FAKE_UTF8 1
956 
 
957 
 
32721 ripley 958 
size_t Rmbrtowc(wchar_t *wc, const char *s)
959 
{
960 
#ifdef FAKE_UTF8
961 
    unsigned int byte;
962 
    wchar_t local, *w;
963 
    byte = *((unsigned char *)s);
964 
    w = wc ? wc: &local;
965 
 
966 
    if (byte == 0) {
45070 ripley 967 
	*w = (wchar_t) 0;
968 
	return 0;
32721 ripley 969 
    } else if (byte < 0xC0) {
45070 ripley 970 
	*w = (wchar_t) byte;
971 
	return 1;
32721 ripley 972 
    } else if (byte < 0xE0) {
973 
	if(strlen(s) < 2) return -2;
45070 ripley 974 
	if ((s[1] & 0xC0) == 0x80) {
975 
	    *w = (wchar_t) (((byte & 0x1F) << 6) | (s[1] & 0x3F));
976 
	    return 2;
977 
	} else return -1;
32721 ripley 978 
    } else if (byte < 0xF0) {
979 
	if(strlen(s) < 3) return -2;
45070 ripley 980 
	if (((s[1] & 0xC0) == 0x80) && ((s[2] & 0xC0) == 0x80)) {
981 
	    *w = (wchar_t) (((byte & 0x0F) << 12)
982 
			    | ((s[1] & 0x3F) << 6) | (s[2] & 0x3F));
32721 ripley 983 
	    byte = *w;
984 
	    if(byte >= 0xD800 && byte <= 0xDFFF) return -1; /* surrogate */
985 
	    if(byte == 0xFFFE || byte == 0xFFFF) return -1;
45070 ripley 986 
	    return 3;
987 
	} else return -1;
32721 ripley 988 
    }
989 
    return -2;
990 
#else
991 
    return mbrtowc(wc, s, MB_CUR_MAX, NULL);
992 
#endif
993 
}
994 
 
995 
size_t Rmbstowcs(wchar_t *wc, const char *s, size_t n)
996 
{
997 
#ifdef FAKE_UTF8
998 
    int m, res=0;
999 
    const char *p;
1000 
 
1001 
    if(wc) {
1002 
	for(p = s; ; p+=m) {
1003 
	    m = Rmbrtowc(wc+res, p);
60844 ripley 1004 
	    if(m < 0) error(_("invalid input in 'Rmbstowcs'"));
32721 ripley 1005 
	    if(m <= 0) break;
1006 
	    res++;
1007 
	    if(res >= n) break;
1008 
	}
1009 
    } else {
1010 
	for(p = s; ; p+=m) {
1011 
	    m  = Rmbrtowc(NULL, p);
60844 ripley 1012 
	    if(m < 0) error(_("invalid input in 'Rmbstowcs'"));
32721 ripley 1013 
	    if(m <= 0) break;
1014 
	    res++;
1015 
	}
1016 
    }
1017 
    return res;
1018 
#else
1019 
    return mbstowcs(wc, s, n);
1020 
#endif
1021 
}
43948 ripley 1022 
#endif
46842 ripley 1023 
 
60688 ripley 1024 
/* base::file.choose */
46842 ripley 1025 
SEXP attribute_hidden do_filechoose(SEXP call, SEXP op, SEXP args, SEXP rho)
1026 
{
1027 
    SEXP ans;
1028 
    wchar_t *fn;
62076 ripley 1029 
    char str[4*MAX_PATH+1];
46842 ripley 1030 
 
1031 
    checkArity(op, args);
48428 murdoch 1032 
    setuserfilterW(L"All files (*.*)\0*.*\0\0");
46842 ripley 1033 
    fn = askfilenameW(G_("Select file"), "");
1034 
    if (!fn)
1035 
	error(_("file choice cancelled"));
72714 murdoch 1036 
    wcstoutf8(str, fn, sizeof(str));
46842 ripley 1037 
    PROTECT(ans = allocVector(STRSXP, 1));
1038 
    SET_STRING_ELT(ans, 0, mkCharCE(str, CE_UTF8));
1039 
    UNPROTECT(1);
1040 
    return ans;
1041 
}
64308 ripley 1042 
 
1043 
const char *getTZinfo(void);  // src/extra/tzone/registryTZ.c
1044 
 
1045 
SEXP attribute_hidden do_tzone_name(SEXP call, SEXP op, SEXP args, SEXP rho)
1046 
{
1047 
    return mkString(getTZinfo());
1048 
}
1049