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