PIKApp/plug-ins/script-fu/libscriptfu/scheme-marshal-return.c

/* PIKA - Photo and Image Kooker Application
 * a rebranding of The GNU Image Manipulation Program (created with heckimp)
 * A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
 *
 * Original copyright, applying to most contents (license remains unchanged): 
 * 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 3 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, see <https://www.gnu.org/licenses/>.
 */

#include "config.h"
#include "libpika/pika.h"
#include "tinyscheme/scheme-private.h"
#include "script-fu-errors.h"
#include "scheme-marshal.h"
#include "scheme-marshal-return.h"

/* When include scheme-private.h, must undef cons macro */
#undef cons

static pointer marshal_PDB_return_by_arity  (scheme         *sc,
                                             PikaValueArray *values,
                                             pointer        *error);

static pointer marshal_returned_PDB_values  (scheme         *sc,
                                             PikaValueArray *values,
                                             pointer        *error);

static pointer marshal_returned_PDB_value   (scheme        *sc,
                                             GValue        *value,
                                             guint          array_length,
                                             pointer       *error);


/* Marshall a GValueArray returned by a PDB procedure.
 * From a GValueArray into scheme value or error.
 *
 * Understands PDB status values.
 * Delegates most marshalling to marshal_PDB_return_by_arity.
 * See its doc string.
 */
pointer
marshal_PDB_return (scheme         *sc,
                    PikaValueArray *values,
                    gchar          *proc_name,
                    pointer        *error)
{
  gchar   error_str[1024];
  pointer result = NULL;

  *error = NULL;

  /* caller asserts status value index 0 exists. */
  switch (PIKA_VALUES_GET_ENUM (values, 0))
    {
    case PIKA_PDB_EXECUTION_ERROR:
      if (pika_value_array_length (values) > 1 &&
          G_VALUE_HOLDS_STRING (pika_value_array_index (values, 1)))
        {
          g_snprintf (error_str, sizeof (error_str),
                      "Procedure execution of %s failed: %s",
                      proc_name,
                      PIKA_VALUES_GET_STRING (values, 1));
        }
      else
        {
          g_snprintf (error_str, sizeof (error_str),
                      "Procedure execution of %s failed",
                      proc_name);
        }
        /* not language errors, procedure returned error for unknown reason. */
      *error = foreign_error (sc, error_str, 0);
      break;

    case PIKA_PDB_CALLING_ERROR:
      if (pika_value_array_length (values) > 1 &&
          G_VALUE_HOLDS_STRING (pika_value_array_index (values, 1)))
        {
          g_snprintf (error_str, sizeof (error_str),
                      "Procedure execution of %s failed on invalid input arguments: %s",
                      proc_name,
                      PIKA_VALUES_GET_STRING (values, 1));
        }
      else
        {
          g_snprintf (error_str, sizeof (error_str),
                      "Procedure execution of %s failed on invalid input arguments",
                      proc_name);
        }
      /* not language errors, PIKA validated the GValueArray
       * and decided it doesn't match the registered signature
       * or the procedure decided its preconditions not met (e.g. out of range)
       */
      *error = foreign_error (sc, error_str, 0);
      break;

    case PIKA_PDB_SUCCESS:
      {
        pointer marshalling_error;

        result = marshal_PDB_return_by_arity (sc, values, &marshalling_error);
        if (marshalling_error != NULL)
          {
            /* Error marshalling set of values.
             * Any scheme values already marshalled will be garbage collected.
             */
            /* Propagate. */
            *error = marshalling_error;
            g_assert (result == NULL);
          }
        /* else assert result is not NULL but can be sc->NIL */
      }
      break;

    case PIKA_PDB_PASS_THROUGH:
      /* Should not happen. No plugin in the repo returns this.
       * See app/pdb/pika-pdb.c for what little doc there is.
       * It says there the result should be discarded
       * in lieu of the subsequent procedure's result.
       * */
      g_warning ("Status is PASS_THROUGH, not handled properly.");
      result = sc->vptr->cons (sc, sc->F, sc->NIL);

    case PIKA_PDB_CANCEL:
      /* A PDB procedure called interactively showed a dialog which the user cancelled. */
      g_debug ("cancelled PDB proc returns (#f)");
      /* A scheme function must return a value.
       * Return false to indicate canceled. But is not an error.
       *
       * This is moot because you can't call a plugin interactively from a script anyway.
       * (Top level scripts can be called interactively.)
       *
       * FUTURE: (when a script can call another script passing run mode INTERACTIVE)
       * A well written script should not call PDB procedure interactively (cancelable)
       * without checking whether the result is just #f or the expected value signature.
       * No PDB procedure returning boolean should be called interactively from ScriptFu
       * since you can't distinguish canceled from another false result.
       * You can call such a procedure only for its side effects, if you ignore the result.
       */
      /* Returning (#f),
       * FUTURE: return only #f, no reason to wrap.
       */
      result = sc->vptr->cons (sc, sc->F, sc->NIL);
      break;
    } /* end switch on PDB status. */

  g_assert (   (result == NULL && *error != NULL)
            || (result != NULL && *error == NULL));
  return result;
}


