Line data Source code
1 : /* FFI interface for TinySCHEME.
2 : *
3 : * Copyright (C) 2016 g10 code GmbH
4 : *
5 : * This file is part of GnuPG.
6 : *
7 : * GnuPG is free software; you can redistribute it and/or modify
8 : * it under the terms of the GNU General Public License as published by
9 : * the Free Software Foundation; either version 3 of the License, or
10 : * (at your option) any later version.
11 : *
12 : * GnuPG is distributed in the hope that it will be useful,
13 : * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 : * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 : * GNU General Public License for more details.
16 : *
17 : * You should have received a copy of the GNU General Public License
18 : * along with this program; if not, see <http://www.gnu.org/licenses/>.
19 : */
20 :
21 : #include <config.h>
22 :
23 : #include <assert.h>
24 : #include <ctype.h>
25 : #include <dirent.h>
26 : #include <errno.h>
27 : #include <fcntl.h>
28 : #include <glob.h>
29 : #include <gpg-error.h>
30 : #include <stdarg.h>
31 : #include <stdlib.h>
32 : #include <stdio.h>
33 : #include <string.h>
34 : #include <sys/types.h>
35 : #include <sys/stat.h>
36 : #include <unistd.h>
37 :
38 : #if HAVE_LIBREADLINE
39 : #include <readline/readline.h>
40 : #include <readline/history.h>
41 : #endif
42 :
43 : #include "../../common/util.h"
44 : #include "../../common/exechelp.h"
45 : #include "../../common/sysutils.h"
46 :
47 : #include "private.h"
48 : #include "ffi.h"
49 : #include "ffi-private.h"
50 :
51 :
52 :
53 : int
54 3044 : ffi_bool_value (scheme *sc, pointer p)
55 : {
56 3044 : return ! (p == sc->F);
57 : }
58 :
59 :
60 :
61 : static pointer
62 0 : do_logand (scheme *sc, pointer args)
63 : {
64 0 : FFI_PROLOG ();
65 0 : unsigned int v, acc = ~0;
66 0 : while (args != sc->NIL)
67 : {
68 0 : FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
69 0 : acc &= v;
70 : }
71 0 : FFI_RETURN_INT (sc, acc);
72 : }
73 :
74 : static pointer
75 215 : do_logior (scheme *sc, pointer args)
76 : {
77 215 : FFI_PROLOG ();
78 215 : unsigned int v, acc = 0;
79 976 : while (args != sc->NIL)
80 : {
81 546 : FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
82 546 : acc |= v;
83 : }
84 215 : FFI_RETURN_INT (sc, acc);
85 : }
86 :
87 : static pointer
88 0 : do_logxor (scheme *sc, pointer args)
89 : {
90 0 : FFI_PROLOG ();
91 0 : unsigned int v, acc = 0;
92 0 : while (args != sc->NIL)
93 : {
94 0 : FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
95 0 : acc ^= v;
96 : }
97 0 : FFI_RETURN_INT (sc, acc);
98 : }
99 :
100 : static pointer
101 0 : do_lognot (scheme *sc, pointer args)
102 : {
103 0 : FFI_PROLOG ();
104 : unsigned int v;
105 0 : FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
106 0 : FFI_ARGS_DONE_OR_RETURN (sc, args);
107 0 : FFI_RETURN_INT (sc, ~v);
108 : }
109 :
110 : /* User interface. */
111 :
112 : static pointer
113 1008 : do_flush_stdio (scheme *sc, pointer args)
114 : {
115 1008 : FFI_PROLOG ();
116 1008 : FFI_ARGS_DONE_OR_RETURN (sc, args);
117 1008 : fflush (stdout);
118 1008 : fflush (stderr);
119 1008 : FFI_RETURN (sc);
120 : }
121 :
122 :
123 : int use_libreadline;
124 :
125 : /* Read a string, and return a pointer to it. Returns NULL on EOF. */
126 : char *
127 0 : rl_gets (const char *prompt)
128 : {
129 : static char *line = NULL;
130 : char *p;
131 0 : xfree (line);
132 :
133 : #if HAVE_LIBREADLINE
134 : {
135 0 : line = readline (prompt);
136 0 : if (line && *line)
137 0 : add_history (line);
138 : }
139 : #else
140 : {
141 : size_t max_size = 0xff;
142 : printf ("%s", prompt);
143 : fflush (stdout);
144 : line = xtrymalloc (max_size);
145 : if (line != NULL)
146 : fgets (line, max_size, stdin);
147 : }
148 : #endif
149 :
150 : /* Strip trailing whitespace. */
151 0 : if (line && strlen (line) > 0)
152 0 : for (p = &line[strlen (line) - 1]; isspace (*p); p--)
153 0 : *p = 0;
154 :
155 0 : return line;
156 : }
157 :
158 : static pointer
159 0 : do_prompt (scheme *sc, pointer args)
160 : {
161 0 : FFI_PROLOG ();
162 : const char *prompt;
163 : const char *line;
164 0 : FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args);
165 0 : FFI_ARGS_DONE_OR_RETURN (sc, args);
166 0 : line = rl_gets (prompt);
167 0 : if (! line)
168 0 : FFI_RETURN_POINTER (sc, sc->EOF_OBJ);
169 :
170 0 : FFI_RETURN_STRING (sc, line);
171 : }
172 :
173 : static pointer
174 0 : do_sleep (scheme *sc, pointer args)
175 : {
176 0 : FFI_PROLOG ();
177 : unsigned int seconds;
178 0 : FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args);
179 0 : FFI_ARGS_DONE_OR_RETURN (sc, args);
180 0 : sleep (seconds);
181 0 : FFI_RETURN (sc);
182 : }
183 :
184 : static pointer
185 0 : do_usleep (scheme *sc, pointer args)
186 : {
187 0 : FFI_PROLOG ();
188 : useconds_t microseconds;
189 0 : FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args);
190 0 : FFI_ARGS_DONE_OR_RETURN (sc, args);
191 0 : usleep (microseconds);
192 0 : FFI_RETURN (sc);
193 : }
194 :
195 : static pointer
196 279 : do_chdir (scheme *sc, pointer args)
197 : {
198 279 : FFI_PROLOG ();
199 : char *name;
200 279 : FFI_ARG_OR_RETURN (sc, char *, name, path, args);
201 279 : FFI_ARGS_DONE_OR_RETURN (sc, args);
202 279 : if (chdir (name))
203 0 : FFI_RETURN_ERR (sc, errno);
204 279 : FFI_RETURN (sc);
205 : }
206 :
207 : static pointer
208 32 : do_strerror (scheme *sc, pointer args)
209 : {
210 32 : FFI_PROLOG ();
211 : int error;
212 32 : FFI_ARG_OR_RETURN (sc, int, error, number, args);
213 32 : FFI_ARGS_DONE_OR_RETURN (sc, args);
214 32 : FFI_RETURN_STRING (sc, gpg_strerror (error));
215 : }
216 :
217 : static pointer
218 5312 : do_getenv (scheme *sc, pointer args)
219 : {
220 5312 : FFI_PROLOG ();
221 : char *name;
222 : char *value;
223 5312 : FFI_ARG_OR_RETURN (sc, char *, name, string, args);
224 5312 : FFI_ARGS_DONE_OR_RETURN (sc, args);
225 5312 : value = getenv (name);
226 5312 : FFI_RETURN_STRING (sc, value ? value : "");
227 : }
228 :
229 : static pointer
230 263 : do_setenv (scheme *sc, pointer args)
231 : {
232 263 : FFI_PROLOG ();
233 : char *name;
234 : char *value;
235 : int overwrite;
236 263 : FFI_ARG_OR_RETURN (sc, char *, name, string, args);
237 263 : FFI_ARG_OR_RETURN (sc, char *, value, string, args);
238 263 : FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args);
239 263 : FFI_ARGS_DONE_OR_RETURN (sc, args);
240 263 : FFI_RETURN_ERR (sc, gnupg_setenv (name, value, overwrite));
241 : }
242 :
243 : static pointer
244 1 : do_exit (scheme *sc, pointer args)
245 : {
246 1 : FFI_PROLOG ();
247 : int retcode;
248 1 : FFI_ARG_OR_RETURN (sc, int, retcode, number, args);
249 1 : FFI_ARGS_DONE_OR_RETURN (sc, args);
250 1 : exit (retcode);
251 : }
252 :
253 : /* XXX: use gnupgs variant b/c mode as string */
254 : static pointer
255 215 : do_open (scheme *sc, pointer args)
256 : {
257 215 : FFI_PROLOG ();
258 : int fd;
259 : char *pathname;
260 : int flags;
261 215 : mode_t mode = 0;
262 215 : FFI_ARG_OR_RETURN (sc, char *, pathname, path, args);
263 215 : FFI_ARG_OR_RETURN (sc, int, flags, number, args);
264 215 : if (args != sc->NIL)
265 116 : FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args);
266 215 : FFI_ARGS_DONE_OR_RETURN (sc, args);
267 :
268 215 : fd = open (pathname, flags, mode);
269 215 : if (fd == -1)
270 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
271 215 : FFI_RETURN_INT (sc, fd);
272 : }
273 :
274 : static pointer
275 50 : do_fdopen (scheme *sc, pointer args)
276 : {
277 50 : FFI_PROLOG ();
278 : FILE *stream;
279 : int fd;
280 : char *mode;
281 : int kind;
282 50 : FFI_ARG_OR_RETURN (sc, int, fd, number, args);
283 50 : FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
284 50 : FFI_ARGS_DONE_OR_RETURN (sc, args);
285 :
286 50 : stream = fdopen (fd, mode);
287 50 : if (stream == NULL)
288 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
289 :
290 50 : if (setvbuf (stream, NULL, _IONBF, 0) != 0)
291 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
292 :
293 50 : kind = 0;
294 50 : if (strchr (mode, 'r'))
295 0 : kind |= port_input;
296 50 : if (strchr (mode, 'w'))
297 50 : kind |= port_output;
298 :
299 50 : FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind));
300 : }
301 :
302 : static pointer
303 535 : do_close (scheme *sc, pointer args)
304 : {
305 535 : FFI_PROLOG ();
306 : int fd;
307 535 : FFI_ARG_OR_RETURN (sc, int, fd, number, args);
308 535 : FFI_ARGS_DONE_OR_RETURN (sc, args);
309 535 : FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ());
310 : }
311 :
312 : static pointer
313 1206 : do_mkdtemp (scheme *sc, pointer args)
314 : {
315 1206 : FFI_PROLOG ();
316 : char *template;
317 : char buffer[128];
318 : char *name;
319 1206 : FFI_ARG_OR_RETURN (sc, char *, template, string, args);
320 1206 : FFI_ARGS_DONE_OR_RETURN (sc, args);
321 :
322 1206 : if (strlen (template) > sizeof buffer - 1)
323 0 : FFI_RETURN_ERR (sc, EINVAL);
324 1206 : strncpy (buffer, template, sizeof buffer);
325 :
326 1206 : name = gnupg_mkdtemp (buffer);
327 1206 : if (name == NULL)
328 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
329 1206 : FFI_RETURN_STRING (sc, name);
330 : }
331 :
332 : static pointer
333 1185 : do_unlink (scheme *sc, pointer args)
334 : {
335 1185 : FFI_PROLOG ();
336 : char *name;
337 1185 : FFI_ARG_OR_RETURN (sc, char *, name, string, args);
338 1185 : FFI_ARGS_DONE_OR_RETURN (sc, args);
339 1185 : if (unlink (name) == -1)
340 31 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
341 1154 : FFI_RETURN (sc);
342 : }
343 :
344 : static gpg_error_t
345 1544 : unlink_recursively (const char *name)
346 : {
347 1544 : gpg_error_t err = 0;
348 : struct stat st;
349 :
350 1544 : if (stat (name, &st) == -1)
351 1 : return gpg_error_from_syserror ();
352 :
353 1543 : if (S_ISDIR (st.st_mode))
354 : {
355 : DIR *dir;
356 : struct dirent *dent;
357 :
358 106 : dir = opendir (name);
359 106 : if (dir == NULL)
360 0 : return gpg_error_from_syserror ();
361 :
362 1910 : while ((dent = readdir (dir)))
363 : {
364 : char *child;
365 :
366 1698 : if (strcmp (dent->d_name, ".") == 0
367 1592 : || strcmp (dent->d_name, "..") == 0)
368 212 : continue;
369 :
370 1486 : child = xtryasprintf ("%s/%s", name, dent->d_name);
371 1486 : if (child == NULL)
372 : {
373 0 : err = gpg_error_from_syserror ();
374 0 : goto leave;
375 : }
376 :
377 1486 : err = unlink_recursively (child);
378 1486 : xfree (child);
379 1486 : if (err == gpg_error_from_errno (ENOENT))
380 0 : err = 0;
381 1486 : if (err)
382 0 : goto leave;
383 : }
384 :
385 : leave:
386 106 : closedir (dir);
387 106 : if (! err)
388 106 : rmdir (name);
389 106 : return err;
390 : }
391 : else
392 1437 : if (unlink (name) == -1)
393 0 : return gpg_error_from_syserror ();
394 1437 : return 0;
395 : }
396 :
397 : static pointer
398 58 : do_unlink_recursively (scheme *sc, pointer args)
399 : {
400 58 : FFI_PROLOG ();
401 : char *name;
402 58 : FFI_ARG_OR_RETURN (sc, char *, name, string, args);
403 58 : FFI_ARGS_DONE_OR_RETURN (sc, args);
404 58 : err = unlink_recursively (name);
405 58 : FFI_RETURN (sc);
406 : }
407 :
408 : static pointer
409 0 : do_rename (scheme *sc, pointer args)
410 : {
411 0 : FFI_PROLOG ();
412 : char *old;
413 : char *new;
414 0 : FFI_ARG_OR_RETURN (sc, char *, old, string, args);
415 0 : FFI_ARG_OR_RETURN (sc, char *, new, string, args);
416 0 : FFI_ARGS_DONE_OR_RETURN (sc, args);
417 0 : if (rename (old, new) == -1)
418 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
419 0 : FFI_RETURN (sc);
420 : }
421 :
422 : static pointer
423 284 : do_getcwd (scheme *sc, pointer args)
424 : {
425 284 : FFI_PROLOG ();
426 : pointer result;
427 : char *cwd;
428 284 : FFI_ARGS_DONE_OR_RETURN (sc, args);
429 284 : cwd = gnupg_getcwd ();
430 284 : if (cwd == NULL)
431 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
432 284 : result = sc->vptr->mk_string (sc, cwd);
433 284 : xfree (cwd);
434 284 : FFI_RETURN_POINTER (sc, result);
435 : }
436 :
437 : static pointer
438 3 : do_mkdir (scheme *sc, pointer args)
439 : {
440 3 : FFI_PROLOG ();
441 : char *name;
442 : char *mode;
443 3 : FFI_ARG_OR_RETURN (sc, char *, name, string, args);
444 3 : FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
445 3 : FFI_ARGS_DONE_OR_RETURN (sc, args);
446 3 : if (gnupg_mkdir (name, mode) == -1)
447 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
448 3 : FFI_RETURN (sc);
449 : }
450 :
451 : static pointer
452 1148 : do_rmdir (scheme *sc, pointer args)
453 : {
454 1148 : FFI_PROLOG ();
455 : char *name;
456 1148 : FFI_ARG_OR_RETURN (sc, char *, name, string, args);
457 1148 : FFI_ARGS_DONE_OR_RETURN (sc, args);
458 1148 : if (rmdir (name) == -1)
459 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
460 1148 : FFI_RETURN (sc);
461 : }
462 :
463 :
464 :
465 : /* estream functions. */
466 :
467 : struct es_object_box
468 : {
469 : estream_t stream;
470 : int closed;
471 : };
472 :
473 : static void
474 5892 : es_object_finalize (scheme *sc, void *data)
475 : {
476 5892 : struct es_object_box *box = data;
477 : (void) sc;
478 :
479 5892 : if (! box->closed)
480 0 : es_fclose (box->stream);
481 5892 : xfree (box);
482 5892 : }
483 :
484 : static void
485 0 : es_object_to_string (scheme *sc, char *out, size_t size, void *data)
486 : {
487 0 : struct es_object_box *box = data;
488 : (void) sc;
489 :
490 0 : snprintf (out, size, "#estream %p", box->stream);
491 0 : }
492 :
493 : static struct foreign_object_vtable es_object_vtable =
494 : {
495 : es_object_finalize,
496 : es_object_to_string,
497 : };
498 :
499 : static pointer
500 5892 : es_wrap (scheme *sc, estream_t stream)
501 : {
502 5892 : struct es_object_box *box = xmalloc (sizeof *box);
503 5892 : if (box == NULL)
504 0 : return sc->NIL;
505 :
506 5892 : box->stream = stream;
507 5892 : box->closed = 0;
508 5892 : return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box);
509 : }
510 :
511 : static struct es_object_box *
512 39780 : es_unwrap (scheme *sc, pointer object)
513 : {
514 : (void) sc;
515 :
516 39780 : if (! is_foreign_object (object))
517 0 : return NULL;
518 :
519 39780 : if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable)
520 0 : return NULL;
521 :
522 39780 : return sc->vptr->get_foreign_object_data (object);
523 : }
524 :
525 : #define CONVERSION_estream(SC, X) es_unwrap (SC, X)
526 : #define IS_A_estream(SC, X) es_unwrap (SC, X)
527 :
528 : static pointer
529 5892 : do_es_fclose (scheme *sc, pointer args)
530 : {
531 5892 : FFI_PROLOG ();
532 : struct es_object_box *box;
533 5892 : FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
534 5892 : FFI_ARGS_DONE_OR_RETURN (sc, args);
535 5892 : err = es_fclose (box->stream);
536 5892 : if (! err)
537 5892 : box->closed = 1;
538 5892 : FFI_RETURN (sc);
539 : }
540 :
541 : static pointer
542 4053 : do_es_read (scheme *sc, pointer args)
543 : {
544 4053 : FFI_PROLOG ();
545 : struct es_object_box *box;
546 : size_t bytes_to_read;
547 :
548 : pointer result;
549 : void *buffer;
550 : size_t bytes_read;
551 :
552 4053 : FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
553 4053 : FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args);
554 4053 : FFI_ARGS_DONE_OR_RETURN (sc, args);
555 :
556 4053 : buffer = xtrymalloc (bytes_to_read);
557 4053 : if (buffer == NULL)
558 0 : FFI_RETURN_ERR (sc, ENOMEM);
559 :
560 4053 : err = es_read (box->stream, buffer, bytes_to_read, &bytes_read);
561 4053 : if (err)
562 0 : FFI_RETURN_ERR (sc, err);
563 :
564 4053 : result = sc->vptr->mk_counted_string (sc, buffer, bytes_read);
565 4053 : xfree (buffer);
566 4053 : FFI_RETURN_POINTER (sc, result);
567 : }
568 :
569 : static pointer
570 7981 : do_es_feof (scheme *sc, pointer args)
571 : {
572 7981 : FFI_PROLOG ();
573 : struct es_object_box *box;
574 7981 : FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
575 7981 : FFI_ARGS_DONE_OR_RETURN (sc, args);
576 :
577 7981 : FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F);
578 : }
579 :
580 : static pointer
581 1964 : do_es_write (scheme *sc, pointer args)
582 : {
583 1964 : FFI_PROLOG ();
584 : struct es_object_box *box;
585 : const char *buffer;
586 : size_t bytes_to_write, bytes_written;
587 :
588 1964 : FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
589 : /* XXX how to get the length of the string buffer? scheme strings
590 : may contain \0. */
591 1964 : FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args);
592 1964 : FFI_ARGS_DONE_OR_RETURN (sc, args);
593 :
594 1964 : bytes_to_write = strlen (buffer);
595 4440 : while (bytes_to_write > 0)
596 : {
597 512 : err = es_write (box->stream, buffer, bytes_to_write, &bytes_written);
598 512 : if (err)
599 0 : break;
600 512 : bytes_to_write -= bytes_written;
601 512 : buffer += bytes_written;
602 : }
603 :
604 1964 : FFI_RETURN (sc);
605 : }
606 :
607 :
608 :
609 : /* Process handling. */
610 :
611 : static pointer
612 1964 : do_spawn_process (scheme *sc, pointer args)
613 : {
614 1964 : FFI_PROLOG ();
615 : pointer arguments;
616 : char **argv;
617 : size_t len;
618 : unsigned int flags;
619 :
620 : estream_t infp;
621 : estream_t outfp;
622 : estream_t errfp;
623 : pid_t pid;
624 :
625 1964 : FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
626 1964 : FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args);
627 1964 : FFI_ARGS_DONE_OR_RETURN (sc, args);
628 :
629 1964 : err = ffi_list2argv (sc, arguments, &argv, &len);
630 1964 : if (err == gpg_error (GPG_ERR_INV_VALUE))
631 0 : return ffi_sprintf (sc, "%luth element of first argument is "
632 : "neither string nor symbol",
633 : (unsigned long) len);
634 1964 : if (err)
635 0 : FFI_RETURN_ERR (sc, err);
636 :
637 1964 : if (verbose > 1)
638 : {
639 : char **p;
640 0 : fprintf (stderr, "Executing:");
641 0 : for (p = argv; *p; p++)
642 0 : fprintf (stderr, " '%s'", *p);
643 0 : fprintf (stderr, "\n");
644 : }
645 :
646 1964 : err = gnupg_spawn_process (argv[0], (const char **) &argv[1],
647 : GPG_ERR_SOURCE_DEFAULT,
648 : NULL,
649 : flags,
650 : &infp, &outfp, &errfp, &pid);
651 1964 : xfree (argv);
652 : #define IMC(A, B) \
653 : _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
654 : #define IMS(A, B) \
655 : _cons (sc, es_wrap (sc, (A)), (B), 1)
656 1964 : FFI_RETURN_POINTER (sc, IMS (infp,
657 : IMS (outfp,
658 : IMS (errfp,
659 : IMC (pid, sc->NIL)))));
660 : #undef IMS
661 : #undef IMC
662 : }
663 :
664 : static pointer
665 336 : do_spawn_process_fd (scheme *sc, pointer args)
666 : {
667 336 : FFI_PROLOG ();
668 : pointer arguments;
669 : char **argv;
670 : size_t len;
671 : int infd, outfd, errfd;
672 :
673 : pid_t pid;
674 :
675 336 : FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
676 336 : FFI_ARG_OR_RETURN (sc, int, infd, number, args);
677 336 : FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
678 336 : FFI_ARG_OR_RETURN (sc, int, errfd, number, args);
679 336 : FFI_ARGS_DONE_OR_RETURN (sc, args);
680 :
681 336 : err = ffi_list2argv (sc, arguments, &argv, &len);
682 336 : if (err == gpg_error (GPG_ERR_INV_VALUE))
683 0 : return ffi_sprintf (sc, "%luth element of first argument is "
684 : "neither string nor symbol",
685 : (unsigned long) len);
686 336 : if (err)
687 0 : FFI_RETURN_ERR (sc, err);
688 :
689 336 : if (verbose > 1)
690 : {
691 : char **p;
692 0 : fprintf (stderr, "Executing:");
693 0 : for (p = argv; *p; p++)
694 0 : fprintf (stderr, " '%s'", *p);
695 0 : fprintf (stderr, "\n");
696 : }
697 :
698 336 : err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1],
699 : infd, outfd, errfd, &pid);
700 336 : xfree (argv);
701 336 : FFI_RETURN_INT (sc, pid);
702 : }
703 :
704 : static pointer
705 2117 : do_wait_process (scheme *sc, pointer args)
706 : {
707 2117 : FFI_PROLOG ();
708 : const char *name;
709 : pid_t pid;
710 : int hang;
711 :
712 : int retcode;
713 :
714 2117 : FFI_ARG_OR_RETURN (sc, const char *, name, string, args);
715 2117 : FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args);
716 2117 : FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
717 2117 : FFI_ARGS_DONE_OR_RETURN (sc, args);
718 2117 : err = gnupg_wait_process (name, pid, hang, &retcode);
719 2117 : if (err == GPG_ERR_GENERAL)
720 18 : err = 0; /* Let the return code speak for itself. */
721 :
722 2117 : FFI_RETURN_INT (sc, retcode);
723 : }
724 :
725 :
726 : static pointer
727 134 : do_wait_processes (scheme *sc, pointer args)
728 : {
729 134 : FFI_PROLOG ();
730 : pointer list_names;
731 : char **names;
732 : pointer list_pids;
733 : size_t i, count;
734 : pid_t *pids;
735 : int hang;
736 : int *retcodes;
737 134 : pointer retcodes_list = sc->NIL;
738 :
739 134 : FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args);
740 134 : FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args);
741 134 : FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
742 134 : FFI_ARGS_DONE_OR_RETURN (sc, args);
743 :
744 268 : if (sc->vptr->list_length (sc, list_names)
745 134 : != sc->vptr->list_length (sc, list_pids))
746 0 : return
747 0 : sc->vptr->mk_string (sc, "length of first two arguments must match");
748 :
749 134 : err = ffi_list2argv (sc, list_names, &names, &count);
750 134 : if (err == gpg_error (GPG_ERR_INV_VALUE))
751 0 : return ffi_sprintf (sc, "%luth element of first argument is "
752 : "neither string nor symbol",
753 : (unsigned long) count);
754 134 : if (err)
755 0 : FFI_RETURN_ERR (sc, err);
756 :
757 134 : err = ffi_list2intv (sc, list_pids, (int **) &pids, &count);
758 134 : if (err == gpg_error (GPG_ERR_INV_VALUE))
759 0 : return ffi_sprintf (sc, "%luth element of second argument is "
760 : "neither string nor symbol",
761 : (unsigned long) count);
762 134 : if (err)
763 0 : FFI_RETURN_ERR (sc, err);
764 :
765 134 : retcodes = xtrycalloc (sizeof *retcodes, count);
766 134 : if (retcodes == NULL)
767 : {
768 0 : xfree (names);
769 0 : xfree (pids);
770 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
771 : }
772 :
773 134 : err = gnupg_wait_processes ((const char **) names, pids, count, hang,
774 : retcodes);
775 134 : if (err == GPG_ERR_GENERAL)
776 9 : err = 0; /* Let the return codes speak. */
777 :
778 317 : for (i = 0; i < count; i++)
779 183 : retcodes_list =
780 366 : (sc->vptr->cons) (sc,
781 183 : sc->vptr->mk_integer (sc,
782 183 : (long) retcodes[count-1-i]),
783 : retcodes_list);
784 :
785 134 : xfree (names);
786 134 : xfree (pids);
787 134 : xfree (retcodes);
788 134 : FFI_RETURN_POINTER (sc, retcodes_list);
789 : }
790 :
791 :
792 : static pointer
793 93 : do_pipe (scheme *sc, pointer args)
794 : {
795 93 : FFI_PROLOG ();
796 : int filedes[2];
797 93 : FFI_ARGS_DONE_OR_RETURN (sc, args);
798 93 : err = gnupg_create_pipe (filedes);
799 : #define IMC(A, B) \
800 : _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
801 93 : FFI_RETURN_POINTER (sc, IMC (filedes[0],
802 : IMC (filedes[1], sc->NIL)));
803 : #undef IMC
804 : }
805 :
806 : static pointer
807 42 : do_inbound_pipe (scheme *sc, pointer args)
808 : {
809 42 : FFI_PROLOG ();
810 : int filedes[2];
811 42 : FFI_ARGS_DONE_OR_RETURN (sc, args);
812 42 : err = gnupg_create_inbound_pipe (filedes, NULL, 0);
813 : #define IMC(A, B) \
814 : _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
815 42 : FFI_RETURN_POINTER (sc, IMC (filedes[0],
816 : IMC (filedes[1], sc->NIL)));
817 : #undef IMC
818 : }
819 :
820 : static pointer
821 49 : do_outbound_pipe (scheme *sc, pointer args)
822 : {
823 49 : FFI_PROLOG ();
824 : int filedes[2];
825 49 : FFI_ARGS_DONE_OR_RETURN (sc, args);
826 49 : err = gnupg_create_outbound_pipe (filedes, NULL, 0);
827 : #define IMC(A, B) \
828 : _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
829 49 : FFI_RETURN_POINTER (sc, IMC (filedes[0],
830 : IMC (filedes[1], sc->NIL)));
831 : #undef IMC
832 : }
833 :
834 :
835 :
836 : /* Test helper functions. */
837 : static pointer
838 530 : do_file_equal (scheme *sc, pointer args)
839 : {
840 530 : FFI_PROLOG ();
841 530 : pointer result = sc->F;
842 : char *a_name, *b_name;
843 : int binary;
844 : const char *mode;
845 530 : FILE *a_stream = NULL, *b_stream = NULL;
846 : struct stat a_stat, b_stat;
847 : #define BUFFER_SIZE 1024
848 : char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE];
849 : #undef BUFFER_SIZE
850 : size_t chunk;
851 :
852 530 : FFI_ARG_OR_RETURN (sc, char *, a_name, string, args);
853 530 : FFI_ARG_OR_RETURN (sc, char *, b_name, string, args);
854 530 : FFI_ARG_OR_RETURN (sc, int, binary, bool, args);
855 530 : FFI_ARGS_DONE_OR_RETURN (sc, args);
856 :
857 530 : mode = binary ? "rb" : "r";
858 530 : a_stream = fopen (a_name, mode);
859 530 : if (a_stream == NULL)
860 0 : goto errout;
861 :
862 530 : b_stream = fopen (b_name, mode);
863 530 : if (b_stream == NULL)
864 0 : goto errout;
865 :
866 530 : if (fstat (fileno (a_stream), &a_stat) < 0)
867 0 : goto errout;
868 :
869 530 : if (fstat (fileno (b_stream), &b_stat) < 0)
870 0 : goto errout;
871 :
872 530 : if (binary && a_stat.st_size != b_stat.st_size)
873 : {
874 0 : if (verbose)
875 0 : fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n",
876 0 : a_name, b_name, (unsigned long) a_stat.st_size,
877 0 : (unsigned long) b_stat.st_size);
878 :
879 0 : goto out;
880 : }
881 :
882 7901 : while (! feof (a_stream))
883 : {
884 6841 : chunk = sizeof a_buf;
885 :
886 6841 : chunk = fread (a_buf, 1, chunk, a_stream);
887 6841 : if (chunk == 0 && ferror (a_stream))
888 0 : goto errout; /* some error */
889 :
890 6841 : if (fread (b_buf, 1, chunk, b_stream) < chunk)
891 : {
892 0 : if (feof (b_stream))
893 0 : goto out; /* short read */
894 0 : goto errout; /* some error */
895 : }
896 :
897 6841 : if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0)
898 0 : goto out;
899 : }
900 :
901 530 : fread (b_buf, 1, 1, b_stream);
902 530 : if (! feof (b_stream))
903 0 : goto out; /* b is longer */
904 :
905 : /* They match. */
906 530 : result = sc->T;
907 :
908 : out:
909 530 : if (a_stream)
910 530 : fclose (a_stream);
911 530 : if (b_stream)
912 530 : fclose (b_stream);
913 530 : FFI_RETURN_POINTER (sc, result);
914 : errout:
915 0 : err = gpg_error_from_syserror ();
916 0 : goto out;
917 : }
918 :
919 : static pointer
920 79 : do_splice (scheme *sc, pointer args)
921 : {
922 79 : FFI_PROLOG ();
923 : int source;
924 : int sink;
925 79 : ssize_t len = -1;
926 : char buffer[1024];
927 : ssize_t bytes_read;
928 79 : FFI_ARG_OR_RETURN (sc, int, source, number, args);
929 79 : FFI_ARG_OR_RETURN (sc, int, sink, number, args);
930 79 : if (args != sc->NIL)
931 17 : FFI_ARG_OR_RETURN (sc, ssize_t, len, number, args);
932 79 : FFI_ARGS_DONE_OR_RETURN (sc, args);
933 1715 : while (len == -1 || len > 0)
934 : {
935 1619 : size_t want = sizeof buffer;
936 1619 : if (len > 0 && (ssize_t) want > len)
937 15 : want = (size_t) len;
938 :
939 1619 : bytes_read = read (source, buffer, want);
940 1619 : if (bytes_read == 0)
941 62 : break;
942 1557 : if (bytes_read < 0)
943 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
944 1557 : if (write (sink, buffer, bytes_read) != bytes_read)
945 0 : FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
946 1557 : if (len != -1)
947 54 : len -= bytes_read;
948 : }
949 79 : FFI_RETURN (sc);
950 : }
951 :
952 : static pointer
953 11202 : do_string_index (scheme *sc, pointer args)
954 : {
955 11202 : FFI_PROLOG ();
956 : char *haystack;
957 : char needle;
958 11202 : ssize_t offset = 0;
959 : char *position;
960 11202 : FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
961 11202 : FFI_ARG_OR_RETURN (sc, char, needle, character, args);
962 11202 : if (args != sc->NIL)
963 : {
964 10944 : FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
965 10944 : if (offset < 0)
966 0 : return ffi_sprintf (sc, "offset must be positive");
967 10944 : if (offset > strlen (haystack))
968 0 : return ffi_sprintf (sc, "offset exceeds haystack");
969 : }
970 11202 : FFI_ARGS_DONE_OR_RETURN (sc, args);
971 :
972 11202 : position = strchr (haystack+offset, needle);
973 11202 : if (position)
974 9644 : FFI_RETURN_INT (sc, position - haystack);
975 : else
976 1558 : FFI_RETURN_POINTER (sc, sc->F);
977 : }
978 :
979 : static pointer
980 1535 : do_string_rindex (scheme *sc, pointer args)
981 : {
982 1535 : FFI_PROLOG ();
983 : char *haystack;
984 : char needle;
985 1535 : ssize_t offset = 0;
986 : char *position;
987 1535 : FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
988 1535 : FFI_ARG_OR_RETURN (sc, char, needle, character, args);
989 1535 : if (args != sc->NIL)
990 : {
991 129 : FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
992 129 : if (offset < 0)
993 0 : return ffi_sprintf (sc, "offset must be positive");
994 129 : if (offset > strlen (haystack))
995 0 : return ffi_sprintf (sc, "offset exceeds haystack");
996 : }
997 1535 : FFI_ARGS_DONE_OR_RETURN (sc, args);
998 :
999 1535 : position = strrchr (haystack+offset, needle);
1000 1535 : if (position)
1001 1277 : FFI_RETURN_INT (sc, position - haystack);
1002 : else
1003 258 : FFI_RETURN_POINTER (sc, sc->F);
1004 : }
1005 :
1006 : static pointer
1007 471 : do_string_contains (scheme *sc, pointer args)
1008 : {
1009 471 : FFI_PROLOG ();
1010 : char *haystack;
1011 : char *needle;
1012 471 : FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
1013 471 : FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
1014 471 : FFI_ARGS_DONE_OR_RETURN (sc, args);
1015 471 : FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
1016 : }
1017 :
1018 : static pointer
1019 1 : do_glob (scheme *sc, pointer args)
1020 : {
1021 1 : FFI_PROLOG ();
1022 1 : pointer result = sc->NIL;
1023 : size_t i;
1024 : char *pattern;
1025 : glob_t pglob;
1026 1 : FFI_ARG_OR_RETURN (sc, char *, pattern, string, args);
1027 1 : FFI_ARGS_DONE_OR_RETURN (sc, args);
1028 :
1029 1 : switch (glob (pattern, 0, NULL, &pglob))
1030 : {
1031 : case 0:
1032 15 : for (i = 0; i < pglob.gl_pathc; i++)
1033 14 : result =
1034 28 : (sc->vptr->cons) (sc,
1035 14 : sc->vptr->mk_string (sc, pglob.gl_pathv[i]),
1036 : result);
1037 1 : globfree (&pglob);
1038 1 : break;
1039 :
1040 : case GLOB_NOMATCH:
1041 : /* Return the empty list. */
1042 0 : break;
1043 :
1044 : case GLOB_NOSPACE:
1045 0 : return ffi_sprintf (sc, "out of memory");
1046 : case GLOB_ABORTED:
1047 0 : return ffi_sprintf (sc, "read error");
1048 : default:
1049 0 : assert (! "not reached");
1050 : }
1051 1 : FFI_RETURN_POINTER (sc, result);
1052 : }
1053 :
1054 :
1055 :
1056 : static pointer
1057 2229 : do_get_verbose (scheme *sc, pointer args)
1058 : {
1059 2229 : FFI_PROLOG ();
1060 2229 : FFI_ARGS_DONE_OR_RETURN (sc, args);
1061 2229 : FFI_RETURN_INT (sc, verbose);
1062 : }
1063 :
1064 : static pointer
1065 0 : do_set_verbose (scheme *sc, pointer args)
1066 : {
1067 0 : FFI_PROLOG ();
1068 : int new_verbosity, old;
1069 0 : FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args);
1070 0 : FFI_ARGS_DONE_OR_RETURN (sc, args);
1071 :
1072 0 : old = verbose;
1073 0 : verbose = new_verbosity;
1074 :
1075 0 : FFI_RETURN_INT (sc, old);
1076 : }
1077 :
1078 :
1079 : gpg_error_t
1080 2434 : ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len)
1081 : {
1082 : int i;
1083 :
1084 2434 : *len = sc->vptr->list_length (sc, list);
1085 2434 : *argv = xtrycalloc (*len + 1, sizeof **argv);
1086 2434 : if (*argv == NULL)
1087 0 : return gpg_error_from_syserror ();
1088 :
1089 19793 : for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
1090 : {
1091 17359 : if (sc->vptr->is_string (sc->vptr->pair_car (list)))
1092 6958 : (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list));
1093 10401 : else if (sc->vptr->is_symbol (sc->vptr->pair_car (list)))
1094 10401 : (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list));
1095 : else
1096 : {
1097 0 : xfree (*argv);
1098 0 : *argv = NULL;
1099 0 : *len = i;
1100 0 : return gpg_error (GPG_ERR_INV_VALUE);
1101 : }
1102 : }
1103 2434 : (*argv)[i] = NULL;
1104 2434 : return 0;
1105 : }
1106 :
1107 : gpg_error_t
1108 134 : ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len)
1109 : {
1110 : int i;
1111 :
1112 134 : *len = sc->vptr->list_length (sc, list);
1113 134 : *intv = xtrycalloc (*len, sizeof **intv);
1114 134 : if (*intv == NULL)
1115 0 : return gpg_error_from_syserror ();
1116 :
1117 317 : for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
1118 : {
1119 183 : if (sc->vptr->is_number (sc->vptr->pair_car (list)))
1120 183 : (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list));
1121 : else
1122 : {
1123 0 : xfree (*intv);
1124 0 : *intv = NULL;
1125 0 : *len = i;
1126 0 : return gpg_error (GPG_ERR_INV_VALUE);
1127 : }
1128 : }
1129 :
1130 134 : return 0;
1131 : }
1132 :
1133 :
1134 : char *
1135 11094 : ffi_schemify_name (const char *s, int macro)
1136 : {
1137 : /* Fixme: We should use xtrystrdup and return NULL. However, this
1138 : * requires a lot more changes. Simply returning S as done
1139 : * originally is not an option. */
1140 11094 : char *n = xstrdup (s), *p;
1141 : /* if (n == NULL) */
1142 : /* return s; */
1143 :
1144 113004 : for (p = n; *p; p++)
1145 : {
1146 101910 : *p = (char) tolower (*p);
1147 : /* We convert _ to - in identifiers. We allow, however, for
1148 : function names to start with a leading _. The functions in
1149 : this namespace are not yet finalized and might change or
1150 : vanish without warning. Use them with care. */
1151 101910 : if (! macro
1152 90429 : && p != n
1153 80625 : && *p == '_')
1154 9417 : *p = '-';
1155 : }
1156 11094 : return n;
1157 : }
1158 :
1159 : pointer
1160 0 : ffi_sprintf (scheme *sc, const char *format, ...)
1161 : {
1162 : pointer result;
1163 : va_list listp;
1164 : char *expression;
1165 : int size, written;
1166 :
1167 0 : va_start (listp, format);
1168 0 : size = vsnprintf (NULL, 0, format, listp);
1169 0 : va_end (listp);
1170 :
1171 0 : expression = xtrymalloc (size + 1);
1172 0 : if (expression == NULL)
1173 0 : return NULL;
1174 :
1175 0 : va_start (listp, format);
1176 0 : written = vsnprintf (expression, size + 1, format, listp);
1177 0 : va_end (listp);
1178 :
1179 0 : assert (size == written);
1180 :
1181 0 : result = sc->vptr->mk_string (sc, expression);
1182 0 : xfree (expression);
1183 0 : return result;
1184 : }
1185 :
1186 : void
1187 5418 : ffi_scheme_eval (scheme *sc, const char *format, ...)
1188 : {
1189 : va_list listp;
1190 : char *expression;
1191 : int size, written;
1192 :
1193 5418 : va_start (listp, format);
1194 5418 : size = vsnprintf (NULL, 0, format, listp);
1195 5418 : va_end (listp);
1196 :
1197 5418 : expression = xtrymalloc (size + 1);
1198 5418 : if (expression == NULL)
1199 5418 : return;
1200 :
1201 5418 : va_start (listp, format);
1202 5418 : written = vsnprintf (expression, size + 1, format, listp);
1203 5418 : va_end (listp);
1204 :
1205 5418 : assert (size == written);
1206 :
1207 5418 : sc->vptr->load_string (sc, expression);
1208 5418 : xfree (expression);
1209 : }
1210 :
1211 : gpg_error_t
1212 129 : ffi_init (scheme *sc, const char *argv0, int argc, const char **argv)
1213 : {
1214 : int i;
1215 129 : pointer args = sc->NIL;
1216 :
1217 : /* bitwise arithmetic */
1218 129 : ffi_define_function (sc, logand);
1219 129 : ffi_define_function (sc, logior);
1220 129 : ffi_define_function (sc, logxor);
1221 129 : ffi_define_function (sc, lognot);
1222 :
1223 : /* libc. */
1224 129 : ffi_define_constant (sc, O_RDONLY);
1225 129 : ffi_define_constant (sc, O_WRONLY);
1226 129 : ffi_define_constant (sc, O_RDWR);
1227 129 : ffi_define_constant (sc, O_CREAT);
1228 129 : ffi_define_constant (sc, O_APPEND);
1229 : #ifndef O_BINARY
1230 : # define O_BINARY 0
1231 : #endif
1232 : #ifndef O_TEXT
1233 : # define O_TEXT 0
1234 : #endif
1235 129 : ffi_define_constant (sc, O_BINARY);
1236 129 : ffi_define_constant (sc, O_TEXT);
1237 129 : ffi_define_constant (sc, STDIN_FILENO);
1238 129 : ffi_define_constant (sc, STDOUT_FILENO);
1239 129 : ffi_define_constant (sc, STDERR_FILENO);
1240 :
1241 129 : ffi_define_function (sc, sleep);
1242 129 : ffi_define_function (sc, usleep);
1243 129 : ffi_define_function (sc, chdir);
1244 129 : ffi_define_function (sc, strerror);
1245 129 : ffi_define_function (sc, getenv);
1246 129 : ffi_define_function (sc, setenv);
1247 129 : ffi_define_function (sc, exit);
1248 129 : ffi_define_function (sc, open);
1249 129 : ffi_define_function (sc, fdopen);
1250 129 : ffi_define_function (sc, close);
1251 129 : ffi_define_function_name (sc, "_mkdtemp", mkdtemp);
1252 129 : ffi_define_function (sc, unlink);
1253 129 : ffi_define_function (sc, unlink_recursively);
1254 129 : ffi_define_function (sc, rename);
1255 129 : ffi_define_function (sc, getcwd);
1256 129 : ffi_define_function (sc, mkdir);
1257 129 : ffi_define_function (sc, rmdir);
1258 :
1259 : /* Process management. */
1260 129 : ffi_define_function (sc, spawn_process);
1261 129 : ffi_define_function (sc, spawn_process_fd);
1262 129 : ffi_define_function (sc, wait_process);
1263 129 : ffi_define_function (sc, wait_processes);
1264 129 : ffi_define_function (sc, pipe);
1265 129 : ffi_define_function (sc, inbound_pipe);
1266 129 : ffi_define_function (sc, outbound_pipe);
1267 :
1268 : /* estream functions. */
1269 129 : ffi_define_function_name (sc, "es-fclose", es_fclose);
1270 129 : ffi_define_function_name (sc, "es-read", es_read);
1271 129 : ffi_define_function_name (sc, "es-feof", es_feof);
1272 129 : ffi_define_function_name (sc, "es-write", es_write);
1273 :
1274 : /* Test helper functions. */
1275 129 : ffi_define_function (sc, file_equal);
1276 129 : ffi_define_function (sc, splice);
1277 129 : ffi_define_function (sc, string_index);
1278 129 : ffi_define_function (sc, string_rindex);
1279 129 : ffi_define_function_name (sc, "string-contains?", string_contains);
1280 129 : ffi_define_function (sc, glob);
1281 :
1282 : /* User interface. */
1283 129 : ffi_define_function (sc, flush_stdio);
1284 129 : ffi_define_function (sc, prompt);
1285 :
1286 : /* Configuration. */
1287 129 : ffi_define_function_name (sc, "*verbose*", get_verbose);
1288 129 : ffi_define_function_name (sc, "*set-verbose!*", set_verbose);
1289 :
1290 129 : ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0));
1291 254 : for (i = argc - 1; i >= 0; i--)
1292 : {
1293 125 : pointer value = sc->vptr->mk_string (sc, argv[i]);
1294 125 : args = (sc->vptr->cons) (sc, value, args);
1295 : }
1296 129 : ffi_define (sc, "*args*", args);
1297 :
1298 : #if _WIN32
1299 : ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';'));
1300 : #else
1301 129 : ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':'));
1302 : #endif
1303 :
1304 129 : ffi_define (sc, "*stdin*",
1305 : sc->vptr->mk_port_from_file (sc, stdin, port_input));
1306 129 : ffi_define (sc, "*stdout*",
1307 : sc->vptr->mk_port_from_file (sc, stdout, port_output));
1308 129 : ffi_define (sc, "*stderr*",
1309 : sc->vptr->mk_port_from_file (sc, stderr, port_output));
1310 :
1311 129 : return 0;
1312 : }
|
