The R Project SVN R

Rev

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

Rev Author Line No. Line
5223 ripley 1 
/*
2 
 *  R : A Computer Language for Statistical Data Analysis
3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
83755 kalibera 4 
 *  Copyright (C) 1997--2023  The R Core Team
5223 ripley 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42300 ripley 17 
 *  along with this program; if not, a copy is available at
68956 ripley 18 
 *  https://www.R-project.org/Licenses/
5223 ripley 19 
 */
20 
 
45070 ripley 21 
	 /* See ../unix/system.txt for a description of functions */
5223 ripley 22 
 
45070 ripley 23 
	/* Windows analogue of unix/sys-unix.c: often rather similar */
5223 ripley 24 
 
25 
#ifdef HAVE_CONFIG_H
7701 hornik 26 
#include <config.h>
5223 ripley 27 
#endif
28 
 
51849 ripley 29 
#include <Defn.h>
60667 ripley 30 
#include <Internal.h>
51849 ripley 31 
#include <Fileio.h>
32 
#include <Startup.h>
5223 ripley 33 
 
51849 ripley 34 
#include <ctype.h> /* for isalpha */
35 
 
5223 ripley 36 
/*
37 
 *  4) INITIALIZATION AND TERMINATION ACTIONS
38 
 */
39 
 
40 
FILE *R_OpenInitFile(void)
41 
{
83755 kalibera 42 
    char  *buf, *p = getenv("R_PROFILE_USER");
5223 ripley 43 
    FILE *fp;
44 
 
45 
    fp = NULL;
46 
    if (LoadInitFile) {
54654 ripley 47 
	if(p) {
48 
	    if(!*p) return NULL;  /* set to "" */
45059 ripley 49 
	    return R_fopen(R_ExpandFileName(p), "r");
54654 ripley 50 
	}
5223 ripley 51 
	if ((fp = R_fopen(".Rprofile", "r")))
52 
	    return fp;
83755 kalibera 53 
	p = getenv("R_USER");
54 
	if (p) {
55 
	    size_t needed = snprintf(NULL, 0, "%s/.Rprofile", p) + 1;
56 
	    buf = (char *)malloc(needed);
57 
	    if (!buf)
58 
		return NULL;
59 
	    snprintf(buf, needed, "%s/.Rprofile", p);
60 
	    fp = R_fopen(buf, "r");
61 
	    free(buf);
62 
	}
5223 ripley 63 
    }
64 
    return fp;
65 
}
66 
/*
67 
 *  5) FILESYSTEM INTERACTION
68 
 */
69 
 
70 
 
71 
static int HaveHOME=-1;
83755 kalibera 72 
static char *UserHOME = NULL;
73 
#define NEWFILENAME_MAX 65536
74 
static char newFileName[NEWFILENAME_MAX];
72719 murdoch 75 
 
