1409 lines
47 KiB
C
1409 lines
47 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/>.
|
|
*/
|
|
|
|
#define DEBUG_SCRIPTS 0
|
|
|
|
|
|
#include "config.h"
|
|
|
|
#include <string.h>
|
|
|
|
#include <glib/gstdio.h>
|
|
|
|
#include <girepository.h>
|
|
|
|
#include <gtk/gtk.h>
|
|
|
|
#include "libpika/pika.h"
|
|
|
|
#include "tinyscheme/scheme-private.h"
|
|
#if USE_DL
|
|
#include "tinyscheme/dynload.h"
|
|
#endif
|
|
#include "ftx/ftx.h"
|
|
|
|
#include "script-fu-types.h"
|
|
|
|
#include "script-fu-interface.h"
|
|
#include "script-fu-regex.h"
|
|
#include "script-fu-scripts.h"
|
|
#include "script-fu-errors.h"
|
|
#include "script-fu-compat.h"
|
|
|
|
#include "scheme-wrapper.h"
|
|
#include "scheme-marshal.h"
|
|
#include "scheme-marshal-return.h"
|
|
|
|
|
|
#undef cons
|
|
|
|
static void ts_init_constants (scheme *sc,
|
|
GIRepository *repo);
|
|
static void ts_init_enums (scheme *sc,
|
|
GIRepository *repo,
|
|
const char *namespace);
|
|
static void ts_define_procedure (scheme *sc,
|
|
const gchar *symbol_name,
|
|
TsWrapperFunc func);
|
|
static void ts_init_procedures (scheme *sc,
|
|
gboolean register_scipts);
|
|
static pointer script_fu_marshal_procedure_call (scheme *sc,
|
|
pointer a,
|
|
gboolean permissive,
|
|
gboolean deprecated);
|
|
static pointer script_fu_marshal_procedure_call_strict (scheme *sc,
|
|
pointer a);
|
|
static pointer script_fu_marshal_procedure_call_permissive (scheme *sc,
|
|
pointer a);
|
|
static pointer script_fu_marshal_procedure_call_deprecated (scheme *sc,
|
|
pointer a);
|
|
|
|
static pointer script_fu_register_call (scheme *sc,
|
|
pointer a);
|
|
static pointer script_fu_register_call_filter (scheme *sc,
|
|
pointer a);
|
|
static pointer script_fu_menu_register_call (scheme *sc,
|
|
pointer a);
|
|
static pointer script_fu_quit_call (scheme *sc,
|
|
pointer a);
|
|
static pointer script_fu_nil_call (scheme *sc,
|
|
pointer a);
|
|
|
|
static gboolean ts_load_file (const gchar *dirname,
|
|
const gchar *basename);
|
|
|
|
typedef struct
|
|
{
|
|
const gchar *name;
|
|
gint value;
|
|
} NamedConstant;
|
|
|
|
/* LHS is text in a script, RHS is constant defined in C. */
|
|
static const NamedConstant script_constants[] =
|
|
{
|
|
/* Useful values from libpikabase/pikalimits.h */
|
|
{ "MIN-IMAGE-SIZE", PIKA_MIN_IMAGE_SIZE },
|
|
{ "MAX-IMAGE-SIZE", PIKA_MAX_IMAGE_SIZE },
|
|
{ "MIN-RESOLUTION", PIKA_MIN_RESOLUTION },
|
|
{ "MAX-RESOLUTION", PIKA_MAX_RESOLUTION },
|
|
|
|
/* Useful misc stuff */
|
|
{ "TRUE", TRUE },
|
|
{ "FALSE", FALSE },
|
|
|
|
/* Builtin units */
|
|
{ "UNIT-PIXEL", PIKA_UNIT_PIXEL },
|
|
{ "UNIT-INCH", PIKA_UNIT_INCH },
|
|
{ "UNIT-MM", PIKA_UNIT_MM },
|
|
{ "UNIT-POINT", PIKA_UNIT_POINT },
|
|
{ "UNIT-PICA", PIKA_UNIT_PICA },
|
|
|
|
/* Script-Fu types */
|
|
|
|
/* Arg types. */
|
|
{ "SF-IMAGE", SF_IMAGE },
|
|
{ "SF-DRAWABLE", SF_DRAWABLE },
|
|
{ "SF-LAYER", SF_LAYER },
|
|
{ "SF-CHANNEL", SF_CHANNEL },
|
|
{ "SF-VECTORS", SF_VECTORS },
|
|
{ "SF-COLOR", SF_COLOR },
|
|
{ "SF-TOGGLE", SF_TOGGLE },
|
|
{ "SF-VALUE", SF_VALUE },
|
|
{ "SF-STRING", SF_STRING },
|
|
{ "SF-FILENAME", SF_FILENAME },
|
|
{ "SF-DIRNAME", SF_DIRNAME },
|
|
{ "SF-ADJUSTMENT", SF_ADJUSTMENT },
|
|
{ "SF-FONT", SF_FONT },
|
|
{ "SF-PATTERN", SF_PATTERN },
|
|
{ "SF-BRUSH", SF_BRUSH },
|
|
{ "SF-GRADIENT", SF_GRADIENT },
|
|
{ "SF-OPTION", SF_OPTION },
|
|
{ "SF-PALETTE", SF_PALETTE },
|
|
{ "SF-TEXT", SF_TEXT },
|
|
{ "SF-ENUM", SF_ENUM },
|
|
{ "SF-DISPLAY", SF_DISPLAY },
|
|
|
|
/* PDB procedure drawable_arity, i.e. sensitivity.
|
|
* Used with script-fu-register-filter.
|
|
*
|
|
* This declares the arity of the algorithm,
|
|
* and not the signature of the PDB procedure.
|
|
* Since v3, PDB procedures that are image procedures,
|
|
* take a container of drawables.
|
|
* This only describes how many drawables the container *should* hold.
|
|
*
|
|
* For calls invoked by a user, this describes
|
|
* how many drawables the user is expected to select,
|
|
* which disables/enables the menu item for the procedure.
|
|
*
|
|
* Procedures are also called from other procedures.
|
|
* A call from another procedure may in fact
|
|
* pass more drawables than declared for drawable_arity.
|
|
* That is a programming error on behalf of the caller.
|
|
* A well-written callee that is passed more drawables than declared
|
|
* should return an error instead of processing any of the drawables.
|
|
*
|
|
* Similarly for fewer than declared.
|
|
*/
|
|
|
|
/* Requires two drawables. Often an operation between them, yielding a new drawable */
|
|
{ "SF-TWO-OR-MORE-DRAWABLE", SF_TWO_OR_MORE_DRAWABLE },
|
|
/* Often processed independently, sequentially, with side effects on the drawables. */
|
|
{ "SF-ONE-OR-MORE-DRAWABLE", SF_ONE_OR_MORE_DRAWABLE },
|
|
/* Requires exactly one drawable. */
|
|
{ "SF-ONE-DRAWABLE", SF_ONE_DRAWABLE },
|
|
|
|
/* For SF-ADJUSTMENT */
|
|
{ "SF-SLIDER", SF_SLIDER },
|
|
{ "SF-SPINNER", SF_SPINNER },
|
|
|
|
{ NULL, 0 }
|
|
};
|
|
|
|
|
|
static scheme sc;
|
|
|
|
/*
|
|
* These callbacks break the backwards compile-time dependence
|
|
* of inner scheme-wrapper on the outer script-fu-server.
|
|
* Only script-fu-server registers, when it runs.
|
|
*/
|
|
static TsCallbackFunc post_command_callback = NULL;
|
|
static TsCallbackFunc quit_callback = NULL;
|
|
|
|
|
|
void
|
|
tinyscheme_init (GList *path,
|
|
gboolean register_scripts)
|
|
{
|
|
GIRepository *repo;
|
|
GITypelib *typelib;
|
|
GError *error = NULL;
|
|
|
|
/* init the interpreter */
|
|
if (! scheme_init (&sc))
|
|
{
|
|
g_warning ("Could not initialize TinyScheme!");
|
|
return;
|
|
}
|
|
|
|
scheme_set_input_port_file (&sc, stdin);
|
|
scheme_set_output_port_file (&sc, stdout);
|
|
ts_register_output_func (ts_stdout_output_func, NULL);
|
|
|
|
/* Initialize the TinyScheme extensions */
|
|
init_ftx (&sc);
|
|
script_fu_regex_init (&sc);
|
|
|
|
/* Fetch the typelib */
|
|
repo = g_irepository_get_default ();
|
|
typelib = g_irepository_require (repo, "Pika", NULL, 0, &error);
|
|
if (!typelib)
|
|
{
|
|
g_warning ("%s", error->message);
|
|
g_clear_error (&error);
|
|
return;
|
|
}
|
|
|
|
/* register in the interpreter the pika functions and types. */
|
|
ts_init_constants (&sc, repo);
|
|
ts_init_procedures (&sc, register_scripts);
|
|
|
|
if (path)
|
|
{
|
|
GList *list;
|
|
|
|
g_debug ("Loading init and compat scripts.");
|
|
|
|
for (list = path; list; list = g_list_next (list))
|
|
{
|
|
gchar *dir = g_file_get_path (list->data);
|
|
|
|
if (ts_load_file (dir, "script-fu.init"))
|
|
{
|
|
/* To improve compatibility with older Script-Fu scripts,
|
|
* load script-fu-compat.init from the same directory.
|
|
*/
|
|
ts_load_file (dir, "script-fu-compat.init");
|
|
|
|
/* To improve compatibility with older PIKA version,
|
|
* load plug-in-compat.init from the same directory.
|
|
*/
|
|
ts_load_file (dir, "plug-in-compat.init");
|
|
|
|
g_free (dir);
|
|
|
|
break;
|
|
}
|
|
|
|
g_free (dir);
|
|
}
|
|
|
|
if (list == NULL)
|
|
g_warning ("Unable to read initialization file script-fu.init\n");
|
|
}
|
|
else
|
|
g_warning ("Not loading initialization or compatibility scripts.");
|
|
}
|
|
|
|
/* Create an SF-RUN-MODE constant for use in scripts.
|
|
* It is set to the run mode state determined by PIKA.
|
|
*/
|
|
void
|
|
ts_set_run_mode (PikaRunMode run_mode)
|
|
{
|
|
pointer symbol;
|
|
|
|
symbol = sc.vptr->mk_symbol (&sc, "SF-RUN-MODE");
|
|
sc.vptr->scheme_define (&sc, sc.global_env, symbol,
|
|
sc.vptr->mk_integer (&sc, run_mode));
|
|
sc.vptr->setimmutable (symbol);
|
|
}
|
|
|
|
void
|
|
ts_set_print_flag (gint print_flag)
|
|
{
|
|
sc.print_output = print_flag;
|
|
}
|
|
|
|
void
|
|
ts_print_welcome (void)
|
|
{
|
|
ts_output_string (TS_OUTPUT_NORMAL,
|
|
"Welcome to TinyScheme, Version 1.40\n", -1);
|
|
ts_output_string (TS_OUTPUT_NORMAL,
|
|
"Copyright (c) Dimitrios Souflis\n", -1);
|
|
}
|
|
|
|
void
|
|
ts_interpret_stdin (void)
|
|
{
|
|
scheme_load_file (&sc, stdin);
|
|
}
|
|
|
|
gint
|
|
ts_interpret_string (const gchar *expr)
|
|
{
|
|
gint result;
|
|
|
|
#if DEBUG_SCRIPTS
|
|
sc.print_output = 1;
|
|
sc.tracing = 1;
|
|
#endif
|
|
|
|
sc.vptr->load_string (&sc, (char *) expr);
|
|
|
|
result = sc.retcode;
|
|
|
|
g_debug ("ts_interpret_string returns: %i", result);
|
|
return result;
|
|
}
|
|
|
|
const gchar *
|
|
ts_get_success_msg (void)
|
|
{
|
|
if (sc.vptr->is_string (sc.value))
|
|
return sc.vptr->string_value (sc.value);
|
|
|
|
return "Success";
|
|
}
|
|
|
|
void
|
|
ts_stdout_output_func (TsOutputType type,
|
|
const char *string,
|
|
int len,
|
|
gpointer user_data)
|
|
{
|
|
if (len < 0)
|
|
len = strlen (string);
|
|
fprintf (stdout, "%.*s", len, string);
|
|
fflush (stdout);
|
|
}
|
|
|
|
void
|
|
ts_gstring_output_func (TsOutputType type,
|
|
const char *string,
|
|
int len,
|
|
gpointer user_data)
|
|
{
|
|
GString *gstr = (GString *) user_data;
|
|
|
|
g_string_append_len (gstr, string, len);
|
|
}
|
|
|
|
void
|
|
ts_register_quit_callback (TsCallbackFunc callback)
|
|
{
|
|
quit_callback = callback;
|
|
}
|
|
|
|
void
|
|
ts_register_post_command_callback (TsCallbackFunc callback)
|
|
{
|
|
post_command_callback = callback;
|
|
}
|
|
|
|
|
|
/* private functions */
|
|
|
|
/*
|
|
* Below can be found the functions responsible for registering the
|
|
* pika functions and types against the scheme interpreter.
|
|
*/
|
|
static void
|
|
ts_init_constants (scheme *sc,
|
|
GIRepository *repo)
|
|
{
|
|
int i;
|
|
pointer symbol;
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-directory");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-data-directory");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_data_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-plug-in-directory");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_plug_in_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-locale-directory");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_locale_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-sysconf-directory");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_sysconf_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
ts_init_enums (sc, repo, "Pika");
|
|
ts_init_enums (sc, repo, "Gegl");
|
|
|
|
/* Constants used in the register block of scripts */
|
|
for (i = 0; script_constants[i].name != NULL; ++i)
|
|
{
|
|
symbol = sc->vptr->mk_symbol (sc, script_constants[i].name);
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_integer (sc,
|
|
script_constants[i].value));
|
|
sc->vptr->setimmutable (symbol);
|
|
}
|
|
|
|
/* Define string constant for use in building paths to files/directories */
|
|
symbol = sc->vptr->mk_symbol (sc, "DIR-SEPARATOR");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, G_DIR_SEPARATOR_S));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
/* Define string constant for use in building search paths */
|
|
symbol = sc->vptr->mk_symbol (sc, "SEARCHPATH-SEPARATOR");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, G_SEARCHPATH_SEPARATOR_S));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
/* These constants are deprecated and will be removed at a later date. */
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-dir");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-data-dir");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_data_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, "pika-plugin-dir");
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_string (sc, pika_plug_in_directory ()));
|
|
sc->vptr->setimmutable (symbol);
|
|
}
|
|
|
|
static void
|
|
ts_init_enum (scheme *sc,
|
|
GIEnumInfo *info,
|
|
const char *namespace)
|
|
{
|
|
int n_values;
|
|
|
|
n_values = g_enum_info_get_n_values ((GIEnumInfo *) info);
|
|
for (int j = 0; j < n_values; j++)
|
|
{
|
|
GIValueInfo *value_info;
|
|
const char *c_identifier;
|
|
char *scheme_name;
|
|
int int_value;
|
|
pointer symbol;
|
|
|
|
value_info = g_enum_info_get_value (info, j);
|
|
|
|
/* Get name & value. Normally, we would use the actual name of the
|
|
* GIBaseInfo here, but that would break bw-compatibility */
|
|
c_identifier = g_base_info_get_attribute ((GIBaseInfo *) value_info, "c:identifier");
|
|
if (c_identifier == NULL)
|
|
{
|
|
g_warning ("Problem in the GIR file: enum value without \"c:identifier\"!");
|
|
g_base_info_unref ((GIBaseInfo *) value_info);
|
|
continue;
|
|
}
|
|
|
|
/* Scheme-ify the name */
|
|
if (g_strcmp0 (namespace, "Pika") == 0)
|
|
{
|
|
/* Skip the PIKA prefix for PIKA enums */
|
|
if (g_str_has_prefix (c_identifier, "PIKA_"))
|
|
c_identifier += strlen ("PIKA_");
|
|
}
|
|
else
|
|
{
|
|
/* Other namespaces: skip non-prefixed symbols, to prevent clashes */
|
|
if (g_ascii_strncasecmp (c_identifier, namespace, strlen (namespace)) != 0)
|
|
{
|
|
g_base_info_unref ((GIBaseInfo *) value_info);
|
|
continue;
|
|
}
|
|
}
|
|
scheme_name = g_strdelimit (g_strdup (c_identifier), "_", '-');
|
|
int_value = g_value_info_get_value (value_info);
|
|
|
|
/* Register the symbol */
|
|
symbol = sc->vptr->mk_symbol (sc, scheme_name);
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_integer (sc, int_value));
|
|
sc->vptr->setimmutable (symbol);
|
|
|
|
g_free (scheme_name);
|
|
g_base_info_unref ((GIBaseInfo *) value_info);
|
|
}
|
|
}
|
|
|
|
static void
|
|
ts_init_enums (scheme *sc,
|
|
GIRepository *repo,
|
|
const char *namespace)
|
|
{
|
|
int i, n_infos;
|
|
|
|
n_infos = g_irepository_get_n_infos (repo, namespace);
|
|
for (i = 0; i < n_infos; i++)
|
|
{
|
|
GIBaseInfo *info;
|
|
|
|
info = g_irepository_get_info (repo, namespace, i);
|
|
if (GI_IS_ENUM_INFO (info))
|
|
{
|
|
ts_init_enum (sc, (GIEnumInfo *) info, namespace);
|
|
}
|
|
|
|
g_base_info_unref (info);
|
|
}
|
|
}
|
|
|
|
/* Define a symbol into interpreter state,
|
|
* bound to a foreign function, language C, defined here in ScriptFu source.
|
|
*/
|
|
static void
|
|
ts_define_procedure (scheme *sc,
|
|
const gchar *symbol_name,
|
|
TsWrapperFunc func)
|
|
{
|
|
pointer symbol;
|
|
|
|
symbol = sc->vptr->mk_symbol (sc, symbol_name);
|
|
sc->vptr->scheme_define (sc, sc->global_env, symbol,
|
|
sc->vptr->mk_foreign_func (sc, func));
|
|
sc->vptr->setimmutable (symbol);
|
|
}
|
|
|
|
|
|
/* Define, into interpreter state,
|
|
* 1) Scheme functions that call wrapper functions in C here in ScriptFu.
|
|
* 2) Scheme functions wrapping every procedure in the PDB.
|
|
*/
|
|
static void
|
|
ts_init_procedures (scheme *sc,
|
|
gboolean register_scripts)
|
|
{
|
|
gchar **proc_list;
|
|
gint num_procs;
|
|
gint i;
|
|
|
|
#if USE_DL
|
|
/* scm_load_ext not same as other wrappers, defined in tinyscheme/dynload */
|
|
ts_define_procedure (sc, "load-extension", scm_load_ext);
|
|
#endif
|
|
|
|
if (register_scripts)
|
|
{
|
|
ts_define_procedure (sc, "script-fu-register", script_fu_register_call);
|
|
ts_define_procedure (sc, "script-fu-register-filter", script_fu_register_call_filter);
|
|
ts_define_procedure (sc, "script-fu-menu-register", script_fu_menu_register_call);
|
|
}
|
|
else
|
|
{
|
|
ts_define_procedure (sc, "script-fu-register", script_fu_nil_call);
|
|
ts_define_procedure (sc, "script-fu-register-filter", script_fu_nil_call);
|
|
ts_define_procedure (sc, "script-fu-menu-register", script_fu_nil_call);
|
|
}
|
|
|
|
ts_define_procedure (sc, "script-fu-quit", script_fu_quit_call);
|
|
|
|
ts_define_procedure (sc, "pika-proc-db-call", script_fu_marshal_procedure_call_strict);
|
|
ts_define_procedure (sc, "-pika-proc-db-call", script_fu_marshal_procedure_call_permissive);
|
|
ts_define_procedure (sc, "--pika-proc-db-call", script_fu_marshal_procedure_call_deprecated);
|
|
|
|
proc_list = pika_pdb_query_procedures (pika_get_pdb (),
|
|
".*", ".*", ".*", ".*",
|
|
".*", ".*", ".*", ".*");
|
|
num_procs = proc_list ? g_strv_length (proc_list) : 0;
|
|
|
|
/* Register each procedure as a scheme func */
|
|
for (i = 0; i < num_procs; i++)
|
|
{
|
|
gchar *buff;
|
|
|
|
/* Build a define that will call the foreign function.
|
|
* The Scheme statement was suggested by Simon Budig.
|
|
*
|
|
* Call the procedure through -pika-proc-db-call, which is a more
|
|
* permissive version of pika-proc-db-call, that accepts (and ignores)
|
|
* any number of arguments for nullary procedures, for backward
|
|
* compatibility.
|
|
*/
|
|
buff = g_strdup_printf (" (define (%s . args)"
|
|
" (apply -pika-proc-db-call \"%s\" args))",
|
|
proc_list[i], proc_list[i]);
|
|
|
|
/* Execute the 'define' */
|
|
sc->vptr->load_string (sc, buff);
|
|
|
|
g_free (buff);
|
|
}
|
|
|
|
g_strfreev (proc_list);
|
|
|
|
/* Register more scheme funcs that call PDB procedures, for compatibility
|
|
* This can overwrite earlier scheme func definitions.
|
|
*/
|
|
define_compat_procs (sc);
|
|
}
|
|
|
|
static gboolean
|
|
ts_load_file (const gchar *dirname,
|
|
const gchar *basename)
|
|
{
|
|
gchar *filename;
|
|
FILE *fin;
|
|
|
|
filename = g_build_filename (dirname, basename, NULL);
|
|
|
|
fin = g_fopen (filename, "rb");
|
|
|
|
g_free (filename);
|
|
|
|
if (fin)
|
|
{
|
|
scheme_load_file (&sc, fin);
|
|
fclose (fin);
|
|
|
|
return TRUE;
|
|
}
|
|
|
|
return FALSE;
|
|
}
|
|
|
|
/* Called by the Scheme interpreter on calls to PIKA PDB procedures */
|
|
static pointer
|
|
script_fu_marshal_procedure_call (scheme *sc,
|
|
pointer a,
|
|
gboolean permissive,
|
|
gboolean deprecated)
|
|
{
|
|
PikaProcedure *procedure;
|
|
PikaValueArray *args;
|
|
PikaValueArray *values = NULL;
|
|
gchar *proc_name;
|
|
GParamSpec **arg_specs;
|
|
gint n_arg_specs;
|
|
gint actual_arg_count;
|
|
gint consumed_arg_count = 0;
|
|
gchar error_str[1024];
|
|
gint i;
|
|
pointer return_val = sc->NIL;
|
|
|
|
|
|
g_debug ("In %s()", G_STRFUNC);
|
|
|
|
if (a == sc->NIL)
|
|
/* Some ScriptFu function is calling this incorrectly. */
|
|
return implementation_error (sc,
|
|
"Procedure argument marshaller was called with no arguments. "
|
|
"The procedure to be executed and the arguments it requires "
|
|
"(possibly none) must be specified.",
|
|
0);
|
|
|
|
/* The PDB procedure name is the argument or first argument of the list */
|
|
if (sc->vptr->is_pair (a))
|
|
proc_name = g_strdup (sc->vptr->string_value (sc->vptr->pair_car (a)));
|
|
else
|
|
proc_name = g_strdup (sc->vptr->string_value (a));
|
|
|
|
g_debug ("proc name: %s", proc_name);
|
|
g_debug ("parms rcvd: %d", sc->vptr->list_length (sc, a)-1);
|
|
|
|
if (deprecated )
|
|
g_warning ("PDB procedure name %s is deprecated, please use %s.",
|
|
deprecated_name_for (proc_name),
|
|
proc_name);
|
|
|
|
/* report the current command */
|
|
script_fu_interface_report_cc (proc_name);
|
|
|
|
/* Attempt to fetch the procedure from the database */
|
|
procedure = pika_pdb_lookup_procedure (pika_get_pdb (), proc_name);
|
|
|
|
if (! procedure)
|
|
{
|
|
g_snprintf (error_str, sizeof (error_str),
|
|
"Invalid procedure name: %s", proc_name);
|
|
return script_error (sc, error_str, 0);
|
|
}
|
|
|
|
arg_specs = pika_procedure_get_arguments (procedure, &n_arg_specs);
|
|
actual_arg_count = sc->vptr->list_length (sc, a) - 1;
|
|
|
|
/* Check the supplied number of arguments.
|
|
* This only gives warnings to the console.
|
|
* It does not ensure that the count of supplied args equals the count of formal args.
|
|
* Subsequent code must not assume that.
|
|
*
|
|
* When too few supplied args, when permissive, scriptfu or downstream machinery
|
|
* can try to provide missing args e.g. defaults.
|
|
*
|
|
* Extra supplied args can be discarded.
|
|
* Formerly, this was a deprecated behavior depending on "permissive".
|
|
*/
|
|
{
|
|
if (actual_arg_count > n_arg_specs)
|
|
{
|
|
/* Warn, but permit extra args. Will discard args from script.*/
|
|
g_warning ("in script, permitting too many args to %s", proc_name);
|
|
}
|
|
else if (actual_arg_count < n_arg_specs)
|
|
{
|
|
/* Warn, but permit too few args.
|
|
* Scriptfu or downstream might provide missing args.
|
|
* It is author friendly to continue to parse the script for type errors.
|
|
*/
|
|
g_warning ("in script, permitting too few args to %s", proc_name);
|
|
}
|
|
/* else equal counts of args. */
|
|
}
|
|
|
|
/* Marshall the supplied arguments */
|
|
args = pika_value_array_new (n_arg_specs);
|
|
|
|
for (i = 0; i < n_arg_specs; i++)
|
|
{
|
|
GParamSpec *arg_spec = arg_specs[i];
|
|
GValue value = G_VALUE_INIT;
|
|
guint n_elements; /* !!! unsigned length */
|
|
pointer vector; /* !!! list or vector */
|
|
gint j;
|
|
|
|
consumed_arg_count++;
|
|
|
|
if (consumed_arg_count > actual_arg_count)
|
|
{
|
|
/* Exhausted supplied arguments before formal specs. */
|
|
|
|
/* Say formal type of first missing arg. */
|
|
g_warning ("Missing arg type: %s", g_type_name (G_PARAM_SPEC_VALUE_TYPE (arg_spec)));
|
|
|
|
/* Break loop over formal specs. Continuation is to call PDB with partial args. */
|
|
break;
|
|
}
|
|
else
|
|
a = sc->vptr->pair_cdr (a); /* advance pointer to next arg in list. */
|
|
|
|
g_value_init (&value, G_PARAM_SPEC_VALUE_TYPE (arg_spec));
|
|
|
|
debug_in_arg (sc, a, i, g_type_name (G_VALUE_TYPE (&value)));
|
|
|
|
if (G_VALUE_HOLDS_INT (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
g_value_set_int (&value,
|
|
sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (G_VALUE_HOLDS_UINT (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
g_value_set_uint (&value,
|
|
sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (G_VALUE_HOLDS_UCHAR (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
g_value_set_uchar (&value,
|
|
sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (G_VALUE_HOLDS_DOUBLE (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
g_value_set_double (&value,
|
|
sc->vptr->rvalue (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (G_VALUE_HOLDS_ENUM (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
g_value_set_enum (&value,
|
|
sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (G_VALUE_HOLDS_BOOLEAN (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
g_value_set_boolean (&value,
|
|
sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (G_VALUE_HOLDS_STRING (&value))
|
|
{
|
|
if (! sc->vptr->is_string (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "string", i, proc_name);
|
|
else
|
|
g_value_set_string (&value,
|
|
sc->vptr->string_value (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (G_VALUE_HOLDS (&value, G_TYPE_STRV))
|
|
{
|
|
vector = sc->vptr->pair_car (a); /* vector is pointing to a list */
|
|
if (! sc->vptr->is_list (sc, vector))
|
|
return script_type_error (sc, "vector", i, proc_name);
|
|
else
|
|
{
|
|
gchar **array;
|
|
|
|
n_elements = sc->vptr->list_length (sc, vector);
|
|
|
|
array = g_new0 (gchar *, n_elements + 1);
|
|
|
|
for (j = 0; j < n_elements; j++)
|
|
{
|
|
pointer v_element = sc->vptr->pair_car (vector);
|
|
|
|
if (!sc->vptr->is_string (v_element))
|
|
{
|
|
g_snprintf (error_str, sizeof (error_str),
|
|
"Item %d in vector is not a string (argument %d for function %s)",
|
|
j+1, i+1, proc_name);
|
|
g_strfreev (array);
|
|
return foreign_error (sc, error_str, vector);
|
|
}
|
|
|
|
array[j] = g_strdup (sc->vptr->string_value (v_element));
|
|
|
|
vector = sc->vptr->pair_cdr (vector);
|
|
}
|
|
|
|
g_value_take_boxed (&value, array);
|
|
|
|
#if DEBUG_MARSHALL
|
|
{
|
|
glong count = sc->vptr->list_length ( sc, sc->vptr->pair_car (a) );
|
|
g_printerr (" string vector has %ld elements\n", count);
|
|
if (count > 0)
|
|
{
|
|
g_printerr (" ");
|
|
for (j = 0; j < count; ++j)
|
|
g_printerr (" \"%s\"",
|
|
args[i].data.d_strv[j]);
|
|
g_printerr ("\n");
|
|
}
|
|
}
|
|
#endif
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_DISPLAY (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
PikaDisplay *display =
|
|
pika_display_get_by_id (sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
|
|
g_value_set_object (&value, display);
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_IMAGE (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
PikaImage *image =
|
|
pika_image_get_by_id (sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
|
|
g_value_set_object (&value, image);
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_LAYER (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
PikaLayer *layer =
|
|
pika_layer_get_by_id (sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
|
|
g_value_set_object (&value, layer);
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_LAYER_MASK (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
PikaLayerMask *layer_mask =
|
|
pika_layer_mask_get_by_id (sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
|
|
g_value_set_object (&value, layer_mask);
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_CHANNEL (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
PikaChannel *channel =
|
|
pika_channel_get_by_id (sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
|
|
g_value_set_object (&value, channel);
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_DRAWABLE (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
gint id = sc->vptr->ivalue (sc->vptr->pair_car (a));
|
|
|
|
pointer error = marshal_ID_to_drawable(sc, a, id, &value);
|
|
if (error)
|
|
return error;
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_VECTORS (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
PikaVectors *vectors =
|
|
pika_vectors_get_by_id (sc->vptr->ivalue (sc->vptr->pair_car (a)));
|
|
|
|
g_value_set_object (&value, vectors);
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_ITEM (&value))
|
|
{
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "numeric", i, proc_name);
|
|
else
|
|
{
|
|
gint item_ID;
|
|
item_ID = sc->vptr->ivalue (sc->vptr->pair_car (a));
|
|
|
|
/* Avoid failed assertion in libpika.*/
|
|
if (pika_item_id_is_valid (item_ID))
|
|
{
|
|
PikaItem *item = pika_item_get_by_id (item_ID);
|
|
g_value_set_object (&value, item);
|
|
}
|
|
else
|
|
{
|
|
return script_error (sc, "runtime: invalid item ID", a);
|
|
}
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_INT32_ARRAY (&value))
|
|
{
|
|
vector = sc->vptr->pair_car (a);
|
|
if (! sc->vptr->is_vector (vector))
|
|
return script_type_error (sc, "vector", i, proc_name);
|
|
else
|
|
{
|
|
/* !!! Comments applying to all array args.
|
|
* n_elements is expected list length, from previous argument.
|
|
* A PDB procedure takes args paired: ...length, array...
|
|
* and a script passes the same paired args (..., 1, '("foo"))
|
|
* (FUTURE: a more object oriented design for the PDB API
|
|
* would obviate need for this discussion.)
|
|
*
|
|
* When a script passes a shorter or empty list,
|
|
* ensure we don't segfault on cdr past end of list.
|
|
*
|
|
* n_elements is unsigned, we don't need to check >= 0
|
|
*
|
|
* Since we are not checking for equality of passed length
|
|
* to actual container length, we adapt an array
|
|
* that is shorter than specified by the length arg.
|
|
* Ignoring a discrepancy by the script author.
|
|
* FUTURE: List must be *exactly* n_elements long.
|
|
* n_elements != sc->vptr->list_length (sc, vector))
|
|
*/
|
|
gint32 *array;
|
|
|
|
n_elements = PIKA_VALUES_GET_INT (args, i - 1);
|
|
|
|
if (n_elements > sc->vptr->vector_length (vector))
|
|
return script_length_error_in_vector (sc, i, proc_name, n_elements, vector);
|
|
|
|
array = g_new0 (gint32, n_elements);
|
|
|
|
for (j = 0; j < n_elements; j++)
|
|
{
|
|
pointer v_element = sc->vptr->vector_elem (vector, j);
|
|
|
|
/* FIXME: Check values in vector stay within range for each type. */
|
|
if (! sc->vptr->is_number (v_element))
|
|
{
|
|
g_free (array);
|
|
return script_type_error_in_container (sc, "numeric", i, j, proc_name, vector);
|
|
}
|
|
|
|
array[j] = (gint32) sc->vptr->ivalue (v_element);
|
|
}
|
|
|
|
pika_value_take_int32_array (&value, array, n_elements);
|
|
|
|
debug_vector (sc, vector, "%ld");
|
|
}
|
|
}
|
|
else if (G_VALUE_HOLDS (&value, G_TYPE_BYTES))
|
|
{
|
|
vector = sc->vptr->pair_car (a);
|
|
if (! sc->vptr->is_vector (vector))
|
|
return script_type_error (sc, "vector", i, proc_name);
|
|
else
|
|
{
|
|
guint8 *array;
|
|
|
|
n_elements = sc->vptr->vector_length (vector);
|
|
|
|
array = g_new0 (guint8, n_elements);
|
|
|
|
for (j = 0; j < n_elements; j++)
|
|
{
|
|
pointer v_element = sc->vptr->vector_elem (vector, j);
|
|
|
|
if (!sc->vptr->is_number (v_element))
|
|
{
|
|
g_free (array);
|
|
return script_type_error_in_container (sc, "numeric", i, j, proc_name, vector);
|
|
}
|
|
|
|
array[j] = (guint8) sc->vptr->ivalue (v_element);
|
|
}
|
|
|
|
g_value_take_boxed (&value, g_bytes_new_take (array, n_elements));
|
|
|
|
debug_vector (sc, vector, "%ld");
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_FLOAT_ARRAY (&value))
|
|
{
|
|
vector = sc->vptr->pair_car (a);
|
|
if (! sc->vptr->is_vector (vector))
|
|
return script_type_error (sc, "vector", i, proc_name);
|
|
else
|
|
{
|
|
gdouble *array;
|
|
|
|
n_elements = PIKA_VALUES_GET_INT (args, i - 1);
|
|
|
|
if (n_elements > sc->vptr->vector_length (vector))
|
|
return script_length_error_in_vector (sc, i, proc_name, n_elements, vector);
|
|
|
|
array = g_new0 (gdouble, n_elements);
|
|
|
|
for (j = 0; j < n_elements; j++)
|
|
{
|
|
pointer v_element = sc->vptr->vector_elem (vector, j);
|
|
|
|
if (!sc->vptr->is_number (v_element))
|
|
{
|
|
g_free (array);
|
|
return script_type_error_in_container (sc, "numeric", i, j, proc_name, vector);
|
|
}
|
|
|
|
array[j] = (gfloat) sc->vptr->rvalue (v_element);
|
|
}
|
|
|
|
pika_value_take_float_array (&value, array, n_elements);
|
|
|
|
debug_vector (sc, vector, "%f");
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_RGB (&value))
|
|
{
|
|
PikaRGB color;
|
|
|
|
if (sc->vptr->is_string (sc->vptr->pair_car (a)))
|
|
{
|
|
if (! pika_rgb_parse_css (&color,
|
|
sc->vptr->string_value (sc->vptr->pair_car (a)),
|
|
-1))
|
|
return script_type_error (sc, "color string", i, proc_name);
|
|
|
|
pika_rgb_set_alpha (&color, 1.0);
|
|
g_debug ("(%s)", sc->vptr->string_value (sc->vptr->pair_car (a)));
|
|
}
|
|
else if (sc->vptr->is_list (sc, sc->vptr->pair_car (a)) &&
|
|
sc->vptr->list_length (sc, sc->vptr->pair_car (a)) == 3)
|
|
{
|
|
pointer color_list;
|
|
guchar r = 0, g = 0, b = 0;
|
|
|
|
color_list = sc->vptr->pair_car (a);
|
|
if (sc->vptr->is_number (sc->vptr->pair_car (color_list)))
|
|
r = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)),
|
|
0, 255);
|
|
else
|
|
return script_type_error_in_container (
|
|
sc, "numeric", i, 0, proc_name, 0);
|
|
|
|
color_list = sc->vptr->pair_cdr (color_list);
|
|
if (sc->vptr->is_number (sc->vptr->pair_car (color_list)))
|
|
g = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)),
|
|
0, 255);
|
|
else
|
|
return script_type_error_in_container (
|
|
sc, "numeric", i, 1, proc_name, 0);
|
|
|
|
color_list = sc->vptr->pair_cdr (color_list);
|
|
if (sc->vptr->is_number (sc->vptr->pair_car (color_list)))
|
|
b = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)),
|
|
0, 255);
|
|
else
|
|
return script_type_error_in_container (sc, "numeric", i, 2, proc_name, 0);
|
|
|
|
pika_rgba_set_uchar (&color, r, g, b, 255);
|
|
pika_value_set_rgb (&value, &color);
|
|
g_debug ("(%d %d %d)", r, g, b);
|
|
}
|
|
else
|
|
return script_type_error (sc, "color string or list", i, proc_name);
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_RGB_ARRAY (&value))
|
|
{
|
|
vector = sc->vptr->pair_car (a);
|
|
if (! sc->vptr->is_vector (vector))
|
|
return script_type_error (sc, "vector", i, proc_name);
|
|
else
|
|
{
|
|
PikaRGB *array;
|
|
|
|
n_elements = PIKA_VALUES_GET_INT (args, i - 1);
|
|
|
|
if (n_elements > sc->vptr->vector_length (vector))
|
|
return script_length_error_in_vector (sc, i, proc_name, n_elements, vector);
|
|
|
|
array = g_new0 (PikaRGB, n_elements);
|
|
|
|
for (j = 0; j < n_elements; j++)
|
|
{
|
|
pointer v_element = sc->vptr->vector_elem (vector, j);
|
|
pointer color_list;
|
|
guchar r, g, b;
|
|
|
|
if (! (sc->vptr->is_list (sc,
|
|
sc->vptr->pair_car (v_element)) &&
|
|
sc->vptr->list_length (sc,
|
|
sc->vptr->pair_car (v_element)) == 3))
|
|
{
|
|
g_free (array);
|
|
g_snprintf (error_str, sizeof (error_str),
|
|
"Item %d in vector is not a color "
|
|
"(argument %d for function %s)",
|
|
j+1, i+1, proc_name);
|
|
return script_error (sc, error_str, 0);
|
|
}
|
|
|
|
color_list = sc->vptr->pair_car (v_element);
|
|
r = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)),
|
|
0, 255);
|
|
color_list = sc->vptr->pair_cdr (color_list);
|
|
g = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)),
|
|
0, 255);
|
|
color_list = sc->vptr->pair_cdr (color_list);
|
|
b = CLAMP (sc->vptr->ivalue (sc->vptr->pair_car (color_list)),
|
|
0, 255);
|
|
|
|
pika_rgba_set_uchar (&array[i], r, g, b, 255);
|
|
}
|
|
|
|
pika_value_take_rgb_array (&value, array, n_elements);
|
|
|
|
g_debug ("color vector has %ld elements", sc->vptr->vector_length (vector));
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_PARASITE (&value))
|
|
{
|
|
if (! sc->vptr->is_list (sc, sc->vptr->pair_car (a)) ||
|
|
sc->vptr->list_length (sc, sc->vptr->pair_car (a)) != 3)
|
|
return script_type_error (sc, "list", i, proc_name);
|
|
else
|
|
{
|
|
PikaParasite parasite;
|
|
pointer temp_val;
|
|
|
|
/* parasite->name */
|
|
temp_val = sc->vptr->pair_car (a);
|
|
|
|
if (! sc->vptr->is_string (sc->vptr->pair_car (temp_val)))
|
|
return script_type_error_in_container (sc, "string", i, 0, proc_name, 0);
|
|
|
|
parasite.name =
|
|
sc->vptr->string_value (sc->vptr->pair_car (temp_val));
|
|
g_debug ("name '%s'", parasite.name);
|
|
|
|
/* parasite->flags */
|
|
temp_val = sc->vptr->pair_cdr (temp_val);
|
|
|
|
if (! sc->vptr->is_number (sc->vptr->pair_car (temp_val)))
|
|
return script_type_error_in_container (sc, "numeric", i, 1, proc_name, 0);
|
|
|
|
parasite.flags =
|
|
sc->vptr->ivalue (sc->vptr->pair_car (temp_val));
|
|
g_debug ("flags %d", parasite.flags);
|
|
|
|
/* parasite->data */
|
|
temp_val = sc->vptr->pair_cdr (temp_val);
|
|
|
|
if (!sc->vptr->is_string (sc->vptr->pair_car (temp_val)))
|
|
return script_type_error_in_container (
|
|
sc, "string", i, 2, proc_name, 0);
|
|
|
|
parasite.data =
|
|
sc->vptr->string_value (sc->vptr->pair_car (temp_val));
|
|
parasite.size = strlen (parasite.data);
|
|
|
|
g_debug ("size %d", parasite.size);
|
|
g_debug ("data '%s'", (char *)parasite.data);
|
|
|
|
g_value_set_boxed (&value, ¶site);
|
|
}
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_OBJECT_ARRAY (&value))
|
|
{
|
|
vector = sc->vptr->pair_car (a);
|
|
|
|
if (sc->vptr->is_vector (vector))
|
|
{
|
|
pointer error = marshal_vector_to_drawable_array (sc, vector, &value);
|
|
if (error)
|
|
return error;
|
|
}
|
|
else
|
|
return script_type_error (sc, "vector", i, proc_name);
|
|
}
|
|
else if (G_VALUE_TYPE (&value) == G_TYPE_FILE)
|
|
{
|
|
if (! sc->vptr->is_string (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "string for path", i, proc_name);
|
|
marshal_path_string_to_gfile (sc, a, &value);
|
|
}
|
|
else if (G_VALUE_TYPE (&value) == PIKA_TYPE_PDB_STATUS_TYPE)
|
|
{
|
|
/* A PDB procedure signature wrongly requires a status. */
|
|
return implementation_error (sc,
|
|
"Status is for return types, not arguments",
|
|
sc->vptr->pair_car (a));
|
|
}
|
|
else if (PIKA_VALUE_HOLDS_RESOURCE (&value))
|
|
{
|
|
if (! sc->vptr->is_integer (sc->vptr->pair_car (a)))
|
|
return script_type_error (sc, "integer", i, proc_name);
|
|
else
|
|
{
|
|
/* Create new instance of a resource object. */
|
|
PikaResource *resource;
|
|
|
|
gint resource_id = sc->vptr->ivalue (sc->vptr->pair_car (a));
|
|
/* Superclass is Resource, subclass is e.g. Brush.
|
|
* Superclass is abstract, can't instantiate it.
|
|
* This returns an instance of the appropriate subclass for the ID.
|
|
* ID's are unique across all instances of Resource.
|
|
*/
|
|
resource = pika_resource_get_by_id (resource_id);
|
|
|
|
g_value_set_object (&value, resource);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
g_snprintf (error_str, sizeof (error_str),
|
|
"Argument %d for %s is unhandled type %s",
|
|
i+1, proc_name, g_type_name (G_VALUE_TYPE (&value)));
|
|
return implementation_error (sc, error_str, 0);
|
|
}
|
|
debug_gvalue (&value);
|
|
pika_value_array_append (args, &value);
|
|
g_value_unset (&value);
|
|
}
|
|
|
|
/* Omit refresh scripts from a script, better than crashing, see #575830. */
|
|
if (strcmp (proc_name, "script-fu-refresh") == 0)
|
|
return script_error (sc, "A script cannot refresh scripts", 0);
|
|
|
|
g_debug ("calling %s", proc_name);
|
|
values = pika_pdb_run_procedure_array (pika_get_pdb (),
|
|
proc_name, args);
|
|
g_debug ("done.");
|
|
|
|
/* Check the return status */
|
|
if (! values)
|
|
{
|
|
/* Usually a plugin that crashed, wire error */
|
|
g_snprintf (error_str, sizeof(error_str),
|
|
"in script, called procedure %s failed to return a status",
|
|
proc_name);
|
|
return script_error (sc, error_str, 0);
|
|
}
|
|
|
|
{
|
|
pointer calling_error;
|
|
return_val = marshal_PDB_return (sc, values, proc_name, &calling_error);
|
|
|
|
/* Now returns error immediately.
|
|
* Which leaks memory normally freed below.
|
|
* Most plugins, except extension script-fu, will exit soon anyway.
|
|
* FUTURE: don't leak.
|
|
*/
|
|
if (calling_error != NULL)
|
|
/* calling error is foreign_error or similar. */
|
|
return calling_error;
|
|
}
|
|
|
|
g_free (proc_name);
|
|
|
|
/* free executed procedure return values */
|
|
pika_value_array_unref (values);
|
|
|
|
/* free arguments and values */
|
|
pika_value_array_unref (args);
|
|
|
|
/* The callback is NULL except for script-fu-server. See explanation there. */
|
|
if (post_command_callback != NULL)
|
|
post_command_callback ();
|
|
|
|
#ifdef GDK_WINDOWING_WIN32
|
|
/* This seems to help a lot on Windoze. */
|
|
while (gtk_events_pending ())
|
|
gtk_main_iteration ();
|
|
#endif
|
|
|
|
return return_val;
|
|
}
|
|
|
|
static pointer
|
|
script_fu_marshal_procedure_call_strict (scheme *sc,
|
|
pointer a)
|
|
{
|
|
return script_fu_marshal_procedure_call (sc, a, FALSE, FALSE);
|
|
}
|
|
|
|
static pointer
|
|
script_fu_marshal_procedure_call_permissive (scheme *sc,
|
|
pointer a)
|
|
{
|
|
return script_fu_marshal_procedure_call (sc, a, TRUE, FALSE);
|
|
}
|
|
|
|
static pointer
|
|
script_fu_marshal_procedure_call_deprecated (scheme *sc,
|
|
pointer a)
|
|
{
|
|
return script_fu_marshal_procedure_call (sc, a, TRUE, TRUE);
|
|
}
|
|
|
|
static pointer
|
|
script_fu_register_call (scheme *sc,
|
|
pointer a)
|
|
{
|
|
return script_fu_add_script (sc, a);
|
|
}
|
|
|
|
static pointer
|
|
script_fu_register_call_filter (scheme *sc,
|
|
pointer a)
|
|
{
|
|
return script_fu_add_script_filter (sc, a);
|
|
}
|
|
|
|
static pointer
|
|
script_fu_menu_register_call (scheme *sc,
|
|
pointer a)
|
|
{
|
|
return script_fu_add_menu (sc, a);
|
|
}
|
|
|
|
static pointer
|
|
script_fu_quit_call (scheme *sc,
|
|
pointer a)
|
|
{
|
|
/* If script-fu-server running, tell it. */
|
|
if (quit_callback != NULL)
|
|
quit_callback ();
|
|
|
|
scheme_deinit (sc);
|
|
|
|
return sc->NIL;
|
|
}
|
|
|
|
static pointer
|
|
script_fu_nil_call (scheme *sc,
|
|
pointer a)
|
|
{
|
|
return sc->NIL;
|
|
}
|
