gimp/plug-ins/script-fu/siod-wrapper.c

/* The GIMP -- an image manipulation program
 * Copyright (C) 1995 Spencer Kimball and Peter Mattis
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 */

#include "config.h"

#include <string.h> /* memcpy, strcpy, strlen */

#include <gtk/gtk.h>

#include "libgimp/gimp.h"

#include "siod/siod.h"

#include "script-fu-types.h"

#include "script-fu-console.h"
#include "script-fu-interface.h"
#include "script-fu-scripts.h"
#include "script-fu-server.h"

#include "siod-wrapper.h"

static int    siod_console_mode;

/* global variables declared by the scheme interpreter */
extern FILE * siod_output;
extern int    siod_verbose_level;
extern gchar  siod_err_msg[];
extern void * siod_output_routine;
extern LISP   repl_return_val;


/* defined in regex.c. not exported by regex.h */
extern void  init_regex   (void);

/* defined in siodp.h but this file cannot be imported... */
extern long  nlength (LISP obj);
extern LISP  leval_define (LISP args, LISP env);


/* wrapper functions */
FILE *
siod_get_output_file (void)
{
  return siod_output;
}

void
siod_set_output_file (FILE *file)
{
  siod_output = file;
}

void
siod_set_console_mode (int flag)
{
  siod_console_mode = flag;
}

int
siod_get_verbose_level (void)
{
  return siod_verbose_level;
}


void
siod_set_verbose_level (gint verbose_level)
{
  siod_verbose_level = verbose_level;
}

void
siod_print_welcome (void)
{
  print_welcome ();
}

gint
siod_interpret_string (const gchar *expr)
{
  return repl_c_string ((char *) expr, 0, 0, 1);
}

const gchar *
siod_get_error_msg (void)
{
  return siod_err_msg;
}

const gchar *
siod_get_success_msg (void)
{
  if (TYPEP (repl_return_val, tc_string))
    return get_c_string (repl_return_val);
  else
    return "Success";
}

void
siod_output_string (FILE        *fp,
                    const gchar *format,
                    ...)
{
  gchar   *buf;
  va_list  args;

  va_start (args, format);
  buf = g_strdup_vprintf (format, args);
  va_end (args);

  if (siod_console_mode && fp == stdout)
    {
      script_fu_output_to_console (buf);
    }
  else
    {
      fprintf (fp, buf);
      fflush (fp);
    }

  g_free (buf);
}


static void  init_constants   (void);
static void  init_procedures  (void);

static gboolean register_scripts = FALSE;

void
siod_init (gboolean local_register_scripts)
{
  gchar * siod_argv[] =
  {
    "siod",
    "-h100000:10",
    "-g0",
    "-o1000",
    "-s200000",
    "-n2048",
    "-v0",
  };

  register_scripts = local_register_scripts;
  siod_output_routine = siod_output_string;

  /* init the interpreter */
  process_cla (G_N_ELEMENTS (siod_argv), siod_argv, 1);

  init_storage ();
  init_subrs ();
  init_trace ();
  init_regex ();

  /* register in the interpreter the gimp functions and types. */
  init_procedures ();
  init_constants ();

}

static void  convert_string               (gchar    *str);
static gint  sputs_fcn                    (gchar    *st,
                                           gpointer  dest);
static LISP  lprin1s                      (LISP      exp,
                                           gchar    *dest);
static LISP  marshall_proc_db_call        (LISP      a);
static LISP  script_fu_register_call      (LISP      a);
static LISP  script_fu_menu_register_call (LISP      a);
static LISP  script_fu_quit_call          (LISP      a);


/*
 * Below can be found the functions responsible for registering the
 * gimp functions and types against the scheme interpreter.
 */


