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