1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1998--2021 The R Core Team
4 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
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
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21
22 /* Notes on so-called 'Large File Support'
23
24 The 'stat' structure returns a file size as 'off_t'. On some
25 32-bit systems this will fail if called on a file > 2GB. On
26 systems with LFS selected (see the notes in connections.c) the call
27 is re-mapped to *stat64, which uses off64_t for the file size.
28
29 file.info() returns file sizes as an R double.
30
31 On Windows we need to remap for ourselves. There are various
32 versions of the 'stat' structure (some with 64-bit times and not
33 available in the original MSVCRT.dll): we use _stati64 that simply
34 replaces off_t by __int64_t.
35 */
36
37 #ifdef HAVE_CONFIG_H
38 # include <config.h>
39 #endif
40
41 #include <Defn.h>
42 #include <Internal.h>
43 #include <Rinterface.h>
44 #include <Fileio.h>
45 #include <ctype.h> /* toupper */
46 #include <float.h> // -> FLT_RADIX
47 #include <limits.h>
48 #include <string.h>
49 #include <stdlib.h> /* for realpath */
50 #include <time.h> /* for ctime */
51
52 # include <errno.h>
53
54 #ifdef HAVE_UNISTD_H
55 #include <unistd.h> /* for symlink, getpid */
56 #endif
57
58 #ifdef HAVE_SYS_TYPES_H
59 # include <sys/types.h>
60 #endif
61 #ifdef HAVE_SYS_STAT_H
62 # include <sys/stat.h>
63 #endif
64
65 #ifdef Win32
66 /* Mingw-w64 defines this to be 0x0502 */
67 #ifndef _WIN32_WINNT
68 # define _WIN32_WINNT 0x0500 /* for CreateHardLink */
69 #endif
70 #include <windows.h>
71 typedef BOOLEAN (WINAPI *PCSL)(LPWSTR, LPWSTR, DWORD);
72 static PCSL pCSL = NULL;
73 const char *formatError(DWORD res); /* extra.c */
74 /* Windows does not have link(), but it does have CreateHardLink() on NTFS */
75 #undef HAVE_LINK
76 #define HAVE_LINK 1
77 /* Windows does not have symlink(), but >= Vista does have
78 CreateSymbolicLink() on NTFS */
79 #undef HAVE_SYMLINK
80 #define HAVE_SYMLINK 1
81 #endif
82
83 /* Machine Constants */
84
85 #define DTYPE double
86 #define MACH_NAME machar
87 #define ABS fabs
88 #include "machar.c"
89 #undef DTYPE
90 #undef MACH_NAME
91 #undef ABS
92
93 #ifdef HAVE_LONG_DOUBLE
94 # define DTYPE long double
95 # define MACH_NAME machar_LD
96 # define ABS fabsl
97 # include "machar.c"
98 # undef DTYPE
99 # undef MACH_NAME
100 # undef ABS
101 #endif
102
Init_R_Machine(SEXP rho)103 static void Init_R_Machine(SEXP rho)
104 {
105 machar(&R_AccuracyInfo.ibeta,
106 &R_AccuracyInfo.it,
107 &R_AccuracyInfo.irnd,
108 &R_AccuracyInfo.ngrd,
109 &R_AccuracyInfo.machep,
110 &R_AccuracyInfo.negep,
111 &R_AccuracyInfo.iexp,
112 &R_AccuracyInfo.minexp,
113 &R_AccuracyInfo.maxexp,
114 &R_AccuracyInfo.eps,
115 &R_AccuracyInfo.epsneg,
116 &R_AccuracyInfo.xmin,
117 &R_AccuracyInfo.xmax);
118
119 R_dec_min_exponent = (int) floor(log10(R_AccuracyInfo.xmin)); /* smallest decimal exponent */
120
121 /*
122 #ifdef HAVE_LONG_DOUBLE
123 # define MACH_SIZE 18+10
124 #else
125 # define MACH_SIZE 18
126 #endif
127 */
128 int MACH_SIZE = 18;
129 if (sizeof(LDOUBLE) > sizeof(double)) MACH_SIZE += 10;
130
131 SEXP ans = PROTECT(allocVector(VECSXP, MACH_SIZE)),
132 nms = PROTECT(allocVector(STRSXP, MACH_SIZE));
133
134 SET_STRING_ELT(nms, 0, mkChar("double.eps"));
135 SET_VECTOR_ELT(ans, 0, ScalarReal(R_AccuracyInfo.eps));
136
137 SET_STRING_ELT(nms, 1, mkChar("double.neg.eps"));
138 SET_VECTOR_ELT(ans, 1, ScalarReal(R_AccuracyInfo.epsneg));
139
140 SET_STRING_ELT(nms, 2, mkChar("double.xmin"));
141 SET_VECTOR_ELT(ans, 2, ScalarReal(R_AccuracyInfo.xmin));
142
143 SET_STRING_ELT(nms, 3, mkChar("double.xmax"));
144 SET_VECTOR_ELT(ans, 3, ScalarReal(R_AccuracyInfo.xmax));
145
146 SET_STRING_ELT(nms, 4, mkChar("double.base"));
147 SET_VECTOR_ELT(ans, 4, ScalarInteger(R_AccuracyInfo.ibeta));
148
149 SET_STRING_ELT(nms, 5, mkChar("double.digits"));
150 SET_VECTOR_ELT(ans, 5, ScalarInteger(R_AccuracyInfo.it));
151
152 SET_STRING_ELT(nms, 6, mkChar("double.rounding"));
153 SET_VECTOR_ELT(ans, 6, ScalarInteger(R_AccuracyInfo.irnd));
154
155 SET_STRING_ELT(nms, 7, mkChar("double.guard"));
156 SET_VECTOR_ELT(ans, 7, ScalarInteger(R_AccuracyInfo.ngrd));
157
158 SET_STRING_ELT(nms, 8, mkChar("double.ulp.digits"));
159 SET_VECTOR_ELT(ans, 8, ScalarInteger(R_AccuracyInfo.machep));
160
161 SET_STRING_ELT(nms, 9, mkChar("double.neg.ulp.digits"));
162 SET_VECTOR_ELT(ans, 9, ScalarInteger(R_AccuracyInfo.negep));
163
164 SET_STRING_ELT(nms, 10, mkChar("double.exponent"));
165 SET_VECTOR_ELT(ans, 10, ScalarInteger(R_AccuracyInfo.iexp));
166
167 SET_STRING_ELT(nms, 11, mkChar("double.min.exp"));
168 SET_VECTOR_ELT(ans, 11, ScalarInteger(R_AccuracyInfo.minexp));
169
170 SET_STRING_ELT(nms, 12, mkChar("double.max.exp"));
171 SET_VECTOR_ELT(ans, 12, ScalarInteger(R_AccuracyInfo.maxexp));
172
173 SET_STRING_ELT(nms, 13, mkChar("integer.max"));
174 SET_VECTOR_ELT(ans, 13, ScalarInteger(INT_MAX));
175
176 SET_STRING_ELT(nms, 14, mkChar("sizeof.long"));
177 SET_VECTOR_ELT(ans, 14, ScalarInteger(SIZEOF_LONG));
178
179 SET_STRING_ELT(nms, 15, mkChar("sizeof.longlong"));
180 SET_VECTOR_ELT(ans, 15, ScalarInteger(SIZEOF_LONG_LONG));
181
182 SET_STRING_ELT(nms, 16, mkChar("sizeof.longdouble"));
183 #ifdef HAVE_LONG_DOUBLE
184 SET_VECTOR_ELT(ans, 16, ScalarInteger(SIZEOF_LONG_DOUBLE));
185 #else
186 SET_VECTOR_ELT(ans, 16, ScalarInteger(0));
187 #endif
188
189 SET_STRING_ELT(nms, 17, mkChar("sizeof.pointer"));
190 SET_VECTOR_ELT(ans, 17, ScalarInteger(sizeof(SEXP)));
191
192 /* This used to be just
193 #ifdef HAVE_LONG_DOUBLE
194 but platforms can have the type and it be identical to double
195 (as on ARM). So do the same as capabilities("long.double")
196 */
197 #ifdef HAVE_LONG_DOUBLE
198 if (sizeof(LDOUBLE) > sizeof(double)) {
199 static struct {
200 int ibeta, it, irnd, ngrd, machep, negep, iexp, minexp, maxexp;
201 long double eps, epsneg, xmin, xmax;
202 } R_LD_AccuracyInfo;
203
204 machar_LD(&R_LD_AccuracyInfo.ibeta,
205 &R_LD_AccuracyInfo.it,
206 &R_LD_AccuracyInfo.irnd,
207 &R_LD_AccuracyInfo.ngrd,
208 &R_LD_AccuracyInfo.machep,
209 &R_LD_AccuracyInfo.negep,
210 &R_LD_AccuracyInfo.iexp,
211 &R_LD_AccuracyInfo.minexp,
212 &R_LD_AccuracyInfo.maxexp,
213 &R_LD_AccuracyInfo.eps,
214 &R_LD_AccuracyInfo.epsneg,
215 &R_LD_AccuracyInfo.xmin,
216 &R_LD_AccuracyInfo.xmax);
217
218 SET_STRING_ELT(nms, 18+0, mkChar("longdouble.eps"));
219 SET_VECTOR_ELT(ans, 18+0, ScalarReal((double) R_LD_AccuracyInfo.eps));
220
221 SET_STRING_ELT(nms, 18+1, mkChar("longdouble.neg.eps"));
222 SET_VECTOR_ELT(ans, 18+1, ScalarReal((double) R_LD_AccuracyInfo.epsneg));
223 /*
224 SET_STRING_ELT(nms, 18+2, mkChar("longdouble.xmin")); // not representable as double
225 SET_VECTOR_ELT(ans, 18+2, ScalarReal(R_LD_AccuracyInfo.xmin));
226
227 SET_STRING_ELT(nms, 18+3, mkChar("longdouble.xmax")); // not representable as double
228 SET_VECTOR_ELT(ans, 18+3, ScalarReal(R_LD_AccuracyInfo.xmax));
229
230 SET_STRING_ELT(nms, 18+4, mkChar("longdouble.base")); // same as "all"
231 SET_VECTOR_ELT(ans, 18+4, ScalarInteger(R_LD_AccuracyInfo.ibeta));
232 */
233
234 SET_STRING_ELT(nms, 18+2, mkChar("longdouble.digits"));
235 SET_VECTOR_ELT(ans, 18+2, ScalarInteger(R_LD_AccuracyInfo.it));
236
237 SET_STRING_ELT(nms, 18+3, mkChar("longdouble.rounding"));
238 SET_VECTOR_ELT(ans, 18+3, ScalarInteger(R_LD_AccuracyInfo.irnd));
239
240 SET_STRING_ELT(nms, 18+4, mkChar("longdouble.guard"));
241 SET_VECTOR_ELT(ans, 18+4, ScalarInteger(R_LD_AccuracyInfo.ngrd));
242
243 SET_STRING_ELT(nms, 18+5, mkChar("longdouble.ulp.digits"));
244 SET_VECTOR_ELT(ans, 18+5, ScalarInteger(R_LD_AccuracyInfo.machep));
245
246 SET_STRING_ELT(nms, 18+6, mkChar("longdouble.neg.ulp.digits"));
247 SET_VECTOR_ELT(ans, 18+6, ScalarInteger(R_LD_AccuracyInfo.negep));
248
249 SET_STRING_ELT(nms, 18+7, mkChar("longdouble.exponent"));
250 SET_VECTOR_ELT(ans, 18+7, ScalarInteger(R_LD_AccuracyInfo.iexp));
251
252 SET_STRING_ELT(nms, 18+8, mkChar("longdouble.min.exp"));
253 SET_VECTOR_ELT(ans, 18+8, ScalarInteger(R_LD_AccuracyInfo.minexp));
254
255 SET_STRING_ELT(nms, 18+9, mkChar("longdouble.max.exp"));
256 SET_VECTOR_ELT(ans, 18+9, ScalarInteger(R_LD_AccuracyInfo.maxexp));
257
258 }
259 #endif
260
261 setAttrib(ans, R_NamesSymbol, nms);
262 defineVar(install(".Machine"), ans, rho);
263 UNPROTECT(2);
264 }
265
266
267 /* Platform
268 *
269 * Return various platform dependent strings. This is similar to
270 * "Machine", but for strings rather than numerical values. These
271 * two functions should probably be amalgamated.
272 */
273 static const char * const R_OSType = OSTYPE;
274 static const char * const R_FileSep = FILESEP;
275
Init_R_Platform(SEXP rho)276 static void Init_R_Platform(SEXP rho)
277 {
278 SEXP value, names;
279
280 PROTECT(value = allocVector(VECSXP, 8));
281 PROTECT(names = allocVector(STRSXP, 8));
282 SET_STRING_ELT(names, 0, mkChar("OS.type"));
283 SET_STRING_ELT(names, 1, mkChar("file.sep"));
284 SET_STRING_ELT(names, 2, mkChar("dynlib.ext"));
285 SET_STRING_ELT(names, 3, mkChar("GUI"));
286 SET_STRING_ELT(names, 4, mkChar("endian"));
287 SET_STRING_ELT(names, 5, mkChar("pkgType"));
288 SET_STRING_ELT(names, 6, mkChar("path.sep"));
289 SET_STRING_ELT(names, 7, mkChar("r_arch"));
290 SET_VECTOR_ELT(value, 0, mkString(R_OSType));
291 SET_VECTOR_ELT(value, 1, mkString(R_FileSep));
292 SET_VECTOR_ELT(value, 2, mkString(SHLIB_EXT));
293 SET_VECTOR_ELT(value, 3, mkString(R_GUIType));
294 #ifdef WORDS_BIGENDIAN
295 SET_VECTOR_ELT(value, 4, mkString("big"));
296 #else
297 SET_VECTOR_ELT(value, 4, mkString("little"));
298 #endif
299 /* pkgType should be "mac.binary" for CRAN build *only*, not for all
300 AQUA builds. Also we want to be able to use "mac.binary.mavericks",
301 "mac.binary.el-capitan" and similar. */
302 #ifdef PLATFORM_PKGTYPE
303 SET_VECTOR_ELT(value, 5, mkString(PLATFORM_PKGTYPE));
304 #else /* unix default */
305 SET_VECTOR_ELT(value, 5, mkString("source"));
306 #endif
307 #ifdef Win32
308 SET_VECTOR_ELT(value, 6, mkString(";"));
309 #else /* not Win32 */
310 SET_VECTOR_ELT(value, 6, mkString(":"));
311 #endif
312 #ifdef R_ARCH
313 SET_VECTOR_ELT(value, 7, mkString(R_ARCH));
314 #else
315 SET_VECTOR_ELT(value, 7, mkString(""));
316 #endif
317 setAttrib(value, R_NamesSymbol, names);
318 defineVar(install(".Platform"), value, rho);
319 UNPROTECT(2);
320 }
321
Init_R_Variables(SEXP rho)322 void attribute_hidden Init_R_Variables(SEXP rho)
323 {
324 Init_R_Machine(rho);
325 Init_R_Platform(rho);
326 }
327
328 #ifdef HAVE_LANGINFO_CODESET
329 /* case-insensitive string comparison (needed for locale check) */
R_strieql(const char * a,const char * b)330 int static R_strieql(const char *a, const char *b)
331 {
332 while (*a && *b && toupper(*a) == toupper(*b)) { a++; b++; }
333 return (*a == 0 && *b == 0);
334 }
335 #endif
336
337 #include <locale.h>
338 #ifdef HAVE_LANGINFO_CODESET
339 # include <langinfo.h>
340 #endif
341
342 static char native_enc[R_CODESET_MAX + 1];
R_nativeEncoding(void)343 const char attribute_hidden *R_nativeEncoding(void)
344 {
345 return native_enc;
346 }
347
348 /* retrieves information about the current locale and
349 sets the corresponding variables (known_to_be_utf8,
350 known_to_be_latin1, utf8locale, latin1locale and mbcslocale) */
351
352 static char codeset[R_CODESET_MAX + 1];
R_check_locale(void)353 void attribute_hidden R_check_locale(void)
354 {
355 known_to_be_utf8 = utf8locale = FALSE;
356 known_to_be_latin1 = latin1locale = FALSE;
357 mbcslocale = FALSE;
358 strcpy(native_enc, "ASCII");
359 strcpy(codeset, "");
360 #ifdef HAVE_LANGINFO_CODESET
361 /* not on Windows */
362 {
363 char *p = nl_langinfo(CODESET);
364 strcpy(codeset, p); // copy just in case something else calls nl_langinfo.
365 /* more relaxed due to Darwin: CODESET is case-insensitive and
366 latin1 is ISO8859-1 */
367 if (R_strieql(p, "UTF-8")) known_to_be_utf8 = utf8locale = TRUE;
368 if (streql(p, "ISO-8859-1")) known_to_be_latin1 = latin1locale = TRUE;
369 if (R_strieql(p, "ISO8859-1")) known_to_be_latin1 = latin1locale = TRUE;
370 # if __APPLE__
371 /* On Darwin 'regular' locales such as 'en_US' are UTF-8 (hence
372 MB_CUR_MAX == 6), but CODESET is ""
373 2021: that comment dated from 2008: MB_CUR_MAX is now 4 in
374 a UTF-8 locale, even on 10.13.
375 */
376 if (*p == 0 && (MB_CUR_MAX == 4 || MB_CUR_MAX == 6)) {
377 known_to_be_utf8 = utf8locale = TRUE;
378 strcpy(codeset, "UTF-8");
379 }
380 # endif
381 if (utf8locale)
382 strcpy(native_enc, "UTF-8");
383 else if (latin1locale)
384 strcpy(native_enc, "ISO-8859-1");
385 else {
386 strncpy(native_enc, p, R_CODESET_MAX);
387 native_enc[R_CODESET_MAX] = 0;
388 }
389 }
390 #endif
391 mbcslocale = MB_CUR_MAX > 1;
392 R_MB_CUR_MAX = MB_CUR_MAX;
393 #ifdef __sun
394 /* Solaris 10 (at least) has MB_CUR_MAX == 3 in some, but ==4
395 in other UTF-8 locales. The former does not allow working
396 with non-BMP characters using mbrtowc(). Work-around by
397 allowing to use more. */
398 if (utf8locale && R_MB_CUR_MAX < 4)
399 R_MB_CUR_MAX = 4;
400 #endif
401 #ifdef Win32
402 {
403 char *ctype = setlocale(LC_CTYPE, NULL), *p;
404 p = strrchr(ctype, '.');
405 if (p) {
406 if (isdigit(p[1]))
407 localeCP = atoi(p+1);
408 else if (!strcasecmp(p+1, "UTF-8") || !strcasecmp(p+1, "UTF8"))
409 localeCP = 65001;
410 else
411 localeCP = 0;
412 }
413 /* Not 100% correct, but CP1252 is a superset */
414 known_to_be_latin1 = latin1locale = (localeCP == 1252);
415 known_to_be_utf8 = utf8locale = (localeCP == 65001);
416 if (localeCP == 65001)
417 strcpy(native_enc, "UTF-8");
418 else if (localeCP) {
419 /* CP1252 when latin1locale is true */
420 snprintf(native_enc, R_CODESET_MAX, "CP%d", localeCP);
421 native_enc[R_CODESET_MAX] = 0;
422 }
423 systemCP = GetACP();
424 }
425 #endif
426 #if defined(SUPPORT_UTF8_WIN32) /* never at present */
427 utf8locale = mbcslocale = TRUE;
428 strcpy(native_enc, "UTF-8");
429 #endif
430 }
431
432 /* date
433 *
434 * Return the current date in a standard format. This uses standard
435 * POSIX calls which should be available on each platform. We should
436 * perhaps check this in the configure script.
437 */
438 /* BDR 2000/7/20.
439 * time and ctime are in fact ANSI C calls, so we don't check them.
440 */
R_Date(void)441 static char *R_Date(void)
442 {
443 time_t t;
444 static char s[26]; /* own space */
445
446 time(&t);
447 strcpy(s, ctime(&t));
448 s[24] = '\0'; /* overwriting the final \n */
449 return s;
450 }
451
do_date(SEXP call,SEXP op,SEXP args,SEXP rho)452 SEXP attribute_hidden do_date(SEXP call, SEXP op, SEXP args, SEXP rho)
453 {
454 checkArity(op, args);
455 return mkString(R_Date());
456 }
457
458 /* file.show
459 *
460 * Display file(s) so that a user can view it. The function calls
461 * "R_ShowFiles" which is a platform-dependent hook that arranges
462 * for the file(s) to be displayed.
463 */
464
465 // .Internal so manages R_alloc stack used by acopy_string
do_fileshow(SEXP call,SEXP op,SEXP args,SEXP rho)466 SEXP attribute_hidden do_fileshow(SEXP call, SEXP op, SEXP args, SEXP rho)
467 {
468 SEXP fn, tl, hd, pg;
469 const char **f, **h, *t, *pager = NULL /* -Wall */;
470 Rboolean dl;
471 int i, n;
472
473 checkArity(op, args);
474 fn = CAR(args); args = CDR(args);
475 hd = CAR(args); args = CDR(args);
476 tl = CAR(args); args = CDR(args);
477 dl = (Rboolean) asLogical(CAR(args)); args = CDR(args);
478 pg = CAR(args);
479 n = 0; /* -Wall */
480 if (!isString(fn) || (n = LENGTH(fn)) < 1)
481 error(_("invalid filename specification"));
482 if (!isString(hd) || LENGTH(hd) != n)
483 error(_("invalid '%s' argument"), "headers");
484 if (!isString(tl))
485 error(_("invalid '%s' argument"), "title");
486 if (!isString(pg))
487 error(_("invalid '%s' argument"), "pager");
488 f = (const char**) R_alloc(n, sizeof(char*));
489 h = (const char**) R_alloc(n, sizeof(char*));
490 for (i = 0; i < n; i++) {
491 SEXP el = STRING_ELT(fn, i);
492 if (!isNull(el) && el != NA_STRING)
493 f[i] = acopy_string(translateCharFP(el));
494 else
495 error(_("invalid filename specification"));
496 if (STRING_ELT(hd, i) != NA_STRING)
497 h[i] = acopy_string(translateCharFP(STRING_ELT(hd, i)));
498 else
499 error(_("invalid '%s' argument"), "headers");
500 }
501 if (isValidStringF(tl))
502 t = acopy_string(translateCharFP(STRING_ELT(tl, 0)));
503 else
504 t = "";
505 if (isValidStringF(pg)) {
506 SEXP pg0 = STRING_ELT(pg, 0);
507 if (pg0 != NA_STRING)
508 pager = acopy_string(CHAR(pg0));
509 else
510 error(_("invalid '%s' argument"), "pager");
511 } else
512 pager = "";
513 R_ShowFiles(n, f, h, t, dl, pager);
514 return R_NilValue;
515 }
516
517 /* file.append
518 *
519 * Given two vectors of file names as arguments and arranges for
520 * the second set of files to be appended to the first.
521 */
522
523 #if defined(BUFSIZ) && (BUFSIZ > 512)
524 /* OS's buffer size in stdio.h, probably.
525 Windows has 512, Solaris 1024, glibc 8192
526 */
527 # define APPENDBUFSIZE BUFSIZ
528 #else
529 # define APPENDBUFSIZE 512
530 #endif
531
R_AppendFile(SEXP file1,SEXP file2)532 static int R_AppendFile(SEXP file1, SEXP file2)
533 {
534 FILE *fp1, *fp2;
535 char buf[APPENDBUFSIZE];
536 size_t nchar;
537 int status = 0;
538 if ((fp1 = RC_fopen(file1, "ab", TRUE)) == NULL) return 0;
539 if ((fp2 = RC_fopen(file2, "rb", TRUE)) == NULL) {
540 fclose(fp1);
541 return 0;
542 }
543 while ((nchar = fread(buf, 1, APPENDBUFSIZE, fp2)) == APPENDBUFSIZE)
544 if (fwrite(buf, 1, APPENDBUFSIZE, fp1) != APPENDBUFSIZE) goto append_error;
545 if (fwrite(buf, 1, nchar, fp1) != nchar) goto append_error;
546 status = 1;
547 append_error:
548 if (status == 0) warning(_("write error during file append"));
549 fclose(fp1);
550 fclose(fp2);
551 return status;
552 }
553
do_fileappend(SEXP call,SEXP op,SEXP args,SEXP rho)554 SEXP attribute_hidden do_fileappend(SEXP call, SEXP op, SEXP args, SEXP rho)
555 {
556 SEXP f1, f2, ans;
557 int n, n1, n2;
558
559 checkArity(op, args);
560 f1 = CAR(args);
561 f2 = CADR(args);
562 if (!isString(f1))
563 error(_("invalid '%s' argument"), "file1");
564 if (!isString(f2))
565 error(_("invalid '%s' argument"), "file2");
566 n1 = LENGTH(f1); n2 = LENGTH(f2);
567 if (n1 < 1)
568 error(_("nothing to append to"));
569 if (n2 < 1)
570 return allocVector(LGLSXP, 0);
571 n = (n1 > n2) ? n1 : n2;
572 PROTECT(ans = allocVector(LGLSXP, n));
573 for (int i = 0; i < n; i++) LOGICAL(ans)[i] = 0; /* all FALSE */
574 if (n1 == 1) { /* common case */
575 FILE *fp1, *fp2;
576 char buf[APPENDBUFSIZE];
577 int status = 0;
578 size_t nchar;
579 if (STRING_ELT(f1, 0) == NA_STRING ||
580 !(fp1 = RC_fopen(STRING_ELT(f1, 0), "ab", TRUE)))
581 goto done;
582 for (int i = 0; i < n; i++) {
583 status = 0;
584 if (STRING_ELT(f2, i) == NA_STRING ||
585 !(fp2 = RC_fopen(STRING_ELT(f2, i), "rb", TRUE))) continue;
586 while ((nchar = fread(buf, 1, APPENDBUFSIZE, fp2)) == APPENDBUFSIZE)
587 if (fwrite(buf, 1, APPENDBUFSIZE, fp1) != APPENDBUFSIZE)
588 goto append_error;
589 if (fwrite(buf, 1, nchar, fp1) != nchar) goto append_error;
590 status = 1;
591 append_error:
592 if (status == 0)
593 warning(_("write error during file append"));
594 LOGICAL(ans)[i] = status;
595 fclose(fp2);
596 }
597 fclose(fp1);
598 } else {
599 for (int i = 0; i < n; i++) {
600 if (STRING_ELT(f1, i%n1) == R_NilValue ||
601 STRING_ELT(f2, i%n2) == R_NilValue)
602 LOGICAL(ans)[i] = 0;
603 else
604 LOGICAL(ans)[i] =
605 R_AppendFile(STRING_ELT(f1, i%n1), STRING_ELT(f2, i%n2));
606 }
607 }
608 done:
609 UNPROTECT(1);
610 return ans;
611 }
612
do_filecreate(SEXP call,SEXP op,SEXP args,SEXP rho)613 SEXP attribute_hidden do_filecreate(SEXP call, SEXP op, SEXP args, SEXP rho)
614 {
615 SEXP fn, ans;
616 FILE *fp;
617 int i, n, show;
618
619 checkArity(op, args);
620 fn = CAR(args);
621 if (!isString(fn))
622 error(_("invalid filename argument"));
623 show = asLogical(CADR(args));
624 if (show == NA_LOGICAL) show = 0;
625 n = LENGTH(fn);
626 PROTECT(ans = allocVector(LGLSXP, n));
627 for (i = 0; i < n; i++) {
628 LOGICAL(ans)[i] = 0;
629 if (STRING_ELT(fn, i) == NA_STRING) continue;
630 if ((fp = RC_fopen(STRING_ELT(fn, i), "w", TRUE)) != NULL) {
631 LOGICAL(ans)[i] = 1;
632 fclose(fp);
633 } else if (show) {
634 // translateChar will translate the file, using escapes
635 warning(_("cannot create file '%s', reason '%s'"),
636 translateChar(STRING_ELT(fn, i)), strerror(errno));
637 }
638 }
639 UNPROTECT(1);
640 return ans;
641 }
642
do_fileremove(SEXP call,SEXP op,SEXP args,SEXP rho)643 SEXP attribute_hidden do_fileremove(SEXP call, SEXP op, SEXP args, SEXP rho)
644 {
645 SEXP f, ans;
646 int i, n;
647 checkArity(op, args);
648 f = CAR(args);
649 if (!isString(f))
650 error(_("invalid first filename"));
651 n = LENGTH(f);
652 PROTECT(ans = allocVector(LGLSXP, n));
653 for (i = 0; i < n; i++) {
654 if (STRING_ELT(f, i) != NA_STRING) {
655 LOGICAL(ans)[i] =
656 #ifdef Win32
657 (_wremove(filenameToWchar(STRING_ELT(f, i), TRUE)) == 0);
658 #else
659 (remove(R_ExpandFileName(translateCharFP(STRING_ELT(f, i)))) == 0);
660 #endif
661 if(!LOGICAL(ans)[i])
662 warning(_("cannot remove file '%s', reason '%s'"),
663 translateChar(STRING_ELT(f, i)), strerror(errno));
664 } else LOGICAL(ans)[i] = FALSE;
665 }
666 UNPROTECT(1);
667 return ans;
668 }
669
670 /* the Win32 stuff here is not ready for release:
671
672 (i) It needs Windows >= Vista
673 (ii) It matters whether 'from' is a file or a dir, and we could only
674 know if it exists already.
675 (iii) This needs specific privileges which in general only Adminstrators
676 have, and which many people report granting in the Policy Editor
677 fails to work.
678 */
do_filesymlink(SEXP call,SEXP op,SEXP args,SEXP rho)679 SEXP attribute_hidden do_filesymlink(SEXP call, SEXP op, SEXP args, SEXP rho)
680 {
681 SEXP f1, f2;
682 int n, n1, n2;
683 #ifdef HAVE_SYMLINK
684 SEXP ans;
685 int i;
686 #endif
687 checkArity(op, args);
688 f1 = CAR(args);
689 f2 = CADR(args);
690 if (!isString(f1))
691 error(_("invalid first filename"));
692 if (!isString(f2))
693 error(_("invalid second filename"));
694 n1 = LENGTH(f1); n2 = LENGTH(f2);
695 if (n1 < 1)
696 error(_("nothing to link"));
697 if (n2 < 1)
698 return allocVector(LGLSXP, 0);
699 n = (n1 > n2) ? n1 : n2;
700
701 #ifdef Win32
702 // Vista, Server 2008 and later
703 pCSL = (PCSL) GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
704 "CreateSymbolicLinkW");
705 if(!pCSL)
706 error(_("symbolic links are not supported on this version of Windows"));
707 #endif
708
709 #ifdef HAVE_SYMLINK
710 PROTECT(ans = allocVector(LGLSXP, n));
711 for (i = 0; i < n; i++) {
712 if (STRING_ELT(f1, i%n1) == NA_STRING ||
713 STRING_ELT(f2, i%n2) == NA_STRING)
714 LOGICAL(ans)[i] = 0;
715 else {
716 #ifdef Win32
717 wchar_t from[PATH_MAX+1], *to, *p;
718 struct _stati64 sb;
719 from[PATH_MAX] = L'\0';
720 p = filenameToWchar(STRING_ELT(f1, i%n1), TRUE);
721 if (wcslen(p) >= PATH_MAX)
722 error(_("'%s' path too long"), "from");
723 wcsncpy(from, p, PATH_MAX);
724 /* This Windows system call does not accept slashes */
725 for (wchar_t *p = from; *p; p++) if (*p == L'/') *p = L'\\';
726 to = filenameToWchar(STRING_ELT(f2, i%n2), TRUE);
727 _wstati64(from, &sb);
728 int isDir = (sb.st_mode & S_IFDIR) > 0;
729 LOGICAL(ans)[i] = pCSL(to, from, isDir) != 0;
730 if(!LOGICAL(ans)[i])
731 warning(_("cannot symlink '%ls' to '%ls', reason '%s'"),
732 from, to, formatError(GetLastError()));
733 #else
734 char from[PATH_MAX], to[PATH_MAX];
735 const char *p;
736 p = R_ExpandFileName(translateCharFP(STRING_ELT(f1, i%n1)));
737 if (strlen(p) >= PATH_MAX - 1) {
738 LOGICAL(ans)[i] = 0;
739 continue;
740 }
741 strcpy(from, p);
742
743 p = R_ExpandFileName(translateCharFP(STRING_ELT(f2, i%n2)));
744 if (strlen(p) >= PATH_MAX - 1) {
745 LOGICAL(ans)[i] = 0;
746 continue;
747 }
748 strcpy(to, p);
749
750 /* Rprintf("linking %s to %s\n", from, to); */
751 LOGICAL(ans)[i] = symlink(from, to) == 0;
752 if(!LOGICAL(ans)[i])
753 warning(_("cannot symlink '%s' to '%s', reason '%s'"),
754 from, to, strerror(errno));
755 #endif
756 }
757 }
758 UNPROTECT(1);
759 return ans;
760 #else
761 warning(_("symbolic links are not supported on this platform"));
762 return allocVector(LGLSXP, n);
763 #endif
764 }
765
766
do_filelink(SEXP call,SEXP op,SEXP args,SEXP rho)767 SEXP attribute_hidden do_filelink(SEXP call, SEXP op, SEXP args, SEXP rho)
768 {
769 SEXP f1, f2;
770 int n, n1, n2;
771 #ifdef HAVE_LINK
772 SEXP ans;
773 int i;
774 #endif
775 checkArity(op, args);
776 f1 = CAR(args);
777 f2 = CADR(args);
778 if (!isString(f1))
779 error(_("invalid first filename"));
780 if (!isString(f2))
781 error(_("invalid second filename"));
782 n1 = LENGTH(f1); n2 = LENGTH(f2);
783 if (n1 < 1)
784 error(_("nothing to link"));
785 if (n2 < 1)
786 return allocVector(LGLSXP, 0);
787 n = (n1 > n2) ? n1 : n2;
788 #ifdef HAVE_LINK
789 PROTECT(ans = allocVector(LGLSXP, n));
790 for (i = 0; i < n; i++) {
791 if (STRING_ELT(f1, i%n1) == NA_STRING ||
792 STRING_ELT(f2, i%n2) == NA_STRING)
793 LOGICAL(ans)[i] = 0;
794 else {
795 #ifdef Win32
796 wchar_t from[PATH_MAX+1], *to, *p;
797 p = filenameToWchar(STRING_ELT(f1, i%n1), TRUE);
798 if (wcslen(p) >= PATH_MAX)
799 error(_("'%s' path too long"), "from");
800 wcscpy(from, p);
801 to = filenameToWchar(STRING_ELT(f2, i%n2), TRUE);
802 LOGICAL(ans)[i] = CreateHardLinkW(to, from, NULL) != 0;
803 if(!LOGICAL(ans)[i]) {
804 warning(_("cannot link '%ls' to '%ls', reason '%s'"),
805 from, to, formatError(GetLastError()));
806 }
807 #else
808 char from[PATH_MAX], to[PATH_MAX];
809 const char *p;
810 p = R_ExpandFileName(translateCharFP(STRING_ELT(f1, i%n1)));
811 if (strlen(p) >= PATH_MAX - 1) {
812 LOGICAL(ans)[i] = 0;
813 continue;
814 }
815 strcpy(from, p);
816
817 p = R_ExpandFileName(translateCharFP(STRING_ELT(f2, i%n2)));
818 if (strlen(p) >= PATH_MAX - 1) {
819 LOGICAL(ans)[i] = 0;
820 continue;
821 }
822 strcpy(to, p);
823
824 LOGICAL(ans)[i] = link(from, to) == 0;
825 if(!LOGICAL(ans)[i]) {
826 warning(_("cannot link '%s' to '%s', reason '%s'"),
827 from, to, strerror(errno));
828 }
829 #endif
830 }
831 }
832 UNPROTECT(1);
833 return ans;
834 #else
835 warning(_("(hard) links are not supported on this platform"));
836 return allocVector(LGLSXP, n);
837 #endif
838 }
839
840 #ifdef Win32
841 int Rwin_rename(char *from, char *to); /* in src/gnuwin32/extra.c */
842 int Rwin_wrename(const wchar_t *from, const wchar_t *to);
843 #endif
844
do_filerename(SEXP call,SEXP op,SEXP args,SEXP rho)845 SEXP attribute_hidden do_filerename(SEXP call, SEXP op, SEXP args, SEXP rho)
846 {
847 SEXP f1, f2, ans;
848 int i, n1, n2;
849 int res;
850 #ifdef Win32
851 wchar_t from[PATH_MAX], to[PATH_MAX];
852 const wchar_t *w;
853 #else
854 char from[PATH_MAX], to[PATH_MAX];
855 const char *p;
856 #endif
857
858 checkArity(op, args);
859 f1 = CAR(args);
860 f2 = CADR(args);
861 if (!isString(f1))
862 error(_("invalid '%s' argument"), "from");
863 if (!isString(f2))
864 error(_("invalid '%s' argument"), "to");
865 n1 = LENGTH(f1); n2 = LENGTH(f2);
866 if (n2 != n1)
867 error(_("'from' and 'to' are of different lengths"));
868 PROTECT(ans = allocVector(LGLSXP, n1));
869 for (i = 0; i < n1; i++) {
870 if (STRING_ELT(f1, i) == NA_STRING ||
871 STRING_ELT(f2, i) == NA_STRING) {
872 LOGICAL(ans)[i] = 0;
873 continue;
874 }
875 #ifdef Win32
876 w = filenameToWchar(STRING_ELT(f1, i), TRUE);
877 if (wcslen(w) >= PATH_MAX - 1)
878 error(_("expanded 'from' name too long"));
879 wcsncpy(from, w, PATH_MAX - 1);
880 w = filenameToWchar(STRING_ELT(f2, i), TRUE);
881 if (wcslen(w) >= PATH_MAX - 1)
882 error(_("expanded 'to' name too long"));
883 wcsncpy(to, w, PATH_MAX - 1);
884 res = Rwin_wrename(from, to);
885 if(res) {
886 warning(_("cannot rename file '%ls' to '%ls', reason '%s'"),
887 from, to, formatError(GetLastError()));
888 }
889 LOGICAL(ans)[i] = (res == 0);
890 #else
891 p = R_ExpandFileName(translateCharFP(STRING_ELT(f1, i)));
892 if (strlen(p) >= PATH_MAX - 1)
893 error(_("expanded 'from' name too long"));
894 strncpy(from, p, PATH_MAX - 1);
895 p = R_ExpandFileName(translateCharFP(STRING_ELT(f2, i)));
896 if (strlen(p) >= PATH_MAX - 1)
897 error(_("expanded 'to' name too long"));
898 strncpy(to, p, PATH_MAX - 1);
899 res = rename(from, to);
900 if(res) {
901 warning(_("cannot rename file '%s' to '%s', reason '%s'"),
902 from, to, strerror(errno));
903 }
904 LOGICAL(ans)[i] = (res == 0);
905 #endif
906 }
907 UNPROTECT(1);
908 return ans;
909 }
910
911 # if defined(Unix) && defined(HAVE_PWD_H) && defined(HAVE_GRP_H) \
912 && defined(HAVE_GETPWUID) && defined(HAVE_GETGRGID)
913 # include <pwd.h>
914 # include <grp.h>
915 # define UNIX_EXTRAS 1
916 # endif
917
918 #ifdef Win32
919 # ifndef SCS_64BIT_BINARY
920 # define SCS_64BIT_BINARY 6
921 # endif
922 #endif
923
924 #if defined HAVE_STRUCT_STAT_ST_ATIM_TV_NSEC
925 # ifdef TYPEOF_STRUCT_STAT_ST_ATIM_IS_STRUCT_TIMESPEC
926 # define STAT_TIMESPEC(st, st_xtim) ((st).st_xtim)
927 # else
928 # define STAT_TIMESPEC_NS(st, st_xtim) ((st).st_xtim.tv_nsec)
929 # endif
930 #elif defined HAVE_STRUCT_STAT_ST_ATIMESPEC_TV_NSEC
931 # define STAT_TIMESPEC(st, st_xtim) ((st).st_xtim##espec)
932 #elif defined HAVE_STRUCT_STAT_ST_ATIMENSEC
933 # define STAT_TIMESPEC_NS(st, st_xtim) ((st).st_xtim##ensec)
934 #elif defined HAVE_STRUCT_STAT_ST_ATIM_ST__TIM_TV_NSEC
935 # define STAT_TIMESPEC_NS(st, st_xtim) ((st).st_xtim.st__tim.tv_nsec)
936 #endif
937
do_fileinfo(SEXP call,SEXP op,SEXP args,SEXP rho)938 SEXP attribute_hidden do_fileinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
939 {
940 SEXP fn, ans, ansnames, fsize, mtime, ctime, atime, isdir,
941 mode, xxclass;
942 #ifdef UNIX_EXTRAS
943 SEXP uid = R_NilValue, gid = R_NilValue,
944 uname = R_NilValue, grname = R_NilValue; // silence -Wall
945 #endif
946 #ifdef Win32
947 SEXP exe = R_NilValue;
948 struct _stati64 sb;
949 #else
950 struct stat sb;
951 #endif
952
953 checkArity(op, args);
954 fn = CAR(args);
955 if (!isString(fn))
956 error(_("invalid filename argument"));
957 int extras = asInteger(CADR(args));
958 if(extras == NA_INTEGER)
959 error(_("invalid '%s' argument"), "extra_cols");
960 int n = LENGTH(fn), ncols = 6;
961 if(extras) {
962 #ifdef UNIX_EXTRAS
963 ncols = 10;
964 #elif defined(Win32)
965 ncols = 7;
966 #endif
967 }
968 PROTECT(ans = allocVector(VECSXP, ncols));
969 PROTECT(ansnames = allocVector(STRSXP, ncols));
970 fsize = SET_VECTOR_ELT(ans, 0, allocVector(REALSXP, n));
971 SET_STRING_ELT(ansnames, 0, mkChar("size"));
972 isdir = SET_VECTOR_ELT(ans, 1, allocVector(LGLSXP, n));
973 SET_STRING_ELT(ansnames, 1, mkChar("isdir"));
974 mode = SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, n));
975 SET_STRING_ELT(ansnames, 2, mkChar("mode"));
976 mtime = SET_VECTOR_ELT(ans, 3, allocVector(REALSXP, n));
977 SET_STRING_ELT(ansnames, 3, mkChar("mtime"));
978 ctime = SET_VECTOR_ELT(ans, 4, allocVector(REALSXP, n));
979 SET_STRING_ELT(ansnames, 4, mkChar("ctime"));
980 atime = SET_VECTOR_ELT(ans, 5, allocVector(REALSXP, n));
981 SET_STRING_ELT(ansnames, 5, mkChar("atime"));
982 if (extras) {
983 #ifdef UNIX_EXTRAS
984 uid = SET_VECTOR_ELT(ans, 6, allocVector(INTSXP, n));
985 SET_STRING_ELT(ansnames, 6, mkChar("uid"));
986 gid = SET_VECTOR_ELT(ans, 7, allocVector(INTSXP, n));
987 SET_STRING_ELT(ansnames, 7, mkChar("gid"));
988 uname = SET_VECTOR_ELT(ans, 8, allocVector(STRSXP, n));
989 SET_STRING_ELT(ansnames, 8, mkChar("uname"));
990 grname = SET_VECTOR_ELT(ans, 9, allocVector(STRSXP, n));
991 SET_STRING_ELT(ansnames, 9, mkChar("grname"));
992 #endif
993 #ifdef Win32
994 exe = SET_VECTOR_ELT(ans, 6, allocVector(STRSXP, n));
995 SET_STRING_ELT(ansnames, 6, mkChar("exe"));
996 #endif
997 }
998 for (int i = 0; i < n; i++) {
999 #ifdef Win32
1000 wchar_t *wfn = filenameToWchar(STRING_ELT(fn, i), TRUE);
1001 /* trailing \ is not valid on Windows except for the
1002 root directory on a drive, specified as "\", or "D:\",
1003 or "\\?\D:\", etc. We remove it in other cases,
1004 to help those who think they're on Unix. */
1005 size_t len = wcslen(wfn);
1006 if (len) {
1007 wchar_t *p = wfn + (len - 1);
1008 if (len > 1 && (*p == L'/' || *p == L'\\') &&
1009 *(p-1) != L':') *p = 0;
1010 }
1011 #else
1012 const char *p = translateCharFP2(STRING_ELT(fn, i));
1013 const char *efn = p ? R_ExpandFileName(p) : p;
1014 #endif
1015 if (STRING_ELT(fn, i) != NA_STRING &&
1016 #ifdef Win32
1017 _wstati64(wfn, &sb)
1018 #else
1019 /* Target not link */
1020 p && stat(efn, &sb)
1021 #endif
1022 == 0) {
1023 REAL(fsize)[i] = (double) sb.st_size;
1024 LOGICAL(isdir)[i] = (sb.st_mode & S_IFDIR) > 0;
1025 INTEGER(mode)[i] = (int) sb.st_mode & 0007777;
1026
1027 #if defined STAT_TIMESPEC
1028 /* POSIX 2008 changed this to a struct timespec st_mtim etc
1029 Not all OSes (e.g. Darwin) agree on this. */
1030 REAL(mtime)[i] = (double) STAT_TIMESPEC(sb, st_mtim).tv_sec
1031 + 1e-9 * (double) STAT_TIMESPEC(sb, st_mtim).tv_nsec;
1032 REAL(ctime)[i] = (double) STAT_TIMESPEC(sb, st_ctim).tv_sec
1033 + 1e-9 * (double) STAT_TIMESPEC(sb, st_ctim).tv_nsec;
1034 REAL(atime)[i] = (double) STAT_TIMESPEC(sb, st_atim).tv_sec
1035 + 1e-9 * (double) STAT_TIMESPEC(sb, st_atim).tv_nsec;
1036 #else
1037 #ifdef Win32
1038 #define WINDOWS_TICK 10000000
1039 #define SEC_TO_UNIX_EPOCH 11644473600LL
1040 {
1041 FILETIME c_ft, a_ft, m_ft;
1042 HANDLE h;
1043 int success = 0;
1044 h = CreateFileW(wfn, 0,
1045 FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
1046 NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL);
1047 if (h != INVALID_HANDLE_VALUE) {
1048 int res = GetFileTime(h, &c_ft, &a_ft, &m_ft);
1049 CloseHandle(h);
1050 if (res) {
1051 ULARGE_INTEGER time;
1052 time.LowPart = m_ft.dwLowDateTime;
1053 time.HighPart = m_ft.dwHighDateTime;
1054 REAL(mtime)[i] = (((double) time.QuadPart) / WINDOWS_TICK - SEC_TO_UNIX_EPOCH);
1055 time.LowPart = c_ft.dwLowDateTime;
1056 time.HighPart = c_ft.dwHighDateTime;
1057 REAL(ctime)[i] = (((double) time.QuadPart) / WINDOWS_TICK - SEC_TO_UNIX_EPOCH);
1058 time.LowPart = a_ft.dwLowDateTime;
1059 time.HighPart = a_ft.dwHighDateTime;
1060 REAL(atime)[i] = (((double) time.QuadPart) / WINDOWS_TICK - SEC_TO_UNIX_EPOCH);
1061 success = 1;
1062 }
1063 } else
1064 warning(_("cannot open file '%ls': %s"),
1065 wfn, formatError(GetLastError()));
1066 if (!success) {
1067 REAL(mtime)[i] = NA_REAL;
1068 REAL(ctime)[i] = NA_REAL;
1069 REAL(atime)[i] = NA_REAL;
1070 }
1071 }
1072 #else
1073 REAL(mtime)[i] = (double) sb.st_mtime;
1074 REAL(ctime)[i] = (double) sb.st_ctime;
1075 REAL(atime)[i] = (double) sb.st_atime;
1076 # ifdef STAT_TIMESPEC_NS
1077 REAL(mtime)[i] += STAT_TIMESPEC_NS (sb, st_mtim);
1078 REAL(ctime)[i] += STAT_TIMESPEC_NS (sb, st_ctim);
1079 REAL(atime)[i] += STAT_TIMESPEC_NS (sb, st_atim);
1080 # endif
1081 #endif
1082 #endif
1083 if (extras) {
1084 #ifdef UNIX_EXTRAS
1085 INTEGER(uid)[i] = (int) sb.st_uid;
1086 INTEGER(gid)[i] = (int) sb.st_gid;
1087
1088 /* Usually all of the uid and gid values in a list of
1089 * files are the same so we can avoid most of the calls
1090 * to getpwuid() and getgrgid(), which can be quite slow
1091 * on some systems. (PR#15804)
1092 */
1093 if (i && INTEGER(uid)[i - 1] == (int) sb.st_uid)
1094 SET_STRING_ELT(uname, i, STRING_ELT(uname, i - 1));
1095 else {
1096 struct passwd *stpwd = getpwuid(sb.st_uid);
1097 SET_STRING_ELT(uname, i,
1098 stpwd ? mkChar(stpwd->pw_name): NA_STRING);
1099 }
1100
1101 if (i && INTEGER(gid)[i - 1] == (int) sb.st_gid)
1102 SET_STRING_ELT(grname, i, STRING_ELT(grname, i - 1));
1103 else {
1104 struct group *stgrp = getgrgid(sb.st_gid);
1105 SET_STRING_ELT(grname, i,
1106 stgrp ? mkChar(stgrp->gr_name): NA_STRING);
1107 }
1108 #endif
1109 #ifdef Win32
1110 {
1111 char *s="no";
1112 DWORD type;
1113 if (GetBinaryTypeW(wfn, &type))
1114 switch(type) {
1115 case SCS_64BIT_BINARY:
1116 s = "win64";
1117 break;
1118 case SCS_32BIT_BINARY:
1119 s = "win32";
1120 break;
1121 case SCS_DOS_BINARY:
1122 case SCS_PIF_BINARY:
1123 s = "msdos";
1124 break;
1125 case SCS_WOW_BINARY:
1126 s = "win16";
1127 break;
1128 default:
1129 s = "unknown";
1130 }
1131 SET_STRING_ELT(exe, i, mkChar(s));
1132 }
1133 #endif
1134 }
1135 } else {
1136 REAL(fsize)[i] = NA_REAL;
1137 LOGICAL(isdir)[i] = NA_INTEGER;
1138 INTEGER(mode)[i] = NA_INTEGER;
1139 REAL(mtime)[i] = NA_REAL;
1140 REAL(ctime)[i] = NA_REAL;
1141 REAL(atime)[i] = NA_REAL;
1142 if (extras) {
1143 #ifdef UNIX_EXTRAS
1144 INTEGER(uid)[i] = NA_INTEGER;
1145 INTEGER(gid)[i] = NA_INTEGER;
1146 SET_STRING_ELT(uname, i, NA_STRING);
1147 SET_STRING_ELT(grname, i, NA_STRING);
1148 #endif
1149 #ifdef Win32
1150 SET_STRING_ELT(exe, i, NA_STRING);
1151 #endif
1152 }
1153 }
1154 }
1155 setAttrib(ans, R_NamesSymbol, ansnames);
1156 PROTECT(xxclass = mkString("octmode"));
1157 classgets(mode, xxclass);
1158 UNPROTECT(3);
1159 return ans;
1160 }
1161
do_direxists(SEXP call,SEXP op,SEXP args,SEXP rho)1162 SEXP attribute_hidden do_direxists(SEXP call, SEXP op, SEXP args, SEXP rho)
1163 {
1164 SEXP fn, ans;
1165
1166 #ifdef Win32
1167 struct _stati64 sb;
1168 #else
1169 struct stat sb;
1170 #endif
1171
1172 checkArity(op, args);
1173 fn = CAR(args);
1174 if (!isString(fn))
1175 error(_("invalid filename argument"));
1176 int n = LENGTH(fn);
1177 PROTECT(ans = allocVector(LGLSXP, n));
1178 for (int i = 0; i < n; i++) {
1179 #ifdef Win32
1180 wchar_t *wfn = filenameToWchar(STRING_ELT(fn, i), TRUE);
1181 /* trailing \ is not valid on Windows except for the
1182 root directory on a drive, specified as "\", or "D:\",
1183 or "\\?\D:\", etc. We remove it in other cases,
1184 to help those who think they're on Unix. */
1185 size_t len = wcslen(wfn);
1186 if (len) {
1187 wchar_t *p = wfn + (len - 1);
1188 if (len > 1 && (*p == L'/' || *p == L'\\') &&
1189 *(p-1) != L':') *p = 0;
1190 }
1191 if (STRING_ELT(fn, i) != NA_STRING && _wstati64(wfn, &sb) == 0) {
1192 LOGICAL(ans)[i] = (sb.st_mode & S_IFDIR) > 0;
1193
1194 } else LOGICAL(ans)[i] = 0;
1195 #else
1196 const char *p = translateCharFP2(STRING_ELT(fn, i));
1197 if (p && STRING_ELT(fn, i) != NA_STRING &&
1198 /* Target not link */
1199 stat(R_ExpandFileName(p), &sb) == 0) {
1200 LOGICAL(ans)[i] = (sb.st_mode & S_IFDIR) > 0;
1201 } else LOGICAL(ans)[i] = 0;
1202 #endif
1203 }
1204 // copy names?
1205 UNPROTECT(1);
1206 return ans;
1207 }
1208
1209 /* No longer required by POSIX, but maybe on earlier OSes */
1210 #ifdef HAVE_SYS_TYPES_H
1211 # include <sys/types.h>
1212 #endif
1213
1214 #if HAVE_DIRENT_H
1215 # include <dirent.h>
1216 #elif HAVE_SYS_NDIR_H
1217 # include <sys/ndir.h>
1218 #elif HAVE_SYS_DIR_H
1219 # include <sys/dir.h>
1220 #elif HAVE_NDIR_H
1221 # include <ndir.h>
1222 #endif
1223
1224 #define CBUFSIZE 2*PATH_MAX+1
filename(const char * dir,const char * file)1225 static SEXP filename(const char *dir, const char *file)
1226 {
1227 SEXP ans;
1228 char cbuf[CBUFSIZE];
1229 if (dir) {
1230 #ifdef Win32
1231 if ((strlen(dir) == 2 && dir[1] == ':') ||
1232 dir[strlen(dir) - 1] == '/' || dir[strlen(dir) - 1] == '\\')
1233 snprintf(cbuf, CBUFSIZE, "%s%s", dir, file);
1234 else
1235 snprintf(cbuf, CBUFSIZE, "%s%s%s", dir, R_FileSep, file);
1236 #else
1237 snprintf(cbuf, CBUFSIZE, "%s%s%s", dir, R_FileSep, file);
1238 #endif
1239 ans = mkChar(cbuf);
1240 } else {
1241 snprintf(cbuf, CBUFSIZE, "%s", file);
1242 ans = mkChar(cbuf);
1243 }
1244 return ans;
1245 }
1246
1247 #include <tre/tre.h>
1248
1249 static void
list_files(const char * dnp,const char * stem,int * count,SEXP * pans,Rboolean allfiles,Rboolean recursive,const regex_t * reg,int * countmax,PROTECT_INDEX idx,Rboolean idirs,Rboolean allowdots)1250 list_files(const char *dnp, const char *stem, int *count, SEXP *pans,
1251 Rboolean allfiles, Rboolean recursive,
1252 const regex_t *reg, int *countmax, PROTECT_INDEX idx,
1253 Rboolean idirs, Rboolean allowdots)
1254 {
1255 DIR *dir;
1256 struct dirent *de;
1257 char p[PATH_MAX], stem2[PATH_MAX];
1258 #ifdef Windows
1259 /* > 2GB files might be skipped otherwise */
1260 struct _stati64 sb;
1261 #else
1262 struct stat sb;
1263 #endif
1264 R_CheckUserInterrupt(); // includes stack check
1265 if ((dir = opendir(dnp)) != NULL) {
1266 while ((de = readdir(dir))) {
1267 if (allfiles || !R_HiddenFile(de->d_name)) {
1268 Rboolean not_dot = strcmp(de->d_name, ".") && strcmp(de->d_name, "..");
1269 if (recursive) {
1270 #ifdef Win32
1271 if (strlen(dnp) == 2 && dnp[1] == ':') // e.g. "C:"
1272 snprintf(p, PATH_MAX, "%s%s", dnp, de->d_name);
1273 else
1274 #endif
1275 snprintf(p, PATH_MAX, "%s%s%s", dnp, R_FileSep, de->d_name);
1276
1277 #ifdef Windows
1278 _stati64(p, &sb);
1279 #else
1280 stat(p, &sb);
1281 #endif
1282 if ((sb.st_mode & S_IFDIR) > 0) {
1283 if (not_dot) {
1284 if (idirs) {
1285 #define IF_MATCH_ADD_TO_ANS \
1286 if (!reg || tre_regexec(reg, de->d_name, 0, NULL, 0) == 0) { \
1287 if (*count == *countmax - 1) { \
1288 *countmax *= 2; \
1289 REPROTECT(*pans = lengthgets(*pans, *countmax), idx); \
1290 } \
1291 SET_STRING_ELT(*pans, (*count)++, \
1292 filename(stem, de->d_name)); \
1293 }
1294 IF_MATCH_ADD_TO_ANS
1295 }
1296 if (stem) {
1297 #ifdef Win32
1298 if(strlen(stem) == 2 && stem[1] == ':')
1299 snprintf(stem2, PATH_MAX, "%s%s", stem,
1300 de->d_name);
1301 else
1302 #endif
1303 snprintf(stem2, PATH_MAX, "%s%s%s", stem,
1304 R_FileSep, de->d_name);
1305 } else
1306 strcpy(stem2, de->d_name);
1307
1308 list_files(p, stem2, count, pans, allfiles,
1309 recursive, reg, countmax, idx, idirs,
1310 allowdots);
1311 }
1312 continue;
1313 }
1314 } // end if(recursive)
1315
1316 if (not_dot || allowdots)
1317 IF_MATCH_ADD_TO_ANS
1318 }
1319
1320 } // end while()
1321 closedir(dir);
1322 }
1323 }
1324 #undef IF_MATCH_ADD_TO_ANS
1325
do_listfiles(SEXP call,SEXP op,SEXP args,SEXP rho)1326 SEXP attribute_hidden do_listfiles(SEXP call, SEXP op, SEXP args, SEXP rho)
1327 {
1328 int countmax = 128;
1329
1330 checkArity(op, args);
1331 SEXP d = CAR(args); args = CDR(args); // d := directory = path
1332 if (!isString(d)) error(_("invalid '%s' argument"), "path");
1333 SEXP p = CAR(args); args = CDR(args);
1334 Rboolean pattern = FALSE;
1335 if (isString(p) && LENGTH(p) >= 1 && STRING_ELT(p, 0) != NA_STRING)
1336 pattern = TRUE;
1337 else if (!isNull(p) && !(isString(p) && LENGTH(p) < 1))
1338 error(_("invalid '%s' argument"), "pattern");
1339 int allfiles = asLogical(CAR(args)); args = CDR(args);
1340 if (allfiles == NA_LOGICAL)
1341 error(_("invalid '%s' argument"), "all.files");
1342 int fullnames = asLogical(CAR(args)); args = CDR(args);
1343 if (fullnames == NA_LOGICAL)
1344 error(_("invalid '%s' argument"), "full.names");
1345 int recursive = asLogical(CAR(args)); args = CDR(args);
1346 if (recursive == NA_LOGICAL)
1347 error(_("invalid '%s' argument"), "recursive");
1348 int igcase = asLogical(CAR(args)); args = CDR(args);
1349 if (igcase == NA_LOGICAL)
1350 error(_("invalid '%s' argument"), "ignore.case");
1351 int idirs = asLogical(CAR(args)); args = CDR(args);
1352 if (idirs == NA_LOGICAL)
1353 error(_("invalid '%s' argument"), "include.dirs");
1354 int nodots = asLogical(CAR(args));
1355 if (nodots == NA_LOGICAL)
1356 error(_("invalid '%s' argument"), "no..");
1357
1358 int flags = REG_EXTENDED;
1359 if (igcase) flags |= REG_ICASE;
1360 regex_t reg;
1361 if (pattern && tre_regcomp(®, translateChar(STRING_ELT(p, 0)), flags))
1362 error(_("invalid 'pattern' regular expression"));
1363 PROTECT_INDEX idx;
1364 SEXP ans;
1365 PROTECT_WITH_INDEX(ans = allocVector(STRSXP, countmax), &idx);
1366 int count = 0;
1367 for (int i = 0; i < LENGTH(d) ; i++) {
1368 if (STRING_ELT(d, i) == NA_STRING) continue;
1369 const char *p = translateCharFP2(STRING_ELT(d, i));
1370 if (!p) continue;
1371 const char *dnp = R_ExpandFileName(p);
1372 list_files(dnp, fullnames ? dnp : NULL, &count, &ans, allfiles,
1373 recursive, pattern ? ® : NULL, &countmax, idx,
1374 idirs, /* allowdots = */ !nodots);
1375 }
1376 REPROTECT(ans = lengthgets(ans, count), idx);
1377 if (pattern) tre_regfree(®);
1378 ssort(STRING_PTR(ans), count);
1379 UNPROTECT(1);
1380 return ans;
1381 }
1382
list_dirs(const char * dnp,const char * nm,Rboolean full,int * count,SEXP * pans,int * countmax,PROTECT_INDEX idx,Rboolean recursive)1383 static void list_dirs(const char *dnp, const char *nm,
1384 Rboolean full, int *count,
1385 SEXP *pans, int *countmax, PROTECT_INDEX idx,
1386 Rboolean recursive)
1387 {
1388 DIR *dir;
1389 struct dirent *de;
1390 char p[PATH_MAX];
1391 #ifdef Windows
1392 /* > 2GB files might be skipped otherwise */
1393 struct _stati64 sb;
1394 #else
1395 struct stat sb;
1396 #endif
1397 R_CheckUserInterrupt(); // includes stack check
1398
1399 if ((dir = opendir(dnp)) != NULL) {
1400 if (recursive) {
1401 if (*count == *countmax - 1) {
1402 *countmax *= 2;
1403 REPROTECT(*pans = lengthgets(*pans, *countmax), idx);
1404 }
1405 SET_STRING_ELT(*pans, (*count)++, mkChar(full ? dnp : nm));
1406 }
1407 while ((de = readdir(dir))) {
1408 #ifdef Win32
1409 if (strlen(dnp) == 2 && dnp[1] == ':')
1410 snprintf(p, PATH_MAX, "%s%s", dnp, de->d_name);
1411 else
1412 snprintf(p, PATH_MAX, "%s%s%s", dnp, R_FileSep, de->d_name);
1413 #else
1414 snprintf(p, PATH_MAX, "%s%s%s", dnp, R_FileSep, de->d_name);
1415 #endif
1416 #ifdef Windows
1417 _stati64(p, &sb);
1418 #else
1419 stat(p, &sb);
1420 #endif
1421 if ((sb.st_mode & S_IFDIR) > 0) {
1422 if (strcmp(de->d_name, ".") && strcmp(de->d_name, "..")) {
1423 if(recursive) {
1424 char nm2[PATH_MAX];
1425 snprintf(nm2, PATH_MAX, "%s%s%s", nm, R_FileSep,
1426 de->d_name);
1427 list_dirs(p, nm[0] ? nm2 : de->d_name, full, count,
1428 pans, countmax, idx, recursive);
1429
1430 } else {
1431 if (*count == *countmax - 1) {
1432 *countmax *= 2;
1433 REPROTECT(*pans = lengthgets(*pans, *countmax), idx);
1434 }
1435 SET_STRING_ELT(*pans, (*count)++,
1436 mkChar(full ? p : de->d_name));
1437 }
1438 }
1439 }
1440 }
1441 closedir(dir);
1442 }
1443 }
1444
do_listdirs(SEXP call,SEXP op,SEXP args,SEXP rho)1445 SEXP attribute_hidden do_listdirs(SEXP call, SEXP op, SEXP args, SEXP rho)
1446 {
1447 int countmax = 128;
1448
1449 checkArity(op, args);
1450 SEXP d = CAR(args); args = CDR(args);
1451 if (!isString(d)) error(_("invalid '%s' argument"), "directory");
1452 int fullnames = asLogical(CAR(args)); args = CDR(args);
1453 if (fullnames == NA_LOGICAL)
1454 error(_("invalid '%s' argument"), "full.names");
1455 int recursive = asLogical(CAR(args)); args = CDR(args);
1456 if (recursive == NA_LOGICAL)
1457 error(_("invalid '%s' argument"), "recursive");
1458
1459 PROTECT_INDEX idx;
1460 SEXP ans;
1461 PROTECT_WITH_INDEX(ans = allocVector(STRSXP, countmax), &idx);
1462 int count = 0;
1463 for (int i = 0; i < LENGTH(d) ; i++) {
1464 if (STRING_ELT(d, i) == NA_STRING) continue;
1465 const char *p = translateCharFP2(STRING_ELT(d, i));
1466 if (!p) continue;
1467 const char *dnp = R_ExpandFileName(p);
1468 list_dirs(dnp, "", fullnames, &count, &ans, &countmax, idx, recursive);
1469 }
1470 REPROTECT(ans = lengthgets(ans, count), idx);
1471 ssort(STRING_PTR(ans), count);
1472 UNPROTECT(1);
1473 return ans;
1474 }
1475
do_Rhome(SEXP call,SEXP op,SEXP args,SEXP rho)1476 SEXP attribute_hidden do_Rhome(SEXP call, SEXP op, SEXP args, SEXP rho)
1477 {
1478 char *path;
1479 checkArity(op, args);
1480 if (!(path = R_HomeDir()))
1481 error(_("unable to determine R home location"));
1482 return mkString(path);
1483 }
1484
1485 #ifdef Win32
R_WFileExists(const wchar_t * path)1486 static Rboolean attribute_hidden R_WFileExists(const wchar_t *path)
1487 {
1488 struct _stati64 sb;
1489 return _wstati64(path, &sb) == 0;
1490 }
1491 #endif
1492
do_fileexists(SEXP call,SEXP op,SEXP args,SEXP rho)1493 SEXP attribute_hidden do_fileexists(SEXP call, SEXP op, SEXP args, SEXP rho)
1494 {
1495 SEXP file, ans;
1496 int i, nfile;
1497 checkArity(op, args);
1498 if (!isString(file = CAR(args)))
1499 error(_("invalid '%s' argument"), "file");
1500 nfile = LENGTH(file);
1501 ans = PROTECT(allocVector(LGLSXP, nfile));
1502 for (i = 0; i < nfile; i++) {
1503 LOGICAL(ans)[i] = 0;
1504 if (STRING_ELT(file, i) != NA_STRING) {
1505 #ifdef Win32
1506 /* Package XML sends arbitrarily long strings to file.exists! */
1507 size_t len = strlen(CHAR(STRING_ELT(file, i)));
1508 if (len > MAX_PATH)
1509 LOGICAL(ans)[i] = FALSE;
1510 else
1511 LOGICAL(ans)[i] =
1512 R_WFileExists(filenameToWchar(STRING_ELT(file, i), TRUE));
1513 #else
1514 // returns NULL if not translatable
1515 const char *p = translateCharFP2(STRING_ELT(file, i));
1516 LOGICAL(ans)[i] = p && R_FileExists(p);
1517 #endif
1518 } else LOGICAL(ans)[i] = FALSE;
1519 }
1520 UNPROTECT(1); /* ans */
1521 return ans;
1522 }
1523
1524 #define CHOOSEBUFSIZE 1024
1525
1526 #ifndef Win32
do_filechoose(SEXP call,SEXP op,SEXP args,SEXP rho)1527 SEXP attribute_hidden do_filechoose(SEXP call, SEXP op, SEXP args, SEXP rho)
1528 {
1529 int _new, len;
1530 char buf[CHOOSEBUFSIZE];
1531 checkArity(op, args);
1532 _new = asLogical(CAR(args));
1533 if ((len = R_ChooseFile(_new, buf, CHOOSEBUFSIZE)) == 0)
1534 error(_("file choice cancelled"));
1535 if (len >= CHOOSEBUFSIZE - 1)
1536 error(_("file name too long"));
1537 return mkString(R_ExpandFileName(buf));
1538 }
1539 #endif
1540
1541 /* needed for access, and perhaps for realpath */
1542 #ifdef HAVE_UNISTD_H
1543 # include <unistd.h>
1544 #endif
1545
1546 #ifdef Win32
1547 extern int winAccessW(const wchar_t *path, int mode);
1548 #endif
1549
1550 /* we require 'access' as from 2.12.0 */
do_fileaccess(SEXP call,SEXP op,SEXP args,SEXP rho)1551 SEXP attribute_hidden do_fileaccess(SEXP call, SEXP op, SEXP args, SEXP rho)
1552 {
1553 SEXP fn, ans;
1554 int i, n, mode, modemask;
1555
1556 checkArity(op, args);
1557 fn = CAR(args);
1558 if (!isString(fn))
1559 error(_("invalid '%s' argument"), "names");
1560 n = LENGTH(fn);
1561 mode = asInteger(CADR(args));
1562 if (mode < 0 || mode > 7) error(_("invalid '%s' argument"), "mode");
1563 modemask = 0;
1564 if (mode & 1) modemask |= X_OK;
1565 if (mode & 2) modemask |= W_OK;
1566 if (mode & 4) modemask |= R_OK;
1567 PROTECT(ans = allocVector(INTSXP, n));
1568 for (i = 0; i < n; i++)
1569 if (STRING_ELT(fn, i) != NA_STRING) {
1570 #ifdef Win32
1571 INTEGER(ans)[i] =
1572 winAccessW(filenameToWchar(STRING_ELT(fn, i), TRUE), modemask);
1573 #else
1574 const char *p = translateCharFP2(STRING_ELT(fn, i));
1575 INTEGER(ans)[i] = p ? access(R_ExpandFileName(p), modemask): -1;
1576 #endif
1577 } else INTEGER(ans)[i] = -1; /* treat NA as non-existent file */
1578 UNPROTECT(1);
1579 return ans;
1580 }
1581
1582 #ifdef Win32
1583
R_rmdir(const wchar_t * dir)1584 static int R_rmdir(const wchar_t *dir)
1585 {
1586 wchar_t tmp[MAX_PATH];
1587 GetShortPathNameW(dir, tmp, MAX_PATH);
1588 //printf("removing directory %ls\n", tmp);
1589 return _wrmdir(tmp);
1590 }
1591
1592 /* Junctions and symbolic links are fundamentally reparse points, so
1593 apparently this is the way to detect them. */
isReparsePoint(const wchar_t * name)1594 static int isReparsePoint(const wchar_t *name)
1595 {
1596 DWORD res = GetFileAttributesW(name);
1597 if(res == INVALID_FILE_ATTRIBUTES) {
1598 warning("cannot get info on '%ls', reason '%s'",
1599 name, formatError(GetLastError()));
1600 return 0;
1601 }
1602 // printf("%ls: %x\n", name, res);
1603 return res & FILE_ATTRIBUTE_REPARSE_POINT;
1604 }
1605
delReparsePoint(const wchar_t * name)1606 static int delReparsePoint(const wchar_t *name)
1607 {
1608 HANDLE hd =
1609 CreateFileW(name, GENERIC_READ | GENERIC_WRITE, 0, 0, OPEN_EXISTING,
1610 FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT,
1611 0);
1612 if(hd == INVALID_HANDLE_VALUE) {
1613 warning("cannot open reparse point '%ls', reason '%s'",
1614 name, formatError(GetLastError()));
1615 return 1;
1616 }
1617 REPARSE_GUID_DATA_BUFFER rgdb = {0};
1618 rgdb.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
1619 DWORD dwBytes;
1620 BOOL res = DeviceIoControl(hd, FSCTL_DELETE_REPARSE_POINT, &rgdb,
1621 REPARSE_GUID_DATA_BUFFER_HEADER_SIZE,
1622 NULL, 0, &dwBytes, 0);
1623 CloseHandle(hd);
1624 if(res == 0)
1625 warning("cannot delete reparse point '%ls', reason '%s'",
1626 name, formatError(GetLastError()));
1627 else /* This may leave an empty dir behind */
1628 R_rmdir(name);
1629 return res == 0;
1630 }
1631
R_unlink(const wchar_t * name,int recursive,int force)1632 static int R_unlink(const wchar_t *name, int recursive, int force)
1633 {
1634 R_CheckStack(); // called recursively
1635 if (wcscmp(name, L".") == 0 || wcscmp(name, L"..") == 0) return 0;
1636 //printf("R_unlink(%ls)\n", name);
1637 if (!R_WFileExists(name)) return 0;
1638 if (force) _wchmod(name, _S_IWRITE);
1639
1640 if (recursive) {
1641 _WDIR *dir;
1642 struct _wdirent *de;
1643 wchar_t p[PATH_MAX];
1644 struct _stati64 sb;
1645 int n, ans = 0;
1646
1647 _wstati64(name, &sb);
1648 /* We need to test for a junction first, as junctions
1649 are detected as directories. */
1650 if (isReparsePoint(name)) ans += delReparsePoint(name);
1651 else if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */
1652 if ((dir = _wopendir(name)) != NULL) {
1653 while ((de = _wreaddir(dir))) {
1654 if (!wcscmp(de->d_name, L".") || !wcscmp(de->d_name, L".."))
1655 continue;
1656 /* On Windows we need to worry about trailing seps */
1657 n = wcslen(name);
1658 if (name[n] == L'/' || name[n] == L'\\') {
1659 wcscpy(p, name); wcscat(p, de->d_name);
1660 } else {
1661 wcscpy(p, name); wcscat(p, L"/"); wcscat(p, de->d_name);
1662 }
1663 /* printf("stat-ing %ls\n", p); */
1664 _wstati64(p, &sb);
1665 if (isReparsePoint(name)) ans += delReparsePoint(name);
1666 else if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */
1667 /* printf("is a directory\n"); */
1668 if (force) _wchmod(p, _S_IWRITE);
1669 ans += R_unlink(p, recursive, force);
1670 } else {
1671 if (force) _wchmod(p, _S_IWRITE);
1672 ans += (_wunlink(p) == 0) ? 0 : 1;
1673 }
1674 }
1675 _wclosedir(dir);
1676 } else { /* we were unable to read a dir */
1677 ans++;
1678 }
1679 ans += (R_rmdir(name) == 0) ? 0 : 1;
1680 return ans;
1681 }
1682 /* drop through */
1683 } else if (isReparsePoint(name)) return delReparsePoint(name);
1684
1685 return _wunlink(name) == 0 ? 0 : 1;
1686 }
1687
R_CleanTempDir(void)1688 void R_CleanTempDir(void)
1689 {
1690 if (Sys_TempDir) {
1691 size_t n = strlen(Sys_TempDir);
1692 /* Windows cannot delete the current working directory */
1693 SetCurrentDirectory(R_HomeDir());
1694 wchar_t w[2*(n+1)];
1695 mbstowcs(w, Sys_TempDir, n+1);
1696 R_unlink(w, 1, 1); /* recursive=TRUE, force=TRUE */
1697 }
1698 }
1699 #else
R_unlink(const char * name,int recursive,int force)1700 static int R_unlink(const char *name, int recursive, int force)
1701 {
1702 R_CheckStack(); // called recursively
1703 struct stat sb;
1704 int res, res2;
1705
1706 if (streql(name, ".") || streql(name, "..")) return 0;
1707 /* We cannot use R_FileExists here since it is false for broken
1708 symbolic links
1709 if (!R_FileExists(name)) return 0; */
1710 res = lstat(name, &sb); /* better to be lstat */
1711 if (!res && force) chmod(name, sb.st_mode | S_IWUSR);
1712
1713 if (!res && recursive) {
1714 DIR *dir;
1715 struct dirent *de;
1716 char p[PATH_MAX];
1717 int ans = 0;
1718
1719 if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */
1720 if ((dir = opendir(name)) != NULL) {
1721 while ((de = readdir(dir))) {
1722 if (streql(de->d_name, ".") || streql(de->d_name, ".."))
1723 continue;
1724 size_t n = strlen(name);
1725 if (name[n] == R_FileSep[0])
1726 snprintf(p, PATH_MAX, "%s%s", name, de->d_name);
1727 else
1728 snprintf(p, PATH_MAX, "%s%s%s", name, R_FileSep,
1729 de->d_name);
1730 lstat(p, &sb);
1731 if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */
1732 if (force) chmod(p, sb.st_mode | S_IWUSR | S_IXUSR);
1733 ans += R_unlink(p, recursive, force);
1734 } else {
1735 if (force) chmod(p, sb.st_mode | S_IWUSR);
1736 ans += (unlink(p) == 0) ? 0 : 1;
1737 }
1738 }
1739 closedir(dir);
1740 } else { /* we were unable to read a dir */
1741 ans++;
1742 }
1743 ans += (rmdir(name) == 0) ? 0 : 1;
1744 return ans;
1745 }
1746 /* drop through */
1747 }
1748 res2 = unlink(name);
1749 /* We want to return 0 if either unlink succeeded or 'name' did not exist */
1750 return (res2 == 0 || res != 0) ? 0 : 1;
1751 }
1752
1753 #endif
1754
1755 /* Note that wildcards are allowed in 'names' */
1756 #ifdef Win32
1757 # include <dos_wglob.h>
do_unlink(SEXP call,SEXP op,SEXP args,SEXP env)1758 SEXP attribute_hidden do_unlink(SEXP call, SEXP op, SEXP args, SEXP env)
1759 {
1760 SEXP fn;
1761 int i, j, nfiles, res, failures = 0, recursive, force, expand;
1762 const wchar_t *names;
1763 wglob_t globbuf;
1764
1765 checkArity(op, args);
1766 fn = CAR(args);
1767 nfiles = length(fn);
1768 if (nfiles > 0) {
1769 if (!isString(fn))
1770 error(_("invalid '%s' argument"), "x");
1771 recursive = asLogical(CADR(args));
1772 if (recursive == NA_LOGICAL)
1773 error(_("invalid '%s' argument"), "recursive");
1774 force = asLogical(CADDR(args));
1775 if (force == NA_LOGICAL)
1776 error(_("invalid '%s' argument"), "force");
1777 expand = asLogical(CADDDR(args));
1778 if (expand == NA_LOGICAL)
1779 error(_("invalid '%s' argument"), "expand");
1780 for (i = 0; i < nfiles; i++) {
1781 if (STRING_ELT(fn, i) != NA_STRING) {
1782 /* FIXME: does not convert encodings, currently matching
1783 filenameToWchar */
1784 if (streql(CHAR(STRING_ELT(fn, i)),"~"))
1785 continue;
1786 names = filenameToWchar(STRING_ELT(fn, i), expand ? TRUE : FALSE);
1787 if (expand) {
1788 res = dos_wglob(names, GLOB_NOCHECK, NULL, &globbuf);
1789 if (res == GLOB_NOSPACE)
1790 error(_("internal out-of-memory condition"));
1791 for (j = 0; j < globbuf.gl_pathc; j++)
1792 failures += R_unlink(globbuf.gl_pathv[j], recursive,
1793 force);
1794 dos_wglobfree(&globbuf);
1795 } else {
1796 failures += R_unlink(names, recursive, force);
1797 }
1798 } else failures++;
1799 }
1800 }
1801 return ScalarInteger(failures ? 1 : 0);
1802 }
1803 #else
1804 # if defined(HAVE_GLOB) && defined(HAVE_GLOB_H)
1805 # include <glob.h>
1806 # endif
1807
do_unlink(SEXP call,SEXP op,SEXP args,SEXP env)1808 SEXP attribute_hidden do_unlink(SEXP call, SEXP op, SEXP args, SEXP env)
1809 {
1810 SEXP fn;
1811 int i, nfiles, failures = 0, recursive, force, expand;
1812 Rboolean useglob = FALSE;
1813 const char *names;
1814 #if defined(HAVE_GLOB)
1815 int j, res;
1816 glob_t globbuf;
1817 #endif
1818
1819 checkArity(op, args);
1820 fn = CAR(args);
1821 nfiles = length(fn);
1822 if (nfiles > 0) {
1823 if (!isString(fn))
1824 error(_("invalid '%s' argument"), "x");
1825 recursive = asLogical(CADR(args));
1826 if (recursive == NA_LOGICAL)
1827 error(_("invalid '%s' argument"), "recursive");
1828 force = asLogical(CADDR(args));
1829 if (force == NA_LOGICAL)
1830 error(_("invalid '%s' argument"), "force");
1831 expand = asLogical(CADDDR(args));
1832 if (expand == NA_LOGICAL)
1833 error(_("invalid '%s' argument"), "expand");
1834 #if defined(HAVE_GLOB)
1835 if (expand)
1836 useglob = TRUE;
1837 #endif
1838 for (i = 0; i < nfiles; i++) {
1839 if (STRING_ELT(fn, i) != NA_STRING) {
1840 names = translateChar(STRING_ELT(fn, i));
1841 if (streql(names, "~"))
1842 continue;
1843 if (expand)
1844 names = R_ExpandFileName(names);
1845 if (useglob) {
1846 #if defined(HAVE_GLOB)
1847 res = glob(names, GLOB_NOCHECK, NULL, &globbuf);
1848 # ifdef GLOB_ABORTED
1849 if (res == GLOB_ABORTED)
1850 warning(_("read error on '%s'"), names);
1851 # endif
1852 # ifdef GLOB_NOSPACE
1853 if (res == GLOB_NOSPACE)
1854 error(_("internal out-of-memory condition"));
1855 # endif
1856 for (j = 0; j < globbuf.gl_pathc; j++)
1857 failures += R_unlink(globbuf.gl_pathv[j], recursive,
1858 force);
1859 globfree(&globbuf);
1860 #endif
1861 } else
1862 failures += R_unlink(names, recursive, force);
1863 } else failures++;
1864 }
1865 }
1866 return ScalarInteger(failures ? 1 : 0);
1867 }
1868 #endif
1869
do_getlocale(SEXP call,SEXP op,SEXP args,SEXP rho)1870 SEXP attribute_hidden do_getlocale(SEXP call, SEXP op, SEXP args, SEXP rho)
1871 {
1872 int cat;
1873 char *p = NULL;
1874
1875 checkArity(op, args);
1876 cat = asInteger(CAR(args));
1877 if (cat == NA_INTEGER || cat < 0)
1878 error(_("invalid '%s' argument"), "category");
1879 switch(cat) {
1880 case 1: cat = LC_ALL; break;
1881 case 2: cat = LC_COLLATE; break;
1882 case 3: cat = LC_CTYPE; break;
1883 case 4: cat = LC_MONETARY; break;
1884 case 5: cat = LC_NUMERIC; break;
1885 case 6: cat = LC_TIME; break;
1886 #ifdef LC_MESSAGES
1887 case 7: cat = LC_MESSAGES; break;
1888 #endif
1889 #ifdef LC_PAPER
1890 case 8: cat = LC_PAPER; break;
1891 #endif
1892 #ifdef LC_MEASUREMENT
1893 case 9: cat = LC_MEASUREMENT; break;
1894 #endif
1895 default: cat = NA_INTEGER;
1896 }
1897 if (cat != NA_INTEGER) p = setlocale(cat, NULL);
1898 return mkString(p ? p : "");
1899 }
1900
1901 /* Locale specs are always ASCII */
do_setlocale(SEXP call,SEXP op,SEXP args,SEXP rho)1902 SEXP attribute_hidden do_setlocale(SEXP call, SEXP op, SEXP args, SEXP rho)
1903 {
1904 SEXP locale = CADR(args), ans;
1905 int cat;
1906 const char *p;
1907
1908 checkArity(op, args);
1909 cat = asInteger(CAR(args));
1910 if (cat == NA_INTEGER || cat < 0)
1911 error(_("invalid '%s' argument"), "category");
1912 if (!isString(locale) || LENGTH(locale) != 1)
1913 error(_("invalid '%s' argument"), "locale");
1914 switch(cat) {
1915 case 1:
1916 {
1917 const char *l = CHAR(STRING_ELT(locale, 0));
1918 cat = LC_ALL;
1919 /* assume we can set LC_CTYPE iff we can set the rest */
1920 if ((p = setlocale(LC_CTYPE, l))) {
1921 setlocale(LC_COLLATE, l);
1922 /* disable the collator when setting to C to take
1923 precedence over R_ICU_LOCALE */
1924 resetICUcollator(!strcmp(l, "C"));
1925 setlocale(LC_MONETARY, l);
1926 setlocale(LC_TIME, l);
1927 dt_invalidate_locale();
1928 /* Need to return value of LC_ALL */
1929 p = setlocale(cat, NULL);
1930 }
1931 break;
1932 }
1933 case 2:
1934 {
1935 const char *l = CHAR(STRING_ELT(locale, 0));
1936 cat = LC_COLLATE;
1937 p = setlocale(cat, l);
1938 /* disable the collator when setting to C to take
1939 precedence over R_ICU_LOCALE */
1940 resetICUcollator(!strcmp(l, "C"));
1941 break;
1942 }
1943 case 3:
1944 cat = LC_CTYPE;
1945 p = setlocale(cat, CHAR(STRING_ELT(locale, 0)));
1946 break;
1947 case 4:
1948 cat = LC_MONETARY;
1949 p = setlocale(cat, CHAR(STRING_ELT(locale, 0)));
1950 break;
1951 case 5:
1952 cat = LC_NUMERIC;
1953 {
1954 const char *new_lc_num = CHAR(STRING_ELT(locale, 0));
1955 if (strcmp(new_lc_num, "C")) /* do not complain about C locale - that's the only
1956 reliable way to restore sanity */
1957 warning(_("setting 'LC_NUMERIC' may cause R to function strangely"));
1958 p = setlocale(cat, new_lc_num);
1959 }
1960 break;
1961 case 6:
1962 cat = LC_TIME;
1963 p = setlocale(cat, CHAR(STRING_ELT(locale, 0)));
1964 dt_invalidate_locale();
1965 break;
1966 #if defined LC_MESSAGES
1967 case 7:
1968 cat = LC_MESSAGES;
1969 #ifdef Win32
1970 /* this seems to exist in MinGW, but it does not work in Windows */
1971 warning(_("LC_MESSAGES exists on Windows but is not operational"));
1972 p = NULL;
1973 #else
1974 p = setlocale(cat, CHAR(STRING_ELT(locale, 0)));
1975 #endif
1976 break;
1977 #endif
1978 #ifdef LC_PAPER
1979 case 8:
1980 cat = LC_PAPER;
1981 p = setlocale(cat, CHAR(STRING_ELT(locale, 0)));
1982 break;
1983 #endif
1984 #ifdef LC_MEASUREMENT
1985 case 9:
1986 cat = LC_MEASUREMENT;
1987 p = setlocale(cat, CHAR(STRING_ELT(locale, 0)));
1988 break;
1989 #endif
1990 default:
1991 p = NULL; /* -Wall */
1992 error(_("invalid '%s' argument"), "category");
1993 }
1994 PROTECT(ans = allocVector(STRSXP, 1));
1995 if (p) SET_STRING_ELT(ans, 0, mkChar(p));
1996 else {
1997 SET_STRING_ELT(ans, 0, mkChar(""));
1998 warning(_("OS reports request to set locale to \"%s\" cannot be honored"),
1999 CHAR(STRING_ELT(locale, 0)));
2000 }
2001 UNPROTECT(1);
2002 R_check_locale();
2003 invalidate_cached_recodings();
2004 return ans;
2005 }
2006
2007
2008
do_localeconv(SEXP call,SEXP op,SEXP args,SEXP rho)2009 SEXP attribute_hidden do_localeconv(SEXP call, SEXP op, SEXP args, SEXP rho)
2010 {
2011 SEXP ans, ansnames;
2012 struct lconv *lc = localeconv();
2013 int i = 0;
2014 char buff[20];
2015
2016 checkArity(op, args);
2017 PROTECT(ans = allocVector(STRSXP, 18));
2018 PROTECT(ansnames = allocVector(STRSXP, 18));
2019 SET_STRING_ELT(ans, i, mkChar(lc->decimal_point));
2020 SET_STRING_ELT(ansnames, i++, mkChar("decimal_point"));
2021 SET_STRING_ELT(ans, i, mkChar(lc->thousands_sep));
2022 SET_STRING_ELT(ansnames, i++, mkChar("thousands_sep"));
2023 SET_STRING_ELT(ans, i, mkChar(lc->grouping));
2024 SET_STRING_ELT(ansnames, i++, mkChar("grouping"));
2025 SET_STRING_ELT(ans, i, mkChar(lc->int_curr_symbol));
2026 SET_STRING_ELT(ansnames, i++, mkChar("int_curr_symbol"));
2027 SET_STRING_ELT(ans, i, mkChar(lc->currency_symbol));
2028 SET_STRING_ELT(ansnames, i++, mkChar("currency_symbol"));
2029 SET_STRING_ELT(ans, i, mkChar(lc->mon_decimal_point));
2030 SET_STRING_ELT(ansnames, i++, mkChar("mon_decimal_point"));
2031 SET_STRING_ELT(ans, i, mkChar(lc->mon_thousands_sep));
2032 SET_STRING_ELT(ansnames, i++, mkChar("mon_thousands_sep"));
2033 SET_STRING_ELT(ans, i, mkChar(lc->mon_grouping));
2034 SET_STRING_ELT(ansnames, i++, mkChar("mon_grouping"));
2035 SET_STRING_ELT(ans, i, mkChar(lc->positive_sign));
2036 SET_STRING_ELT(ansnames, i++, mkChar("positive_sign"));
2037 SET_STRING_ELT(ans, i, mkChar(lc->negative_sign));
2038 SET_STRING_ELT(ansnames, i++, mkChar("negative_sign"));
2039 sprintf(buff, "%d", (int)lc->int_frac_digits);
2040 SET_STRING_ELT(ans, i, mkChar(buff));
2041 SET_STRING_ELT(ansnames, i++, mkChar("int_frac_digits"));
2042 sprintf(buff, "%d", (int)lc->frac_digits);
2043 SET_STRING_ELT(ans, i, mkChar(buff));
2044 SET_STRING_ELT(ansnames, i++, mkChar("frac_digits"));
2045 sprintf(buff, "%d", (int)lc->p_cs_precedes);
2046 SET_STRING_ELT(ans, i, mkChar(buff));
2047 SET_STRING_ELT(ansnames, i++, mkChar("p_cs_precedes"));
2048 sprintf(buff, "%d", (int)lc->p_sep_by_space);
2049 SET_STRING_ELT(ans, i, mkChar(buff));
2050 SET_STRING_ELT(ansnames, i++, mkChar("p_sep_by_space"));
2051 sprintf(buff, "%d", (int)lc->n_cs_precedes);
2052 SET_STRING_ELT(ans, i, mkChar(buff));
2053 SET_STRING_ELT(ansnames, i++, mkChar("n_cs_precedes"));
2054 sprintf(buff, "%d", (int)lc->n_sep_by_space);
2055 SET_STRING_ELT(ans, i, mkChar(buff));
2056 SET_STRING_ELT(ansnames, i++, mkChar("n_sep_by_space"));
2057 sprintf(buff, "%d", (int)lc->p_sign_posn);
2058 SET_STRING_ELT(ans, i, mkChar(buff));
2059 SET_STRING_ELT(ansnames, i++, mkChar("p_sign_posn"));
2060 sprintf(buff, "%d", (int)lc->n_sign_posn);
2061 SET_STRING_ELT(ans, i, mkChar(buff));
2062 SET_STRING_ELT(ansnames, i++, mkChar("n_sign_posn"));
2063 setAttrib(ans, R_NamesSymbol, ansnames);
2064 UNPROTECT(2);
2065 return ans;
2066 }
2067
2068 /* .Internal function for path.expand */
do_pathexpand(SEXP call,SEXP op,SEXP args,SEXP rho)2069 SEXP attribute_hidden do_pathexpand(SEXP call, SEXP op, SEXP args, SEXP rho)
2070 {
2071 SEXP fn, ans;
2072 int i, n;
2073
2074 checkArity(op, args);
2075 fn = CAR(args);
2076 if (!isString(fn))
2077 error(_("invalid '%s' argument"), "path");
2078 n = LENGTH(fn);
2079 PROTECT(ans = allocVector(STRSXP, n));
2080 for (i = 0; i < n; i++) {
2081 SEXP tmp = STRING_ELT(fn, i);
2082 if (tmp != NA_STRING) {
2083 #ifdef Win32
2084 /* Windows can have files and home directories that aren't
2085 representable in the native encoding (e.g. latin1). Translate
2086 to UTF-8 when the input is in UTF-8 already or is in latin1,
2087 but the native encoding is not latin1.
2088
2089 R (including R_ExpandFileNameUTF8) for now only supports R home
2090 directories representable in native encoding.
2091 */
2092 if (IS_UTF8(tmp) || (IS_LATIN1(tmp) && !latin1locale))
2093 tmp = mkCharCE(R_ExpandFileNameUTF8(trCharUTF8(tmp)), CE_UTF8);
2094 else
2095 #endif
2096 {
2097 const char *p = translateCharFP2(tmp);
2098 if (p)
2099 tmp = markKnown(R_ExpandFileName(p), tmp);
2100 }
2101 }
2102 SET_STRING_ELT(ans, i, tmp);
2103 }
2104 UNPROTECT(1);
2105 return ans;
2106 }
2107
2108 #ifdef Unix
2109 static int var_R_can_use_X11 = -1;
2110
2111 extern Rboolean R_access_X11(void); /* from src/unix/X11.c */
2112
R_can_use_X11(void)2113 static Rboolean R_can_use_X11(void)
2114 {
2115 if (var_R_can_use_X11 < 0) {
2116 #ifdef HAVE_X11
2117 if (strcmp(R_GUIType, "none") != 0) {
2118 /* At this point we have permission to use the module, so try it */
2119 var_R_can_use_X11 = R_access_X11();
2120 } else {
2121 var_R_can_use_X11 = 0;
2122 }
2123 #else
2124 var_R_can_use_X11 = 0;
2125 #endif
2126 }
2127
2128 return var_R_can_use_X11 > 0;
2129 }
2130 #endif
2131
2132 /* only actually used on Unix */
do_capabilitiesX11(SEXP call,SEXP op,SEXP args,SEXP rho)2133 SEXP attribute_hidden do_capabilitiesX11(SEXP call, SEXP op, SEXP args, SEXP rho)
2134 {
2135 checkArity(op, args);
2136 #ifdef Unix
2137 return ScalarLogical(R_can_use_X11());
2138 #else
2139 return ScalarLogical(FALSE);
2140 #endif
2141 }
2142
do_capabilities(SEXP call,SEXP op,SEXP args,SEXP rho)2143 SEXP attribute_hidden do_capabilities(SEXP call, SEXP op, SEXP args, SEXP rho)
2144 {
2145 SEXP ans, ansnames;
2146 int i = 0;
2147 #ifdef Unix
2148 # ifdef HAVE_X11
2149 int X11 = NA_LOGICAL;
2150 # else
2151 int X11 = FALSE;
2152 # endif
2153 #endif
2154
2155 checkArity(op, args);
2156
2157 PROTECT(ans = allocVector(LGLSXP, 19));
2158 PROTECT(ansnames = allocVector(STRSXP, 19));
2159
2160 SET_STRING_ELT(ansnames, i, mkChar("jpeg"));
2161 #ifdef HAVE_JPEG
2162 # if defined Unix && !defined HAVE_WORKING_CAIRO
2163 LOGICAL(ans)[i++] = X11;
2164 # else
2165 LOGICAL(ans)[i++] = TRUE;
2166 # endif
2167 #else
2168 LOGICAL(ans)[i++] = FALSE;
2169 #endif
2170
2171 SET_STRING_ELT(ansnames, i, mkChar("png"));
2172 #ifdef HAVE_PNG
2173 # if defined Unix && !defined HAVE_WORKING_CAIRO
2174 LOGICAL(ans)[i++] = X11;
2175 # else /* Windows */
2176 LOGICAL(ans)[i++] = TRUE;
2177 # endif
2178 #else
2179 LOGICAL(ans)[i++] = FALSE;
2180 #endif
2181
2182 SET_STRING_ELT(ansnames, i, mkChar("tiff"));
2183 #ifdef HAVE_TIFF
2184 # if defined Unix && !defined HAVE_WORKING_CAIRO
2185 LOGICAL(ans)[i++] = X11;
2186 # else /* Windows */
2187 LOGICAL(ans)[i++] = TRUE;
2188 # endif
2189 #else
2190 LOGICAL(ans)[i++] = FALSE;
2191 #endif
2192
2193 SET_STRING_ELT(ansnames, i, mkChar("tcltk"));
2194 #ifdef HAVE_TCLTK
2195 LOGICAL(ans)[i++] = TRUE;
2196 #else
2197 LOGICAL(ans)[i++] = FALSE;
2198 #endif
2199
2200 SET_STRING_ELT(ansnames, i, mkChar("X11"));
2201 #ifdef HAVE_X11
2202 # if defined(Unix)
2203 LOGICAL(ans)[i++] = X11;
2204 # else
2205 LOGICAL(ans)[i++] = TRUE;
2206 # endif
2207 #else
2208 LOGICAL(ans)[i++] = FALSE;
2209 #endif
2210
2211 SET_STRING_ELT(ansnames, i, mkChar("aqua"));
2212 #ifdef HAVE_AQUA
2213 LOGICAL(ans)[i++] = TRUE;
2214 #else
2215 LOGICAL(ans)[i++] = FALSE;
2216 #endif
2217
2218 SET_STRING_ELT(ansnames, i, mkChar("http/ftp"));
2219 LOGICAL(ans)[i++] = TRUE;
2220
2221 SET_STRING_ELT(ansnames, i, mkChar("sockets"));
2222 LOGICAL(ans)[i++] = TRUE;
2223
2224 SET_STRING_ELT(ansnames, i, mkChar("libxml"));
2225 LOGICAL(ans)[i++] = TRUE;
2226
2227 SET_STRING_ELT(ansnames, i, mkChar("fifo"));
2228 #if (defined(HAVE_MKFIFO) && defined(HAVE_FCNTL_H)) || defined(_WIN32)
2229 LOGICAL(ans)[i++] = TRUE;
2230 #else
2231 LOGICAL(ans)[i++] = FALSE;
2232 #endif
2233
2234 /* This one is complex. Set it to be true only in interactive use,
2235 with the Windows and GNOME GUIs (but not Tk GUI) or under Unix
2236 if readline is available and in use. */
2237 SET_STRING_ELT(ansnames, i, mkChar("cledit"));
2238 LOGICAL(ans)[i] = FALSE;
2239 #if defined(Win32)
2240 if (R_Interactive) LOGICAL(ans)[i] = TRUE;
2241 #endif
2242 #ifdef Unix
2243 if (strcmp(R_GUIType, "GNOME") == 0) { /* always interactive */
2244 LOGICAL(ans)[i] = TRUE; /* also AQUA ? */
2245 } else {
2246 #if defined(HAVE_LIBREADLINE)
2247 extern Rboolean UsingReadline;
2248 if (R_Interactive && UsingReadline) LOGICAL(ans)[i] = TRUE;
2249 #endif
2250 }
2251 #endif
2252 i++;
2253
2254 /* always true as from R 2.10.0 */
2255 SET_STRING_ELT(ansnames, i, mkChar("iconv"));
2256 LOGICAL(ans)[i++] = TRUE;
2257
2258 SET_STRING_ELT(ansnames, i, mkChar("NLS"));
2259 #ifdef ENABLE_NLS
2260 LOGICAL(ans)[i++] = TRUE;
2261 #else
2262 LOGICAL(ans)[i++] = FALSE;
2263 #endif
2264
2265 SET_STRING_ELT(ansnames, i, mkChar("Rprof"));
2266 #ifdef R_PROFILING
2267 LOGICAL(ans)[i++] = TRUE;
2268 #else
2269 LOGICAL(ans)[i++] = FALSE;
2270 #endif
2271
2272 SET_STRING_ELT(ansnames, i, mkChar("profmem"));
2273 #ifdef R_MEMORY_PROFILING
2274 LOGICAL(ans)[i++] = TRUE;
2275 #else
2276 LOGICAL(ans)[i++] = FALSE;
2277 #endif
2278
2279 SET_STRING_ELT(ansnames, i, mkChar("cairo"));
2280 #ifdef HAVE_WORKING_CAIRO
2281 LOGICAL(ans)[i++] = TRUE;
2282 #elif defined(Win32)
2283 {
2284 /* This is true iff winCairo.dll is available */
2285 struct stat sb;
2286 char path[1000];
2287 snprintf(path, 1000, "%s/library/grDevices/libs/%s/winCairo.dll",
2288 R_HomeDir(), R_ARCH);
2289 LOGICAL(ans)[i++] = stat(path, &sb) == 0;
2290 }
2291 #else
2292 LOGICAL(ans)[i++] = FALSE;
2293 #endif
2294
2295 SET_STRING_ELT(ansnames, i, mkChar("ICU"));
2296 #ifdef USE_ICU
2297 LOGICAL(ans)[i++] = TRUE;
2298 #else
2299 LOGICAL(ans)[i++] = FALSE;
2300 #endif
2301
2302 SET_STRING_ELT(ansnames, i, mkChar("long.double"));
2303 LOGICAL(ans)[i++] = sizeof(LDOUBLE) > sizeof(double);
2304
2305 SET_STRING_ELT(ansnames, i, mkChar("libcurl"));
2306 #ifdef HAVE_LIBCURL
2307 LOGICAL(ans)[i++] = TRUE;
2308 #else
2309 LOGICAL(ans)[i++] = FALSE;
2310 #endif
2311
2312
2313 setAttrib(ans, R_NamesSymbol, ansnames);
2314 UNPROTECT(2);
2315 return ans;
2316 }
2317
do_sysgetpid(SEXP call,SEXP op,SEXP args,SEXP rho)2318 SEXP attribute_hidden do_sysgetpid(SEXP call, SEXP op, SEXP args, SEXP rho)
2319 {
2320 checkArity(op, args);
2321 return ScalarInteger(getpid());
2322 }
2323
2324
2325 /* NB: we save errno immediately after the call here. This should not
2326 be necessary on a POSIX OS, but it is on Windows, where it seems
2327 that on some versions strerror itself changes errno (something
2328 allowed in C99 but disallowed in POSIX). Also, something under
2329 warning() might set errno in a future version.
2330 */
2331 #ifndef Win32
2332 /* mkdir is defined in <sys/stat.h> */
do_dircreate(SEXP call,SEXP op,SEXP args,SEXP env)2333 SEXP attribute_hidden do_dircreate(SEXP call, SEXP op, SEXP args, SEXP env)
2334 {
2335 SEXP path;
2336 int res, show, recursive, mode, serrno = 0;
2337 char *p, dir[PATH_MAX];
2338
2339 checkArity(op, args);
2340 path = CAR(args);
2341 if (!isString(path) || LENGTH(path) != 1)
2342 error(_("invalid '%s' argument"), "path");
2343 if (STRING_ELT(path, 0) == NA_STRING) return ScalarLogical(FALSE);
2344 show = asLogical(CADR(args));
2345 if (show == NA_LOGICAL) show = 0;
2346 recursive = asLogical(CADDR(args));
2347 if (recursive == NA_LOGICAL) recursive = 0;
2348 mode = asInteger(CADDDR(args));
2349 if (mode == NA_LOGICAL) mode = 0777;
2350 strcpy(dir, R_ExpandFileName(translateCharFP(STRING_ELT(path, 0))));
2351 /* remove trailing slashes */
2352 p = dir + strlen(dir) - 1;
2353 while (*p == '/' && strlen(dir) > 1) *p-- = '\0';
2354 if (recursive) {
2355 p = dir;
2356 while ((p = Rf_strchr(p+1, '/'))) {
2357 *p = '\0';
2358 struct stat sb;
2359 res = stat(dir, &sb);
2360 if (res == 0) {
2361 if (! S_ISDIR (sb.st_mode)) {
2362 /* file already exists but is not a directory */
2363 res = -1;
2364 serrno = ENOTDIR;
2365 goto end;
2366 }
2367 } else if (errno != ENOENT || !*dir) {
2368 serrno = errno;
2369 goto end;
2370 } else
2371 res = mkdir(dir, (mode_t) mode);
2372
2373 /* Solaris 10 returns ENOSYS on automount, PR#13834
2374 EROFS is allowed by POSIX, so we skip that too */
2375 serrno = errno;
2376 if (res && serrno != EEXIST && serrno != ENOSYS && serrno != EROFS)
2377 goto end;
2378 *p = '/';
2379 }
2380 }
2381 res = mkdir(dir, (mode_t) mode);
2382 serrno = errno;
2383 if (show && res && serrno == EEXIST)
2384 warning(_("'%s' already exists"), dir);
2385 end:
2386 if (show && res && serrno != EEXIST)
2387 warning(_("cannot create dir '%s', reason '%s'"), dir,
2388 strerror(serrno));
2389 return ScalarLogical(res == 0);
2390 }
2391 #else /* Win32 */
2392 #include <io.h> /* mkdir is defined here */
do_dircreate(SEXP call,SEXP op,SEXP args,SEXP env)2393 SEXP attribute_hidden do_dircreate(SEXP call, SEXP op, SEXP args, SEXP env)
2394 {
2395 SEXP path;
2396 wchar_t *p, dir[MAX_PATH];
2397 int res, show, recursive, serrno = 0, maybeshare;
2398
2399 checkArity(op, args);
2400 path = CAR(args);
2401 if (!isString(path) || LENGTH(path) != 1)
2402 error(_("invalid '%s' argument"), "path");
2403 if (STRING_ELT(path, 0) == NA_STRING) return ScalarLogical(FALSE);
2404 show = asLogical(CADR(args));
2405 if (show == NA_LOGICAL) show = 0;
2406 recursive = asLogical(CADDR(args));
2407 if (recursive == NA_LOGICAL) recursive = 0;
2408 p = filenameToWchar(STRING_ELT(path, 0), TRUE);
2409 if (wcslen(p) >= MAX_PATH)
2410 error(_("'%s' too long"), "path");
2411 wcsncpy(dir, p, MAX_PATH);
2412 for (p = dir; *p; p++) if (*p == L'/') *p = L'\\';
2413 /* remove trailing slashes */
2414 p = dir + wcslen(dir) - 1;
2415 while (*p == L'\\' && wcslen(dir) > 1 && *(p-1) != L':') *p-- = L'\0';
2416 if (recursive) {
2417 p = dir;
2418 maybeshare = 0;
2419 /* skip leading \\server\\share, \\share */
2420 /* FIXME: is \\share (still) possible? */
2421 if (*p == L'\\' && *(p+1) == L'\\') {
2422 p += 2;
2423 p = wcschr(p, L'\\');
2424 maybeshare = 1; /* the next element may be a share name */
2425 }
2426 while ((p = wcschr(p+1, L'\\'))) {
2427 *p = L'\0';
2428 if (*(p-1) != L':') {
2429 res = _wmkdir(dir);
2430 serrno = errno;
2431 if (res && serrno != EEXIST && !maybeshare) goto end;
2432 }
2433 maybeshare = 0;
2434 *p = L'\\';
2435 }
2436 }
2437 res = _wmkdir(dir);
2438 serrno = errno;
2439 if (show && res) {
2440 if (serrno == EEXIST)
2441 warning(_("'%ls' already exists"), dir);
2442 else
2443 warning(_("cannot create dir '%ls', reason '%s'"), dir,
2444 strerror(serrno));
2445 }
2446 return ScalarLogical(res == 0);
2447 end:
2448 if (show && res && serrno != EEXIST)
2449 warning(_("cannot create dir '%ls', reason '%s'"), dir,
2450 strerror(serrno));
2451 return ScalarLogical(res == 0);
2452 }
2453 #endif
2454
2455 /* take file/dir 'name' in dir 'from' and copy it to 'to'
2456 'from', 'to' should have trailing path separator if needed.
2457 */
2458 #ifdef Win32
copyFileTime(const wchar_t * from,const wchar_t * to)2459 static void copyFileTime(const wchar_t *from, const wchar_t * to)
2460 {
2461 HANDLE hFrom, hTo;
2462 FILETIME modft;
2463
2464 hFrom = CreateFileW(from, GENERIC_READ, 0, NULL, OPEN_EXISTING,
2465 FILE_FLAG_BACKUP_SEMANTICS, NULL);
2466 if (hFrom == INVALID_HANDLE_VALUE) return;
2467 int res = GetFileTime(hFrom, NULL, NULL, &modft);
2468 CloseHandle(hFrom);
2469 if(!res) return;
2470
2471 hTo = CreateFileW(to, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
2472 FILE_FLAG_BACKUP_SEMANTICS, NULL);
2473 if (hTo == INVALID_HANDLE_VALUE) return;
2474 SetFileTime(hTo, NULL, NULL, &modft);
2475 CloseHandle(hTo);
2476 }
2477
do_copy(const wchar_t * from,const wchar_t * name,const wchar_t * to,int over,int recursive,int perms,int dates,int depth)2478 static int do_copy(const wchar_t* from, const wchar_t* name, const wchar_t* to,
2479 int over, int recursive, int perms, int dates, int depth)
2480 {
2481 R_CheckUserInterrupt(); // includes stack check
2482 if(depth > 100) {
2483 warning(_("too deep nesting"));
2484 return 1;
2485 }
2486 struct _stati64 sb;
2487 int nfail = 0, res;
2488 wchar_t dest[PATH_MAX + 1], this[PATH_MAX + 1];
2489
2490 if (wcslen(from) + wcslen(name) >= PATH_MAX) {
2491 warning(_("over-long path"));
2492 return 1;
2493 }
2494 wsprintfW(this, L"%ls%ls", from, name);
2495 _wstati64(this, &sb);
2496 if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */
2497 _WDIR *dir;
2498 struct _wdirent *de;
2499 wchar_t p[PATH_MAX + 1];
2500
2501 if (!recursive) return 1;
2502 if (wcslen(to) + wcslen(name) >= PATH_MAX) {
2503 warning(_("over-long path"));
2504 return 1;
2505 }
2506 wsprintfW(dest, L"%ls%ls", to, name);
2507 /* We could set the mode (only the 200 part matters) later */
2508 res = _wmkdir(dest);
2509 if (res) {
2510 if (errno == EEXIST) {
2511 struct _stati64 dsb;
2512 if (over && _wstati64(dest, &dsb) == 0 &&
2513 (dsb.st_mode & S_IFDIR) == 0) {
2514
2515 warning(_("cannot overwrite non-directory %ls with directory %ls"),
2516 dest, this);
2517 return 1;
2518 }
2519 } else {
2520 warning(_("problem creating directory %ls: %s"),
2521 dest, strerror(errno));
2522 return 1;
2523 }
2524 }
2525 // NB Windows' mkdir appears to require \ not /.
2526 if ((dir = _wopendir(this)) != NULL) {
2527 depth++;
2528 while ((de = _wreaddir(dir))) {
2529 if (!wcscmp(de->d_name, L".") || !wcscmp(de->d_name, L".."))
2530 continue;
2531 if (wcslen(name) + wcslen(de->d_name) + 1 >= PATH_MAX) {
2532 warning(_("over-long path"));
2533 _wclosedir(dir);
2534 return 1;
2535 }
2536 wsprintfW(p, L"%ls%\\%ls", name, de->d_name);
2537 nfail += do_copy(from, p, to, over, recursive,
2538 perms, dates, depth);
2539 }
2540 _wclosedir(dir);
2541 } else {
2542 warning(_("problem reading directory %ls: %s"), this, strerror(errno));
2543 nfail++; /* we were unable to read a dir */
2544 }
2545 // chmod(dest, ... perms ...) [TODO?]
2546 if(dates) copyFileTime(this, dest);
2547 } else { /* a file */
2548 FILE *fp1 = NULL, *fp2 = NULL;
2549 wchar_t buf[APPENDBUFSIZE];
2550
2551 nfail = 0;
2552 int nc = wcslen(to);
2553 if (nc + wcslen(name) >= PATH_MAX) {
2554 warning(_("over-long path"));
2555 nfail++;
2556 goto copy_error;
2557 }
2558 wsprintfW(dest, L"%ls%ls", to, name);
2559 if (over || !R_WFileExists(dest)) { /* FIXME */
2560 if ((fp1 = _wfopen(this, L"rb")) == NULL ||
2561 (fp2 = _wfopen(dest, L"wb")) == NULL) {
2562 warning(_("problem copying %ls to %ls: %s"),
2563 this, dest, strerror(errno));
2564 nfail++;
2565 goto copy_error;
2566 }
2567 while ((nc = fread(buf, 1, APPENDBUFSIZE, fp1)) == APPENDBUFSIZE)
2568 if ( fwrite(buf, 1, APPENDBUFSIZE, fp2) != APPENDBUFSIZE) {
2569 nfail++;
2570 goto copy_error;
2571 }
2572 if (fwrite(buf, 1, nc, fp2) != nc) {
2573 nfail++;
2574 goto copy_error;
2575 }
2576 } else if (!over) {
2577 nfail++;
2578 goto copy_error;
2579 }
2580 if(fp1) { fclose(fp1); fp1 = NULL; }
2581 if(fp2) { fclose(fp2); fp2 = NULL; }
2582 /* FIXME: perhaps manipulate mode as we do in Sys.chmod? */
2583 if(perms) _wchmod(dest, sb.st_mode & 0777);
2584 if(dates) copyFileTime(this, dest);
2585 copy_error:
2586 if(fp2) fclose(fp2);
2587 if(fp1) fclose(fp1);
2588 }
2589 return nfail;
2590 }
2591
2592 /* file.copy(from, to, overwrite, recursive, copy.mode, copy.date)
2593 * --------- Windows */
do_filecopy(SEXP call,SEXP op,SEXP args,SEXP rho)2594 SEXP attribute_hidden do_filecopy(SEXP call, SEXP op, SEXP args, SEXP rho)
2595 {
2596 checkArity(op, args);
2597 SEXP fn = CAR(args);
2598 int nfiles = length(fn);
2599 SEXP ans = PROTECT(allocVector(LGLSXP, nfiles));
2600 if (nfiles > 0) {
2601 args = CDR(args);
2602 if (!isString(fn))
2603 error(_("invalid '%s' argument"), "from");
2604 SEXP to = CAR(args); args = CDR(args);
2605 if (!isString(to) || LENGTH(to) != 1)
2606 error(_("invalid '%s' argument"), "to");
2607 int over = asLogical(CAR(args)); args = CDR(args);
2608 if (over == NA_LOGICAL)
2609 error(_("invalid '%s' argument"), "overwrite");
2610 int recursive = asLogical(CAR(args)); args = CDR(args);
2611 if (recursive == NA_LOGICAL)
2612 error(_("invalid '%s' argument"), "recursive");
2613 int perms = asLogical(CAR(args)); args = CDR(args);
2614 if (perms == NA_LOGICAL)
2615 error(_("invalid '%s' argument"), "copy.mode");
2616 int dates = asLogical(CAR(args));
2617 if (dates == NA_LOGICAL)
2618 error(_("invalid '%s' argument"), "copy.date");
2619 wchar_t *p = filenameToWchar(STRING_ELT(to, 0), TRUE);
2620 if (wcslen(p) >= PATH_MAX)
2621 error(_("'%s' path too long"), "to");
2622 wchar_t dir[PATH_MAX];
2623 wcsncpy(dir, p, PATH_MAX);
2624 dir[PATH_MAX - 1] = L'\0';
2625 if (*(dir + (wcslen(dir) - 1)) != L'\\')
2626 wcsncat(dir, L"\\", PATH_MAX);
2627 int nfail;
2628 for (int i = 0; i < nfiles; i++) {
2629 if (STRING_ELT(fn, i) != NA_STRING) {
2630 p = filenameToWchar(STRING_ELT(fn, i), TRUE);
2631 if (wcslen(p) >= PATH_MAX)
2632 error(_("'%s' path too long"), "from");
2633 wchar_t from[PATH_MAX];
2634 wcsncpy(from, p, PATH_MAX);
2635 from[PATH_MAX - 1] = L'\0';
2636 size_t ll = wcslen(from);
2637 if (ll) { // people do pass ""
2638 /* If there is a trailing sep, this is a mistake */
2639 p = from + (ll - 1);
2640 if(*p == L'\\') *p = L'\0';
2641 p = wcsrchr(from, L'\\') ;
2642 wchar_t name[PATH_MAX];
2643 if (p) {
2644 wcsncpy(name, p+1, PATH_MAX);
2645 name[PATH_MAX - 1] = L'\0';
2646 *(p+1) = L'\0';
2647 } else {
2648 if(wcslen(from) > 2 && from[1] == L':') {
2649 wcsncpy(name, from+2, PATH_MAX);
2650 name[PATH_MAX - 1] = L'\0';
2651 from[2] = L'\0';
2652 } else {
2653 wcsncpy(name, from, PATH_MAX);
2654 name[PATH_MAX - 1] = L'\0';
2655 wcsncpy(from, L".\\", PATH_MAX);
2656 }
2657 }
2658 nfail = do_copy(from, name, dir, over, recursive,
2659 perms, dates, 1);
2660 } else nfail = 1;
2661 } else nfail = 1;
2662 LOGICAL(ans)[i] = (nfail == 0);
2663 }
2664 }
2665 UNPROTECT(1);
2666 return ans;
2667 }
2668
2669 #else
2670
2671 /* Only 10.13 (High Sierra) has this, but the headers in Xcode 9 on 10.12
2672 declare it, for some people. */
2673 #if defined(__APPLE__) && defined(MACOS_SIERRA)
2674 # undef HAVE_UTIMENSAT
2675 #endif
2676
2677 #if defined(HAVE_UTIMENSAT)
2678 # include <fcntl.h>
2679 # include <sys/stat.h>
2680 #elif defined(HAVE_UTIMES)
2681 # include <sys/time.h>
2682 #elif defined(HAVE_UTIME)
2683 # include <utime.h>
2684 #endif
2685
copyFileTime(const char * from,const char * to)2686 static void copyFileTime(const char *from, const char * to)
2687 {
2688 struct stat sb;
2689 if(stat(from, &sb)) return;
2690 double ftime;
2691
2692 #ifdef STAT_TIMESPEC
2693 ftime = (double) STAT_TIMESPEC(sb, st_mtim).tv_sec
2694 + 1e-9 * (double) STAT_TIMESPEC(sb, st_mtim).tv_nsec;
2695 #elif defined STAT_TIMESPEC_NS
2696 ftime = STAT_TIMESPEC_NS (sb, st_mtim);
2697 #else
2698 ftime = (double) sb.st_mtime;
2699 #endif
2700
2701 #if defined(HAVE_UTIMENSAT)
2702 struct timespec times[2];
2703
2704 times[0].tv_sec = times[1].tv_sec = (int)ftime;
2705 times[0].tv_nsec = times[1].tv_nsec = (int)(1e9*(ftime - (int)ftime));
2706 utimensat(AT_FDCWD, to, times, 0);
2707 #elif defined(HAVE_UTIMES)
2708 struct timeval times[2];
2709
2710 times[0].tv_sec = times[1].tv_sec = (int)ftime;
2711 times[0].tv_usec = times[1].tv_usec = (int)(1e6*(ftime - (int)ftime));
2712 utimes(to, times);
2713 #elif defined(HAVE_UTIME)
2714 struct utimbuf settime;
2715
2716 settime.actime = settime.modtime = (int)ftime;
2717 utime(to, &settime);
2718 #endif
2719 }
2720
do_copy(const char * from,const char * name,const char * to,int over,int recursive,int perms,int dates,int depth)2721 static int do_copy(const char* from, const char* name, const char* to,
2722 int over, int recursive, int perms, int dates, int depth)
2723 {
2724 R_CheckUserInterrupt(); // includes stack check
2725 if(depth > 100) {
2726 warning(_("too deep nesting"));
2727 return 1;
2728 }
2729 struct stat sb;
2730 int nfail = 0, res;
2731 char dest[PATH_MAX + 1], this[PATH_MAX + 1];
2732
2733 int mask;
2734 #ifdef HAVE_UMASK
2735 int um = umask(0); umask((mode_t) um);
2736 mask = 0777 & ~um;
2737 #else
2738 mask = 0777;
2739 #endif
2740 /* REprintf("from: %s, name: %s, to: %s\n", from, name, to); */
2741 if (strlen(from) + strlen(name) >= PATH_MAX) {
2742 warning(_("over-long path"));
2743 return 1;
2744 }
2745 snprintf(this, PATH_MAX+1, "%s%s", from, name);
2746 /* Here we want the target not the link */
2747 stat(this, &sb);
2748 if ((sb.st_mode & S_IFDIR) > 0) { /* a directory */
2749 DIR *dir;
2750 struct dirent *de;
2751 char p[PATH_MAX + 1];
2752
2753 if (!recursive) return 1;
2754 if (strlen(to) + strlen(name) >= PATH_MAX) {
2755 warning(_("over-long path"));
2756 return 1;
2757 }
2758 snprintf(dest, PATH_MAX+1, "%s%s", to, name);
2759 /* If a directory does not have write permission for the user,
2760 we will fail to create files in that directory, so defer
2761 setting mode */
2762 res = mkdir(dest, 0700);
2763 if (res) {
2764 if (errno == EEXIST) {
2765 struct stat dsb;
2766 if (over && stat(dest, &dsb) == 0 &&
2767 (dsb.st_mode & S_IFDIR) == 0) {
2768
2769 warning(_("cannot overwrite non-directory %s with directory %s"),
2770 dest, this);
2771 return 1;
2772 }
2773 } else {
2774 warning(_("problem creating directory %s: %s"),
2775 this, strerror(errno));
2776 return 1;
2777 }
2778 }
2779 strcat(dest, "/");
2780 if ((dir = opendir(this)) != NULL) {
2781 depth++;
2782 while ((de = readdir(dir))) {
2783 if (streql(de->d_name, ".") || streql(de->d_name, ".."))
2784 continue;
2785 if (strlen(name) + strlen(de->d_name) + 1 >= PATH_MAX) {
2786 warning(_("over-long path"));
2787 closedir(dir);
2788 return 1;
2789 }
2790 snprintf(p, PATH_MAX+1, "%s/%s", name, de->d_name);
2791 nfail += do_copy(from, p, to, over, recursive,
2792 perms, dates, depth);
2793 }
2794 closedir(dir);
2795 } else {
2796 warning(_("problem reading directory %s: %s"), this, strerror(errno));
2797 nfail++; /* we were unable to read a dir */
2798 }
2799 chmod(dest, (mode_t) (perms ? (sb.st_mode & mask): mask));
2800 if(dates) copyFileTime(this, dest);
2801 } else { /* a file */
2802 FILE *fp1 = NULL, *fp2 = NULL;
2803 char buf[APPENDBUFSIZE];
2804
2805 nfail = 0;
2806 size_t nc = strlen(to);
2807 if (nc + strlen(name) >= PATH_MAX) {
2808 warning(_("over-long path"));
2809 nfail++;
2810 goto copy_error;
2811 }
2812 snprintf(dest, PATH_MAX+1, "%s%s", to, name);
2813 if (over || !R_FileExists(dest)) {
2814 /* REprintf("copying %s to %s\n", this, dest); */
2815 if ((fp1 = R_fopen(this, "rb")) == NULL ||
2816 (fp2 = R_fopen(dest, "wb")) == NULL) {
2817 warning(_("problem copying %s to %s: %s"),
2818 this, dest, strerror(errno));
2819 nfail++;
2820 goto copy_error;
2821 }
2822 while ((nc = fread(buf, 1, APPENDBUFSIZE, fp1)) == APPENDBUFSIZE)
2823 if ( fwrite(buf, 1, APPENDBUFSIZE, fp2) != APPENDBUFSIZE) {
2824 nfail++;
2825 goto copy_error;
2826 }
2827 if (fwrite(buf, 1, nc, fp2) != nc) {
2828 nfail++;
2829 goto copy_error;
2830 }
2831 } else if (!over) {
2832 nfail++;
2833 goto copy_error;
2834 }
2835 if(fp1) { fclose(fp1); fp1 = NULL; }
2836 if(fp2) { fclose(fp2); fp2 = NULL; }
2837 if(perms) chmod(dest, sb.st_mode & mask);
2838 if(dates) copyFileTime(this, dest);
2839 copy_error:
2840 if(fp2) fclose(fp2);
2841 if(fp1) fclose(fp1);
2842 }
2843 return nfail;
2844 }
2845
2846 /* file.copy(from, to, overwrite, recursive, copy.mode, copy.date)
2847 * --------- Unix-alike */
do_filecopy(SEXP call,SEXP op,SEXP args,SEXP rho)2848 SEXP attribute_hidden do_filecopy(SEXP call, SEXP op, SEXP args, SEXP rho)
2849 {
2850 checkArity(op, args);
2851 SEXP fn = CAR(args);
2852 int nfiles = length(fn);
2853 SEXP ans = PROTECT(allocVector(LGLSXP, nfiles));
2854 if (nfiles > 0) {
2855 args = CDR(args);
2856 if (!isString(fn))
2857 error(_("invalid '%s' argument"), "from");
2858 SEXP to = CAR(args); args = CDR(args);
2859 if (!isString(to) || LENGTH(to) != 1)
2860 error(_("invalid '%s' argument"), "to");
2861 int over = asLogical(CAR(args)); args = CDR(args);
2862 if (over == NA_LOGICAL)
2863 error(_("invalid '%s' argument"), "overwrite");
2864 int recursive = asLogical(CAR(args)); args = CDR(args);
2865 if (recursive == NA_LOGICAL)
2866 error(_("invalid '%s' argument"), "recursive");
2867 int perms = asLogical(CAR(args)); args = CDR(args);
2868 if (perms == NA_LOGICAL)
2869 error(_("invalid '%s' argument"), "copy.mode");
2870 int dates = asLogical(CAR(args));
2871 if (dates == NA_LOGICAL)
2872 error(_("invalid '%s' argument"), "copy.date");
2873 const char* q = R_ExpandFileName(translateCharFP(STRING_ELT(to, 0)));
2874 if(strlen(q) > PATH_MAX - 2) // allow for '/' and terminator
2875 error(_("invalid '%s' argument"), "to");
2876 char dir[PATH_MAX];
2877 // gcc 10 with sanitizers objects to PATH_MAX here.
2878 strncpy(dir, q, PATH_MAX - 1);
2879 dir[PATH_MAX - 1] = '\0';
2880 if (*(dir + (strlen(dir) - 1)) != '/')
2881 strcat(dir, "/");
2882 int nfail;
2883 for (int i = 0; i < nfiles; i++) {
2884 if (STRING_ELT(fn, i) != NA_STRING) {
2885 char from[PATH_MAX];
2886 strncpy(from,
2887 R_ExpandFileName(translateCharFP(STRING_ELT(fn, i))),
2888 PATH_MAX - 1);
2889 from[PATH_MAX - 1] = '\0';
2890 size_t ll = strlen(from);
2891 if (ll) { // people do pass ""
2892 /* If there is a trailing sep, this is a mistake */
2893 char* p = from + (ll - 1);
2894 if(*p == '/') *p = '\0';
2895 p = strrchr(from, '/') ;
2896 char name[PATH_MAX];
2897 if (p) {
2898 strncpy(name, p+1, PATH_MAX - 1);
2899 name[PATH_MAX - 1] = '\0';
2900 *(p+1) = '\0';
2901 } else {
2902 strncpy(name, from, PATH_MAX);
2903 name[PATH_MAX - 1] = '\0';
2904 strncpy(from, "./", PATH_MAX);
2905 }
2906 nfail = do_copy(from, name, dir, over, recursive,
2907 perms, dates, 1);
2908 } else nfail = 1;
2909 } else nfail = 1;
2910 LOGICAL(ans)[i] = (nfail == 0);
2911 }
2912 }
2913 UNPROTECT(1);
2914 return ans;
2915 }
2916 #endif
2917
do_l10n_info(SEXP call,SEXP op,SEXP args,SEXP env)2918 SEXP attribute_hidden do_l10n_info(SEXP call, SEXP op, SEXP args, SEXP env)
2919 {
2920 #ifdef Win32
2921 int len = 5;
2922 #else
2923 int len = 4;
2924 #endif
2925 SEXP ans, names;
2926 checkArity(op, args);
2927 PROTECT(ans = allocVector(VECSXP, len));
2928 PROTECT(names = allocVector(STRSXP, len));
2929 SET_STRING_ELT(names, 0, mkChar("MBCS"));
2930 SET_STRING_ELT(names, 1, mkChar("UTF-8"));
2931 SET_STRING_ELT(names, 2, mkChar("Latin-1"));
2932 SET_VECTOR_ELT(ans, 0, ScalarLogical(mbcslocale));
2933 SET_VECTOR_ELT(ans, 1, ScalarLogical(utf8locale));
2934 SET_VECTOR_ELT(ans, 2, ScalarLogical(latin1locale));
2935 #ifndef Win32
2936 SET_STRING_ELT(names, 3, mkChar("codeset"));
2937 SET_VECTOR_ELT(ans, 3, mkString(codeset));
2938 #endif
2939 #ifdef Win32
2940 SET_STRING_ELT(names, 3, mkChar("codepage"));
2941 SET_VECTOR_ELT(ans, 3, ScalarInteger(localeCP));
2942 SET_STRING_ELT(names, 4, mkChar("system.codepage"));
2943 SET_VECTOR_ELT(ans, 4, ScalarInteger(systemCP));
2944 #endif
2945 setAttrib(ans, R_NamesSymbol, names);
2946 UNPROTECT(2);
2947 return ans;
2948 }
2949
2950 /* do_normalizepath moved to util.c in R 2.13.0 */
2951
do_syschmod(SEXP call,SEXP op,SEXP args,SEXP env)2952 SEXP attribute_hidden do_syschmod(SEXP call, SEXP op, SEXP args, SEXP env)
2953 {
2954 #ifdef HAVE_CHMOD
2955 SEXP paths, smode, ans;
2956 int i, m, n, *modes, res;
2957 mode_t um = 0;
2958
2959 checkArity(op, args);
2960 paths = CAR(args);
2961 if (!isString(paths))
2962 error(_("invalid '%s' argument"), "paths");
2963 n = LENGTH(paths);
2964 PROTECT(smode = coerceVector(CADR(args), INTSXP));
2965 modes = INTEGER(smode);
2966 m = LENGTH(smode);
2967 if(!m && n) error(_("'mode' must be of length at least one"));
2968 int useUmask = asLogical(CADDR(args));
2969 if (useUmask == NA_LOGICAL)
2970 error(_("invalid '%s' argument"), "use_umask");
2971 #ifdef HAVE_UMASK
2972 um = umask(0); umask(um);
2973 #endif
2974 PROTECT(ans = allocVector(LGLSXP, n));
2975 for (i = 0; i < n; i++) {
2976 mode_t mode = (mode_t) modes[i % m];
2977 if (mode == NA_INTEGER) mode = 0777;
2978 #ifdef HAVE_UMASK
2979 if(useUmask) mode = mode & ~um;
2980 #endif
2981 #ifdef Win32
2982 /* Windows' _[w]chmod seems only to support read access
2983 or read-write access. _S_IWRITE is 0200.
2984 */
2985 mode = (mode & 0200) ? (_S_IWRITE | _S_IREAD): _S_IREAD;
2986 #endif
2987 if (STRING_ELT(paths, i) != NA_STRING) {
2988 #ifdef Win32
2989 res = _wchmod(filenameToWchar(STRING_ELT(paths, i), TRUE), mode);
2990 #else
2991 res = chmod(R_ExpandFileName(translateCharFP(STRING_ELT(paths, i))),
2992 mode);
2993 #endif
2994 } else res = 1;
2995 LOGICAL(ans)[i] = (res == 0);
2996 }
2997 UNPROTECT(2);
2998 return ans;
2999 #else
3000 SEXP paths, ans;
3001 int i, n;
3002
3003 checkArity(op, args);
3004 paths = CAR(args);
3005 if (!isString(paths))
3006 error(_("invalid '%s' argument"), "paths");
3007 n = LENGTH(paths);
3008 warning("insufficient OS support on this platform");
3009 PROTECT(ans = allocVector(LGLSXP, n));
3010 for (i = 0; i < n; i++) LOGICAL(ans)[i] = 0;
3011 UNPROTECT(1);
3012 return ans;
3013 #endif
3014 }
3015
do_sysumask(SEXP call,SEXP op,SEXP args,SEXP env)3016 SEXP attribute_hidden do_sysumask(SEXP call, SEXP op, SEXP args, SEXP env)
3017 {
3018 SEXP ans;
3019 int mode;
3020 mode_t res = 0;
3021 Rboolean visible;
3022
3023 checkArity(op, args);
3024 mode = asInteger(CAR(args));
3025 #ifdef HAVE_UMASK
3026 if (mode == NA_INTEGER) {
3027 res = umask(0);
3028 umask(res);
3029 visible = TRUE;
3030 } else {
3031 res = umask((mode_t) mode);
3032 visible = FALSE;
3033 }
3034 #else
3035 warning(_("insufficient OS support on this platform"));
3036 visible = FALSE;
3037 #endif
3038 PROTECT(ans = ScalarInteger(res));
3039 setAttrib(ans, R_ClassSymbol, mkString("octmode"));
3040 UNPROTECT(1);
3041 R_Visible = visible;
3042 return ans;
3043 }
3044
do_readlink(SEXP call,SEXP op,SEXP args,SEXP env)3045 SEXP attribute_hidden do_readlink(SEXP call, SEXP op, SEXP args, SEXP env)
3046 {
3047 checkArity(op, args);
3048 SEXP paths = CAR(args);
3049 if(!isString(paths))
3050 error(_("invalid '%s' argument"), "paths");
3051 int n = LENGTH(paths);
3052 SEXP ans = PROTECT(allocVector(STRSXP, n));
3053 #ifdef HAVE_READLINK
3054 char buf[PATH_MAX+1];
3055 for (int i = 0; i < n; i++) {
3056 const char *p = translateCharFP2(STRING_ELT(paths, i));
3057 if (p) {
3058 memset(buf, 0, PATH_MAX+1);
3059 ssize_t res = readlink(R_ExpandFileName(p), buf, PATH_MAX);
3060 if (res == PATH_MAX) {
3061 SET_STRING_ELT(ans, i, mkChar(buf));
3062 warning("possible truncation of value for element %d", i + 1);
3063 } else if (res >= 0) SET_STRING_ELT(ans, i, mkChar(buf));
3064 else if (errno == EINVAL) SET_STRING_ELT(ans, i, mkChar(""));
3065 else SET_STRING_ELT(ans, i, NA_STRING);
3066 } else SET_STRING_ELT(ans, i, NA_STRING);
3067 }
3068 #endif
3069 UNPROTECT(1);
3070 return ans;
3071 }
3072
3073
do_Cstack_info(SEXP call,SEXP op,SEXP args,SEXP rho)3074 SEXP attribute_hidden do_Cstack_info(SEXP call, SEXP op, SEXP args, SEXP rho)
3075 {
3076 SEXP ans, nms;
3077
3078 checkArity(op, args);
3079 PROTECT(ans = allocVector(INTSXP, 4));
3080 PROTECT(nms = allocVector(STRSXP, 4));
3081 /* FIXME: could be out of range */
3082 INTEGER(ans)[0] = (R_CStackLimit == -1) ? NA_INTEGER : (int) R_CStackLimit;
3083 INTEGER(ans)[1] = (R_CStackLimit == -1) ? NA_INTEGER : (int)
3084 (R_CStackDir * (R_CStackStart - (uintptr_t) &ans));
3085 INTEGER(ans)[2] = R_CStackDir;
3086 INTEGER(ans)[3] = R_EvalDepth;
3087 SET_STRING_ELT(nms, 0, mkChar("size"));
3088 SET_STRING_ELT(nms, 1, mkChar("current"));
3089 SET_STRING_ELT(nms, 2, mkChar("direction"));
3090 SET_STRING_ELT(nms, 3, mkChar("eval_depth"));
3091
3092 UNPROTECT(2);
3093 setAttrib(ans, R_NamesSymbol, nms);
3094 return ans;
3095 }
3096
3097 #ifdef Win32
winSetFileTime(const char * fn,double ftime)3098 static int winSetFileTime(const char *fn, double ftime)
3099 {
3100 SYSTEMTIME st;
3101 FILETIME modft;
3102 struct tm *utctm;
3103 HANDLE hFile;
3104 time_t ftimei = (time_t) ftime;
3105
3106 utctm = gmtime(&ftimei);
3107 if (!utctm) return 0;
3108
3109 st.wYear = (WORD) utctm->tm_year + 1900;
3110 st.wMonth = (WORD) utctm->tm_mon + 1;
3111 st.wDayOfWeek = (WORD) utctm->tm_wday;
3112 st.wDay = (WORD) utctm->tm_mday;
3113 st.wHour = (WORD) utctm->tm_hour;
3114 st.wMinute = (WORD) utctm->tm_min;
3115 st.wSecond = (WORD) utctm->tm_sec;
3116 st.wMilliseconds = (WORD) 1000*(ftime - ftimei);
3117 if (!SystemTimeToFileTime(&st, &modft)) return 0;
3118
3119 hFile = CreateFile(fn, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
3120 FILE_FLAG_BACKUP_SEMANTICS, NULL);
3121 if (hFile == INVALID_HANDLE_VALUE) return 0;
3122 int res = SetFileTime(hFile, NULL, NULL, &modft);
3123 CloseHandle(hFile);
3124 return res != 0; /* success is non-zero */
3125 }
3126 #endif
3127
3128 SEXP attribute_hidden
do_setFileTime(SEXP call,SEXP op,SEXP args,SEXP rho)3129 do_setFileTime(SEXP call, SEXP op, SEXP args, SEXP rho)
3130 {
3131 checkArity(op, args);
3132 const char *fn;
3133 double ftime;
3134 int res;
3135 R_xlen_t n, m;
3136 SEXP paths, times, ans;
3137 const void *vmax;
3138
3139 paths = CAR(args);
3140 if (!isString(paths))
3141 error(_("invalid '%s' argument"), "path");
3142 n = XLENGTH(paths);
3143 PROTECT(times = coerceVector(CADR(args), REALSXP));
3144 m = XLENGTH(times);
3145 if (!m && n) error(_("'%s' must be of length at least one"), "time");
3146
3147 PROTECT(ans = allocVector(LGLSXP, n));
3148 vmax = vmaxget();
3149 for(R_xlen_t i = 0; i < n; i++) {
3150 fn = translateCharFP(STRING_ELT(paths, i));
3151 ftime = REAL(times)[i % m];
3152 #ifdef Win32
3153 res = winSetFileTime(fn, ftime);
3154 #elif defined(HAVE_UTIMENSAT)
3155 struct timespec times[2];
3156
3157 times[0].tv_sec = times[1].tv_sec = (int)ftime;
3158 times[0].tv_nsec = times[1].tv_nsec = (int)(1e9*(ftime - (int)ftime));
3159
3160 res = utimensat(AT_FDCWD, fn, times, 0) == 0;
3161 #elif defined(HAVE_UTIMES)
3162 struct timeval times[2];
3163
3164 times[0].tv_sec = times[1].tv_sec = (int)ftime;
3165 times[0].tv_usec = times[1].tv_usec = (int)(1e6*(ftime - (int)ftime));
3166
3167 res = utimes(fn, times) == 0;
3168 #elif defined(HAVE_UTIME)
3169 struct utimbuf settime;
3170
3171 settime.actime = settime.modtime = (int)ftime;
3172 res = utime(fn, &settime) == 0;
3173 #endif
3174 LOGICAL(ans)[i] = (res == 0) ? FALSE : TRUE;
3175 fn = NULL;
3176 vmaxset(vmax); // throws away result of translateCharFP
3177 }
3178 UNPROTECT(2); /* times, ans */
3179 return ans;
3180 }
3181
3182 #ifdef Win32
3183 /* based on ideas in
3184 http://www.codeproject.com/KB/winsdk/junctionpoints.aspx
3185 */
3186 typedef struct TMN_REPARSE_DATA_BUFFER
3187 {
3188 DWORD ReparseTag;
3189 WORD ReparseDataLength;
3190 WORD Reserved;
3191 WORD SubstituteNameOffset;
3192 WORD SubstituteNameLength;
3193 WORD PrintNameOffset;
3194 WORD PrintNameLength;
3195 WCHAR PathBuffer[1024];
3196 } TMN_REPARSE_DATA_BUFFER;
3197
do_mkjunction(SEXP call,SEXP op,SEXP args,SEXP rho)3198 SEXP attribute_hidden do_mkjunction(SEXP call, SEXP op, SEXP args, SEXP rho)
3199 {
3200 wchar_t from[10000];
3201 const wchar_t *to;
3202
3203 checkArity(op, args);
3204 /* from and to are both directories: and to exists */
3205 wcscpy(from, filenameToWchar(STRING_ELT(CAR(args), 0), FALSE));
3206 to = filenameToWchar(STRING_ELT(CADR(args), 0), TRUE);
3207 // printf("ln %ls %ls\n", from, to);
3208
3209 HANDLE hd =
3210 CreateFileW(to, GENERIC_READ | GENERIC_WRITE, 0, 0, OPEN_EXISTING,
3211 FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT,
3212 0);
3213 if(hd == INVALID_HANDLE_VALUE) {
3214 warning("cannot open reparse point '%ls', reason '%s'",
3215 to, formatError(GetLastError()));
3216 return ScalarLogical(0);
3217 }
3218 TMN_REPARSE_DATA_BUFFER rdb;
3219 const size_t nbytes = wcslen(from) * 2;
3220 rdb.ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
3221 rdb.ReparseDataLength = nbytes + 12;
3222 wcscpy(rdb.PathBuffer, from);
3223 rdb.Reserved = 0;
3224 rdb.SubstituteNameOffset = 0;
3225 rdb.SubstituteNameLength = nbytes;
3226 rdb.PrintNameOffset = nbytes + 2;
3227 rdb.PrintNameLength = 0;
3228 DWORD dwBytes;
3229 const BOOL bOK =
3230 DeviceIoControl(hd, FSCTL_SET_REPARSE_POINT, &rdb,
3231 8 /* header */ + rdb.ReparseDataLength,
3232 NULL, 0, &dwBytes, 0);
3233 CloseHandle(hd);
3234 if(!bOK)
3235 warning("cannot set reparse point '%ls', reason '%s'",
3236 to, formatError(GetLastError()));
3237 return ScalarLogical(bOK != 0);
3238 }
3239 #endif
3240
3241 #include <zlib.h>
3242 #include <bzlib.h>
3243 #include <lzma.h>
3244
3245 #ifdef HAVE_PCRE2
3246 /* PCRE2_CODE_UNIT_WIDTH is defined to 8 via config.h */
3247 # include<pcre2.h>
3248 #else
3249 # ifdef HAVE_PCRE_PCRE_H
3250 # include <pcre/pcre.h>
3251 # else
3252 # include <pcre.h>
3253 # endif
3254 #endif
3255
3256 #ifdef USE_ICU
3257 # ifndef USE_ICU_APPLE
3258 # include <unicode/uversion.h>
3259 # else
3260 # define U_MAX_VERSION_LENGTH 4
3261 # define U_MAX_VERSION_STRING_LENGTH 20
3262 typedef uint8_t UVersionInfo[U_MAX_VERSION_LENGTH];
3263 void u_versionToString(const UVersionInfo versionArray, char *versionString);
3264 void u_getVersion(UVersionInfo versionArray);
3265 # endif
3266 #endif
3267
3268 #include <iconv.h>
3269 #if defined(__GLIBC__)
3270 # include <gnu/libc-version.h>
3271 #endif
3272
3273 #ifdef HAVE_LIBREADLINE
3274 // that ensures we have this header
3275 # include <readline/readline.h>
3276 #endif
3277
3278 #if defined(HAVE_REALPATH) && defined(HAVE_DECL_REALPATH) && !HAVE_DECL_REALPATH
3279 extern char *realpath(const char *path, char *resolved_path);
3280 #endif
3281
3282 #ifdef HAVE_DLFCN_H
3283 #include <dlfcn.h> /* for dladdr, dlsym */
3284 #endif
3285
3286 #if defined(HAVE_DLADDR) && defined(HAVE_DECL_DLADDR) && !HAVE_DECL_DLADDR
3287 extern int dladdr(void *addr, Dl_info *info);
3288 #endif
3289
3290 #if defined(HAVE_DLSYM) && defined(HAVE_DECL_DLSYM) && !HAVE_DECL_DLSYM
3291 extern void *dlsym(void *handle, const char *symbol);
3292 #endif
3293
3294 /* extSoftVersion only detects versions of libraries that are available
3295 without loading any modules; libraries available via modules are
3296 treated individually (libcurlVersion(), La_version(), etc)
3297 */
3298 SEXP attribute_hidden
do_eSoftVersion(SEXP call,SEXP op,SEXP args,SEXP rho)3299 do_eSoftVersion(SEXP call, SEXP op, SEXP args, SEXP rho)
3300 {
3301 checkArity(op, args);
3302 SEXP ans = PROTECT(allocVector(STRSXP, 9));
3303 SEXP nms = PROTECT(allocVector(STRSXP, 9));
3304 setAttrib(ans, R_NamesSymbol, nms);
3305 unsigned int i = 0;
3306 char p[256];
3307 snprintf(p, 256, "%s", zlibVersion());
3308 SET_STRING_ELT(ans, i, mkChar(p));
3309 SET_STRING_ELT(nms, i++, mkChar("zlib"));
3310 snprintf(p, 256, "%s", BZ2_bzlibVersion());
3311 SET_STRING_ELT(ans, i, mkChar(p));
3312 SET_STRING_ELT(nms, i++, mkChar("bzlib"));
3313 snprintf(p, 256, "%s", lzma_version_string());
3314 SET_STRING_ELT(ans, i, mkChar(p));
3315 SET_STRING_ELT(nms, i++, mkChar("xz"));
3316 #ifdef HAVE_PCRE2
3317 pcre2_config(PCRE2_CONFIG_VERSION, p);
3318 #else
3319 snprintf(p, 256, "%s", pcre_version());
3320 #endif
3321 SET_STRING_ELT(ans, i, mkChar(p));
3322 SET_STRING_ELT(nms, i++, mkChar("PCRE"));
3323 #ifdef USE_ICU
3324 UVersionInfo icu;
3325 char pu[U_MAX_VERSION_STRING_LENGTH];
3326 u_getVersion(icu);
3327 u_versionToString(icu, pu);
3328 SET_STRING_ELT(ans, i, mkChar(pu));
3329 #else
3330 SET_STRING_ELT(ans, i, mkChar(""));
3331 #endif
3332 SET_STRING_ELT(nms, i++, mkChar("ICU"));
3333 snprintf(p, 256, "%s", tre_version());
3334 SET_STRING_ELT(ans, i, mkChar(p));
3335 SET_STRING_ELT(nms, i++, mkChar("TRE"));
3336 #ifdef _LIBICONV_VERSION
3337 {
3338 int ver = _libiconv_version;
3339 snprintf(p, 256, "GNU libiconv %d.%d", ver/0x0100, ver%0x0100);
3340 }
3341 #elif defined(_WIN32)
3342 snprintf(p, 256, "%s", "win_iconv");
3343 #elif defined(__GLIBC__)
3344 snprintf(p, 256, "glibc %s", gnu_get_libc_version());
3345 #else
3346 snprintf(p, 256, "%s", "unknown");
3347 #endif
3348 SET_STRING_ELT(ans, i, mkChar(p));
3349 SET_STRING_ELT(nms, i++, mkChar("iconv"));
3350 #ifdef HAVE_LIBREADLINE
3351 /* libedit reports "EditLine wrapper": so we look at
3352 rl_readline_version, which is currently 0x0402 */
3353 const char *rl = rl_library_version;
3354 if (streql(rl, "EditLine wrapper")) {
3355 int num = rl_readline_version;
3356 int maj = num / 256, min = num % 256;
3357 char buf[40];
3358 snprintf(buf, 40, "%d.%d (%s)", maj, min, rl);
3359 SET_STRING_ELT(ans, i, mkChar(buf));
3360 } else
3361 SET_STRING_ELT(ans, i, mkChar(rl));
3362 #else
3363 SET_STRING_ELT(ans, i, mkChar(""));
3364 #endif
3365 SET_STRING_ELT(nms, i++, mkChar("readline"));
3366
3367 SET_STRING_ELT(ans, i, mkChar(""));
3368
3369 #if defined(HAVE_DLADDR) && defined(HAVE_REALPATH) && defined(HAVE_DLSYM) \
3370 && defined(HAVE_DECL_RTLD_DEFAULT) && HAVE_DECL_RTLD_DEFAULT \
3371 && defined(HAVE_DECL_RTLD_NEXT) && HAVE_DECL_RTLD_NEXT
3372
3373 /* Look for blas function dgemm and try to figure out in which
3374 binary/shared library it is defined. That is based on experimentation
3375 and heuristics, and depends on implementation details
3376 of dynamic linkers.
3377 */
3378 #ifdef HAVE_F77_UNDERSCORE
3379 char *dgemm_name = "dgemm_";
3380 #else
3381 char *dgemm_name = "dgemm";
3382 #endif
3383
3384 Rboolean ok = TRUE;
3385
3386 void *dgemm_addr = dlsym(RTLD_DEFAULT, dgemm_name);
3387
3388 Dl_info dl_info1, dl_info2;
3389
3390 /* these calls to dladdr() convert a function pointer to an object
3391 pointer, which is not allowed by ISO C, but there is no compliant
3392 alternative to using dladdr() */
3393 if (!dladdr((void *)do_eSoftVersion, &dl_info1)) ok = FALSE;
3394 if (!dladdr((void *)dladdr, &dl_info2)) ok = FALSE;
3395
3396 if (ok && !strcmp(dl_info1.dli_fname, dl_info2.dli_fname)) {
3397
3398 /* dladdr is not inside R, hence we probably have the PLT for
3399 dynamically linked symbols; lets use dlsym(RTLD_NEXT) to
3400 get the real address for dgemm.
3401
3402 PLT is used on Linux and on Solaris when the main binary
3403 is _not_ position independent. PLT is not used on macOS.
3404 */
3405 if (dgemm_addr != NULL) {
3406
3407 /* If dgemm_addr is NULL, dgemm is statically linked and
3408 we are on Linux. On Solaris, dgemm_addr is never NULL.
3409 */
3410 void *dgemm_next_addr = dlsym(RTLD_NEXT, dgemm_name);
3411 if (dgemm_next_addr != NULL)
3412
3413 /* If dgemm_next_addr is NULL, dgemm is statically linked.
3414 Otherwise, it is linked dynamically and dgemm_next_addr
3415 is its true address (dgemm points to PLT).
3416
3417 On Linux, dgemm_next_addr is only NULL here when
3418 dgemm is export-dynamic (yet statically linked).
3419 */
3420 dgemm_addr = dgemm_next_addr;
3421 }
3422 }
3423
3424 char buf[PATH_MAX+1];
3425 if (ok && dladdr(dgemm_addr, &dl_info1)) {
3426 char *res = realpath(dl_info1.dli_fname, buf);
3427 if (res)
3428 SET_STRING_ELT(ans, i, mkChar(res));
3429 }
3430 #endif
3431 SET_STRING_ELT(nms, i++, mkChar("BLAS"));
3432
3433 UNPROTECT(2);
3434 return ans;
3435 }
3436
3437 /* platform-specific */
3438 extern void Rsleep(double timeint);
3439
do_syssleep(SEXP call,SEXP op,SEXP args,SEXP rho)3440 SEXP attribute_hidden do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho)
3441 {
3442 checkArity(op, args);
3443 double time = asReal(CAR(args));
3444 if (ISNAN(time) || time < 0.)
3445 error(_("invalid '%s' value"), "time");
3446 Rsleep(time);
3447 return R_NilValue;
3448 }
3449
3450