829384ae185fe21bd1ff69ac848f595c8a52a136
[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   char *value;
222   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
223   FFI_ARGS_DONE_OR_RETURN (sc, args);
224   value = getenv (name);
225   FFI_RETURN_STRING (sc, value ? value : "");
226 }
227
228 static pointer
229 do_setenv (scheme *sc, pointer args)
230 {
231   FFI_PROLOG ();
232   char *name;
233   char *value;
234   int overwrite;
235   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
236   FFI_ARG_OR_RETURN (sc, char *, value, string, args);
237   FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args);
238   FFI_ARGS_DONE_OR_RETURN (sc, args);
239   FFI_RETURN_ERR (sc, gnupg_setenv (name, value, overwrite));
240 }
241
242 static pointer
243 do_exit (scheme *sc, pointer args)
244 {
245   FFI_PROLOG ();
246   int retcode;
247   FFI_ARG_OR_RETURN (sc, int, retcode, number, args);
248   FFI_ARGS_DONE_OR_RETURN (sc, args);
249   exit (retcode);
250 }
251
252 /* XXX: use gnupgs variant b/c mode as string */
253 static pointer
254 do_open (scheme *sc, pointer args)
255 {
256   FFI_PROLOG ();
257   int fd;
258   char *pathname;
259   int flags;
260   mode_t mode = 0;
261   FFI_ARG_OR_RETURN (sc, char *, pathname, path, args);
262   FFI_ARG_OR_RETURN (sc, int, flags, number, args);
263   if (args != sc->NIL)
264     FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args);
265   FFI_ARGS_DONE_OR_RETURN (sc, args);
266
267   fd = open (pathname, flags, mode);
268   if (fd == -1)
269     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
270   FFI_RETURN_INT (sc, fd);
271 }
272
273 static pointer
274 do_fdopen (scheme *sc, pointer args)
275 {
276   FFI_PROLOG ();
277   FILE *stream;
278   int fd;
279   char *mode;
280   int kind;
281   FFI_ARG_OR_RETURN (sc, int, fd, number, args);
282   FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
283   FFI_ARGS_DONE_OR_RETURN (sc, args);
284
285   stream = fdopen (fd, mode);
286   if (stream == NULL)
287     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
288
289   if (setvbuf (stream, NULL, _IONBF, 0) != 0)
290     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
291
292   kind = 0;
293   if (strchr (mode, 'r'))
294     kind |= port_input;
295   if (strchr (mode, 'w'))
296     kind |= port_output;
297
298   FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind));
299 }
300
301 static pointer
302 do_close (scheme *sc, pointer args)
303 {
304   FFI_PROLOG ();
305   int fd;
306   FFI_ARG_OR_RETURN (sc, int, fd, number, args);
307   FFI_ARGS_DONE_OR_RETURN (sc, args);
308   FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ());
309 }
310
311 static pointer
312 do_mkdtemp (scheme *sc, pointer args)
313 {
314   FFI_PROLOG ();
315   char *template;
316   char buffer[128];
317   char *name;
318   FFI_ARG_OR_RETURN (sc, char *, template, string, args);
319   FFI_ARGS_DONE_OR_RETURN (sc, args);
320
321   if (strlen (template) > sizeof buffer - 1)
322     FFI_RETURN_ERR (sc, EINVAL);
323   strncpy (buffer, template, sizeof buffer);
324
325   name = gnupg_mkdtemp (buffer);
326   if (name == NULL)
327     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
328   FFI_RETURN_STRING (sc, name);
329 }
330
331 static pointer
332 do_unlink (scheme *sc, pointer args)
333 {
334   FFI_PROLOG ();
335   char *name;
336   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
337   FFI_ARGS_DONE_OR_RETURN (sc, args);
338   if (unlink (name) == -1)
339     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
340   FFI_RETURN (sc);
341 }
342
343 static gpg_error_t
344 unlink_recursively (const char *name)
345 {
346   gpg_error_t err = 0;
347   struct stat st;
348
349   if (stat (name, &st) == -1)
350     return gpg_error_from_syserror ();
351
352   if (S_ISDIR (st.st_mode))
353     {
354       DIR *dir;
355       struct dirent *dent;
356
357       dir = opendir (name);
358       if (dir == NULL)
359         return gpg_error_from_syserror ();
360
361       while ((dent = readdir (dir)))
362         {
363           char *child;
364
365           if (strcmp (dent->d_name, ".") == 0
366               || strcmp (dent->d_name, "..") == 0)
367             continue;
368
369           child = xtryasprintf ("%s/%s", name, dent->d_name);
370           if (child == NULL)
371             {
372               err = gpg_error_from_syserror ();
373               goto leave;
374             }
375
376           err = unlink_recursively (child);
377           xfree (child);
378           if (err == gpg_error_from_errno (ENOENT))
379             err = 0;
380           if (err)
381             goto leave;
382         }
383
384     leave:
385       closedir (dir);
386       if (! err)
387         rmdir (name);
388       return err;
389     }
390   else
391     if (unlink (name) == -1)
392       return gpg_error_from_syserror ();
393   return 0;
394 }
395
396 static pointer
397 do_unlink_recursively (scheme *sc, pointer args)
398 {
399   FFI_PROLOG ();
400   char *name;
401   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
402   FFI_ARGS_DONE_OR_RETURN (sc, args);
403   err = unlink_recursively (name);
404   FFI_RETURN (sc);
405 }
406
407 static pointer
408 do_rename (scheme *sc, pointer args)
409 {
410   FFI_PROLOG ();
411   char *old;
412   char *new;
413   FFI_ARG_OR_RETURN (sc, char *, old, string, args);
414   FFI_ARG_OR_RETURN (sc, char *, new, string, args);
415   FFI_ARGS_DONE_OR_RETURN (sc, args);
416   if (rename (old, new) == -1)
417     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
418   FFI_RETURN (sc);
419 }
420
421 static pointer
422 do_getcwd (scheme *sc, pointer args)
423 {
424   FFI_PROLOG ();
425   pointer result;
426   char *cwd;
427   FFI_ARGS_DONE_OR_RETURN (sc, args);
428   cwd = gnupg_getcwd ();
429   if (cwd == NULL)
430     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
431   result = sc->vptr->mk_string (sc, cwd);
432   xfree (cwd);
433   FFI_RETURN_POINTER (sc, result);
434 }
435
436 static pointer
437 do_mkdir (scheme *sc, pointer args)
438 {
439   FFI_PROLOG ();
440   char *name;
441   char *mode;
442   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
443   FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
444   FFI_ARGS_DONE_OR_RETURN (sc, args);
445   if (gnupg_mkdir (name, mode) == -1)
446     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
447   FFI_RETURN (sc);
448 }
449
450 static pointer
451 do_rmdir (scheme *sc, pointer args)
452 {
453   FFI_PROLOG ();
454   char *name;
455   FFI_ARG_OR_RETURN (sc, char *, name, string, args);
456   FFI_ARGS_DONE_OR_RETURN (sc, args);
457   if (rmdir (name) == -1)
458     FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
459   FFI_RETURN (sc);
460 }
461
462 static pointer
463 do_get_isotime (scheme *sc, pointer args)
464 {
465   FFI_PROLOG ();
466   gnupg_isotime_t timebuf;
467   FFI_ARGS_DONE_OR_RETURN (sc, args);
468   gnupg_get_isotime (timebuf);
469   FFI_RETURN_STRING (sc, timebuf);
470 }
471
472 \f
473
474 /* estream functions.  */
475
476 struct es_object_box
477 {
478   estream_t stream;
479   int closed;
480 };
481
482 static void
483 es_object_finalize (scheme *sc, void *data)
484 {
485   struct es_object_box *box = data;
486   (void) sc;
487
488   if (! box->closed)
489     es_fclose (box->stream);
490   xfree (box);
491 }
492
493 static void
494 es_object_to_string (scheme *sc, char *out, size_t size, void *data)
495 {
496   struct es_object_box *box = data;
497   (void) sc;
498
499   snprintf (out, size, "#estream %p", box->stream);
500 }
501
502 static struct foreign_object_vtable es_object_vtable =
503   {
504     es_object_finalize,
505     es_object_to_string,
506   };
507
508 static pointer
509 es_wrap (scheme *sc, estream_t stream)
510 {
511   struct es_object_box *box = xmalloc (sizeof *box);
512   if (box == NULL)
513     return sc->NIL;
514
515   box->stream = stream;
516   box->closed = 0;
517   return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box);
518 }
519
520 static struct es_object_box *
521 es_unwrap (scheme *sc, pointer object)
522 {
523   (void) sc;
524
525   if (! is_foreign_object (object))
526     return NULL;
527
528   if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable)
529     return NULL;
530
531   return sc->vptr->get_foreign_object_data (object);
532 }
533
534 #define CONVERSION_estream(SC, X)       es_unwrap (SC, X)
535 #define IS_A_estream(SC, X)             es_unwrap (SC, X)
536
537 static pointer
538 do_es_fclose (scheme *sc, pointer args)
539 {
540   FFI_PROLOG ();
541   struct es_object_box *box;
542   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
543   FFI_ARGS_DONE_OR_RETURN (sc, args);
544   err = es_fclose (box->stream);
545   if (! err)
546     box->closed = 1;
547   FFI_RETURN (sc);
548 }
549
550 static pointer
551 do_es_read (scheme *sc, pointer args)
552 {
553   FFI_PROLOG ();
554   struct es_object_box *box;
555   size_t bytes_to_read;
556
557   pointer result;
558   void *buffer;
559   size_t bytes_read;
560
561   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
562   FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args);
563   FFI_ARGS_DONE_OR_RETURN (sc, args);
564
565   buffer = xtrymalloc (bytes_to_read);
566   if (buffer == NULL)
567     FFI_RETURN_ERR (sc, ENOMEM);
568
569   err = es_read (box->stream, buffer, bytes_to_read, &bytes_read);
570   if (err)
571     FFI_RETURN_ERR (sc, err);
572
573   result = sc->vptr->mk_counted_string (sc, buffer, bytes_read);
574   xfree (buffer);
575   FFI_RETURN_POINTER (sc, result);
576 }
577
578 static pointer
579 do_es_feof (scheme *sc, pointer args)
580 {
581   FFI_PROLOG ();
582   struct es_object_box *box;
583   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
584   FFI_ARGS_DONE_OR_RETURN (sc, args);
585
586   FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F);
587 }
588
589 static pointer
590 do_es_write (scheme *sc, pointer args)
591 {
592   FFI_PROLOG ();
593   struct es_object_box *box;
594   const char *buffer;
595   size_t bytes_to_write, bytes_written;
596
597   FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
598   /* XXX how to get the length of the string buffer?  scheme strings
599      may contain \0.  */
600   FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args);
601   FFI_ARGS_DONE_OR_RETURN (sc, args);
602
603   bytes_to_write = strlen (buffer);
604   while (bytes_to_write > 0)
605     {
606       err = es_write (box->stream, buffer, bytes_to_write, &bytes_written);
607       if (err)
608         break;
609       bytes_to_write -= bytes_written;
610       buffer += bytes_written;
611     }
612
613   FFI_RETURN (sc);
614 }
615
616 \f
617
618 /* Process handling.  */
619
620 static pointer
621 do_spawn_process (scheme *sc, pointer args)
622 {
623   FFI_PROLOG ();
624   pointer arguments;
625   char **argv;
626   size_t len;
627   unsigned int flags;
628
629   estream_t infp;
630   estream_t outfp;
631   estream_t errfp;
632   pid_t pid;
633
634   FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
635   FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args);
636   FFI_ARGS_DONE_OR_RETURN (sc, args);
637
638   err = ffi_list2argv (sc, arguments, &argv, &len);
639   if (err == gpg_error (GPG_ERR_INV_VALUE))
640     return ffi_sprintf (sc, "%luth element of first argument is "
641                         "neither string nor symbol",
642                         (unsigned long) len);
643   if (err)
644     FFI_RETURN_ERR (sc, err);
645
646   if (verbose > 1)
647     {
648       char **p;
649       fprintf (stderr, "Executing:");
650       for (p = argv; *p; p++)
651         fprintf (stderr, " '%s'", *p);
652       fprintf (stderr, "\n");
653     }
654
655   err = gnupg_spawn_process (argv[0], (const char **) &argv[1],
656                              GPG_ERR_SOURCE_DEFAULT,
657                              NULL,
658                              flags,
659                              &infp, &outfp, &errfp, &pid);
660   xfree (argv);
661 #define IMC(A, B)                                                       \
662   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
663 #define IMS(A, B)                                                       \
664   _cons (sc, es_wrap (sc, (A)), (B), 1)
665   FFI_RETURN_POINTER (sc, IMS (infp,
666                               IMS (outfp,
667                                    IMS (errfp,
668                                         IMC (pid, sc->NIL)))));
669 #undef IMS
670 #undef IMC
671 }
672
673 static pointer
674 do_spawn_process_fd (scheme *sc, pointer args)
675 {
676   FFI_PROLOG ();
677   pointer arguments;
678   char **argv;
679   size_t len;
680   int infd, outfd, errfd;
681
682   pid_t pid;
683
684   FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
685   FFI_ARG_OR_RETURN (sc, int, infd, number, args);
686   FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
687   FFI_ARG_OR_RETURN (sc, int, errfd, number, args);
688   FFI_ARGS_DONE_OR_RETURN (sc, args);
689
690   err = ffi_list2argv (sc, arguments, &argv, &len);
691   if (err == gpg_error (GPG_ERR_INV_VALUE))
692     return ffi_sprintf (sc, "%luth element of first argument is "
693                         "neither string nor symbol",
694                         (unsigned long) len);
695   if (err)
696     FFI_RETURN_ERR (sc, err);
697
698   if (verbose > 1)
699     {
700       char **p;
701       fprintf (stderr, "Executing:");
702       for (p = argv; *p; p++)
703         fprintf (stderr, " '%s'", *p);
704       fprintf (stderr, "\n");
705     }
706
707   err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1],
708                                 infd, outfd, errfd, &pid);
709   xfree (argv);
710   FFI_RETURN_INT (sc, pid);
711 }
712
713 static pointer
714 do_wait_process (scheme *sc, pointer args)
715 {
716   FFI_PROLOG ();
717   const char *name;
718   pid_t pid;
719   int hang;
720
721   int retcode;
722
723   FFI_ARG_OR_RETURN (sc, const char *, name, string, args);
724   FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args);
725   FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
726   FFI_ARGS_DONE_OR_RETURN (sc, args);
727   err = gnupg_wait_process (name, pid, hang, &retcode);
728   if (err == GPG_ERR_GENERAL)
729     err = 0;    /* Let the return code speak for itself.  */
730
731   FFI_RETURN_INT (sc, retcode);
732 }
733
734
735 static pointer
736 do_wait_processes (scheme *sc, pointer args)
737 {
738   FFI_PROLOG ();
739   pointer list_names;
740   char **names;
741   pointer list_pids;
742   size_t i, count;
743   pid_t *pids;
744   int hang;
745   int *retcodes;
746   pointer retcodes_list = sc->NIL;
747
748   FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args);
749   FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args);
750   FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
751   FFI_ARGS_DONE_OR_RETURN (sc, args);
752
753   if (sc->vptr->list_length (sc, list_names)
754       != sc->vptr->list_length (sc, list_pids))
755     return
756       sc->vptr->mk_string (sc, "length of first two arguments must match");
757
758   err = ffi_list2argv (sc, list_names, &names, &count);
759   if (err == gpg_error (GPG_ERR_INV_VALUE))
760     return ffi_sprintf (sc, "%luth element of first argument is "
761                         "neither string nor symbol",
762                         (unsigned long) count);
763   if (err)
764     FFI_RETURN_ERR (sc, err);
765
766   err = ffi_list2intv (sc, list_pids, (int **) &pids, &count);
767   if (err == gpg_error (GPG_ERR_INV_VALUE))
768     return ffi_sprintf (sc, "%luth element of second argument is "
769                         "neither string nor symbol",
770                         (unsigned long) count);
771   if (err)
772     FFI_RETURN_ERR (sc, err);
773
774   retcodes = xtrycalloc (sizeof *retcodes, count);
775   if (retcodes == NULL)
776     {
777       xfree (names);
778       xfree (pids);
779       FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
780     }
781
782   err = gnupg_wait_processes ((const char **) names, pids, count, hang,
783                               retcodes);
784   if (err == GPG_ERR_GENERAL)
785     err = 0;    /* Let the return codes speak.  */
786
787   for (i = 0; i < count; i++)
788     retcodes_list =
789       (sc->vptr->cons) (sc,
790                         sc->vptr->mk_integer (sc,
791                                               (long) retcodes[count-1-i]),
792                         retcodes_list);
793
794   xfree (names);
795   xfree (pids);
796   xfree (retcodes);
797   FFI_RETURN_POINTER (sc, retcodes_list);
798 }
799
800
801 static pointer
802 do_pipe (scheme *sc, pointer args)
803 {
804   FFI_PROLOG ();
805   int filedes[2];
806   FFI_ARGS_DONE_OR_RETURN (sc, args);
807   err = gnupg_create_pipe (filedes);
808 #define IMC(A, B)                                                       \
809   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
810   FFI_RETURN_POINTER (sc, IMC (filedes[0],
811                               IMC (filedes[1], sc->NIL)));
812 #undef IMC
813 }
814
815 static pointer
816 do_inbound_pipe (scheme *sc, pointer args)
817 {
818   FFI_PROLOG ();
819   int filedes[2];
820   FFI_ARGS_DONE_OR_RETURN (sc, args);
821   err = gnupg_create_inbound_pipe (filedes, NULL, 0);
822 #define IMC(A, B)                                                       \
823   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
824   FFI_RETURN_POINTER (sc, IMC (filedes[0],
825                               IMC (filedes[1], sc->NIL)));
826 #undef IMC
827 }
828
829 static pointer
830 do_outbound_pipe (scheme *sc, pointer args)
831 {
832   FFI_PROLOG ();
833   int filedes[2];
834   FFI_ARGS_DONE_OR_RETURN (sc, args);
835   err = gnupg_create_outbound_pipe (filedes, NULL, 0);
836 #define IMC(A, B)                                                       \
837   _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
838   FFI_RETURN_POINTER (sc, IMC (filedes[0],
839                               IMC (filedes[1], sc->NIL)));
840 #undef IMC
841 }
842
843 \f
844
845 /* Test helper functions.  */
846 static pointer
847 do_file_equal (scheme *sc, pointer args)
848 {
849   FFI_PROLOG ();
850   pointer result = sc->F;
851   char *a_name, *b_name;
852   int binary;
853   const char *mode;
854   FILE *a_stream = NULL, *b_stream = NULL;
855   struct stat a_stat, b_stat;
856 #define BUFFER_SIZE     1024
857   char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE];
858 #undef BUFFER_SIZE
859   size_t chunk;
860
861   FFI_ARG_OR_RETURN (sc, char *, a_name, string, args);
862   FFI_ARG_OR_RETURN (sc, char *, b_name, string, args);
863   FFI_ARG_OR_RETURN (sc, int, binary, bool, args);
864   FFI_ARGS_DONE_OR_RETURN (sc, args);
865
866   mode = binary ? "rb" : "r";
867   a_stream = fopen (a_name, mode);
868   if (a_stream == NULL)
869     goto errout;
870
871   b_stream = fopen (b_name, mode);
872   if (b_stream == NULL)
873     goto errout;
874
875   if (fstat (fileno (a_stream), &a_stat) < 0)
876     goto errout;
877
878   if (fstat (fileno (b_stream), &b_stat) < 0)
879     goto errout;
880
881   if (binary && a_stat.st_size != b_stat.st_size)
882     {
883       if (verbose)
884         fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n",
885                  a_name, b_name, (unsigned long) a_stat.st_size,
886                  (unsigned long) b_stat.st_size);
887
888       goto out;
889     }
890
891   while (! feof (a_stream))
892     {
893       chunk = sizeof a_buf;
894
895       chunk = fread (a_buf, 1, chunk, a_stream);
896       if (chunk == 0 && ferror (a_stream))
897         goto errout;    /* some error */
898
899       if (fread (b_buf, 1, chunk, b_stream) < chunk)
900         {
901           if (feof (b_stream))
902             goto out;   /* short read */
903           goto errout;  /* some error */
904         }
905
906       if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0)
907         goto out;
908     }
909
910   fread (b_buf, 1, 1, b_stream);
911   if (! feof (b_stream))
912     goto out;   /* b is longer */
913
914   /* They match.  */
915   result = sc->T;
916
917  out:
918   if (a_stream)
919     fclose (a_stream);
920   if (b_stream)
921     fclose (b_stream);
922   FFI_RETURN_POINTER (sc, result);
923  errout:
924   err = gpg_error_from_syserror ();
925   goto out;
926 }
927
928 static pointer
929 do_splice (scheme *sc, pointer args)
930 {
931   FFI_PROLOG ();
932   int source;
933   int sink;
934   ssize_t len = -1;
935   char buffer[1024];
936   ssize_t bytes_read;
937   FFI_ARG_OR_RETURN (sc, int, source, number, args);
938   FFI_ARG_OR_RETURN (sc, int, sink, number, args);
939   if (args != sc->NIL)
940     FFI_ARG_OR_RETURN (sc, ssize_t, len, number, args);
941   FFI_ARGS_DONE_OR_RETURN (sc, args);
942   while (len == -1 || len > 0)
943     {
944       size_t want = sizeof buffer;
945       if (len > 0 && (ssize_t) want > len)
946         want = (size_t) len;
947
948       bytes_read = read (source, buffer, want);
949       if (bytes_read == 0)
950         break;
951       if (bytes_read < 0)
952         FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
953       if (write (sink, buffer, bytes_read) != bytes_read)
954         FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
955       if (len != -1)
956         len -= bytes_read;
957     }
958   FFI_RETURN (sc);
959 }
960
961 static pointer
962 do_string_index (scheme *sc, pointer args)
963 {
964   FFI_PROLOG ();
965   char *haystack;
966   char needle;
967   ssize_t offset = 0;
968   char *position;
969   FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
970   FFI_ARG_OR_RETURN (sc, char, needle, character, args);
971   if (args != sc->NIL)
972     {
973       FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
974       if (offset < 0)
975         return ffi_sprintf (sc, "offset must be positive");
976       if (offset > strlen (haystack))
977         return ffi_sprintf (sc, "offset exceeds haystack");
978     }
979   FFI_ARGS_DONE_OR_RETURN (sc, args);
980
981   position = strchr (haystack+offset, needle);
982   if (position)
983     FFI_RETURN_INT (sc, position - haystack);
984   else
985     FFI_RETURN_POINTER (sc, sc->F);
986 }
987
988 static pointer
989 do_string_rindex (scheme *sc, pointer args)
990 {
991   FFI_PROLOG ();
992   char *haystack;
993   char needle;
994   ssize_t offset = 0;
995   char *position;
996   FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
997   FFI_ARG_OR_RETURN (sc, char, needle, character, args);
998   if (args != sc->NIL)
999     {
1000       FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
1001       if (offset < 0)
1002         return ffi_sprintf (sc, "offset must be positive");
1003       if (offset > strlen (haystack))
1004         return ffi_sprintf (sc, "offset exceeds haystack");
1005     }
1006   FFI_ARGS_DONE_OR_RETURN (sc, args);
1007
1008   position = strrchr (haystack+offset, needle);
1009   if (position)
1010     FFI_RETURN_INT (sc, position - haystack);
1011   else
1012     FFI_RETURN_POINTER (sc, sc->F);
1013 }
1014
1015 static pointer
1016 do_string_contains (scheme *sc, pointer args)
1017 {
1018   FFI_PROLOG ();
1019   char *haystack;
1020   char *needle;
1021   FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
1022   FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
1023   FFI_ARGS_DONE_OR_RETURN (sc, args);
1024   FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
1025 }
1026
1027 \f
1028
1029 static pointer
1030 do_get_verbose (scheme *sc, pointer args)
1031 {
1032   FFI_PROLOG ();
1033   FFI_ARGS_DONE_OR_RETURN (sc, args);
1034   FFI_RETURN_INT (sc, verbose);
1035 }
1036
1037 static pointer
1038 do_set_verbose (scheme *sc, pointer args)
1039 {
1040   FFI_PROLOG ();
1041   int new_verbosity, old;
1042   FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args);
1043   FFI_ARGS_DONE_OR_RETURN (sc, args);
1044
1045   old = verbose;
1046   verbose = new_verbosity;
1047
1048   FFI_RETURN_INT (sc, old);
1049 }
1050
1051 \f
1052 gpg_error_t
1053 ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len)
1054 {
1055   int i;
1056
1057   *len = sc->vptr->list_length (sc, list);
1058   *argv = xtrycalloc (*len + 1, sizeof **argv);
1059   if (*argv == NULL)
1060     return gpg_error_from_syserror ();
1061
1062   for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
1063     {
1064       if (sc->vptr->is_string (sc->vptr->pair_car (list)))
1065         (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list));
1066       else if (sc->vptr->is_symbol (sc->vptr->pair_car (list)))
1067         (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list));
1068       else
1069         {
1070           xfree (*argv);
1071           *argv = NULL;
1072           *len = i;
1073           return gpg_error (GPG_ERR_INV_VALUE);
1074         }
1075     }
1076   (*argv)[i] = NULL;
1077   return 0;
1078 }
1079
1080 gpg_error_t
1081 ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len)
1082 {
1083   int i;
1084
1085   *len = sc->vptr->list_length (sc, list);
1086   *intv = xtrycalloc (*len, sizeof **intv);
1087   if (*intv == NULL)
1088     return gpg_error_from_syserror ();
1089
1090   for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
1091     {
1092       if (sc->vptr->is_number (sc->vptr->pair_car (list)))
1093         (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list));
1094       else
1095         {
1096           xfree (*intv);
1097           *intv = NULL;
1098           *len = i;
1099           return gpg_error (GPG_ERR_INV_VALUE);
1100         }
1101     }
1102
1103   return 0;
1104 }
1105
1106 \f
1107 char *
1108 ffi_schemify_name (const char *s, int macro)
1109 {
1110   /* Fixme: We should use xtrystrdup and return NULL.  However, this
1111    * requires a lot more changes.  Simply returning S as done
1112    * originally is not an option.  */
1113   char *n = xstrdup (s), *p;
1114   /* if (n == NULL) */
1115   /*   return s; */
1116
1117   for (p = n; *p; p++)
1118     {
1119       *p = (char) tolower (*p);
1120        /* We convert _ to - in identifiers.  We allow, however, for
1121           function names to start with a leading _.  The functions in
1122           this namespace are not yet finalized and might change or
1123           vanish without warning.  Use them with care.  */
1124       if (! macro
1125           && p != n
1126           && *p == '_')
1127         *p = '-';
1128     }
1129   return n;
1130 }
1131
1132 pointer
1133 ffi_sprintf (scheme *sc, const char *format, ...)
1134 {
1135   pointer result;
1136   va_list listp;
1137   char *expression;
1138   int size, written;
1139
1140   va_start (listp, format);
1141   size = vsnprintf (NULL, 0, format, listp);
1142   va_end (listp);
1143
1144   expression = xtrymalloc (size + 1);
1145   if (expression == NULL)
1146     return NULL;
1147
1148   va_start (listp, format);
1149   written = vsnprintf (expression, size + 1, format, listp);
1150   va_end (listp);
1151
1152   assert (size == written);
1153
1154   result = sc->vptr->mk_string (sc, expression);
1155   xfree (expression);
1156   return result;
1157 }
1158
1159 void
1160 ffi_scheme_eval (scheme *sc, const char *format, ...)
1161 {
1162   va_list listp;
1163   char *expression;
1164   int size, written;
1165
1166   va_start (listp, format);
1167   size = vsnprintf (NULL, 0, format, listp);
1168   va_end (listp);
1169
1170   expression = xtrymalloc (size + 1);
1171   if (expression == NULL)
1172     return;
1173
1174   va_start (listp, format);
1175   written = vsnprintf (expression, size + 1, format, listp);
1176   va_end (listp);
1177
1178   assert (size == written);
1179
1180   sc->vptr->load_string (sc, expression);
1181   xfree (expression);
1182 }
1183
1184 gpg_error_t
1185 ffi_init (scheme *sc, const char *argv0, const char *scriptname,
1186           int argc, const char **argv)
1187 {
1188   int i;
1189   pointer args = sc->NIL;
1190
1191   /* bitwise arithmetic */
1192   ffi_define_function (sc, logand);
1193   ffi_define_function (sc, logior);
1194   ffi_define_function (sc, logxor);
1195   ffi_define_function (sc, lognot);
1196
1197   /* libc.  */
1198   ffi_define_constant (sc, O_RDONLY);
1199   ffi_define_constant (sc, O_WRONLY);
1200   ffi_define_constant (sc, O_RDWR);
1201   ffi_define_constant (sc, O_CREAT);
1202   ffi_define_constant (sc, O_APPEND);
1203 #ifndef O_BINARY
1204 # define O_BINARY       0
1205 #endif
1206 #ifndef O_TEXT
1207 # define O_TEXT         0
1208 #endif
1209   ffi_define_constant (sc, O_BINARY);
1210   ffi_define_constant (sc, O_TEXT);
1211   ffi_define_constant (sc, STDIN_FILENO);
1212   ffi_define_constant (sc, STDOUT_FILENO);
1213   ffi_define_constant (sc, STDERR_FILENO);
1214
1215   ffi_define_function (sc, sleep);
1216   ffi_define_function (sc, usleep);
1217   ffi_define_function (sc, chdir);
1218   ffi_define_function (sc, strerror);
1219   ffi_define_function (sc, getenv);
1220   ffi_define_function (sc, setenv);
1221   ffi_define_function_name (sc, "_exit", exit);
1222   ffi_define_function (sc, open);
1223   ffi_define_function (sc, fdopen);
1224   ffi_define_function (sc, close);
1225   ffi_define_function_name (sc, "_mkdtemp", mkdtemp);
1226   ffi_define_function (sc, unlink);
1227   ffi_define_function (sc, unlink_recursively);
1228   ffi_define_function (sc, rename);
1229   ffi_define_function (sc, getcwd);
1230   ffi_define_function (sc, mkdir);
1231   ffi_define_function (sc, rmdir);
1232   ffi_define_function (sc, get_isotime);
1233
1234   /* Process management.  */
1235   ffi_define_function (sc, spawn_process);
1236   ffi_define_function (sc, spawn_process_fd);
1237   ffi_define_function (sc, wait_process);
1238   ffi_define_function (sc, wait_processes);
1239   ffi_define_function (sc, pipe);
1240   ffi_define_function (sc, inbound_pipe);
1241   ffi_define_function (sc, outbound_pipe);
1242
1243   /* estream functions.  */
1244   ffi_define_function_name (sc, "es-fclose", es_fclose);
1245   ffi_define_function_name (sc, "es-read", es_read);
1246   ffi_define_function_name (sc, "es-feof", es_feof);
1247   ffi_define_function_name (sc, "es-write", es_write);
1248
1249   /* Test helper functions.  */
1250   ffi_define_function (sc, file_equal);
1251   ffi_define_function (sc, splice);
1252   ffi_define_function (sc, string_index);
1253   ffi_define_function (sc, string_rindex);
1254   ffi_define_function_name (sc, "string-contains?", string_contains);
1255
1256   /* User interface.  */
1257   ffi_define_function (sc, flush_stdio);
1258   ffi_define_function (sc, prompt);
1259
1260   /* Configuration.  */
1261   ffi_define_function_name (sc, "*verbose*", get_verbose);
1262   ffi_define_function_name (sc, "*set-verbose!*", set_verbose);
1263
1264   ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0));
1265   ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname));
1266   for (i = argc - 1; i >= 0; i--)
1267     {
1268       pointer value = sc->vptr->mk_string (sc, argv[i]);
1269       args = (sc->vptr->cons) (sc, value, args);
1270     }
1271   ffi_define (sc, "*args*", args);
1272
1273 #if _WIN32
1274   ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';'));
1275 #else
1276   ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':'));
1277 #endif
1278
1279   ffi_define (sc, "*stdin*",
1280               sc->vptr->mk_port_from_file (sc, stdin, port_input));
1281   ffi_define (sc, "*stdout*",
1282               sc->vptr->mk_port_from_file (sc, stdout, port_output));
1283   ffi_define (sc, "*stderr*",
1284               sc->vptr->mk_port_from_file (sc, stderr, port_output));
1285
1286   return 0;
1287 }