1 /* Copyright (C) 1995, 1996, 1998-2003, 2005, 2006, 2009-2014,
2 * 2016-2019 Free Software Foundation, Inc.
3 *
4 * This library is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU Lesser General Public License
6 * as published by the Free Software Foundation; either version 3 of
7 * the License, or (at your option) any later version.
8 *
9 * This library is distributed in the hope that it will be useful, but
10 * WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 * Lesser General Public License for more details.
13 *
14 * You should have received a copy of the GNU Lesser General Public
15 * License along with this library; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 * 02110-1301 USA
18 */
19
20
21
22
23 #ifdef HAVE_CONFIG_H
24 # include <config.h>
25 #endif
26
27 #include "libguile/_scm.h"
28
29 #include <stdio.h>
30 #include <unistd.h>
31 #include <intprops.h>
32
33 #include "libguile/bytevectors.h"
34 #include "libguile/eval.h"
35 #include "libguile/ports.h"
36 #include "libguile/read.h"
37 #include "libguile/strings.h"
38 #include "libguile/modules.h"
39 #include "libguile/validate.h"
40 #include "libguile/deprecation.h"
41 #include "libguile/srfi-4.h"
42
43 #include "libguile/strports.h"
44
45 #ifdef HAVE_STRING_H
46 #include <string.h>
47 #endif
48
49
50
51 /* {Ports - string ports}
52 *
53 */
54
55 SCM_SYMBOL (sym_UTF_8, "UTF-8");
56
57 scm_t_port_type *scm_string_port_type;
58
59 struct string_port {
60 SCM bytevector;
61 size_t pos;
62 size_t len;
63 };
64
65 static size_t
string_port_read(SCM port,SCM dst,size_t start,size_t count)66 string_port_read (SCM port, SCM dst, size_t start, size_t count)
67 {
68 struct string_port *stream = (void *) SCM_STREAM (port);
69
70 if (stream->pos >= stream->len)
71 return 0;
72
73 if (count > stream->len - stream->pos)
74 count = stream->len - stream->pos;
75
76 memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start,
77 SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos,
78 count);
79
80 stream->pos += count;
81 return count;
82 }
83
84 static size_t
string_port_write(SCM port,SCM src,size_t start,size_t count)85 string_port_write (SCM port, SCM src, size_t start, size_t count)
86 #define FUNC_NAME "string_port_write"
87 {
88 struct string_port *stream = (void *) SCM_STREAM (port);
89 size_t old_size = SCM_BYTEVECTOR_LENGTH (stream->bytevector);
90
91 if (count > old_size - stream->pos)
92 {
93 SCM new_bv;
94 size_t new_size;
95
96 if (INT_ADD_OVERFLOW (stream->pos, count))
97 scm_num_overflow (FUNC_NAME);
98
99 /* If (old_size * 2) overflows, it's harmless. */
100 new_size = max (old_size * 2, stream->pos + count);
101 new_bv = scm_c_make_bytevector (new_size);
102 memcpy (SCM_BYTEVECTOR_CONTENTS (new_bv),
103 SCM_BYTEVECTOR_CONTENTS (stream->bytevector),
104 stream->len);
105 stream->bytevector = new_bv;
106 }
107
108 memcpy (SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos,
109 SCM_BYTEVECTOR_CONTENTS (src) + start,
110 count);
111 stream->pos += count;
112 if (stream->pos > stream->len)
113 stream->len = stream->pos;
114
115 return count;
116 }
117 #undef FUNC_NAME
118
119 static scm_t_off
string_port_seek(SCM port,scm_t_off offset,int whence)120 string_port_seek (SCM port, scm_t_off offset, int whence)
121 #define FUNC_NAME "string_port_seek"
122 {
123 struct string_port *stream = (void *) SCM_STREAM (port);
124 size_t base;
125 scm_t_off target;
126
127 if (whence == SEEK_CUR)
128 base = stream->pos;
129 else if (whence == SEEK_SET)
130 base = 0;
131 else if (whence == SEEK_END)
132 base = stream->len;
133 else
134 scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter");
135
136 if (base > SCM_T_OFF_MAX
137 || INT_ADD_OVERFLOW ((scm_t_off) base, offset))
138 scm_num_overflow (FUNC_NAME);
139 target = (scm_t_off) base + offset;
140
141 if (target >= 0 && target <= stream->len)
142 stream->pos = target;
143 else
144 scm_out_of_range (FUNC_NAME, scm_from_off_t (offset));
145
146 return target;
147 }
148 #undef FUNC_NAME
149
150 static void
string_port_truncate(SCM port,scm_t_off length)151 string_port_truncate (SCM port, scm_t_off length)
152 #define FUNC_NAME "string_port_truncate"
153 {
154 struct string_port *stream = (void *) SCM_STREAM (port);
155
156 if (0 <= length && stream->pos <= length && length <= stream->len)
157 stream->len = length;
158 else
159 scm_out_of_range (FUNC_NAME, scm_from_off_t (length));
160 }
161 #undef FUNC_NAME
162
163
164 /* The initial size in bytes of a string port's buffer. */
165 #define INITIAL_BUFFER_SIZE 128
166
167 /* Return a new string port with MODES. If STR is #f, a new backing
168 buffer is allocated; otherwise STR must be a string and a copy of it
169 serves as the buffer for the new port. */
170 SCM
scm_mkstrport(SCM pos,SCM str,long modes,const char * caller)171 scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
172 {
173 SCM buf;
174 size_t len, byte_pos;
175 struct string_port *stream;
176
177 if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
178 scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
179
180 if (scm_is_false (str))
181 {
182 /* Allocate a new buffer to write to. */
183 buf = scm_c_make_bytevector (INITIAL_BUFFER_SIZE);
184 len = byte_pos = 0;
185 }
186 else
187 {
188 SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
189
190 buf = scm_string_to_utf8 (str);
191 len = scm_c_bytevector_length (buf);
192
193 if (scm_is_eq (pos, SCM_INUM0))
194 byte_pos = 0;
195 else
196 /* Inefficient but simple way to convert the character position
197 POS into a byte position BYTE_POS. */
198 byte_pos = scm_c_string_utf8_length
199 (scm_substring (str, SCM_INUM0, pos));
200 }
201
202 stream = scm_gc_typed_calloc (struct string_port);
203 stream->bytevector = buf;
204 stream->pos = byte_pos;
205 stream->len = len;
206
207 return
208 scm_c_make_port_with_encoding (scm_string_port_type, modes, sym_UTF_8,
209 scm_i_default_port_conversion_strategy (),
210 (scm_t_bits) stream);
211 }
212
213 /* Create a new string from the buffer of PORT, a string port, converting from
214 PORT's encoding to the standard string representation. */
215 SCM
scm_strport_to_string(SCM port)216 scm_strport_to_string (SCM port)
217 {
218 signed char *ptr;
219 struct string_port *stream = (void *) SCM_STREAM (port);
220
221 scm_flush (port);
222
223 if (stream->len == 0)
224 return scm_nullstr;
225
226 ptr = SCM_BYTEVECTOR_CONTENTS (stream->bytevector);
227 return scm_from_port_stringn ((char *) ptr, stream->len, port);
228 }
229
230 SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
231 (SCM obj, SCM printer),
232 "Return a Scheme string obtained by printing @var{obj}.\n"
233 "Printing function can be specified by the optional second\n"
234 "argument @var{printer} (default: @code{write}).")
235 #define FUNC_NAME s_scm_object_to_string
236 {
237 SCM port, result;
238
239 if (!SCM_UNBNDP (printer))
240 SCM_VALIDATE_PROC (2, printer);
241
242 port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME);
243
244 if (SCM_UNBNDP (printer))
245 scm_write (obj, port);
246 else
247 scm_call_2 (printer, obj, port);
248
249 result = scm_strport_to_string (port);
250
251 /* Explicitly close PORT so that the iconv CDs associated with it are
252 deallocated right away. This is important because CDs use a lot of
253 memory that's not visible to the GC, so not freeing them can lead
254 to almost large heap usage. See
255 <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
256 for details. */
257 scm_close_port (port);
258
259 return result;
260 }
261 #undef FUNC_NAME
262
263 SCM
scm_call_with_output_string(SCM proc)264 scm_call_with_output_string (SCM proc)
265 {
266 static SCM var = SCM_BOOL_F;
267
268 if (scm_is_false (var))
269 var = scm_c_private_lookup ("guile", "call-with-output-string");
270
271 return scm_call_1 (scm_variable_ref (var), proc);
272 }
273
274 SCM
scm_call_with_input_string(SCM string,SCM proc)275 scm_call_with_input_string (SCM string, SCM proc)
276 {
277 static SCM var = SCM_BOOL_F;
278
279 if (scm_is_false (var))
280 var = scm_c_private_lookup ("guile", "call-with-input-string");
281
282 return scm_call_2 (scm_variable_ref (var), string, proc);
283 }
284
285 SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
286 (SCM str),
287 "Take a string and return an input port that delivers characters\n"
288 "from the string. The port can be closed by\n"
289 "@code{close-input-port}, though its storage will be reclaimed\n"
290 "by the garbage collector if it becomes inaccessible.")
291 #define FUNC_NAME s_scm_open_input_string
292 {
293 return scm_mkstrport (SCM_INUM0, str, SCM_RDNG, FUNC_NAME);
294 }
295 #undef FUNC_NAME
296
297 SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
298 (void),
299 "Return an output port that will accumulate characters for\n"
300 "retrieval by @code{get-output-string}. The port can be closed\n"
301 "by the procedure @code{close-output-port}, though its storage\n"
302 "will be reclaimed by the garbage collector if it becomes\n"
303 "inaccessible.")
304 #define FUNC_NAME s_scm_open_output_string
305 {
306 return scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME);
307 }
308 #undef FUNC_NAME
309
310 SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0,
311 (SCM port),
312 "Given an output port created by @code{open-output-string},\n"
313 "return a string consisting of the characters that have been\n"
314 "output to the port so far.")
315 #define FUNC_NAME s_scm_get_output_string
316 {
317 SCM_VALIDATE_OPOUTSTRPORT (1, port);
318 return scm_strport_to_string (port);
319 }
320 #undef FUNC_NAME
321
322
323 /* Given a null-terminated string EXPR containing a Scheme expression
324 read it, and return it as an SCM value. */
325 SCM
scm_c_read_string(const char * expr)326 scm_c_read_string (const char *expr)
327 {
328 SCM port, form;
329
330 port = scm_mkstrport (SCM_INUM0, scm_from_locale_string (expr),
331 SCM_RDNG, "scm_c_read_string");
332 form = scm_read (port);
333 scm_close_port (port);
334
335 return form;
336 }
337
338 /* Given a null-terminated string EXPR containing Scheme program text,
339 evaluate it, and return the result of the last expression evaluated. */
340 SCM
scm_c_eval_string(const char * expr)341 scm_c_eval_string (const char *expr)
342 {
343 return scm_eval_string (scm_from_locale_string (expr));
344 }
345
346 SCM
scm_c_eval_string_in_module(const char * expr,SCM module)347 scm_c_eval_string_in_module (const char *expr, SCM module)
348 {
349 return scm_eval_string_in_module (scm_from_locale_string (expr), module);
350 }
351
352
353 static SCM eval_string_var;
354 static SCM k_module;
355
356 static void
init_eval_string_var_and_k_module(void)357 init_eval_string_var_and_k_module (void)
358 {
359 eval_string_var = scm_c_public_variable ("ice-9 eval-string", "eval-string");
360 k_module = scm_from_utf8_keyword ("module");
361 }
362
363 SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
364 (SCM string, SCM module),
365 "Evaluate @var{string} as the text representation of a Scheme\n"
366 "form or forms, and return whatever value they produce.\n"
367 "Evaluation takes place in the given module, or the current\n"
368 "module when no module is given.\n"
369 "While the code is evaluated, the given module is made the\n"
370 "current one. The current module is restored when this\n"
371 "procedure returns.")
372 #define FUNC_NAME s_scm_eval_string_in_module
373 {
374 static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
375 scm_i_pthread_once (&once, init_eval_string_var_and_k_module);
376
377 if (SCM_UNBNDP (module))
378 module = scm_current_module ();
379 else
380 SCM_VALIDATE_MODULE (2, module);
381
382 return scm_call_3 (scm_variable_ref (eval_string_var),
383 string, k_module, module);
384 }
385 #undef FUNC_NAME
386
387 SCM
scm_eval_string(SCM string)388 scm_eval_string (SCM string)
389 {
390 return scm_eval_string_in_module (string, SCM_UNDEFINED);
391 }
392
393 static scm_t_port_type *
scm_make_string_port_type()394 scm_make_string_port_type ()
395 {
396 scm_t_port_type *ptob = scm_make_port_type ("string",
397 string_port_read,
398 string_port_write);
399 scm_set_port_seek (ptob, string_port_seek);
400 scm_set_port_truncate (ptob, string_port_truncate);
401
402 return ptob;
403 }
404
405 void
scm_init_strports()406 scm_init_strports ()
407 {
408 scm_string_port_type = scm_make_string_port_type ();
409
410 #include "libguile/strports.x"
411 }
412
413
414 /*
415 Local Variables:
416 c-file-style: "gnu"
417 End:
418 */
419