LCOV - code coverage report
Current view: top level - tests/gpgscm - ffi.c (source / functions) Hit Total Coverage
Test: coverage.info Lines: 505 687 73.5 %
Date: 2016-11-29 15:00:56 Functions: 48 62 77.4 %

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

Generated by: LCOV version 1.11