The R Project SVN R

Rev

Rev 62583 | Rev 65805 | 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
62583 ripley 6 
 *  Copyright (C) 2005--2013  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
20 
 *  http://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>
57540 ripley 34 
#include <time.h>
9920 ripley 35 
#include "Defn.h"
60667 ripley 36 
#include <Internal.h>
9920 ripley 37 
#include "Fileio.h"
38 
#include <direct.h>
44008 ripley 39 
#include "graphapp/ga.h"
58001 ripley 40 
/* Mingw-w64 defines this to be 0x0502 */
44720 ripley 41 
#ifndef _WIN32_WINNT
51502 ripley 42 
# define _WIN32_WINNT 0x0502 /* for GetLongPathName, KEY_WOW64_64KEY */
44720 ripley 43 
#endif
9920 ripley 44 
#include <windows.h>
45 
#include "rui.h"
45005 ripley 46 
#undef ERROR
47 
#include <R_ext/RS.h> /* for Calloc */
9920 ripley 48 
 
49 
#include <winbase.h>
43328 ripley 50 
 
9920 ripley 51 
 
55471 murdoch 52 
/* used in rui.c */
41783 ripley 53 
void internal_shellexec(const char * file)
9920 ripley 54 
{
41783 ripley 55 
    const char *home;
55458 ripley 56 
    char home2[10000], *p;
42244 ripley 57 
    uintptr_t ret;
9920 ripley 58 
 
59 
    home = getenv("R_HOME");
60 
    if (home == NULL)
32888 ripley 61 
	error(_("R_HOME not set"));
55458 ripley 62 
    strncpy(home2, home, 10000);
63 
    for(p = home2; *p; p++) if(*p == '/') *p = '\\';
64 
    ret = (uintptr_t) ShellExecute(NULL, "open", file, NULL, home2, SW_SHOW);
39991 ripley 65 
    if(ret <= 32) { /* an error condition */
66 
	if(ret == ERROR_FILE_NOT_FOUND  || ret == ERROR_PATH_NOT_FOUND
67 
	   || ret == SE_ERR_FNF || ret == SE_ERR_PNF)
68 
	    error(_("'%s' not found"), file);
69 
	if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
43323 ripley 70 
	    error(_("file association for '%s' not available or invalid"),
39991 ripley 71 
		  file);
72 
	if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
73 
	    error(_("access to '%s' denied"), file);
74 
	error(_("problem in displaying '%s'"), file);
75 
    }
9920 ripley 76 
}
77 
 
55471 murdoch 78 
/* used by shell.exec() with rhome=FALSE.  2.13.0 and earlier were
79 
   like rhome=TRUE, but without fixing the path */
80 
static void internal_shellexecW(const wchar_t * file, Rboolean rhome)
44008 ripley 81 
{
82 
    const wchar_t *home;
55471 murdoch 83 
    wchar_t home2[10000], *p;
44008 ripley 84 
    uintptr_t ret;
55471 murdoch 85 
 
86 
    if (rhome) {
87 
    	home = _wgetenv(L"R_HOME");
88 
    	if (home == NULL)
89 
	    error(_("R_HOME not set"));
90 
    	wcsncpy(home2, home, 10000);
91 
    	for(p = home2; *p; p++) if(*p == L'/') *p = L'\\';
92 
	home = home2;
93 
    } else home = NULL;
94 
 
44008 ripley 95 
    ret = (uintptr_t) ShellExecuteW(NULL, L"open", file, NULL, home, SW_SHOW);
96 
    if(ret <= 32) { /* an error condition */
97 
	if(ret == ERROR_FILE_NOT_FOUND  || ret == ERROR_PATH_NOT_FOUND
98 
	   || ret == SE_ERR_FNF || ret == SE_ERR_PNF)
48339 murdoch 99 
	    error(_("'%ls' not found"), file);
44008 ripley 100 
	if(ret == SE_ERR_ASSOCINCOMPLETE || ret == SE_ERR_NOASSOC)
48339 murdoch 101 
	    error(_("file association for '%ls' not available or invalid"),
44008 ripley 102 
		  file);
103 
	if(ret == SE_ERR_ACCESSDENIED || ret == SE_ERR_SHARE)
48339 murdoch 104 
	    error(_("access to '%ls' denied"), file);
105 
	error(_("problem in displaying '%ls'"), file);
44008 ripley 106 
    }
107 
}
108 
 
9920 ripley 109 
SEXP do_shellexec(SEXP call, SEXP op, SEXP args, SEXP env)
110 
{
111 
    SEXP file;
112 
 
113 
    checkArity(op, args);
114 
    file = CAR(args);
115 
    if (!isString(file) || length(file) != 1)
35264 ripley 116 
	errorcall(call, _("invalid '%s' argument"), "file");
55471 murdoch 117 
    internal_shellexecW(filenameToWchar(STRING_ELT(file, 0), FALSE), FALSE);
9920 ripley 118 
    return R_NilValue;
119 
}
120 
 