/* Marshall a GValueArray returned by a PDB procedure.
 * From a GValueArray into scheme value.
 *
 * Understands the return arity of PDB procedures.
 *
 * Returns a scheme "pointer" type referencing the scheme return value.
 *
 * The return value is a list.
 * FUTURE: value is either a single value or a list.
 *
 * Same error return as marshal_returned_PDB_values.
 */
pointer
marshal_PDB_return_by_arity (scheme         *sc,
                             PikaValueArray *values,
                             pointer        *error)
{
  /* NULL, not defaulting to sc->NIL. */
  pointer result = NULL;
  pointer marshalling_error = NULL;
  gint   return_arity;

  *error = NULL;

  /* values has an extra status value over the return arity of the procedure.
   * This is actual signature of the returned values.
   * Could compare with the declared formal signature.
   */
  return_arity = pika_value_array_length (values) - 1;

  /* Require caller ensured there is a status value. */
  g_assert (return_arity >= 0);

  if (return_arity == 0)
    {
      /* PDB procedure returns void.
       * Every scheme function must return a value.
       * Return (#t)
       * FUTURE: return just sc->T, no reason to wrap it.
       * result = sc->T;
       */
      g_debug ("void PDB proc returns (#t)");
      result = sc->vptr->cons (sc, sc->T, sc->NIL);
    }
  else if (return_arity == 1)
    {
      /* Unary result.
       * Return a list wrapping the result.
       * FUTURE: return just unwrapped result (which can itself be a list.)
       * i.e. just call marshal_returned_PDB_value (singular)
       */
      result = marshal_returned_PDB_values (sc, values, &marshalling_error);
      if (marshalling_error != NULL)
        {
          /* Propagate error. */
          *error = marshalling_error;
        }
    }
  else /* >1 */
    {
      /* Many result values.
       * Return a list wrapping the results. Similar to Python tuple return.
       */
      result = marshal_returned_PDB_values (sc, values, &marshalling_error);
      if (marshalling_error != NULL)
        {
          /* Propagate error. */
          *error = marshalling_error;
        }
    }
  g_assert (   (result == NULL && *error != NULL)
            || (result != NULL && *error == NULL));
  /* result is: (#t) or sc->NIL i.e. empty list or a non-empty list. */
  /* FUTURE result is: #t or an atom or a vector
   * or empty list or a non-empty list.
   * A non-empty list is either a single result that itself is a list
   * or a list wrapping a multiple result.
   */
  return result;
}


