The R Project SVN R

Rev

Rev 73630 | Rev 83755 | Go to most recent revision | 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
75824 kalibera 4 
 *  Copyright (C) 1997--2018  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 
{
51229 ripley 42 
    char  buf[PATH_MAX], *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;
51229 ripley 53 
	snprintf(buf, PATH_MAX, "%s/.Rprofile", getenv("R_USER"));
5223 ripley 54 
	if ((fp = R_fopen(buf, "r")))
55 
	    return fp;
56 
    }
57 
    return fp;
58 
}
59 
/*
60 
 *  5) FILESYSTEM INTERACTION
61 
 */
62 
 
63 
 
64 
static int HaveHOME=-1;
65 
static char UserHOME[PATH_MAX];
66 
static char newFileName[PATH_MAX];
72719 murdoch 67 
 
41783 ripley 68 
const char *R_ExpandFileName(const char *s)
5223 ripley 69 
{
70 
    char *p;
71 
 
72719 murdoch 72 
    if(s[0] != '~' || (s[0] && isalpha(s[1]))) return s;
5223 ripley 73 
    if(HaveHOME < 0) {
74 
	HaveHOME = 0;
45070 ripley 75 
	p = getenv("R_USER"); /* should be set so the rest is a safety measure */
28888 ripley 76 
	if(p && strlen(p) && strlen(p) < PATH_MAX) {
5223 ripley 77 
	    strcpy(UserHOME, p);
45070 ripley 78 
	    HaveHOME = 1;
5223 ripley 79 
	} else {
41474 ripley 80 
	    p = getenv("HOME");
81 
	    if(p && strlen(p) && strlen(p) < PATH_MAX) {
5223 ripley 82 
		strcpy(UserHOME, p);
41474 ripley 83 
		HaveHOME = 1;
84 
	    } else {
85 
		p = getenv("HOMEDRIVE");
86 
		if(p && strlen(p) < PATH_MAX) {
87 
		    strcpy(UserHOME, p);
88 
		    p = getenv("HOMEPATH");
89 
		    if(p && strlen(UserHOME) + strlen(p) < PATH_MAX) {
90 
			strcat(UserHOME, p);
91 
			HaveHOME = 1;
92 
		    }
5223 ripley 93 
		}
94 
	    }
95 
	}
96 
    }
28888 ripley 97 
    if(HaveHOME > 0 && strlen(UserHOME) + strlen(s+1) < PATH_MAX) {
5223 ripley 98 
	strcpy(newFileName, UserHOME);
99 
	strcat(newFileName, s+1);
100 
	return newFileName;
41778 ripley 101 
    } else return s;
5223 ripley 102 
}
103 
 
72719 murdoch 104 
/* from sysutils.c */
105 
void reEnc2(const char *x, char *y, int ny,
106 
	    cetype_t ce_in, cetype_t ce_out, int subst);
107 
 
108 
/* The following is a version of R_ExpandFileName that assumes
109 
   s is in UTF-8 and returns the final result in that encoding as well. */
110 
const char *R_ExpandFileNameUTF8(const char *s)
111 
{
112 
    if (s[0] !='~' || (s[0] && isalpha(s[1]))) return s;
113 
    else {
114 
    	char home[PATH_MAX];
115 
    	reEnc2(R_ExpandFileName("~"), home, PATH_MAX, CE_NATIVE, CE_UTF8, 3);
116 
    	if (strlen(home) + strlen(s+1) < PATH_MAX) {
117 
    	    strcpy(newFileName, home);
118 
    	    strcat(newFileName, s+1);
119 
    	    return newFileName;
120 
    	} else return s;
121 
    }
122 
}
123 
 
5223 ripley 124 
/*
125 
 *  7) PLATFORM DEPENDENT FUNCTIONS
126 
 */
127 
 
