The R Project SVN R

Rev

Rev 45667 | Rev 50473 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 45667 Rev 45847
Line 46... Line 46...
46 
   deliberate -- see ?paste -- and implicitly coerces it to "NA"
 46 
   deliberate -- see ?paste -- and implicitly coerces it to "NA"
47 
*/
 47 
*/
48 
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
 48 
SEXP attribute_hidden do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
49 
{
 49 
{
50 
    SEXP ans, collapse, sep, x;
 50 
    SEXP ans, collapse, sep, x;
51 
    int i, j, k, maxlen, nx, pwidth, sepw, ienc;
 51 
    int i, j, k, maxlen, nx, pwidth, sepw, u_sepw, ienc;
52 
    const char *s, *csep, *cbuf; char *buf;
 52 
    const char *s, *csep, *cbuf, *u_csep=NULL;
- 
 
 53 
    char *buf;
53 
    Rboolean allKnown, anyKnown, sepASCII, sepKnown;
 54 
    Rboolean allKnown, anyKnown, sepASCII, sepKnown, use_UTF8, sepUTF8;
54 
 
 55 
 
55 
    checkArity(op, args);
 56 
    checkArity(op, args);
56 
 
 57 
 
57 
    /* We use formatting and so we */
 58 
    /* We use formatting and so we */
58 
    /* must initialize printing. */
 59 
    /* must initialize printing. */
Line 70... Line 71...
70 
    sep = CADR(args);
 71 
    sep = CADR(args);
71 
    if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
 72 
    if (!isString(sep) || LENGTH(sep) <= 0 || STRING_ELT(sep, 0) == NA_STRING)
72 
	error(_("invalid separator"));
 73 
	error(_("invalid separator"));
73 
    sep = STRING_ELT(sep, 0);
 74 
    sep = STRING_ELT(sep, 0);
74 
    csep = translateChar(sep);
 75 
    csep = translateChar(sep);
75 
    sepw = strlen(csep); /* not LENGTH as might contain \0 */
 76 
    u_sepw = sepw = strlen(csep);
76 
    sepASCII = strIsASCII(csep);
 77 
    sepASCII = strIsASCII(csep);
77 
    sepKnown = ENC_KNOWN(sep) > 0;
 78 
    sepKnown = ENC_KNOWN(sep) > 0;
- 
 
 79 
    sepUTF8 = IS_UTF8(sep);
78 
 
 80 
 
79 
    collapse = CADDR(args);
 81 
    collapse = CADDR(args);
80 
    if (!isNull(collapse))
 82 
    if (!isNull(collapse))
81 
	if(!isString(collapse) || LENGTH(collapse) <= 0 ||
 83 
	if(!isString(collapse) || LENGTH(collapse) <= 0 ||
82 
	   STRING_ELT(collapse, 0) == NA_STRING)
 84 
	   STRING_ELT(collapse, 0) == NA_STRING)
Line 117... Line 119...
117 
	 * the separator) are ASCII, so is the output and we don't
 119 
	 * the separator) are ASCII, so is the output and we don't
118 
	 * need to mark.  Otherwise if all non-ASCII inputs are of
 120 
	 * need to mark.  Otherwise if all non-ASCII inputs are of
119 
	 * declared encoding, we should mark.
 121 
	 * declared encoding, we should mark.
120 
	 * Need to be careful only to include separator if it is used.
 122 
	 * Need to be careful only to include separator if it is used.
121 
	 */
 123 
	 */
122 
	anyKnown = FALSE; allKnown = TRUE;
 124 
	anyKnown = FALSE; allKnown = TRUE; use_UTF8 = FALSE;
123 
	if(nx > 1) {
 125 
	if(nx > 1) {
124 
	    allKnown = allKnown && (sepKnown || sepASCII);
 126 
	    allKnown = sepKnown || sepASCII;
125 
	    anyKnown = anyKnown || sepKnown;
 127 
	    anyKnown = sepKnown;
- 
 
 128 
	    use_UTF8 = sepUTF8;
126 
	}
 129 
	}
127 
 
 130 
 
128 
	pwidth = 0;
 131 
	pwidth = 0;