41783 ripley 121 
int check_doc_file(const char * file)
9920 ripley 122 
{
41783 ripley 123 
    const char *home;
124 
    char path[MAX_PATH];
9920 ripley 125 
 
126 
    home = getenv("R_HOME");
127 
    if (home == NULL)
32888 ripley 128 
	error(_("R_HOME not set"));
28888 ripley 129 
    if(strlen(home) + strlen(file) + 1 >= MAX_PATH) return(1); /* cannot exist */
9920 ripley 130 
    strcpy(path, home);
131 
    strcat(path, "/");
132 
    strcat(path, file);
44008 ripley 133 
    return access(path, 4) == 0; /* read access */
9920 ripley 134 
}
135 
 
136 
#include "Startup.h"
137 
extern UImode CharacterMode;
138 
 
44201 ripley 139 
void Rwin_fpset(void)
9920 ripley 140 
{
37410 ripley 141 
    /* Under recent MinGW this is what fpreset does.  It sets the
142 
       control word to 0x37f which corresponds to 0x8001F as used by
143 
       _controlfp.  That is all errors are masked, 64-bit mantissa and
144 
       rounding are selected. */
145 
 
37409 ripley 146 
    __asm__ ( "fninit" ) ;
9920 ripley 147 
}
148 
 
19940 ripley 149 
 
37626 murdoch 150 
#include <preferences.h>
151 
 
60690 ripley 152 
/* utils::loadRconsole */
60717 ripley 153 
SEXP in_loadRconsole(SEXP sfile)
37626 murdoch 154 
{
155 
    struct structGUI gui;
63181 ripley 156 
    const void *vmax = vmaxget();
37626 murdoch 157 
 
158 
    if (!isString(sfile) || LENGTH(sfile) < 1)
60717 ripley 159 
	error(_("invalid '%s' argument"), "file");
43958 murdoch 160 
    getActive(&gui);  /* Will get defaults if there's no active console */
44008 ripley 161 
    if (loadRconsole(&gui, translateChar(STRING_ELT(sfile, 0)))) applyGUI(&gui);
52072 murdoch 162 
    if (strlen(gui.warning)) warning(gui.warning);
63181 ripley 163 
    vmaxset(vmax);
37626 murdoch 164 
    return R_NilValue;
165 
}
43323 ripley 166 
 
9920 ripley 167 
#include <lmcons.h>
60688 ripley 168 
typedef void (WINAPI *PGNSI)(LPSYSTEM_INFO);
9920 ripley 169 
 
60690 ripley 170 
/* base::Sys.info */
9920 ripley 171 
SEXP do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
172 
{
173 
    SEXP ans, ansnames;
43328 ripley 174 
    OSVERSIONINFOEX osvi;
45070 ripley 175 
    char ver[256], buf[1000];
44059 ripley 176 
    wchar_t name[MAX_COMPUTERNAME_LENGTH + 1], user[UNLEN+1];
9920 ripley 177 
    DWORD namelen = MAX_COMPUTERNAME_LENGTH + 1, userlen = UNLEN+1;
178 
 
179 
    checkArity(op, args);
56204 ripley 180 
    PROTECT(ans = allocVector(STRSXP, 8));
43328 ripley 181 
    osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX);
182 
    if(!GetVersionEx((OSVERSIONINFO *)&osvi))
183 
	error(_("unsupported version of Windows"));
9920 ripley 184 
 
10172 luke 185 
    SET_STRING_ELT(ans, 0, mkChar("Windows"));
43326 ripley 186 
 
43328 ripley 187 
    /* Here for unknown future versions */
62583 ripley 188 
    snprintf(ver, 256, "%d.%d",
189 
	     (int)osvi.dwMajorVersion, (int)osvi.dwMinorVersion);
43328 ripley 190 
 
43323 ripley 191 
    if((int)osvi.dwMajorVersion >= 5) {
192 
	PGNSI pGNSI;
193 
	SYSTEM_INFO si;
194 
	if(osvi.dwMajorVersion == 6) {
52150 ripley 195 
	    if(osvi.wProductType == VER_NT_WORKSTATION) {
196 
		if(osvi.dwMinorVersion == 0)
197 
		    strcpy(ver, "Vista");
198 
		else strcpy(ver, "7");
199 
	    } else
43323 ripley 200 
		strcpy(ver, "Server 2008");
201 
	}
202 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 0)
203 
	    strcpy(ver, "2000");
204 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 1)
205 
	    strcpy(ver, "XP");
206 
	if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 2) {
43328 ripley 207 
	    if(osvi.wProductType == VER_NT_WORKSTATION)
43323 ripley 208 
		strcpy(ver, "XP Professional");
209 
	    else strcpy(ver, "Server 2003");
210 
	}
43328 ripley 211 
	/* GetNativeSystemInfo is XP or later */
43323 ripley 212 
	pGNSI = (PGNSI)
213 
	    GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
214 
			   "GetNativeSystemInfo");
215 
	if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
216 
	if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
217 
	    strcat(ver, " x64");
43326 ripley 218 
    }
10172 luke 219 
    SET_STRING_ELT(ans, 1, mkChar(ver));
43323 ripley 220 
 
221 
    if((int)osvi.dwMajorVersion >= 5) {
43328 ripley 222 
	if(osvi.wServicePackMajor > 0)
62583 ripley 223 
	    snprintf(ver, 256, "build %d, Service Pack %d",
224 
		     LOWORD(osvi.dwBuildNumber),
225 
		     (int) osvi.wServicePackMajor);
226 
	else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
43323 ripley 227 
    } else