128 
SEXP do_machine(SEXP call, SEXP op, SEXP args, SEXP env)
129 
{
69326 luke 130 
    checkArity(op, args);
5223 ripley 131 
    return mkString("Win32");
132 
}
133 
 
36901 ripley 134 
#define WIN32_LEAN_AND_MEAN 1
6121 ripley 135 
#include <windows.h>
136 
 
5223 ripley 137 
static DWORD StartTime;
138 
 
6098 pd 139 
static FILETIME Create, Exit, Kernel, User;
140 
 
7824 ripley 141 
void R_setStartTime(void)
5223 ripley 142 
{
143 
    StartTime = GetTickCount();
144 
}
145 
 
10172 luke 146 
void R_getProcTime(double *data)
5223 ripley 147 
{
42253 ripley 148 
    DWORD elapsed;
6098 pd 149 
    double kernel, user;
45072 ripley 150 
 
37670 ripley 151 
    /* This is in msec, but to clock-tick accuracy,
152 
       said to be 10ms on NT and 55ms on Win95 */
6098 pd 153 
    elapsed = (GetTickCount() - StartTime) / 10;
5223 ripley 154 
 
45072 ripley 155 
    /* These are in units of 100ns, but with an accuracy only
156 
       in clock ticks.  So we round to 0.01s */
157 
    GetProcessTimes(GetCurrentProcess(), &Create, &Exit, &Kernel, &User);
158 
    user = 1e-5 * ((double) User.dwLowDateTime +
159 
		   (double) User.dwHighDateTime * 4294967296.0);
160 
    user = floor(user)/100.0;
161 
    kernel = 1e-5 * ((double) Kernel.dwLowDateTime +
162 
		     (double) Kernel.dwHighDateTime * 4294967296.0);
163 
    kernel = floor(kernel)/100.0;
10172 luke 164 
    data[0] = user;
165 
    data[1] = kernel;
166 
    data[2] = (double) elapsed / 100.0;
167 
    data[3] = R_NaReal;
168 
    data[4] = R_NaReal;
169 
}
170 
 
57499 ripley 171 
/* use in memory.c: increments for CPU times */
10172 luke 172 
double R_getClockIncrement(void)
173 
{
45070 ripley 174 
    return 1.0 / 100.0;
10172 luke 175 
}
5223 ripley 176 
 
177 
/*
75824 kalibera 178 
 * Stderr, Stdout
179 
 *   =FALSE .. drop output
180 
 *   =TRUE  .. return output
181 
 *   =""    .. print to standard error/output
182 
 *   =fname .. redirect to file of that name
183 
 *
184 
 * Redirection and dropping is supported with all flag values. Printing is
185 
 * supported with all flag values on non-RGui only (and happens via standard
186 
 * handles). For returning output (anywhere) and printing (on RGui),
187 
 * restrictions apply (below).
188 
 *
189 
 * flag =0 don't wait
190 
 *   returning of output not supported
191 
 *   RGui: non-redirected standard error and standard output always dropped
192 
 *         (printing not supported)
193 
 *
194 
 * flag =1 wait
195 
 *   otherwise like flag =0
196 
 *
197 
 * flag =2 wait/printing in RGui
198 
 *   returning of output not supported
199 
 *   non-RGui: works like flag =1
200 
 *   RGui: standard error and/or standard output is printed on console;
201 
 *         flag=2 may only be used when at least one of the outputs
202 
 *         is to be printed
203 
 *
204 
 * flag =3 wait/return output
205 
 *   standard error and/or standard output is returned
206 
 *   flag=3 may only be used when at least one of the outputs is to be returned
207 
 *   RGui: printing is not supported (one cannot return one output and print
208 
 *         the other)
209 
 *
210 
 * Add 10 to flag to minimize application
211 
 * Add 20 to flag make application "invisible"
5223 ripley 212 
*/
213 
 
214 
#include "run.h"
215 
 