static void
init_procedures (void)
{
  gchar          **proc_list;
  gchar           *proc_blurb;
  gchar           *proc_help;
  gchar           *proc_author;
  gchar           *proc_copyright;
  gchar           *proc_date;
  GimpPDBProcType  proc_type;
  gint             nparams;
  gint             nreturn_vals;
  GimpParamDef    *params;
  GimpParamDef    *return_vals;
  gint             num_procs;
  gint             i;

  /*  register the database execution procedure  */
  init_lsubr ("gimp-proc-db-call",       marshall_proc_db_call);
  init_lsubr ("script-fu-register",      script_fu_register_call);
  init_lsubr ("script-fu-menu-register", script_fu_menu_register_call);
  init_lsubr ("script-fu-quit",          script_fu_quit_call);

  gimp_procedural_db_query (".*", ".*", ".*", ".*", ".*", ".*", ".*",
                            &num_procs, &proc_list);

  /*  Register each procedure as a scheme func  */
  for (i = 0; i < num_procs; i++)
    {
      /*  lookup the procedure  */
      if (gimp_procedural_db_proc_info (proc_list[i],
                                        &proc_blurb,
                                        &proc_help,
                                        &proc_author,
                                        &proc_copyright,
                                        &proc_date,
                                        &proc_type,
                                        &nparams, &nreturn_vals,
                                        &params, &return_vals))
        {
          LISP   args = NIL;
          LISP   code = NIL;
          gint   j;

          /*  create a new scheme func that calls gimp-proc-db-call  */
          for (j = 0; j < nparams; j++)
            {
              args = cons (rintern (params[j].name), args);
              code = cons (rintern (params[j].name), code);
            }

          /*  reverse the list  */
          args = nreverse (args);
          code = nreverse (code);

          /*  set the procedure name  */
          args = cons (rintern (proc_list[i]), args);

          /*  set the actual pdb procedure name  */
          code = cons (cons (cintern ("quote"),
                             cons (rintern (proc_list[i]), NIL)), code);
          code = cons (cintern ("gimp-proc-db-call"), code);

          leval_define (cons (args, cons (code, NIL)), NIL);

          /*  free the queried information  */
          g_free (proc_blurb);
          g_free (proc_help);
          g_free (proc_author);
          g_free (proc_copyright);
          g_free (proc_date);

          gimp_destroy_paramdefs (params, nparams);
          gimp_destroy_paramdefs (return_vals, nreturn_vals);
        }

      g_free (proc_list[i]);
    }

  g_free (proc_list);
}