62583 ripley 228 
	snprintf(ver, 256, "build %d, %s",
229 
		 LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
10172 luke 230 
    SET_STRING_ELT(ans, 2, mkChar(ver));
44059 ripley 231 
    GetComputerNameW(name, &namelen);
232 
    wcstoutf8(buf, name, 1000);
44986 ripley 233 
    SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
52152 ripley 234 
#ifdef WIN64
235 
    SET_STRING_ELT(ans, 4, mkChar("x86-64"));
236 
#else
10172 luke 237 
    SET_STRING_ELT(ans, 4, mkChar("x86"));
52152 ripley 238 
#endif
44059 ripley 239 
    GetUserNameW(user, &userlen);
240 
    wcstoutf8(buf, user, 1000);
44986 ripley 241 
    SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
10172 luke 242 
    SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
56204 ripley 243 
    SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
244 
    PROTECT(ansnames = allocVector(STRSXP, 8));
10172 luke 245 
    SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
246 
    SET_STRING_ELT(ansnames, 1, mkChar("release"));
247 
    SET_STRING_ELT(ansnames, 2, mkChar("version"));
248 
    SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
249 
    SET_STRING_ELT(ansnames, 4, mkChar("machine"));
250 
    SET_STRING_ELT(ansnames, 5, mkChar("login"));
251 
    SET_STRING_ELT(ansnames, 6, mkChar("user"));
56204 ripley 252 
    SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
9920 ripley 253 
    setAttrib(ans, R_NamesSymbol, ansnames);
254 
    UNPROTECT(2);
255 
    return ans;
256 
}
257 
 
9934 ripley 258 
SEXP do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho)
19940 ripley 259 
{
13548 ripley 260 
    DWORD mtime;
9934 ripley 261 
    int ntime;
262 
    double time;
19940 ripley 263 
 
9934 ripley 264 
    checkArity(op, args);
265 
    time = asReal(CAR(args));
266 
    if (ISNAN(time) || time < 0)
35265 ripley 267 
	errorcall(call, _("invalid '%s' value"), "time");
9934 ripley 268 
    ntime = 1000*(time) + 0.5;
269 
    while (ntime > 0) {
270 
	mtime = min(500, ntime);
271 
	ntime -= mtime;
272 
	Sleep(mtime);
273 
	R_ProcessEvents();
274 
    }
275 
    return R_NilValue;
276 
}
10365 ripley 277 
 
11609 ripley 278 
#ifdef LEA_MALLOC
45865 ripley 279 
#define MALLINFO_FIELD_TYPE size_t
10365 ripley 280 
struct mallinfo {
45865 ripley 281 
    MALLINFO_FIELD_TYPE arena;    /* non-mmapped space allocated from system */
282 
    MALLINFO_FIELD_TYPE ordblks;  /* number of free chunks */
283 
    MALLINFO_FIELD_TYPE smblks;   /* number of fastbin blocks */
284 
    MALLINFO_FIELD_TYPE hblks;    /* number of mmapped regions */
285 
    MALLINFO_FIELD_TYPE hblkhd;   /* space in mmapped regions */
286 
    MALLINFO_FIELD_TYPE usmblks;  /* maximum total allocated space */
287 
    MALLINFO_FIELD_TYPE fsmblks;  /* space available in freed fastbin blocks */
288 
    MALLINFO_FIELD_TYPE uordblks; /* total allocated space */
289 
    MALLINFO_FIELD_TYPE fordblks; /* total free space */
290 
    MALLINFO_FIELD_TYPE keepcost; /* top-most, releasable (via malloc_trim) space */
10365 ripley 291 
};
50907 ripley 292 
extern R_size_t R_max_memory;
10365 ripley 293 
 
44201 ripley 294 
struct mallinfo mallinfo(void);
60717 ripley 295 
#endif
10365 ripley 296 
 
60717 ripley 297 
SEXP in_memsize(SEXP ssize)
10365 ripley 298 
{
299 
    SEXP ans;
48394 murdoch 300 
    int maxmem = NA_LOGICAL;
19940 ripley 301 
 
60717 ripley 302 
    if(isLogical(ssize))
303 
	maxmem = asLogical(ssize);
304 
    else if(isReal(ssize)) {
52886 murdoch 305 
	R_size_t newmax;
60717 ripley 306 
	double mem = asReal(ssize);
15848 ripley 307 
	if (!R_FINITE(mem))
60717 ripley 308 
	    error(_("incorrect argument"));
24283 ripley 309 
#ifdef LEA_MALLOC
50961 ripley 310 
#ifndef WIN64
32478 ripley 311 
	if(mem >= 4096)
60717 ripley 312 
	    error(_("don't be silly!: your machine has a 4Gb address limit"));
50961 ripley 313 
#endif
15848 ripley 314 
	newmax = mem * 1048576.0;
315 
	if (newmax < R_max_memory)
60717 ripley 316 
	    warning(_("cannot decrease memory limit: ignored"));
42236 ripley 317 
	else
318 
	    R_max_memory = newmax;
24283 ripley 319 
#endif
15848 ripley 320 
    } else
60717 ripley 321 
	error(_("incorrect argument"));
48390 murdoch 322 
 
323 
    PROTECT(ans = allocVector(REALSXP, 1));
324 
#ifdef LEA_MALLOC
325 
    if(maxmem == NA_LOGICAL)
326 
	REAL(ans)[0] = R_max_memory;
327 
    else if(maxmem)
328 
	REAL(ans)[0] = mallinfo().usmblks;
329 
    else
330 
	REAL(ans)[0] = mallinfo().uordblks;
331 
    REAL(ans)[0] /= 1048576.0;
332 
#else
333 
    REAL(ans)[0] = NA_REAL;
334 
#endif
335 
    UNPROTECT(1);
336 
    return ans;
10365 ripley 337 
}
338 
 
