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