static void
init_constants (void)
{
  const gchar **enum_type_names;
  gint          n_enum_type_names;
  gint          i;
  GimpUnit      unit;

  setvar (cintern ("gimp-directory"),
          strcons (-1, (gchar *) gimp_directory ()), NIL);

  setvar (cintern ("gimp-data-directory"),
          strcons (-1, (gchar *) gimp_data_directory ()), NIL);

  setvar (cintern ("gimp-plug-in-directory"),
          strcons (-1, (gchar *) gimp_plug_in_directory ()), NIL);

  setvar (cintern ("gimp-locale-directory"),
          strcons (-1, (gchar *) gimp_locale_directory ()), NIL);

  setvar (cintern ("gimp-sysconf-directory"),
          strcons (-1, (gchar *) gimp_sysconf_directory ()), NIL);

  enum_type_names = gimp_enums_get_type_names (&n_enum_type_names);

  for (i = 0; i < n_enum_type_names; i++)
    {
      const gchar *enum_name  = enum_type_names[i];
      GType        enum_type  = g_type_from_name (enum_name);
      GEnumClass  *enum_class = g_type_class_ref (enum_type);
      GEnumValue  *value;

      for (value = enum_class->values; value->value_name; value++)
        {
          if (! strncmp ("GIMP_", value->value_name, 5))
            {
              gchar *scheme_name;

              scheme_name = g_strdup (value->value_name + 5);
              convert_string (scheme_name);

              setvar (rintern (scheme_name), flocons (value->value), NIL);

              g_free (scheme_name);
            }
        }

      g_type_class_unref (enum_class);
    }

  for (unit = GIMP_UNIT_PIXEL;
       unit < gimp_unit_get_number_of_built_in_units ();
       unit++)
    {
      gchar *tmp;
      gchar *scheme_name;

      tmp = g_ascii_strup (gimp_unit_get_singular (unit), -1);
      scheme_name = g_strconcat ("UNIT-", tmp, NULL);
      g_free (tmp);

      setvar (rintern (scheme_name), flocons (unit), NIL);

      g_free (scheme_name);
    }

  /* These are for backwards compatibility; they should be removed sometime */
  setvar (cintern ("gimp-dir"),
          strcons (-1, (gchar *) gimp_directory ()), NIL);

  setvar (cintern ("gimp-data-dir"),
          strcons (-1, (gchar *) gimp_data_directory ()), NIL);

  setvar (cintern ("gimp-plugin-dir"),
          strcons (-1, (gchar *) gimp_plug_in_directory ()), NIL);

  setvar (cintern ("NORMAL"),         flocons (GIMP_NORMAL_MODE),       NIL);
  setvar (cintern ("DISSOLVE"),       flocons (GIMP_DISSOLVE_MODE),     NIL);
  setvar (cintern ("BEHIND"),         flocons (GIMP_BEHIND_MODE),       NIL);
  setvar (cintern ("MULTIPLY"),       flocons (GIMP_MULTIPLY_MODE),     NIL);
  setvar (cintern ("SCREEN"),         flocons (GIMP_SCREEN_MODE),       NIL);
  setvar (cintern ("OVERLAY"),        flocons (GIMP_OVERLAY_MODE),      NIL);
  setvar (cintern ("DIFFERENCE"),     flocons (GIMP_DIFFERENCE_MODE),   NIL);
  setvar (cintern ("ADDITION"),       flocons (GIMP_ADDITION_MODE),     NIL);
  setvar (cintern ("SUBTRACT"),       flocons (GIMP_SUBTRACT_MODE),     NIL);
  setvar (cintern ("DARKEN-ONLY"),    flocons (GIMP_DARKEN_ONLY_MODE),  NIL);
  setvar (cintern ("LIGHTEN-ONLY"),   flocons (GIMP_LIGHTEN_ONLY_MODE), NIL);
  setvar (cintern ("HUE"),            flocons (GIMP_HUE_MODE),          NIL);
  setvar (cintern ("SATURATION"),     flocons (GIMP_SATURATION_MODE),   NIL);
  setvar (cintern ("COLOR"),          flocons (GIMP_COLOR_MODE),        NIL);
  setvar (cintern ("VALUE"),          flocons (GIMP_VALUE_MODE),        NIL);
  setvar (cintern ("DIVIDE"),         flocons (GIMP_DIVIDE_MODE),       NIL);

  setvar (cintern ("BLUR"),           flocons (GIMP_BLUR_CONVOLVE),     NIL);
  setvar (cintern ("SHARPEN"),        flocons (GIMP_SHARPEN_CONVOLVE),  NIL);

  setvar (cintern ("WHITE-MASK"),     flocons (GIMP_ADD_WHITE_MASK),    NIL);
  setvar (cintern ("BLACK-MASK"),     flocons (GIMP_ADD_BLACK_MASK),    NIL);
  setvar (cintern ("ALPHA-MASK"),     flocons (GIMP_ADD_ALPHA_MASK),    NIL);

  setvar (cintern ("ADD"),         flocons (GIMP_CHANNEL_OP_ADD),       NIL);
  setvar (cintern ("SUB"),         flocons (GIMP_CHANNEL_OP_SUBTRACT),  NIL);
  setvar (cintern ("REPLACE"),     flocons (GIMP_CHANNEL_OP_REPLACE),   NIL);
  setvar (cintern ("INTERSECT"),   flocons (GIMP_CHANNEL_OP_INTERSECT), NIL);

  setvar (cintern ("FG-BG-RGB"),   flocons (GIMP_FG_BG_RGB_MODE),       NIL);
  setvar (cintern ("FG-BG-HSV"),   flocons (GIMP_FG_BG_HSV_MODE),       NIL);
  setvar (cintern ("FG-TRANS"),    flocons (GIMP_FG_TRANSPARENT_MODE),  NIL);
  setvar (cintern ("CUSTOM"),      flocons (GIMP_CUSTOM_MODE),          NIL);

  setvar (cintern ("FG-IMAGE-FILL"),    flocons (GIMP_FOREGROUND_FILL),  NIL);
  setvar (cintern ("BG-IMAGE-FILL"),    flocons (GIMP_BACKGROUND_FILL),  NIL);
  setvar (cintern ("WHITE-IMAGE-FILL"), flocons (GIMP_WHITE_FILL),       NIL);
  setvar (cintern ("TRANS-IMAGE-FILL"), flocons (GIMP_TRANSPARENT_FILL), NIL);

  setvar (cintern ("APPLY"),     flocons (GIMP_MASK_APPLY),   NIL);
  setvar (cintern ("DISCARD"),   flocons (GIMP_MASK_DISCARD), NIL);

  setvar (cintern ("HARD"),      flocons (GIMP_BRUSH_HARD), NIL);
  setvar (cintern ("SOFT"),      flocons (GIMP_BRUSH_SOFT), NIL);

  setvar (cintern ("CONTINUOUS"),  flocons (GIMP_PAINT_CONSTANT),    NIL);
  setvar (cintern ("INCREMENTAL"), flocons (GIMP_PAINT_INCREMENTAL), NIL);

  setvar (cintern ("HORIZONTAL"), flocons (GIMP_ORIENTATION_HORIZONTAL), NIL);
  setvar (cintern ("VERTICAL"),   flocons (GIMP_ORIENTATION_VERTICAL),   NIL);
  setvar (cintern ("UNKNOWN"),    flocons (GIMP_ORIENTATION_UNKNOWN),    NIL);

  setvar (cintern ("LINEAR"),               flocons (GIMP_GRADIENT_LINEAR),               NIL);
  setvar (cintern ("BILINEAR"),             flocons (GIMP_GRADIENT_BILINEAR),             NIL);
  setvar (cintern ("RADIAL"),               flocons (GIMP_GRADIENT_RADIAL),               NIL);
  setvar (cintern ("SQUARE"),               flocons (GIMP_GRADIENT_SQUARE),               NIL);
  setvar (cintern ("CONICAL-SYMMETRIC"),    flocons (GIMP_GRADIENT_CONICAL_SYMMETRIC),    NIL);
  setvar (cintern ("CONICAL-ASYMMETRIC"),   flocons (GIMP_GRADIENT_CONICAL_ASYMMETRIC),   NIL);
  setvar (cintern ("SHAPEBURST-ANGULAR"),   flocons (GIMP_GRADIENT_SHAPEBURST_ANGULAR),   NIL);
  setvar (cintern ("SHAPEBURST-SPHERICAL"), flocons (GIMP_GRADIENT_SHAPEBURST_SPHERICAL), NIL);
  setvar (cintern ("SHAPEBURST-DIMPLED"),   flocons (GIMP_GRADIENT_SHAPEBURST_DIMPLED),   NIL);
  setvar (cintern ("SPIRAL-CLOCKWISE"),     flocons (GIMP_GRADIENT_SPIRAL_CLOCKWISE),     NIL);
  setvar (cintern ("SPIRAL-ANTICLOCKWISE"), flocons (GIMP_GRADIENT_SPIRAL_ANTICLOCKWISE), NIL);

  setvar (cintern ("VALUE-LUT"), flocons (GIMP_HISTOGRAM_VALUE), NIL);
  setvar (cintern ("RED-LUT"),   flocons (GIMP_HISTOGRAM_RED),   NIL);
  setvar (cintern ("GREEN-LUT"), flocons (GIMP_HISTOGRAM_GREEN), NIL);
  setvar (cintern ("BLUE-LUT"),  flocons (GIMP_HISTOGRAM_BLUE),  NIL);
  setvar (cintern ("ALPHA-LUT"), flocons (GIMP_HISTOGRAM_ALPHA), NIL);

  /* Useful values from libgimpbase/gimplimits.h */
  setvar (cintern ("MIN-IMAGE-SIZE"), flocons (GIMP_MIN_IMAGE_SIZE), NIL);
  setvar (cintern ("MAX-IMAGE-SIZE"), flocons (GIMP_MAX_IMAGE_SIZE), NIL);
  setvar (cintern ("MIN-RESOLUTION"), flocons (GIMP_MIN_RESOLUTION), NIL);
  setvar (cintern ("MAX-RESOLUTION"), flocons (GIMP_MAX_RESOLUTION), NIL);

  /* Useful misc stuff */
  setvar (cintern ("TRUE"),           flocons (TRUE),  NIL);
  setvar (cintern ("FALSE"),          flocons (FALSE), NIL);

  /*  Script-fu types  */
  setvar (cintern ("SF-IMAGE"),       flocons (SF_IMAGE),      NIL);
  setvar (cintern ("SF-DRAWABLE"),    flocons (SF_DRAWABLE),   NIL);
  setvar (cintern ("SF-LAYER"),       flocons (SF_LAYER),      NIL);
  setvar (cintern ("SF-CHANNEL"),     flocons (SF_CHANNEL),    NIL);
  setvar (cintern ("SF-COLOR"),       flocons (SF_COLOR),      NIL);
  setvar (cintern ("SF-TOGGLE"),      flocons (SF_TOGGLE),     NIL);
  setvar (cintern ("SF-VALUE"),       flocons (SF_VALUE),      NIL);
  setvar (cintern ("SF-STRING"),      flocons (SF_STRING),     NIL);
  setvar (cintern ("SF-FILENAME"),    flocons (SF_FILENAME),   NIL);
  setvar (cintern ("SF-DIRNAME"),     flocons (SF_DIRNAME),    NIL);
  setvar (cintern ("SF-ADJUSTMENT"),  flocons (SF_ADJUSTMENT), NIL);
  setvar (cintern ("SF-FONT"),        flocons (SF_FONT),       NIL);
  setvar (cintern ("SF-PATTERN"),     flocons (SF_PATTERN),    NIL);
  setvar (cintern ("SF-BRUSH"),       flocons (SF_BRUSH),      NIL);
  setvar (cintern ("SF-GRADIENT"),    flocons (SF_GRADIENT),   NIL);
  setvar (cintern ("SF-OPTION"),      flocons (SF_OPTION),     NIL);
  setvar (cintern ("SF-PALETTE"),     flocons (SF_PALETTE),    NIL);
  setvar (cintern ("SF-TEXT"),        flocons (SF_TEXT),       NIL);
  setvar (cintern ("SF-ENUM"),        flocons (SF_ENUM),       NIL);

  /* for SF_ADJUSTMENT */
  setvar (cintern ("SF-SLIDER"),      flocons (SF_SLIDER),     NIL);
  setvar (cintern ("SF-SPINNER"),     flocons (SF_SPINNER),    NIL);
}