339 
SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho)
340 
{
60688 ripley 341 
    SEXP path = R_NilValue, ans;
44008 ripley 342 
    const wchar_t *dll;
10365 ripley 343 
    DWORD dwVerInfoSize;
344 
    DWORD dwVerHnd;
19940 ripley 345 
 
10365 ripley 346 
    checkArity(op, args);
347 
    path = CAR(args);
348 
    if(!isString(path) || LENGTH(path) != 1)
35264 ripley 349 
	errorcall(call, _("invalid '%s' argument"), "path");
44008 ripley 350 
    dll = filenameToWchar(STRING_ELT(path, 0), FALSE);
351 
    dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd);
10365 ripley 352 
    PROTECT(ans = allocVector(STRSXP, 2));
10377 ripley 353 
    SET_STRING_ELT(ans, 0, mkChar(""));
354 
    SET_STRING_ELT(ans, 1, mkChar(""));
10365 ripley 355 
    if (dwVerInfoSize) {
356 
	BOOL  fRet;
357 
	LPSTR lpstrVffInfo;
358 
	LPSTR lszVer = NULL;
359 
	UINT  cchVer = 0;
360 
 
361 
	lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize);
60690 ripley 362 
	if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) {
19940 ripley 363 
 
10365 ripley 364 
	    fRet = VerQueryValue(lpstrVffInfo,
365 
				 TEXT("\\StringFileInfo\\040904E4\\FileVersion"),
366 
				 (LPVOID)&lszVer, &cchVer);
10377 ripley 367 
	    if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer));
10365 ripley 368 
 
369 
	    fRet = VerQueryValue(lpstrVffInfo,
370 
				 TEXT("\\StringFileInfo\\040904E4\\R Version"),
371 
				 (LPVOID)&lszVer, &cchVer);
10377 ripley 372 
	    if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
10365 ripley 373 
	    else {
374 
		fRet = VerQueryValue(lpstrVffInfo,
375 
				     TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"),
376 
				     (LPVOID)&lszVer, &cchVer);
10377 ripley 377 
		if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
10365 ripley 378 
	    }
19940 ripley 379 
 
10365 ripley 380 
	} else ans = R_NilValue;
381 
	free(lpstrVffInfo);
382 
    } else ans = R_NilValue;
383 
    UNPROTECT(1);
384 
    return ans;
385 
}
386 
 
13548 ripley 387 
 
388 
 