41783 ripley 76 
const char *R_ExpandFileName(const char *s)
5223 ripley 77 
{
83755 kalibera 78 
    char *p, *q;
5223 ripley 79 
 
72719 murdoch 80 
    if(s[0] != '~' || (s[0] && isalpha(s[1]))) return s;
5223 ripley 81 
    if(HaveHOME < 0) {
82 
	HaveHOME = 0;
45070 ripley 83 
	p = getenv("R_USER"); /* should be set so the rest is a safety measure */
83755 kalibera 84 
	if(p && strlen(p)) {
85 
	    if ((UserHOME = (char *)malloc(strlen(p) + 1))) {
86 
		strcpy(UserHOME, p);
87 
		HaveHOME = 1;
88 
	    }
5223 ripley 89 
	} else {
41474 ripley 90 
	    p = getenv("HOME");
83755 kalibera 91 
	    if(p && strlen(p)) {
92 
		if ((UserHOME = (char *)malloc(strlen(p) + 1))) {
93 
		    strcpy(UserHOME, p);
94 
		    HaveHOME = 1;
95 
		}
41474 ripley 96 
	    } else {
97 
		p = getenv("HOMEDRIVE");
83755 kalibera 98 
		q = getenv("HOMEPATH");
99 
		if(p && q &&
100 
		   (UserHOME = (char *)malloc(strlen(p) + strlen(q) + 1))) {
101 
 
41474 ripley 102 
		    strcpy(UserHOME, p);
83755 kalibera 103 
		    strcat(UserHOME, q);
104 
		    HaveHOME = 1;
5223 ripley 105 
		}
106 
	    }
107 
	}
108 
    }
81942 ripley 109 
    if(HaveHOME > 0) {
110 
	size_t len = strlen(UserHOME) + strlen(s+1);
83755 kalibera 111 
	if(len < NEWFILENAME_MAX) {
81942 ripley 112 
	    strcpy(newFileName, UserHOME);
113 
	    strcat(newFileName, s+1);
114 
	    return newFileName;
115 
	} else {
85625 kalibera 116 
	    warning(_("expanded path length %llu would be too long for\n%s\n"),
117 
		    (unsigned long long)len, s);
81942 ripley 118 
	    return s;
119 
	}
41778 ripley 120 
    } else return s;
5223 ripley 121 
}
122 
 
72719 murdoch 123 
/* from sysutils.c */
124 
void reEnc2(const char *x, char *y, int ny,
125 
	    cetype_t ce_in, cetype_t ce_out, int subst);
126 
 
127 
/* The following is a version of R_ExpandFileName that assumes
128 
   s is in UTF-8 and returns the final result in that encoding as well. */
129 
const char *R_ExpandFileNameUTF8(const char *s)
130 
{
131 
    if (s[0] !='~' || (s[0] && isalpha(s[1]))) return s;
132 
    else {
83755 kalibera 133 
	const char *native_home = R_ExpandFileName("~");
134 
	/* a defensive guess, reEnc2 would throw error if not enough */
135 
	size_t len = strlen(native_home) * 4;
136 
    	char *utf8_home = (char *)malloc(len);
137 
	if (!utf8_home) {
85625 kalibera 138 
	    warning(_("expanded path length %llu would be too long for\n%s\n"),
139 
	            (unsigned long long)len, s);
83755 kalibera 140 
	    return s;
141 
	}
142 
    	reEnc2(native_home, utf8_home, len, CE_NATIVE, CE_UTF8, 3);
143 
	len = strlen(utf8_home) + strlen(s+1) + 1;
144 
    	if (len <= NEWFILENAME_MAX) {
145 
    	    strcpy(newFileName, utf8_home);
72719 murdoch 146 
    	    strcat(newFileName, s+1);
147 
    	    return newFileName;
83755 kalibera 148 
    	} else {
85625 kalibera 149 
	    warning(_("expanded path length %llu would be too long for\n%s\n"),
150 
	            (unsigned long long)len, s);
83755 kalibera 151 
	    return s;
152 
	}
72719 murdoch 153 
    }
154 
}
155 
 
5223 ripley 156 
/*
157 
 *  7) PLATFORM DEPENDENT FUNCTIONS
158 
 */
159 
 
160 
SEXP do_machine(SEXP call, SEXP op, SEXP args, SEXP env)
161 
{
69326 luke 162 
    checkArity(op, args);
5223 ripley 163 
    return mkString("Win32");
164 
}
165 
 
36901 ripley 166 
#define WIN32_LEAN_AND_MEAN 1
6121 ripley 167 
#include <windows.h>
168 
 
5223 ripley 169 
static DWORD StartTime;
170 
 
6098 pd 171 
static FILETIME Create, Exit, Kernel, User;
172 
 
7824 ripley 173 
void R_setStartTime(void)
5223 ripley 174 
{
175 
    StartTime = GetTickCount();
176 
}
177 
 