22229 ripley 216 
#define INTERN_BUFSIZE 8096
5223 ripley 217 
SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
218 
{
219 
    rpipe *fp;
22229 ripley 220 
    char  buf[INTERN_BUFSIZE];
52814 ripley 221 
    const char *fout = "", *ferr = "";
64237 murdoch 222 
    int   vis = 0, flag = 2, i = 0, j, ll = 0;
52814 ripley 223 
    SEXP  cmd, fin, Stdout, Stderr, tlist = R_NilValue, tchar, rval;
75824 kalibera 224 
    PROTECT_INDEX ti;
72855 kalibera 225 
    int timeout = 0, timedout = 0;
5223 ripley 226 
 
227 
    checkArity(op, args);
52814 ripley 228 
    cmd = CAR(args);
229 
    if (!isString(cmd) || LENGTH(cmd) != 1)
32888 ripley 230 
	errorcall(call, _("character string expected as first argument"));
52814 ripley 231 
    args = CDR(args);
232 
    flag = asInteger(CAR(args)); args = CDR(args);
233 
    if (flag >= 20) {vis = -1; flag -= 20;}
234 
    else if (flag >= 10) {vis = 0; flag -= 10;}
235 
    else vis = 1;
236 
 
237 
    fin = CAR(args);
238 
    if (!isString(fin))
32888 ripley 239 
	errorcall(call, _("character string expected as third argument"));
52814 ripley 240 
    args = CDR(args);
241 
    Stdout = CAR(args);
242 
    args = CDR(args);
243 
    Stderr = CAR(args);
72855 kalibera 244 
    args = CDR(args);
245 
    timeout = asInteger(CAR(args));
246 
    if (timeout == NA_INTEGER || timeout < 0 || timeout > 2000000)
247 
	/* the limit could be increased, but not much as in milliseconds it
248 
	   has to fit into a 32-bit unsigned integer */
249 
	errorcall(call, _("invalid '%s' argument"), "timeout");
250 
    if (timeout && !flag)
251 
	errorcall(call, "Timeout with background running processes is not supported.");
252 
 
5223 ripley 253 
    if (CharacterMode == RGui) {
53348 ripley 254 
	/* This is a rather conservative approach: if
255 
	   Rgui is launched from a console window it does have
256 
	   standard handles -- but users might well not expect that.
257 
	*/
5223 ripley 258 
	SetStdHandle(STD_INPUT_HANDLE, INVALID_HANDLE_VALUE);
259 
	SetStdHandle(STD_OUTPUT_HANDLE, INVALID_HANDLE_VALUE);
260 
	SetStdHandle(STD_ERROR_HANDLE, INVALID_HANDLE_VALUE);
63695 ripley 261 
	if (TYPEOF(Stdout) == STRSXP) fout = CHAR(STRING_ELT(Stdout, 0));
262 
	if (TYPEOF(Stderr) == STRSXP) ferr = CHAR(STRING_ELT(Stderr, 0));
52814 ripley 263 
    } else {
264 
	if (flag == 2) flag = 1; /* ignore std.output.on.console */
53348 ripley 265 
	if (TYPEOF(Stdout) == STRSXP) fout = CHAR(STRING_ELT(Stdout, 0));
266 
	else if (asLogical(Stdout) == 0) fout = NULL;
267 
	if (TYPEOF(Stderr) == STRSXP) ferr = CHAR(STRING_ELT(Stderr, 0));
268 
	else if (asLogical(Stderr) == 0) ferr = NULL;
5223 ripley 269 
    }
52814 ripley 270 
 
271 
    if (flag < 2) { /* Neither intern = TRUE nor
52813 ripley 272 
		       show.output.on.console for Rgui */
72855 kalibera 273 
	ll = runcmd_timeout(CHAR(STRING_ELT(cmd, 0)),
52814 ripley 274 
		    getCharCE(STRING_ELT(cmd, 0)),
72855 kalibera 275 
		    flag, vis, CHAR(STRING_ELT(fin, 0)), fout, ferr,
276 
		    timeout, &timedout);
73609 kalibera 277 
	if (ll == NOLAUNCH) warning(runerror());
5223 ripley 278 
    } else {
52813 ripley 279 
	/* read stdout +/- stderr from pipe */
75824 kalibera 280 
	int m = -1;
281 
	if ((TYPEOF(Stderr) == LGLSXP && asLogical(Stderr)) ||
282 
	   (CharacterMode == RGui && TYPEOF(Stderr) == STRSXP && ferr && !ferr[0]))
283 
	    /* read stderr from pipe */
284 
	    m = 2;
285 
	if ((TYPEOF(Stdout) == LGLSXP && asLogical(Stdout)) ||
286 
	    (CharacterMode == RGui && TYPEOF(Stdout) == STRSXP && fout && !fout[0]))
287 
	    /* read stdout from pipe */
288 
	    m = (m == 2) ? 3 : 0;
289 
	if (m == -1)
290 
	    /* does not happen with system()/system2() */
291 
	    error(_("invalid %s argument"), "flag");
292 
 
53595 ripley 293 
	fp = rpipeOpen(CHAR(STRING_ELT(cmd, 0)), getCharCE(STRING_ELT(cmd, 0)),
72855 kalibera 294 
		       vis, CHAR(STRING_ELT(fin, 0)), m, fout, ferr, timeout);
5223 ripley 295 
	if (!fp) {
52813 ripley 296 
	    /* If intern = TRUE generate an error */
52802 ripley 297 
	    if (flag == 3) error(runerror());
5223 ripley 298 
	    ll = NOLAUNCH;
299 
	} else {
75824 kalibera 300 
	    if (flag == 3) { /* intern */
301 
		PROTECT_WITH_INDEX(tlist, &ti);
302 
		for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++) {
303 
		    ll = strlen(buf) - 1;
304 
		    if ((ll >= 0) && (buf[ll] == '\n')) buf[ll] = '\0';
305 
		    tchar = mkChar(buf);
306 
		    REPROTECT(tlist = CONS(tchar, tlist), ti);
307 
		}
308 
	    } else { /* print on RGui console */
53612 ripley 309 
		for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++)
5223 ripley 310 
		    R_WriteConsole(buf, strlen(buf));
311 
	    }
72855 kalibera 312 
	    ll = rpipeClose(fp, &timedout);
5223 ripley 313 
	}