129 
	for (j = 0; j < nx; j++) {
 132 
	for (j = 0; j < nx; j++) {
130 
	    k = length(VECTOR_ELT(x, j));
 133 
	    k = length(VECTOR_ELT(x, j));
131 
	    if (k > 0)
 134 
	    if (k > 0) {
132 
		pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j),
 135 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
- 
 
 136 
		if(IS_UTF8(cs)) use_UTF8 = TRUE;
133 
							  i % k)));
 137 
	    }
134 
	}
 138 
	}
- 
 
 139 
	for (j = 0; j < nx; j++) {
- 
 
 140 
	    k = length(VECTOR_ELT(x, j));
- 
 
 141 
	    if (k > 0) {
- 
 
 142 
		if(use_UTF8)
- 
 
 143 
		    pwidth += strlen(translateCharUTF8(STRING_ELT(VECTOR_ELT(x, j), i % k)));
- 
 
 144 
		else
- 
 
 145 
		    pwidth += strlen(translateChar(STRING_ELT(VECTOR_ELT(x, j), i % k)));
- 
 
 146 
	    }
- 
 
 147 
	}
- 
 
 148 
	if (use_UTF8 && !u_csep) {
- 
 
 149 
	    u_csep = translateCharUTF8(sep);
- 
 
 150 
	    u_sepw = strlen(u_csep);
- 
 
 151 
	}
135 
	pwidth += (nx - 1) * sepw;
 152 
	pwidth += (nx - 1) * (use_UTF8 ? u_sepw : sepw);
136 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
 153 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
137 
	for (j = 0; j < nx; j++) {
 154 
	for (j = 0; j < nx; j++) {
138 
	    k = length(VECTOR_ELT(x, j));
 155 
	    k = length(VECTOR_ELT(x, j));
139 
	    if (k > 0) {
 156 
	    if (k > 0) {
140 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
 157 
		SEXP cs = STRING_ELT(VECTOR_ELT(x, j), i % k);
- 
 
 158 
		if (use_UTF8) {
- 
 
 159 
		    s = translateCharUTF8(cs);
- 
 
 160 
		    strcpy(buf, s);
- 
 
 161 
		    buf += strlen(s);
- 
 
 162 
		} else {
141 
		s = translateChar(cs);
 163 
		    s = translateChar(cs);
142 
		strcpy(buf, s);
 164 
		    strcpy(buf, s);
143 
		buf += strlen(s);
 165 
		    buf += strlen(s);
144 
		allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
 166 
		    allKnown = allKnown && (strIsASCII(s) || (ENC_KNOWN(cs)> 0));
145 
		anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
 167 
		    anyKnown = anyKnown || (ENC_KNOWN(cs)> 0);
- 
 
 168 
		}
146 
	    }
 169 
	    }
147 
	    if (j != nx - 1 && sepw != 0) {
 170 
	    if (j != nx - 1 && sepw != 0) {
- 
 
 171 
		if (use_UTF8) {
- 
 
 172 
		    strcpy(buf, u_csep);
- 
 
 173 
		    buf += u_sepw;
- 
 
 174 
		} else {
148 
		strcpy(buf, csep);
 175 
		    strcpy(buf, csep);
149 
		buf += sepw;
 176 
		    buf += sepw;
- 
 
 177 
		}
150 
	    }
 178 
	    }
151 
	}
 179 
	}
152 
	ienc = 0;
 180 
	ienc = 0;
- 
 
 181 
	if(use_UTF8) ienc = CE_UTF8;
153 
	if(anyKnown && allKnown) {
 182 
	else if(anyKnown && allKnown) {
154 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
 183 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
155 
	    if(known_to_be_utf8) ienc = CE_UTF8;
 184 
	    if(known_to_be_utf8) ienc = CE_UTF8;
156 
	}
 185 
	}
157 
	SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
 186 
	SET_STRING_ELT(ans, i, mkCharCE(cbuf, ienc));
158 
    }
 187 
    }
159 
 
 188 
 
160 
    /* Now collapse, if required. */
 189 
    /* Now collapse, if required. */
161 
 
 190 
 
