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