/* Marshall a set of values returned by a PDB procedure.
 * From a GValueArray into scheme list.
 *
 * Returns a scheme "pointer" type referencing the scheme list.
 *
 * Either returns a non-null scheme value and sets error to null,
 * or sets error and returns a null scheme value.
 * IOW, error is an OUT argument.
 *
 * The returned scheme value is scheme type list.
 * The list can be non-homogenous (elements of different scheme types.)
 *
 * The returned list may be empty or have only a single element.
 * FUTURE:
 * When a PDB procedure returns a single value (which can be a container)
 * do not wrap it in a list.
 * It will be an error to call this function
 * for PDB procedures that return a single value or return void.
 * IOW, for PDB procedures of return arity < 2.
 */
static pointer
marshal_returned_PDB_values (scheme         *sc,
                             PikaValueArray *values,
                             pointer        *error)
{
  /* Result is empty list. */
  pointer result = sc->NIL;

  *error = NULL;

  /* Counting down, i.e. traversing in reverse.
  * i+1 is the current index.  i is the preceding value.
  * When at the current index is an array, preceding value (at i) is array length.
  */
  for (gint i = pika_value_array_length (values) - 2; i >= 0; --i)
    {
      GValue *value = pika_value_array_index (values, i + 1);
      pointer scheme_value;
      pointer single_error = NULL;
      gint32  array_length = 0;

      g_debug ("Return value %d is type %s", i+1, G_VALUE_TYPE_NAME (value));

      /* In some cases previous value is array_length. */
      if (   PIKA_VALUE_HOLDS_INT32_ARRAY (value)
          || PIKA_VALUE_HOLDS_FLOAT_ARRAY (value)
          || PIKA_VALUE_HOLDS_RGB_ARRAY   (value))
        {
          array_length = PIKA_VALUES_GET_INT (values, i);
        }

      scheme_value = marshal_returned_PDB_value (sc, value, array_length, &single_error);

      if (single_error == NULL)
        {
          /* Prepend to scheme list of returned values and continue iteration. */
          result = sc->vptr->cons (sc, scheme_value, result);
        }
      else
        {
          /* Error marshalling a single return value.
          * Any scheme values already marshalled will be garbage collected.
          */
          /* Propagate error to caller. */
          *error = single_error;
          /* null C pointer not the same as pointer to scheme NIL */
          result = NULL;
          break;
        }
    }

  g_assert (   (result == NULL && *error != NULL)
            || (result != NULL && *error == NULL));
  /* result can be sc->NIL i.e. empty list. */
  return result;
}



/* The below code for array results is not safe.
 * It implicitly requires, but does not explicitly check,
 * that the returned length equals the actual length of the returned array,
 * and iterates over the returned array assuming it has the returned length.
 * It could read past the end of the array.
 */

/* Convert a GValue from C type to Scheme type.
 *
 * Returns a scheme "pointer" type referencing the scheme value.
 *
 * When the value has C type an array type,
 * array_length must be its length,
 * otherwise array_length is not used.
 *
 * Either returns a non-null scheme value and sets error to null,
 * or sets error and returns a null scheme value.
 * IOW, error is an OUT argument.
 *
 * The returned scheme value is an atom or a container (list or vector.)
 * Returned containers are homogeneous (elements all the same type.)
 * Returned atoms are scheme type number or string.
 * Currently, does not return atoms of scheme type byte or char
 * (no PDB procedure returns those types.)
 *
 * !!! Returns a scheme number (0 or 1) for C type boolean.
 * FUTURE: return atoms #f and #t.
 */