10172 luke 178 
void R_getProcTime(double *data)
5223 ripley 179 
{
42253 ripley 180 
    DWORD elapsed;
6098 pd 181 
    double kernel, user;
45072 ripley 182 
 
37670 ripley 183 
    /* This is in msec, but to clock-tick accuracy,
184 
       said to be 10ms on NT and 55ms on Win95 */
6098 pd 185 
    elapsed = (GetTickCount() - StartTime) / 10;
5223 ripley 186 
 
45072 ripley 187 
    /* These are in units of 100ns, but with an accuracy only
188 
       in clock ticks.  So we round to 0.01s */
189 
    GetProcessTimes(GetCurrentProcess(), &Create, &Exit, &Kernel, &User);
190 
    user = 1e-5 * ((double) User.dwLowDateTime +
191 
		   (double) User.dwHighDateTime * 4294967296.0);
192 
    user = floor(user)/100.0;
193 
    kernel = 1e-5 * ((double) Kernel.dwLowDateTime +
194 
		     (double) Kernel.dwHighDateTime * 4294967296.0);
195 
    kernel = floor(kernel)/100.0;
10172 luke 196 
    data[0] = user;
197 
    data[1] = kernel;
198 
    data[2] = (double) elapsed / 100.0;
199 
    data[3] = R_NaReal;
200 
    data[4] = R_NaReal;
201 
}
202 
 
57499 ripley 203 
/* use in memory.c: increments for CPU times */
10172 luke 204 
double R_getClockIncrement(void)
205 
{
45070 ripley 206 
    return 1.0 / 100.0;
10172 luke 207 
}
5223 ripley 208 
 
209 
/*
75824 kalibera 210 
 * Stderr, Stdout
211 
 *   =FALSE .. drop output
212 
 *   =TRUE  .. return output
213 
 *   =""    .. print to standard error/output
214 
 *   =fname .. redirect to file of that name
215 
 *
216 
 * Redirection and dropping is supported with all flag values. Printing is
217 
 * supported with all flag values on non-RGui only (and happens via standard
218 
 * handles). For returning output (anywhere) and printing (on RGui),
219 
 * restrictions apply (below).
220 
 *
221 
 * flag =0 don't wait
222 
 *   returning of output not supported
223 
 *   RGui: non-redirected standard error and standard output always dropped
224 
 *         (printing not supported)
225 
 *
226 
 * flag =1 wait
227 
 *   otherwise like flag =0
228 
 *
229 
 * flag =2 wait/printing in RGui
230 
 *   returning of output not supported
231 
 *   non-RGui: works like flag =1
232 
 *   RGui: standard error and/or standard output is printed on console;
233 
 *         flag=2 may only be used when at least one of the outputs
234 
 *         is to be printed
235 
 *
236 
 * flag =3 wait/return output
237 
 *   standard error and/or standard output is returned
238 
 *   flag=3 may only be used when at least one of the outputs is to be returned
239 
 *   RGui: printing is not supported (one cannot return one output and print
240 
 *         the other)
241 
 *
242 
 * Add 10 to flag to minimize application
243 
 * Add 20 to flag make application "invisible"
5223 ripley 244 
*/
245 
 
246 
#include "run.h"
247 
 
