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