41783 ripley 389 
int Rwin_rename(const char *from, const char *to)
19531 ripley 390 
{
51980 murdoch 391 
    return (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
44008 ripley 392 
}
19531 ripley 393 
 
44008 ripley 394 
int Rwin_wrename(const wchar_t *from, const wchar_t *to)
395 
{
51980 murdoch 396 
    return (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
19531 ripley 397 
}
20669 ripley 398 
 
43323 ripley 399 
 
60686 ripley 400 
const char *formatError(DWORD res)
401 
{
402 
    static char buf[1000], *p;
403 
    FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
404 
		  NULL, res,
405 
		  MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
406 
		  buf, 1000, NULL);
407 
    p = buf+strlen(buf) -1;
408 
    if(*p == '\n') *p = '\0';
409 
    p = buf+strlen(buf) -1;
410 
    if(*p == '\r') *p = '\0';
411 
    p = buf+strlen(buf) -1;
412 
    if(*p == '.') *p = '\0';
413 
    return buf;
414 
}
46777 murdoch 415 
 
53131 ripley 416 
 
417 
void R_UTF8fixslash(char *s); /* from main/util.c */
33233 ripley 418 
SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho)
419 
{
53131 ripley 420 
    SEXP ans, paths = CAR(args), el, slash;
53238 ripley 421 
    int i, n = LENGTH(paths), res;
44008 ripley 422 
    char tmp[MAX_PATH], longpath[MAX_PATH], *tmp2;
53238 ripley 423 
    wchar_t wtmp[32768], wlongpath[32768], *wtmp2;
53131 ripley 424 
    int mustWork, fslash = 0;
43323 ripley 425 
 
33233 ripley 426 
    checkArity(op, args);
33266 ripley 427 
    if(!isString(paths))
45070 ripley 428 
	errorcall(call, _("'path' must be a character vector"));
33266 ripley 429 
 
53131 ripley 430 
    slash = CADR(args);
431 
    if(!isString(slash) || LENGTH(slash) != 1)
432 
	errorcall(call, "'winslash' must be a character string");
433 
    const char *sl = CHAR(STRING_ELT(slash, 0));
434 
    if (strcmp(sl, "/") && strcmp(sl, "\\"))
435 
	errorcall(call, "'winslash' must be '/' or '\\\\'");
436 
    if (strcmp(sl, "/") == 0) fslash = 1;
437 
 
438 
    mustWork = asLogical(CADDR(args));
439 
 
33233 ripley 440 
    PROTECT(ans = allocVector(STRSXP, n));
441 
    for (i = 0; i < n; i++) {
53131 ripley 442 
    	int warn = 0;
51977 murdoch 443 
    	SEXP result;
44008 ripley 444 
	el = STRING_ELT(paths, i);
53131 ripley 445 
	result = el;
44986 ripley 446 
	if(getCharCE(el) == CE_UTF8) {
53238 ripley 447 
	    if ((res = GetFullPathNameW(filenameToWchar(el, FALSE), 32768,
448 
					wtmp, &wtmp2)) && res <= 32768) {
449 
		if ((res = GetLongPathNameW(wtmp, wlongpath, 32768))
450 
		    && res <= 32768) {
51977 murdoch 451 
	    	    wcstoutf8(longpath, wlongpath, wcslen(wlongpath)+1);
53131 ripley 452 
		    if(fslash) R_UTF8fixslash(longpath);
51977 murdoch 453 
	    	    result = mkCharCE(longpath, CE_UTF8);
53135 ripley 454 
		} else if(mustWork == 1) {
53131 ripley 455 
		    errorcall(call, "path[%d]=\"%s\": %s", i+1,
456 
			      translateChar(el),
457 
			      formatError(GetLastError()));
51977 murdoch 458 
	    	} else {
459 
	    	    wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
53131 ripley 460 
		    if(fslash) R_UTF8fixslash(tmp);
51977 murdoch 461 
	    	    result = mkCharCE(tmp, CE_UTF8);
462 
	    	    warn = 1;
463 
	    	}
53135 ripley 464 
	    } else if(mustWork == 1) {
53131 ripley 465 
		errorcall(call, "path[%d]=\"%s\": %s", i+1,
466 
			  translateChar(el),
467 
			  formatError(GetLastError()));
51977 murdoch 468 
	    } else {
53131 ripley 469 
		if (fslash) {
470 
		    strcpy(tmp, translateCharUTF8(el));
471 
		    R_UTF8fixslash(tmp);
472 
	    	    result = mkCharCE(tmp, CE_UTF8);
473 
		}
51977 murdoch 474 
	    	warn = 1;
475 
	    }
53135 ripley 476 
	    if (warn && (mustWork == NA_LOGICAL))
53128 ripley 477 
	    	warningcall(call, "path[%d]=\"%ls\": %s", i+1,
478 
			    filenameToWchar(el,FALSE),
479 
			    formatError(GetLastError()));
44008 ripley 480 
	} else {
53238 ripley 481 
	    if ((res = GetFullPathName(translateChar(el), MAX_PATH, tmp, &tmp2))
482 
		&& res <= MAX_PATH) {
483 
	    	if ((res = GetLongPathName(tmp, longpath, MAX_PATH))
484 
		    && res <= MAX_PATH) {
53131 ripley 485 
		    if(fslash) R_fixslash(longpath);
51977 murdoch 486 
	    	    result = mkChar(longpath);
53135 ripley 487 
		} else if(mustWork == 1) {
53131 ripley 488 
		    errorcall(call, "path[%d]=\"%s\": %s", i+1,
489 
			      translateChar(el),
490 
			      formatError(GetLastError()));
491 
	    	} else {
492 
		    if(fslash) R_fixslash(tmp);
51977 murdoch 493 
	    	    result = mkChar(tmp);
494 
	    	    warn = 1;
495 
	    	}
53135 ripley 496 
	    } else if(mustWork == 1) {
53131 ripley 497 
		errorcall(call, "path[%d]=\"%s\": %s", i+1,
498 
			  translateChar(el),
499 
			  formatError(GetLastError()));
51977 murdoch 500 
	    } else {
53131 ripley 501 
		if (fslash) {
502 
		    strcpy(tmp, translateChar(el));
503 
		    R_fixslash(tmp);
504 
		    result = mkChar(tmp);
505 
		}
51977 murdoch 506 
	    	warn = 1;
507 
	    }
53135 ripley 508 
	    if (warn && (mustWork == NA_LOGICAL))
53128 ripley 509 
		warningcall(call, "path[%d]=\"%s\": %s", i+1,
510 
			    translateChar(el),
51977 murdoch 511 
			    formatError(GetLastError()));
44008 ripley 512 
	}
51977 murdoch 513 
	SET_STRING_ELT(ans, i, result);
33233 ripley 514 
    }
515 
    UNPROTECT(1);
516 
    return ans;
517 
}
518 
 
