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

619 lines
21 KiB
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;
}