22229 ripley 248 
#define INTERN_BUFSIZE 8096
5223 ripley 249 
SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
250 
{
251 
    rpipe *fp;
22229 ripley 252 
    char  buf[INTERN_BUFSIZE];
52814 ripley 253 
    const char *fout = "", *ferr = "";
64237 murdoch 254 
    int   vis = 0, flag = 2, i = 0, j, ll = 0;
52814 ripley 255 
    SEXP  cmd, fin, Stdout, Stderr, tlist = R_NilValue, tchar, rval;
75824 kalibera 256 
    PROTECT_INDEX ti;
84676 kalibera 257 
    int timeout = 0, timedout = 0, consignals = 0;
85648 kalibera 258 
    const void *vmax = vmaxget();
5223 ripley 259 
 
260 
    checkArity(op, args);
52814 ripley 261 
    cmd = CAR(args);
262 
    if (!isString(cmd) || LENGTH(cmd) != 1)
32888 ripley 263 
	errorcall(call, _("character string expected as first argument"));
52814 ripley 264 
    args = CDR(args);
265 
    flag = asInteger(CAR(args)); args = CDR(args);
266 
    if (flag >= 20) {vis = -1; flag -= 20;}
267 
    else if (flag >= 10) {vis = 0; flag -= 10;}
268 
    else vis = 1;
269 
 
270 
    fin = CAR(args);
271 
    if (!isString(fin))
32888 ripley 272 
	errorcall(call, _("character string expected as third argument"));
52814 ripley 273 
    args = CDR(args);
274 
    Stdout = CAR(args);
275 
    args = CDR(args);
276 
    Stderr = CAR(args);
72855 kalibera 277 
    args = CDR(args);
278 
    timeout = asInteger(CAR(args));
279 
    if (timeout == NA_INTEGER || timeout < 0 || timeout > 2000000)
280 
	/* the limit could be increased, but not much as in milliseconds it
281 
	   has to fit into a 32-bit unsigned integer */
282 
	errorcall(call, _("invalid '%s' argument"), "timeout");
283 
    if (timeout && !flag)
284 
	errorcall(call, "Timeout with background running processes is not supported.");
84676 kalibera 285 
    args = CDR(args);
286 
    consignals = asLogical(CAR(args));
287 
    if (consignals == NA_INTEGER)
288 
	errorcall(call, _("invalid '%s' argument"), "receive.console.signals");
72855 kalibera 289 
 
5223 ripley 290 
    if (CharacterMode == RGui) {
53348 ripley 291 
	/* This is a rather conservative approach: if
292 
	   Rgui is launched from a console window it does have
293 
	   standard handles -- but users might well not expect that.
294 
	*/
5223 ripley 295 
	SetStdHandle(STD_INPUT_HANDLE, INVALID_HANDLE_VALUE);
296 
	SetStdHandle(STD_OUTPUT_HANDLE, INVALID_HANDLE_VALUE);
297 
	SetStdHandle(STD_ERROR_HANDLE, INVALID_HANDLE_VALUE);
85648 kalibera 298 
	if (TYPEOF(Stdout) == STRSXP)
299 
	    fout = translateCharFP(STRING_ELT(Stdout, 0));
300 
	if (TYPEOF(Stderr) == STRSXP)
301 
	    ferr = translateCharFP(STRING_ELT(Stderr, 0));
52814 ripley 302 
    } else {
303 
	if (flag == 2) flag = 1; /* ignore std.output.on.console */
85648 kalibera 304 
	if (TYPEOF(Stdout) == STRSXP)
305 
	    fout = translateCharFP(STRING_ELT(Stdout, 0));
306 
	else if (asLogical(Stdout) == 0)
307 
	    fout = NULL;
308 
	if (TYPEOF(Stderr) == STRSXP)
309 
	    ferr = translateCharFP(STRING_ELT(Stderr, 0));
310 
	else if (asLogical(Stderr) == 0)
311 
	    ferr = NULL;
5223 ripley 312 
    }
52814 ripley 313 
 
314 
    if (flag < 2) { /* Neither intern = TRUE nor
52813 ripley 315 
		       show.output.on.console for Rgui */
85648 kalibera 316 
	ll = runcmd_timeout(translateCharFP(STRING_ELT(cmd, 0)),
317 
		    CE_NATIVE,
318 
		    flag, vis, translateCharFP(STRING_ELT(fin, 0)), fout, ferr,
84676 kalibera 319 
		    timeout, &timedout, consignals);
85625 kalibera 320 
	if (ll == NOLAUNCH) warning("%s", runerror());
5223 ripley 321 
    } else {
52813 ripley 322 
	/* read stdout +/- stderr from pipe */
75824 kalibera 323 
	int m = -1;
324 
	if ((TYPEOF(Stderr) == LGLSXP && asLogical(Stderr)) ||
325 
	   (CharacterMode == RGui && TYPEOF(Stderr) == STRSXP && ferr && !ferr[0]))
326 
	    /* read stderr from pipe */
327 
	    m = 2;
328 
	if ((TYPEOF(Stdout) == LGLSXP && asLogical(Stdout)) ||
329 
	    (CharacterMode == RGui && TYPEOF(Stdout) == STRSXP && fout && !fout[0]))
330 
	    /* read stdout from pipe */
331 
	    m = (m == 2) ? 3 : 0;
332 
	if (m == -1)
333 
	    /* does not happen with system()/system2() */
334 
	    error(_("invalid %s argument"), "flag");
335 
 
85648 kalibera 336 
	fp = rpipeOpen(translateCharFP(STRING_ELT(cmd, 0)), CE_NATIVE,
337 
		       vis, translateCharFP(STRING_ELT(fin, 0)), m, fout, ferr,
338 
	               timeout, 0);
5223 ripley 339 
	if (!fp) {
52813 ripley 340 
	    /* If intern = TRUE generate an error */
85625 kalibera 341 
	    if (flag == 3) error("%s", runerror());
5223 ripley 342 
	    ll = NOLAUNCH;
343 
	} else {
75824 kalibera 344 
	    if (flag == 3) { /* intern */
345 
		PROTECT_WITH_INDEX(tlist, &ti);
346 
		for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++) {
347 
		    ll = strlen(buf) - 1;
348 
		    if ((ll >= 0) && (buf[ll] == '\n')) buf[ll] = '\0';
349 
		    tchar = mkChar(buf);
350 
		    REPROTECT(tlist = CONS(tchar, tlist), ti);
351 
		}
352 
	    } else { /* print on RGui console */
53612 ripley 353 
		for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++)
5223 ripley 354 
		    R_WriteConsole(buf, strlen(buf));
355 
	    }
72855 kalibera 356 
	    ll = rpipeClose(fp, &timedout);
5223 ripley 357 
	}
