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