60690 ripley 519 
/* utils::shortPathName */
60717 ripley 520 
SEXP in_shortpath(SEXP paths)
35920 ripley 521 
{
60717 ripley 522 
    SEXP ans, el;
35920 ripley 523 
    int i, n = LENGTH(paths);
524 
    char tmp[MAX_PATH];
53238 ripley 525 
    wchar_t wtmp[32768];
44906 ripley 526 
    DWORD res;
63181 ripley 527 
    const void *vmax = vmaxget();
43323 ripley 528 
 
60717 ripley 529 
    if(!isString(paths)) error(_("'path' must be a character vector"));
35920 ripley 530 
 
531 
    PROTECT(ans = allocVector(STRSXP, n));
532 
    for (i = 0; i < n; i++) {
44008 ripley 533 
	el = STRING_ELT(paths, i);
44986 ripley 534 
	if(getCharCE(el) == CE_UTF8) {
53238 ripley 535 
	    res = GetShortPathNameW(filenameToWchar(el, FALSE), wtmp, 32768);
536 
	    if (res && res <= 32768)
44906 ripley 537 
		wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
45070 ripley 538 
	    else
44906 ripley 539 
		strcpy(tmp, translateChar(el));
44008 ripley 540 
	    /* documented to return paths using \, which the API call does
541 
	       not necessarily do */
542 
	    R_fixbackslash(tmp);
44986 ripley 543 
	    SET_STRING_ELT(ans, i, mkCharCE(tmp, CE_UTF8));
44008 ripley 544 
	} else {
44906 ripley 545 
	    res = GetShortPathName(translateChar(el), tmp, MAX_PATH);
53238 ripley 546 
	    if (res == 0 || res > MAX_PATH) strcpy(tmp, translateChar(el));
44008 ripley 547 
	    /* documented to return paths using \, which the API call does
548 
	       not necessarily do */
549 
	    R_fixbackslash(tmp);
550 
	    SET_STRING_ELT(ans, i, mkChar(tmp));
551 
	}
35920 ripley 552 
    }
553 
    UNPROTECT(1);
63181 ripley 554 
    vmaxset(vmax);
35920 ripley 555 
    return ans;
556 
}
49479 murdoch 557 
 
32311 ripley 558 
#include "devWindows.h"
44160 ripley 559 
#include <Startup.h>
44412 ripley 560 
#include <R_ext/GraphicsEngine.h> /* GEgetDevice */
32260 ripley 561 
extern UImode CharacterMode;
562 
 
60690 ripley 563 
/* grDevices::bringToTop */
60717 ripley 564 
SEXP bringtotop(SEXP sdev, SEXP sstay)
32260 ripley 565 
{
566 
    int dev, stay;
44500 ripley 567 
    pGEDevDesc gdd;
32260 ripley 568 
    gadesc *xd;
569 
 
60717 ripley 570 
    dev = asInteger(sdev);
571 
    stay = asInteger(sstay);
32260 ripley 572 
 
573 
    if(dev == -1) { /* console */
574 
	if(CharacterMode == RGui) BringToTop(RConsole, stay);
575 
    } else {
576 
	if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
60717 ripley 577 
	    error(_("invalid '%s' argument"), "which");
44412 ripley 578 
	gdd = GEgetDevice(dev - 1);
60717 ripley 579 
	if(!gdd) error(_("invalid device"));
32260 ripley 580 
	xd = (gadesc *) gdd->dev->deviceSpecific;
60717 ripley 581 
	if(!xd) error(_("invalid device"));
32888 ripley 582 
	if(stay && ismdi()) error(_("requires SDI mode"));
32260 ripley 583 
	BringToTop(xd->gawin, stay);
584 
    }
585 
    return R_NilValue;
586 
}
587 
 
60690 ripley 588 
/* grDevices::msgWindow */
60717 ripley 589 
SEXP msgwindow(SEXP sdev, SEXP stype)
47352 ripley 590 
{
591 
    int dev, type;
592 
    pGEDevDesc gdd;
593 
    gadesc *xd;
594 
 
60717 ripley 595 
    dev = asInteger(sdev);
596 
    type = asInteger(stype);
47352 ripley 597 
 
598 
    if(dev == -1) { /* console */
599 
	if(CharacterMode == RGui) GA_msgWindow(RConsole, type);
600 
    } else {
601 
	if(dev < 1 || dev > R_MaxDevices || dev == NA_INTEGER)
60717 ripley 602 
	    error(_("invalid '%s' argument"), "which");
47352 ripley 603 
	gdd = GEgetDevice(dev - 1);
60717 ripley 604 
	if(!gdd) error(_("invalid device"));
47352 ripley 605 
	xd = (gadesc *) gdd->dev->deviceSpecific;
60717 ripley 606 
	if(!xd) error(_("invalid device"));
47352 ripley 607 
	if(type == 5) {
608 
	    xd->recording = TRUE;
609 
	    check(xd->mrec);
610 
	} else if(type == 6) {
611 
	    xd-> recording = FALSE;
612 
	    uncheck(xd->mrec);
613 
	} else
614 
	    GA_msgWindow(xd->gawin, type);
615 
    }
616 
    return R_NilValue;
617 
}
618 
 
32260 ripley 619 
 
52804 ripley 620 
/* This assumes a menuname of the form
621 
   $Graph<nn>Main, $Graph<nn>Popup, $Graph<nn>LocMain,
32260 ripley 622 
   or $Graph<nn>LocPopup where <nn> is the
623 
   device number.  We've already checked the $Graph prefix. */
624 
 