358 
    }
72855 kalibera 359 
    if (timedout) {
360 
	ll = 124;
73630 kalibera 361 
	warning(_("command '%s' timed out after %ds"),
85648 kalibera 362 
	        translateChar(STRING_ELT(cmd, 0)), timeout);
72855 kalibera 363 
    } else if (flag == 3 && ll) {
73630 kalibera 364 
	warning(_("running command '%s' had status %d"),
85648 kalibera 365 
	        translateChar(STRING_ELT(cmd, 0)), ll);
64237 murdoch 366 
    }
52813 ripley 367 
    if (flag == 3) { /* intern = TRUE: convert pairlist to list */
52802 ripley 368 
	PROTECT(rval = allocVector(STRSXP, i));
5223 ripley 369 
	for (j = (i - 1); j >= 0; j--) {
10172 luke 370 
	    SET_STRING_ELT(rval, j, CAR(tlist));
5223 ripley 371 
	    tlist = CDR(tlist);
372 
	}
60370 urbaneks 373 
	if(ll) {
374 
	    SEXP lsym = install("status");
375 
	    setAttrib(rval, lsym, ScalarInteger(ll));
376 
	}
85648 kalibera 377 
	vmaxset(vmax);
75824 kalibera 378 
	UNPROTECT(2); /* tlist, rval */
52802 ripley 379 
	return rval;
5223 ripley 380 
    } else {
85648 kalibera 381 
	vmaxset(vmax);
52814 ripley 382 
	rval = ScalarInteger(ll);
5223 ripley 383 
	R_Visible = 0;
52814 ripley 384 
	return rval;
5223 ripley 385 
    }
386 
}