static pointer
marshal_returned_PDB_value    (scheme        *sc,
                               GValue        *value,
                               guint          array_length,
                               pointer       *error)
{
  pointer  result = sc->NIL;
  gint     j;
  gchar    error_str[1024];

  *error = NULL;

  /* Order is important.
    * GFile before other objects.
    * PIKA Image, Drawable, etc. objects.
    * Alternatively, more specific tests.
    */
  if (G_VALUE_TYPE (value) == G_TYPE_FILE)
    {
      gchar *parsed_filepath = marshal_returned_gfile_to_string (value);

      if (parsed_filepath)
        {
          g_debug ("PDB procedure returned GFile '%s'", parsed_filepath);
          /* copy string into interpreter state. */
          result = sc->vptr->mk_string (sc, parsed_filepath);
          g_free (parsed_filepath);
        }
      else
        {
          g_warning ("PDB procedure failed to return a valid GFile");
          result = sc->vptr->mk_string (sc, "");
        }
      /* Ensure result holds a string, possibly empty. */
    }
  else if (G_VALUE_HOLDS_OBJECT (value))
    {
      /* G_VALUE_HOLDS_OBJECT only ensures value derives from GObject.
        * Could be a PIKA or a GLib type.
        * Here we handle PIKA types, which all have an id property.
        * Resources, Images, Drawables etc. have an int ID.
        */
      GObject *object = g_value_get_object (value);
      gint     id     = -1;

      /* expect a PIKA opaque object having an "id" property */
      if (object)
        g_object_get (object, "id", &id, NULL);

      /* id is -1 when the gvalue had no GObject*,
        * or the referenced object had no property "id".
        * This can be an undetected fault in the called procedure.
        * It is not necessarily an error in the script.
        */
      if (id == -1)
        g_warning ("PDB procedure returned NULL PIKA object.");

      g_debug ("PDB procedure returned object ID: %i", id);

      /* Scriptfu stores object IDs as int. */
      result = sc->vptr->mk_integer (sc, id);
    }
  else if (G_VALUE_HOLDS_INT (value))
    {
      gint v = g_value_get_int (value);
      result = sc->vptr->mk_integer (sc, v);
    }
  else if (G_VALUE_HOLDS_UINT (value))
    {
      guint v = g_value_get_uint (value);
      result = sc->vptr->mk_integer (sc, v);
    }
  else if (G_VALUE_HOLDS_DOUBLE (value))
    {
      gdouble v = g_value_get_double (value);
      result = sc->vptr->mk_real (sc, v);
    }
  else if (G_VALUE_HOLDS_ENUM (value))
    {
      gint v = g_value_get_enum (value);
      result = sc->vptr->mk_integer (sc, v);
    }
  else if (G_VALUE_HOLDS_BOOLEAN (value))
    {
      gboolean v = g_value_get_boolean (value);
      result = sc->vptr->mk_integer (sc, v);
    }
  else if (G_VALUE_HOLDS_STRING (value))
    {
      const gchar *v = g_value_get_string (value);

      if (! v)
        v = "";

      result = sc->vptr->mk_string (sc, v);
    }
  else if (PIKA_VALUE_HOLDS_INT32_ARRAY (value))
    {
      const gint32 *v      = pika_value_get_int32_array (value);
      pointer       vector = sc->vptr->mk_vector (sc, array_length);

      for (j = 0; j < array_length; j++)
        {
          sc->vptr->set_vector_elem (vector, j,
                                      sc->vptr->mk_integer (sc, v[j]));
        }

      result = vector;
    }
  else if (G_VALUE_HOLDS (value, G_TYPE_BYTES))
    {
      GBytes       *v_bytes  = g_value_get_boxed (value);
      const guint8 *v        = g_bytes_get_data (v_bytes, NULL);
      gsize         n        = g_bytes_get_size (v_bytes);
      pointer       vector   = sc->vptr->mk_vector (sc, n);

      for (j = 0; j < n; j++)
        {
          sc->vptr->set_vector_elem (vector, j,
                                      sc->vptr->mk_integer (sc, v[j]));
        }

      result = vector;
    }
  else if (PIKA_VALUE_HOLDS_FLOAT_ARRAY (value))
    {
      const gdouble *v      = pika_value_get_float_array (value);
      pointer        vector = sc->vptr->mk_vector (sc, array_length);

      for (j = 0; j < array_length; j++)
        {
          sc->vptr->set_vector_elem (vector, j,
                                      sc->vptr->mk_real (sc, v[j]));
        }

      result = vector;
    }
  else if (G_VALUE_HOLDS (value, G_TYPE_STRV))
    {
      gint32         n    = 0;
      const gchar  **v    = g_value_get_boxed (value);
      pointer        list = sc->NIL;

      n = (v)? g_strv_length ((char **) v) : 0;
      for (j = n - 1; j >= 0; j--)
        {
          list = sc->vptr->cons (sc,
                                  sc->vptr->mk_string (sc,
                                                      v[j] ?
                                                      v[j] : ""),
                                  list);
        }

      result = list;
    }
  else if (PIKA_VALUE_HOLDS_RGB (value))
    {
      PikaRGB  v;
      guchar   r, g, b;
      gpointer temp_val;

      pika_value_get_rgb (value, &v);
      pika_rgb_get_uchar (&v, &r, &g, &b);

      temp_val = sc->vptr->cons
                    (sc,
                    sc->vptr->mk_integer (sc, r),
                    sc->vptr->cons
                      (sc,
                        sc->vptr->mk_integer (sc, g),
                        sc->vptr->cons
                          (sc,
                          sc->vptr->mk_integer (sc, b),
                          sc->NIL)));

      result = temp_val;
    }
  else if (PIKA_VALUE_HOLDS_RGB_ARRAY (value))
    {
      const PikaRGB  *v = pika_value_get_rgb_array (value);
      pointer  vector   = sc->vptr->mk_vector (sc, array_length);

      for (j = 0; j < array_length; j++)
        {
          guchar  r, g, b;
          pointer temp_val;

          pika_rgb_get_uchar (&v[j], &r, &g, &b);

          temp_val = sc->vptr->cons
                      (sc,
                        sc->vptr->mk_integer (sc, r),
                        sc->vptr->cons
                          (sc,
                          sc->vptr->mk_integer (sc, g),
                          sc->vptr->cons
                            (sc,
                              sc->vptr->mk_integer (sc, b),
                              sc->NIL)));
          sc->vptr->set_vector_elem (vector, j, temp_val);
        }

      result = vector;
    }
  else if (PIKA_VALUE_HOLDS_PARASITE (value))
    {
      PikaParasite *v = g_value_get_boxed (value);

      if (v->name == NULL)
        {
          /* Wrongly passed a Parasite that appears to be null, or other error. */
          *error = implementation_error (sc, "Error: null parasite", 0);
        }
      else
        {
          gchar   *data = g_strndup (v->data, v->size);
          gint     char_cnt = g_utf8_strlen (data, v->size);
          pointer  temp_val;

          /* don't move the mk_foo() calls outside this function call,
            * otherwise they might be garbage collected away!
            */
          temp_val = sc->vptr->cons
                        (sc,
                        sc->vptr->mk_string (sc, v->name),
                        sc->vptr->cons
                          (sc,
                            sc->vptr->mk_integer (sc, v->flags),
                            sc->vptr->cons
                              (sc,
                              sc->vptr->mk_counted_string (sc,
                                                            data,
                                                            char_cnt),
                              sc->NIL)));

          result = temp_val;
          g_free (data);

          g_debug ("name '%s'", v->name);
          g_debug ("flags %d", v->flags);
          g_debug ("size %d", v->size);
          g_debug ("data '%.*s'", v->size, (gchar *) v->data);
        }
    }
  else if (PIKA_VALUE_HOLDS_OBJECT_ARRAY (value))
    {
      result = marshal_returned_object_array_to_vector (sc, value);
    }
  else if (G_VALUE_TYPE (&value) == PIKA_TYPE_PDB_STATUS_TYPE)
    {
      /* Called procedure implemented incorrectly. */
      *error = implementation_error (sc, "Procedure execution returned multiple status values", 0);
    }
  else
    {
      /* Missing cases here. */
      g_snprintf (error_str, sizeof (error_str),
                  "Unhandled return type %s",
                  G_VALUE_TYPE_NAME (value));
      *error = implementation_error (sc, error_str, 0);
    }

  g_assert (   (result == NULL && *error != NULL)
            || (result != NULL && *error == NULL));

  return result;
}