60690 ripley 625 
/* called from rui.c, only */
41793 ripley 626 
menu getGraphMenu(const char* menuname)
32260 ripley 627 
{
628 
    int devnum;
44500 ripley 629 
    pGEDevDesc gdd;
32260 ripley 630 
    gadesc *xd;
631 
 
632 
    menuname = menuname + 6;
633 
    devnum = atoi(menuname);
634 
    if(devnum < 1 || devnum > R_MaxDevices)
45070 ripley 635 
	error(_("invalid graphical device number"));
32260 ripley 636 
 
637 
    while (('0' <= *menuname) && (*menuname <= '9')) menuname++;
638 
 
44412 ripley 639 
    gdd = GEgetDevice(devnum - 1);
32260 ripley 640 
 
32888 ripley 641 
    if(!gdd) error(_("invalid device"));
32260 ripley 642 
 
643 
    xd = (gadesc *) gdd->dev->deviceSpecific;
644 
 
32888 ripley 645 
    if(!xd || xd->kind != SCREEN) error(_("bad device"));
32260 ripley 646 
 
647 
    if (strcmp(menuname, "Main") == 0) return(xd->mbar);
648 
    else if (strcmp(menuname, "Popup") == 0) return(xd->grpopup);
649 
    else return(NULL);
650 
}
651 
 
43323 ripley 652 
/*
41206 ripley 653 
   Replacement for MSVCRT's access.
654 
   Coded looking at tcl's tclWinFile.c
655 
*/
32787 ripley 656 
 
44008 ripley 657 
int winAccessW(const wchar_t *path, int mode)
41206 ripley 658 
{
44008 ripley 659 
    DWORD attr = GetFileAttributesW(path);
43323 ripley 660 
 
41206 ripley 661 
    if(attr == 0xffffffff) return -1;
662 
    if(mode == F_OK) return 0;
663 
 
664 
    if(mode & X_OK)
665 
	if(!(attr & FILE_ATTRIBUTE_DIRECTORY)) { /* Directory, so OK */
666 
	    /* Look at extension for executables */
44008 ripley 667 
	    wchar_t *p = wcsrchr(path, '.');
43323 ripley 668 
	    if(p == NULL ||
44008 ripley 669 
	       !((wcsicmp(p, L".exe") == 0) || (wcsicmp(p, L".com") == 0) ||
670 
		 (wcsicmp(p, L".bat") == 0) || (wcsicmp(p, L".cmd") == 0)) )
41228 ripley 671 
		return -1;
41206 ripley 672 
	}
43328 ripley 673 
    {
674 
	/* Now look for file security info */
41206 ripley 675 
	SECURITY_DESCRIPTOR *sdPtr = NULL;
42242 ripley 676 
	DWORD size = 0;
41206 ripley 677 
	GENERIC_MAPPING genMap;
678 
	HANDLE hToken = NULL;
679 
	DWORD desiredAccess = 0;
680 
	DWORD grantedAccess = 0;
681 
	BOOL accessYesNo = FALSE;
682 
	PRIVILEGE_SET privSet;
683 
	DWORD privSetSize = sizeof(PRIVILEGE_SET);
684 
	int error;
685 
 
686 
	/* get size */
44008 ripley 687 
	GetFileSecurityW(path,
45070 ripley 688 
			 OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
689 
			 | DACL_SECURITY_INFORMATION, 0, 0, &size);
41206 ripley 690 
	error = GetLastError();
691 
	if (error != ERROR_INSUFFICIENT_BUFFER) return -1;
692 
	sdPtr = (SECURITY_DESCRIPTOR *) alloca(size);
44008 ripley 693 
	if(!GetFileSecurityW(path,
45070 ripley 694 
			     OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
695 
			     | DACL_SECURITY_INFORMATION, sdPtr, size, &size))
41206 ripley 696 
	    return -1;
697 
	/*
698 
	 * Perform security impersonation of the user and open the
699 
	 * resulting thread token.
700 
	 */
701 
	if(!ImpersonateSelf(SecurityImpersonation)) return -1;
702 
	if(!OpenThreadToken(GetCurrentThread (),
703 
			    TOKEN_DUPLICATE | TOKEN_QUERY, FALSE,
704 
			    &hToken)) return -1;
705 
	if (mode & R_OK) desiredAccess |= FILE_GENERIC_READ;
706 
	if (mode & W_OK) desiredAccess |= FILE_GENERIC_WRITE;
707 
	if (mode & X_OK) desiredAccess |= FILE_GENERIC_EXECUTE;
708 
 
709 
	memset(&genMap, 0x0, sizeof (GENERIC_MAPPING));
710 
	genMap.GenericRead = FILE_GENERIC_READ;
711 
	genMap.GenericWrite = FILE_GENERIC_WRITE;
712 
	genMap.GenericExecute = FILE_GENERIC_EXECUTE;
713 
	genMap.GenericAll = FILE_ALL_ACCESS;
714 
	if(!AccessCheck(sdPtr, hToken, desiredAccess, &genMap, &privSet,
715 
			&privSetSize, &grantedAccess, &accessYesNo)) {
716 
	    CloseHandle(hToken);
717 
	    return -1;
718 
	}
719 
	CloseHandle(hToken);
720 
	if (!accessYesNo) return -1;
721 
 
722 
	if ((mode & W_OK)
723 
	    && !(attr & FILE_ATTRIBUTE_DIRECTORY)
724 
	    && (attr & FILE_ATTRIBUTE_READONLY)) return -1;
725 
    }
726 
    return 0;
727 
}
728 
 
