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