static void
convert_string (gchar *str)
{
  while (*str)
    {
      if (*str == '_') *str = '-';
      str++;
    }
}

static gboolean
sputs_fcn (gchar    *st,
           gpointer  dest)
{
  strcpy (*((gchar**)dest), st);
  *((gchar**)dest) += strlen (st);

  return TRUE;
}

static LISP
lprin1s (LISP   exp,
         gchar *dest)
{
  struct gen_printio s;

  s.putc_fcn    = NULL;
  s.puts_fcn    = sputs_fcn;
  s.cb_argument = &dest;

  lprin1g (exp, &s);

  return (NIL);
}


static LISP
marshall_proc_db_call (LISP a)
{
  GimpParam       *args;
  GimpParam       *values = NULL;
  gint             nvalues;
  gchar           *proc_name;
  gchar           *proc_blurb;
  gchar           *proc_help;
  gchar           *proc_author;
  gchar           *proc_copyright;
  gchar           *proc_date;
  GimpPDBProcType  proc_type;
  gint             nparams;
  gint             nreturn_vals;
  GimpParamDef    *params;
  GimpParamDef    *return_vals;
  gchar            error_str[256];
  gint             i;
  gint             success = TRUE;
  LISP             intermediate_val;
  LISP             return_val = NIL;
  gchar           *string;
  gint             string_len;
  LISP             a_saved;

  /* Save a in case it is needed for an error message. */
  a_saved = a;

  /*  Make sure there are arguments  */
  if (a == NIL)
    return my_err ("Procedure database argument marshaller was called with no arguments. "
                   "The procedure to be executed and the arguments it requires "
                   "(possibly none) must be specified.", NIL);

  /*  Derive the pdb procedure name from the argument
      or first argument of a list  */
  if (TYPEP (a, tc_cons))
    proc_name = g_strdup (get_c_string (car (a)));
  else
    proc_name = g_strdup (get_c_string (a));

  /*  report the current command  */
  script_fu_interface_report_cc (proc_name);

  /*  Attempt to fetch the procedure from the database  */
  if (! gimp_procedural_db_proc_info (proc_name,
                                      &proc_blurb,
                                      &proc_help,
                                      &proc_author,
                                      &proc_copyright,
                                      &proc_date,
                                      &proc_type,
                                      &nparams, &nreturn_vals,
                                      &params, &return_vals))
    {
      g_snprintf (error_str, sizeof (error_str),
                  "Invalid procedure name %s specified", proc_name);
      return my_err (error_str, NIL);
    }

  /* Free the name and the description which are of no use here.  */
  for (i = 0; i < nparams; i++)
    {
      g_free (params[i].name);
      g_free (params[i].description);
    }
  for (i = 0; i < nreturn_vals; i++)
    {
      g_free (return_vals[i].name);
      g_free (return_vals[i].description);
    }

  /*  Check the supplied number of arguments  */
  if ((nlength (a) - 1) != nparams)
    {
      g_snprintf (error_str, sizeof (error_str),
                  "Invalid arguments supplied to %s -- "
                  "(# args: %ld, expecting: %d)",
                  proc_name, (nlength (a) - 1), nparams);
      return my_err (error_str, NIL);
    }

  /*  Marshall the supplied arguments  */
  if (nparams)
    args = g_new (GimpParam, nparams);
  else
    args = NULL;

  for (i = 0; i < nparams && success; i++)
    {
      a = cdr (a);

      args[i].type = params[i].type;

      switch (params[i].type)
        {
        case GIMP_PDB_INT32:
        case GIMP_PDB_DISPLAY:
        case GIMP_PDB_IMAGE:
        case GIMP_PDB_LAYER:
        case GIMP_PDB_CHANNEL:
        case GIMP_PDB_DRAWABLE:
        case GIMP_PDB_SELECTION:
        case GIMP_PDB_VECTORS:
          if (!TYPEP (car (a), tc_flonum))
            success = FALSE;
          else
            args[i].data.d_int32 = get_c_long (car (a));
          break;

        case GIMP_PDB_INT16:
          if (!TYPEP (car (a), tc_flonum))
            success = FALSE;
          else
            args[i].data.d_int16 = (gint16) get_c_long (car (a));
          break;

        case GIMP_PDB_INT8:
          if (!TYPEP (car (a), tc_flonum))
            success = FALSE;
          else
            args[i].data.d_int8 = (gint8) get_c_long (car (a));
          break;

        case GIMP_PDB_FLOAT:
          if (!TYPEP (car (a), tc_flonum))
            success = FALSE;
          else
            args[i].data.d_float = get_c_double (car (a));
          break;

        case GIMP_PDB_STRING:
          if (!TYPEP (car (a), tc_string))
            success = FALSE;
          else
            args[i].data.d_string = get_c_string (car (a));
          break;

        case GIMP_PDB_INT32ARRAY:
          if (!TYPEP (car (a), tc_long_array))
            success = FALSE;
          else
            {
              gint n_elements = args[i - 1].data.d_int32;
              LISP list       = car (a);

              if ((n_elements < 0) || (n_elements > nlength (list)))
                {
                  g_snprintf (error_str, sizeof (error_str),
                              "INT32 array (argument %d) for function %s has "
                              "incorrect length (got %ld, expected %d)",
                              i + 1, proc_name, nlength (list), n_elements);
                  return my_err (error_str, NIL);
                }

              args[i].data.d_int32array =
                (gint32 *) list->storage_as.long_array.data;
            }
          break;

        case GIMP_PDB_INT16ARRAY:
          if (!TYPEP (car (a), tc_long_array))
            success = FALSE;
          else
            {
              gint n_elements = args[i - 1].data.d_int32;
              LISP list       = car (a);

              if ((n_elements < 0) || (n_elements > nlength (list)))
                {
                  g_snprintf (error_str, sizeof (error_str),
                              "INT16 array (argument %d) for function %s has "
                              "incorrect length (got %ld, expected %d)",
                              i + 1, proc_name, nlength (list), n_elements);
                  return my_err (error_str, NIL);
                }

              args[i].data.d_int16array =
                (gint16 *) list->storage_as.long_array.data;
            }
          break;

        case GIMP_PDB_INT8ARRAY:
          if (!TYPEP (car (a), tc_byte_array))
            success = FALSE;
          else
            {
              gint n_elements = args[i - 1].data.d_int32;
              LISP list       = car (a);

              if ((n_elements < 0) || (n_elements > nlength (list)))
                {
                  g_snprintf (error_str, sizeof (error_str),
                              "INT8 array (argument %d) for function %s has "
                              "incorrect length (got %ld, expected %d)",
                              i + 1, proc_name, nlength (list), n_elements);
                  return my_err (error_str, NIL);
                }

              args[i].data.d_int8array =
                (gint8 *) list->storage_as.string.data;
            }
          break;

        case GIMP_PDB_FLOATARRAY:
          if (!TYPEP (car (a), tc_double_array))
            success = FALSE;
          else
            {
              gint n_elements = args[i - 1].data.d_int32;
              LISP list       = car (a);

              if ((n_elements < 0) || (n_elements > nlength (list)))
                {
                  g_snprintf (error_str, sizeof (error_str),
                              "FLOAT array (argument %d) for function %s has "
                              "incorrect length (got %ld, expected %d)",
                              i + 1, proc_name, nlength (list), n_elements);
                  return my_err (error_str, NIL);
                }

              args[i].data.d_floatarray = list->storage_as.double_array.data;
            }
          break;

        case GIMP_PDB_STRINGARRAY:
          if (!TYPEP (car (a), tc_cons))
            success = FALSE;
          else
            {
              gint n_elements = args[i - 1].data.d_int32;
              LISP list       = car (a);
              gint j;

              if ((n_elements < 0) || (n_elements > nlength (list)))
                {
                  g_snprintf (error_str, sizeof (error_str),
                              "String array (argument %d) for function %s has "
                              "incorrect length (got %ld, expected %d)",
                              i + 1, proc_name, nlength (list), n_elements);
                  return my_err (error_str, NIL);
                }

              args[i].data.d_stringarray = g_new0 (gchar *, n_elements);

              for (j = 0; j < n_elements; j++)
                {
                  args[i].data.d_stringarray[j] = get_c_string (car (list));
                  list = cdr (list);
                }
            }
          break;

        case GIMP_PDB_COLOR:
          if (TYPEP (car (a), tc_string))
            {
              if (! gimp_rgb_parse_css (&args[i].data.d_color,
                                        get_c_string (car (a)), -1))
                success = FALSE;

              gimp_rgb_set_alpha (&args[i].data.d_color, 1.0);
            }
          else if (TYPEP (car (a), tc_cons))
            {
              LISP   color_list;
              guchar r, g, b;

              color_list = car (a);
              r = CLAMP (get_c_long (car (color_list)), 0, 255);
              color_list = cdr (color_list);
              g = CLAMP (get_c_long (car (color_list)), 0, 255);
              color_list = cdr (color_list);
              b = CLAMP (get_c_long (car (color_list)), 0, 255);

              gimp_rgba_set_uchar (&args[i].data.d_color, r, g, b, 255);
            }
          else
            {
              success = FALSE;
            }
          break;

        case GIMP_PDB_REGION:
          return my_err ("Regions are currently unsupported as arguments",
                         car (a));
          break;

        case GIMP_PDB_BOUNDARY:
          return my_err ("Boundaries are currently unsupported as arguments",
                         car (a));
          break;

        case GIMP_PDB_PARASITE:
          if (!TYPEP (car (a), tc_cons))
            success = FALSE;
          else
            {
              /* parasite->name */
              intermediate_val = car (a);

              if (!TYPEP (car (intermediate_val), tc_string))
                {
                  success = FALSE;
                  break;
                }

              args[i].data.d_parasite.name =
                get_c_string (car (intermediate_val));

              /* parasite->flags */
              intermediate_val = cdr (intermediate_val);

              if (!TYPEP (car (intermediate_val), tc_flonum))
                {
                  success = FALSE;
                  break;
                }

              args[i].data.d_parasite.flags =
                get_c_long (car (intermediate_val));

              /* parasite->size */
              intermediate_val = cdr (intermediate_val);

              if (!TYPEP (car (intermediate_val), tc_string) &&
                  !TYPEP (car (intermediate_val), tc_byte_array))
                {
                  success = FALSE;
                  break;
                }

              args[i].data.d_parasite.size =
                (car (intermediate_val))->storage_as.string.dim;

              /* parasite->data */
              args[i].data.d_parasite.data =
                (car (intermediate_val))->storage_as.string.data;
            }
          break;

        case GIMP_PDB_STATUS:
          return my_err ("Status is for return types, not arguments", car (a));

        default:
          g_snprintf (error_str, sizeof (error_str),
                      "Argument %d for %s is an unknown type",
                      i + 1, proc_name);
          return my_err (error_str, NIL);
        }
    }

  if (success)
    {
      values = gimp_run_procedure2 (proc_name, &nvalues, nparams, args);
    }
  else
    {
      g_snprintf (error_str, sizeof (error_str),
                  "Invalid type for argument %d to %s", i + 1, proc_name);
      return my_err (error_str, NIL);
    }

  /*  Check the return status  */
  if (! values)
    {
      strcpy (error_str,
              "Procedural database execution did not return a status:\n    ");
      lprin1s (a_saved, error_str + strlen (error_str));

      return my_err (error_str, NIL);
    }

  switch (values[0].data.d_status)
    {
    case GIMP_PDB_EXECUTION_ERROR:
      strcpy (error_str,
              "Procedural database execution failed:\n    ");
      lprin1s (a_saved, error_str + strlen (error_str));
      return my_err (error_str, NIL);
      break;

    case GIMP_PDB_CALLING_ERROR:
      strcpy (error_str,
              "Procedural database execution failed on invalid input arguments:\n    ");
      lprin1s (a_saved, error_str + strlen (error_str));
      return my_err (error_str, NIL);
      break;

    case GIMP_PDB_SUCCESS:
      return_val = NIL;

      for (i = 0; i < nvalues - 1; i++)
        {
          switch (return_vals[i].type)
            {
            case GIMP_PDB_INT32:
            case GIMP_PDB_DISPLAY:
            case GIMP_PDB_IMAGE:
            case GIMP_PDB_LAYER:
            case GIMP_PDB_CHANNEL:
            case GIMP_PDB_DRAWABLE:
            case GIMP_PDB_SELECTION:
            case GIMP_PDB_VECTORS:
              return_val = cons (flocons (values[i + 1].data.d_int32),
                                 return_val);
              break;

            case GIMP_PDB_INT16:
              return_val = cons (flocons (values[i + 1].data.d_int16),
                                 return_val);
              break;

            case GIMP_PDB_INT8:
              return_val = cons (flocons (values[i + 1].data.d_int8),
                                 return_val);
              break;

            case GIMP_PDB_FLOAT:
              return_val = cons (flocons (values[i + 1].data.d_float),
                                 return_val);
              break;

            case GIMP_PDB_STRING:
              string = values[i + 1].data.d_string;
              if (! string)
                string = "";
              string_len = strlen (string);
              return_val = cons (strcons (string_len, string), return_val);
              break;

            case GIMP_PDB_INT32ARRAY:
              {
                LISP array;
                gint j;

                array = arcons (tc_long_array, values[i].data.d_int32, 0);
                for (j = 0; j < values[i].data.d_int32; j++)
                  {
                    array->storage_as.long_array.data[j] =
                      values[i + 1].data.d_int32array[j];
                  }
                return_val = cons (array, return_val);
              }
              break;

            case GIMP_PDB_INT16ARRAY:
              {
                LISP array;
                gint j;

                array = arcons (tc_long_array, values[i].data.d_int32, 0);
                for (j = 0; j < values[i].data.d_int32; j++)
                  {
                    array->storage_as.long_array.data[j] =
                      values[i + 1].data.d_int16array[j];
                  }
                return_val = cons (array, return_val);
              }
              break;

            case GIMP_PDB_INT8ARRAY:
              {
                LISP array;
                gint j;

                array = arcons (tc_byte_array, values[i].data.d_int32, 0);
                for (j = 0; j < values[i].data.d_int32; j++)
                  {
                    array->storage_as.string.data[j] =
                      values[i + 1].data.d_int8array[j];
                  }
                return_val = cons (array, return_val);
              }
              break;

            case GIMP_PDB_FLOATARRAY:
              {
                LISP array;
                gint j;

                array = arcons (tc_double_array, values[i].data.d_int32, 0);
                for (j = 0; j < values[i].data.d_int32; j++)
                  {
                    array->storage_as.double_array.data[j] =
                      values[i + 1].data.d_floatarray[j];
                  }
                return_val = cons (array, return_val);
              }
              break;

            case GIMP_PDB_STRINGARRAY:
              {
                LISP array = NIL;
                gint j;

                for (j = 0; j < values[i].data.d_int32; j++)
                  {
                    string = (values[i + 1].data.d_stringarray)[j];

                    if (string)
                      {
                        string_len = strlen (string);
                        array = cons (strcons (string_len, string), array);
                      }
                    else
                      {
                        array = cons (strcons (0, ""), array);
                      }
                  }

                return_val = cons (nreverse (array), return_val);
              }
              break;

            case GIMP_PDB_COLOR:
              {
                guchar r, g, b;

                gimp_rgb_get_uchar (&values[i + 1].data.d_color, &r, &g, &b);

                intermediate_val = cons (flocons (r),
                                         cons (flocons (g),
                                               cons (flocons (b),
                                                     NIL)));
                return_val = cons (intermediate_val, return_val);
                break;
              }

            case GIMP_PDB_REGION:
              return my_err ("Regions are currently unsupported as return values", NIL);
              break;

            case GIMP_PDB_BOUNDARY:
              return my_err ("Boundaries are currently unsupported as return values", NIL);
              break;

            case GIMP_PDB_PARASITE:
              {
                LISP name, flags, data;

                if (values[i + 1].data.d_parasite.name == NULL)
                  {
                    return_val = my_err("Error: null parasite", NIL);
                  }
                else
                  {
                    string_len = strlen (values[i + 1].data.d_parasite.name);
                    name    = strcons (string_len,
                                       values[i + 1].data.d_parasite.name);

                    flags   = flocons (values[i + 1].data.d_parasite.flags);
                    data    = arcons (tc_byte_array,
                                      values[i + 1].data.d_parasite.size, 0);
                    memcpy(data->storage_as.string.data,
                           values[i + 1].data.d_parasite.data,
                           values[i + 1].data.d_parasite.size);

                    intermediate_val = cons (name,
                                             cons(flags, cons(data, NIL)));
                    return_val = cons (intermediate_val, return_val);
                  }
              }
              break;

            case GIMP_PDB_STATUS:
              return my_err ("Procedural database execution returned multiple status values", NIL);
              break;

            default:
              return my_err ("Unknown return type", NIL);
            }
        }
      break;

    case GIMP_PDB_PASS_THROUGH:
    case GIMP_PDB_CANCEL:   /*  should we do something here?  */
      break;
    }

  /*  free the proc name  */
  g_free (proc_name);

  /*  free up the executed procedure return values  */
  gimp_destroy_params (values, nvalues);

  /*  free up arguments and values  */
  g_free (args);

  /*  free the query information  */
  g_free (proc_blurb);
  g_free (proc_help);
  g_free (proc_author);
  g_free (proc_copyright);
  g_free (proc_date);
  g_free (params);
  g_free (return_vals);

  /*  reverse the return values  */
  return_val = nreverse (return_val);

  /*  if we're in server mode, listen for additional commands for 10 ms  */
  if (script_fu_server_get_mode ())
    script_fu_server_listen (10);

#ifdef GDK_WINDOWING_WIN32
  /* This seems to help a lot on Windoze. */
  while (gtk_events_pending ())
    gtk_main_iteration ();
#endif

  return return_val;
}

static LISP
script_fu_register_call (LISP a)
{
  if (register_scripts)
    return script_fu_add_script (a);
  else
    return NIL;
}

static LISP
script_fu_menu_register_call (LISP a)
{
  if (register_scripts)
    return script_fu_add_menu (a);
  else
    return NIL;
}

static LISP
script_fu_quit_call (LISP a)
{
  script_fu_server_quit ();

  return NIL;
}