314 
    }
72855 kalibera 315 
    if (timedout) {
316 
	ll = 124;
73630 kalibera 317 
	warning(_("command '%s' timed out after %ds"),
318 
	        CHAR(STRING_ELT(cmd, 0)), timeout);
72855 kalibera 319 
    } else if (flag == 3 && ll) {
73630 kalibera 320 
	warning(_("running command '%s' had status %d"),
321 
	        CHAR(STRING_ELT(cmd, 0)), ll);
64237 murdoch 322 
    }
52813 ripley 323 
    if (flag == 3) { /* intern = TRUE: convert pairlist to list */
52802 ripley 324 
	PROTECT(rval = allocVector(STRSXP, i));
5223 ripley 325 
	for (j = (i - 1); j >= 0; j--) {
10172 luke 326 
	    SET_STRING_ELT(rval, j, CAR(tlist));
5223 ripley 327 
	    tlist = CDR(tlist);
328 
	}
60370 urbaneks 329 
	if(ll) {
330 
	    SEXP lsym = install("status");
331 
	    setAttrib(rval, lsym, ScalarInteger(ll));
332 
	}
75824 kalibera 333 
	UNPROTECT(2); /* tlist, rval */
52802 ripley 334 
	return rval;
5223 ripley 335 
    } else {
52814 ripley 336 
	rval = ScalarInteger(ll);
5223 ripley 337 
	R_Visible = 0;
52814 ripley 338 
	return rval;
5223 ripley 339 
    }
340 
}