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