1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 2020 The R Core Team.
4 *
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, a copy is available at
17 * https://www.R-project.org/Licenses/
18 */
19
20 #include <R.h>
21 #include <Rdefines.h>
22 #include <ctype.h>
23 #include "tools.h"
24
package_dependencies_scan_one(SEXP this)25 static SEXP package_dependencies_scan_one(SEXP this) {
26 SEXP y;
27 Rboolean save, skip;
28 int size = 256, i, j, nb = 0, ne = 0, u, v, w;
29 int *beg, *end;
30 const char *s;
31 char c, *t, *p, q = '\0';
32 cetype_t e;
33
34 if(this == NA_STRING) {
35 return NEW_CHARACTER(0);
36 }
37
38 beg = Calloc(size, int);
39 end = Calloc(size, int);
40
41 e = getCharCE(this);
42 s = CHAR(this);
43 i = 0;
44 save = FALSE;
45 skip = FALSE;
46 while((c = *s++) != '\0') {
47 if(skip) {
48 if(c == ',')
49 skip = FALSE;
50 } else {
51 if(save) {
52 if(!isalnum(c) && (c != '.')) {
53 save = FALSE;
54 if((q == 'R') && (beg[ne] == (i - 1)))
55 nb--;
56 else {
57 end[ne] = i - 1;
58 ne++;
59 }
60 }
61 } else {
62 if(isalpha(c)) {
63 save = TRUE;
64 q = c;
65 if(nb >= size) {
66 if(size > INT_MAX / 2)
67 error(_("too many items"));
68 size *= 2;
69 beg = Realloc(beg, size, int);
70 end = Realloc(end, size, int);
71 }
72 beg[nb] = i;
73 nb++;
74 }
75 }
76 }
77 i++;
78 }
79 if(ne < nb) {
80 if((q == 'R') && (beg[ne] == (i - 1)))
81 nb--;
82 else
83 end[ne] = i - 1;
84 }
85
86 PROTECT(y = NEW_CHARACTER(nb));
87 s = CHAR(this);
88 v = -1;
89 for(i = 0; i < nb; i++) {
90 u = beg[i];
91 s += (u - v - 1);
92 v = end[i];
93 w = v - u + 1;
94 p = t = (char *) R_alloc(w + 1, sizeof(char));
95 for(j = 0; j < w; j++) {
96 *t++ = *s++;
97 }
98 *t = '\0';
99 SET_STRING_ELT(y, i, mkCharCE(p, e));
100 }
101
102 Free(beg);
103 Free(end);
104
105 UNPROTECT(1);
106
107 return y;
108 }
109
package_dependencies_scan(SEXP x)110 SEXP package_dependencies_scan(SEXP x) {
111 SEXP y, z, this;
112 R_xlen_t i, j, k, nx, ny;
113
114 if(TYPEOF(x) != STRSXP)
115 error(_("non-character argument"));
116
117 nx = LENGTH(x);
118
119 if(nx < 1)
120 return NEW_CHARACTER(0);
121
122 if(nx == 1)
123 return package_dependencies_scan_one(STRING_ELT(x, 0));
124
125 PROTECT(z = NEW_LIST(nx));
126 ny = 0;
127 for(i = 0; i < nx; i++) {
128 this = package_dependencies_scan_one(STRING_ELT(x, i));
129 SET_VECTOR_ELT(z, i, this);
130 ny += LENGTH(this);
131 }
132 // Now unlist.
133 k = 0;
134 PROTECT(y = NEW_STRING(ny));
135 for(i = 0; i < nx; i++) {
136 this = VECTOR_ELT(z, i);
137 for(j = 0; j < LENGTH(this); j++, k++)
138 SET_STRING_ELT(y, k, STRING_ELT(this, j));
139 }
140
141 UNPROTECT(2);
142
143 return y;
144 }
145