43331 ripley 729 
#include <Rversion.h>
44201 ripley 730 
char *getDLLVersion(void)
43331 ripley 731 
{
732 
    static char DLLversion[25];
733 
    OSVERSIONINFO osvi;
734 
    osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
735 
    GetVersionEx(&osvi);
736 
    /* 95, 98, ME are 4.x */
737 
    if(osvi.dwMajorVersion < 5)
738 
	R_Suicide("Windows 2000 or later is required");
62583 ripley 739 
    snprintf(DLLversion, 25, "%s.%s", R_MAJOR, R_MINOR);
43331 ripley 740 
    return (DLLversion);
741 
}
41206 ripley 742 
 
743 
 
45070 ripley 744 
 
32721 ripley 745 
/* UTF-8 support ----------------------------------------------- */
746 
 
44091 ripley 747 
#ifdef SUPPORT_UTF8_WIN32
748 
/* This is currently unused: for faking UTF-8 locale conversions */
749 
 
750 
#define FAKE_UTF8 1
751 
 
752 
 
32721 ripley 753 
size_t Rmbrtowc(wchar_t *wc, const char *s)
754 
{
755 
#ifdef FAKE_UTF8
756 
    unsigned int byte;
757 
    wchar_t local, *w;
758 
    byte = *((unsigned char *)s);
759 
    w = wc ? wc: &local;
760 
 
761 
    if (byte == 0) {
45070 ripley 762 
	*w = (wchar_t) 0;
763 
	return 0;
32721 ripley 764 
    } else if (byte < 0xC0) {
45070 ripley 765 
	*w = (wchar_t) byte;
766 
	return 1;
32721 ripley 767 
    } else if (byte < 0xE0) {
768 
	if(strlen(s) < 2) return -2;
45070 ripley 769 
	if ((s[1] & 0xC0) == 0x80) {
770 
	    *w = (wchar_t) (((byte & 0x1F) << 6) | (s[1] & 0x3F));
771 
	    return 2;
772 
	} else return -1;
32721 ripley 773 
    } else if (byte < 0xF0) {
774 
	if(strlen(s) < 3) return -2;
45070 ripley 775 
	if (((s[1] & 0xC0) == 0x80) && ((s[2] & 0xC0) == 0x80)) {
776 
	    *w = (wchar_t) (((byte & 0x0F) << 12)
777 
			    | ((s[1] & 0x3F) << 6) | (s[2] & 0x3F));
32721 ripley 778 
	    byte = *w;
779 
	    if(byte >= 0xD800 && byte <= 0xDFFF) return -1; /* surrogate */
780 
	    if(byte == 0xFFFE || byte == 0xFFFF) return -1;
45070 ripley 781 
	    return 3;
782 
	} else return -1;
32721 ripley 783 
    }
784 
    return -2;
785 
#else
786 
    return mbrtowc(wc, s, MB_CUR_MAX, NULL);
787 
#endif
788 
}
789 
 
790 
size_t Rmbstowcs(wchar_t *wc, const char *s, size_t n)
791 
{
792 
#ifdef FAKE_UTF8
793 
    int m, res=0;
794 
    const char *p;
795 
 
796 
    if(wc) {
797 
	for(p = s; ; p+=m) {
798 
	    m = Rmbrtowc(wc+res, p);
60844 ripley 799 
	    if(m < 0) error(_("invalid input in 'Rmbstowcs'"));
32721 ripley 800 
	    if(m <= 0) break;
801 
	    res++;
802 
	    if(res >= n) break;
803 
	}
804 
    } else {
805 
	for(p = s; ; p+=m) {
806 
	    m  = Rmbrtowc(NULL, p);
60844 ripley 807 
	    if(m < 0) error(_("invalid input in 'Rmbstowcs'"));
32721 ripley 808 
	    if(m <= 0) break;
809 
	    res++;
810 
	}
811 
    }
812 
    return res;
813 
#else
814 
    return mbstowcs(wc, s, n);
815 
#endif
816 
}
43948 ripley 817 
#endif
46842 ripley 818 
 
60688 ripley 819 
/* base::file.choose */
46842 ripley 820 
SEXP attribute_hidden do_filechoose(SEXP call, SEXP op, SEXP args, SEXP rho)
821 
{
822 
    SEXP ans;
823 
    wchar_t *fn;
62076 ripley 824 
    char str[4*MAX_PATH+1];
46842 ripley 825 
 
826 
    checkArity(op, args);
48428 murdoch 827 
    setuserfilterW(L"All files (*.*)\0*.*\0\0");
46842 ripley 828 
    fn = askfilenameW(G_("Select file"), "");
829 
    if (!fn)
830 
	error(_("file choice cancelled"));
62076 ripley 831 
    wcstoutf8(str, fn, 4*MAX_PATH+1);
46842 ripley 832 
    PROTECT(ans = allocVector(STRSXP, 1));
833 
    SET_STRING_ELT(ans, 0, mkCharCE(str, CE_UTF8));
834 
    UNPROTECT(1);
835 
    return ans;
836 
}