162 
    if(collapse != R_NilValue && (nx = LENGTH(ans)) > 0) {
 191 
    if(collapse != R_NilValue && (nx = LENGTH(ans)) > 0) {
163 
	sep = STRING_ELT(collapse, 0);
 192 
	sep = STRING_ELT(collapse, 0);
- 
 
 193 
	use_UTF8 = IS_UTF8(sep);
- 
 
 194 
	for (i = 0; i < nx; i++)
- 
 
 195 
	    if(IS_UTF8(STRING_ELT(ans, i))) use_UTF8 = TRUE;
- 
 
 196 
	if(use_UTF8)
- 
 
 197 
	    csep = translateCharUTF8(sep);
- 
 
 198 
	else
164 
	csep = translateChar(sep);
 199 
	    csep = translateChar(sep);
165 
	sepw = strlen(csep);
 200 
	sepw = strlen(csep);
166 
	anyKnown = ENC_KNOWN(sep) > 0;
 201 
	anyKnown = ENC_KNOWN(sep) > 0;
167 
	allKnown = anyKnown || strIsASCII(csep);
 202 
	allKnown = anyKnown || strIsASCII(csep);
168 
	pwidth = 0;
 203 
	pwidth = 0;
169 
	/* 'ans' is already translated */
 - 
 
170 
	for (i = 0; i < nx; i++)
 204 
	for (i = 0; i < nx; i++)
- 
 
 205 
	    if(use_UTF8)
- 
 
 206 
		pwidth += strlen(translateCharUTF8(STRING_ELT(ans, i)));
- 
 
 207 
	    else
171 
	    pwidth += strlen(CHAR(STRING_ELT(ans, i)));
 208 
		pwidth += strlen(CHAR(STRING_ELT(ans, i)));
172 
	pwidth += (nx - 1) * sepw;
 209 
	pwidth += (nx - 1) * sepw;
173 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
 210 
	cbuf = buf = R_AllocStringBuffer(pwidth, &cbuff);
174 
	for (i = 0; i < nx; i++) {
 211 
	for (i = 0; i < nx; i++) {
175 
	    if(i > 0) {
 212 
	    if(i > 0) {
176 
		strcpy(buf, csep);
 213 
		strcpy(buf, csep);
177 
		buf += sepw;
 214 
		buf += sepw;
178 
	    }
 215 
	    }
- 
 
 216 
	    if(use_UTF8)
- 
 
 217 
		s = translateCharUTF8(STRING_ELT(ans, i));
- 
 
 218 
	    else /* already translated */
179 
	    s = CHAR(STRING_ELT(ans, i));
 219 
		s = CHAR(STRING_ELT(ans, i));
180 
	    strcpy(buf, s);
 220 
	    strcpy(buf, s);
181 
	    while (*buf)
 221 
	    while (*buf)
182 
		buf++;
 222 
		buf++;
183 
	    allKnown = allKnown &&
 223 
	    allKnown = allKnown &&
184 
		(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i))> 0));
 224 
		(strIsASCII(s) || (ENC_KNOWN(STRING_ELT(ans, i))> 0));
185 
	    anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i))> 0);
 225 
	    anyKnown = anyKnown || (ENC_KNOWN(STRING_ELT(ans, i))> 0);
186 
	}
 226 
	}
187 
	UNPROTECT(1);
 227 
	UNPROTECT(1);
188 
	ienc = 0;
 228 
	ienc = CE_NATIVE;
- 
 
 229 
	if(use_UTF8) ienc = CE_UTF8;
189 
	if(anyKnown && allKnown) {
 230 
	else if(anyKnown && allKnown) {
190 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
 231 
	    if(known_to_be_latin1) ienc = CE_LATIN1;
191 
	    if(known_to_be_utf8) ienc = CE_UTF8;
 232 
	    if(known_to_be_utf8) ienc = CE_UTF8;
192 
	}
 233 
	}
193 
	PROTECT(ans = allocVector(STRSXP, 1));
 234 
	PROTECT(ans = allocVector(STRSXP, 1));
194 
	SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));
 235 
	SET_STRING_ELT(ans, 0, mkCharCE(cbuf, ienc));