Glib-Object-Introspection-0.019/000755 001750 000024 00000000000 12266655505 016707 5ustar00brianstaff000000 000000 Glib-Object-Introspection-0.019/GObjectIntrospection.xs000644 001750 000024 00000104420 12266654673 023367 0ustar00brianstaff000000 000000 /* * Copyright (C) 2005 muppet * Copyright (C) 2005-2013 Torsten Schoenfeld * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Lesser General Public License as published by the * Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library 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 Lesser General Public License * for more details. * * You should have received a copy of the GNU Lesser General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA * */ #include "build/gi-version.h" #include #include #include #include /* #define NOISY */ #ifdef NOISY # define dwarn(...) warn(__VA_ARGS__) #else # define dwarn(...) #endif /* ------------------------------------------------------------------------- */ typedef struct { ffi_cif *cif; ffi_closure *closure; GICallableInfo *interface; /* either we have a code and data pair, ... */ SV *code; SV *data; /* ... or a sub name to be called as a method on the invocant. */ gchar *sub_name; /* these are currently only used for signal handler invocation. */ gboolean swap_data; SV *args_converter; guint data_pos; guint destroy_pos; gboolean free_after_use; gpointer priv; /* perl context */ } GPerlI11nPerlCallbackInfo; typedef struct { GISignalInfo *interface; SV *args_converter; } GPerlI11nPerlSignalInfo; typedef struct { GICallableInfo *interface; gpointer func; gpointer data; GDestroyNotify destroy; gint data_pos; gint destroy_pos; SV *data_sv; } GPerlI11nCCallbackInfo; typedef struct { gsize length; guint length_pos; } GPerlI11nArrayInfo; /* This stores information that the different marshallers might need to * communicate to each other. This struct is used for invoking C and Perl * code. */ typedef struct { GICallableInfo *interface; const gchar *target_package; const gchar *target_namespace; const gchar *target_function; gboolean is_function; gboolean is_vfunc; gboolean is_callback; gboolean is_signal; guint n_args; guint n_invoke_args; guint n_expected_args; guint n_nullable_args; guint n_given_args; gboolean is_constructor; gboolean is_method; gboolean throws; gpointer * args; ffi_type ** arg_types; GIArgument * in_args; GIArgument * out_args; GITypeInfo ** out_arg_infos; GIArgument * aux_args; gboolean * is_automatic_arg; gboolean has_return_value; ffi_type * return_type_ffi; GITypeInfo * return_type_info; GITransfer return_type_transfer; guint current_pos; guint method_offset; guint stack_offset; gint dynamic_stack_offset; GSList * callback_infos; GSList * free_after_call; GSList * array_infos; } GPerlI11nInvocationInfo; /* callbacks */ static GPerlI11nPerlCallbackInfo * create_perl_callback_closure_for_named_sub (GIBaseInfo *cb_info, gchar *sub_name); static GPerlI11nPerlCallbackInfo * create_perl_callback_closure (GIBaseInfo *cb_info, SV *code); static void attach_perl_callback_data (GPerlI11nPerlCallbackInfo *info, SV *data); static void release_perl_callback (gpointer data); static GPerlI11nCCallbackInfo * create_c_callback_closure (GIBaseInfo *interface, gpointer func); static void attach_c_callback_data (GPerlI11nCCallbackInfo *info, gpointer data); static void release_c_callback (gpointer data); /* invocation */ #if GI_CHECK_VERSION (1, 33, 10) static void invoke_perl_signal_handler (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata); #endif static void invoke_perl_code (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata); static void invoke_c_code (GICallableInfo *info, gpointer func_pointer, SV **sp, I32 ax, SV **mark, I32 items, /* these correspond to dXSARGS */ UV internal_stack_offset, const gchar *package, const gchar *namespace, const gchar *function); static void free_after_call (GPerlI11nInvocationInfo *iinfo, GFunc func, gpointer data); /* info finders */ static GIFunctionInfo * get_function_info (GIRepository *repository, const gchar *basename, const gchar *namespace, const gchar *method); static GIFieldInfo * get_field_info (GIBaseInfo *info, const gchar *field_name); static GISignalInfo * get_signal_info (GIBaseInfo *container_info, const gchar *signal_name); static gchar * synthesize_gtype_name (GIBaseInfo *info); static gchar * synthesize_prefixed_gtype_name (GIBaseInfo *info); static GType get_gtype (GIRegisteredTypeInfo *info); static const gchar * get_package_for_basename (const gchar *basename); static gboolean is_forbidden_sub_name (const gchar *name); /* marshallers */ static SV * interface_to_sv (GITypeInfo* info, GIArgument *arg, gboolean own, GPerlI11nInvocationInfo *iinfo); static void sv_to_interface (GIArgInfo * arg_info, GITypeInfo * type_info, GITransfer transfer, gboolean may_be_null, SV * sv, GIArgument * arg, GPerlI11nInvocationInfo * invocation_info); static SV * instance_pointer_to_sv (GICallableInfo *info, gpointer pointer); static gpointer instance_sv_to_pointer (GICallableInfo *info, SV *sv); static void sv_to_arg (SV * sv, GIArgument * arg, GIArgInfo * arg_info, GITypeInfo * type_info, GITransfer transfer, gboolean may_be_null, GPerlI11nInvocationInfo * invocation_info); static SV * arg_to_sv (GIArgument * arg, GITypeInfo * info, GITransfer transfer, GPerlI11nInvocationInfo *iinfo); static gpointer sv_to_callback (GIArgInfo * arg_info, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo * invocation_info); static gpointer sv_to_callback_data (SV * sv, GPerlI11nInvocationInfo * invocation_info); static SV * callback_to_sv (GICallableInfo *interface, gpointer func, GPerlI11nInvocationInfo *invocation_info); static SV * callback_data_to_sv (gpointer data, GPerlI11nInvocationInfo * invocation_info); static SV * struct_to_sv (GIBaseInfo* info, GIInfoType info_type, gpointer pointer, gboolean own); static gpointer sv_to_struct (GITransfer transfer, GIBaseInfo * info, GIInfoType info_type, SV * sv); static SV * array_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer, GPerlI11nInvocationInfo *iinfo); static gpointer sv_to_array (GITransfer transfer, GITypeInfo *type_info, SV *sv, GPerlI11nInvocationInfo *iinfo); static SV * glist_to_sv (GITypeInfo* info, gpointer pointer, GITransfer transfer); static gpointer sv_to_glist (GITransfer transfer, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo *iinfo); static SV * ghash_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer); static gpointer sv_to_ghash (GITransfer transfer, GITypeInfo *type_info, SV *sv); #define CAST_RAW(raw, type) (*((type *) raw)) static void raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info); static void arg_to_raw (GIArgument *arg, gpointer raw, GITypeInfo *info); /* sizes */ static gsize size_of_type_tag (GITypeTag type_tag); static gsize size_of_interface (GITypeInfo *type_info); static gsize size_of_type_info (GITypeInfo *type_info); /* enums/flags */ static GType register_unregistered_enum (GIEnumInfo *info); /* fields */ static void store_fields (HV *fields, GIBaseInfo *info, GIInfoType info_type); static SV * get_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer); static void set_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer, SV *value); /* unions */ static SV * rebless_union_sv (GType type, const char *package, gpointer mem, gboolean own); static void associate_union_members_with_gtype (GIUnionInfo *info, const gchar *package, GType type); static GType find_union_member_gtype (const gchar *package, const gchar *namespace); /* methods */ static void store_methods (HV *namespaced_functions, GIBaseInfo *info, GIInfoType info_type); /* object vfuncs */ static void store_objects_with_vfuncs (AV *objects_with_vfuncs, GIObjectInfo *info); static void generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class); /* interface vfuncs */ static void generic_interface_init (gpointer iface, gpointer data); static void generic_interface_finalize (gpointer iface, gpointer data); /* misc. */ static void call_carp_croak (const char *msg); static void call_carp_carp (const char *msg); #define ccroak(...) call_carp_croak (form (__VA_ARGS__)); #define cwarn(...) call_carp_carp (form (__VA_ARGS__)); /* interface_to_sv and its callers might invoke Perl code, so any xsub invoking * them needs to save the stack. this wrapper does this automatically. */ #define SAVED_STACK_SV(expr) \ ({ \ SV *_saved_stack_sv; \ PUTBACK; \ _saved_stack_sv = expr; \ SPAGAIN; \ _saved_stack_sv; \ }) /* ------------------------------------------------------------------------- */ #include "gperl-i11n-callback.c" #include "gperl-i11n-croak.c" #include "gperl-i11n-enums.c" #include "gperl-i11n-field.c" #include "gperl-i11n-gvalue.c" #include "gperl-i11n-info.c" #include "gperl-i11n-invoke-c.c" #include "gperl-i11n-invoke-perl.c" #include "gperl-i11n-marshal-arg.c" #include "gperl-i11n-marshal-array.c" #include "gperl-i11n-marshal-callback.c" #include "gperl-i11n-marshal-hash.c" #include "gperl-i11n-marshal-interface.c" #include "gperl-i11n-marshal-list.c" #include "gperl-i11n-marshal-raw.c" #include "gperl-i11n-marshal-struct.c" #include "gperl-i11n-method.c" #include "gperl-i11n-size.c" #include "gperl-i11n-union.c" #include "gperl-i11n-vfunc-interface.c" #include "gperl-i11n-vfunc-object.c" /* ------------------------------------------------------------------------- */ MODULE = Glib::Object::Introspection PACKAGE = Glib::Object::Introspection gboolean CHECK_VERSION (class, gint major, gint minor, gint micro) CODE: RETVAL = GI_CHECK_VERSION (major, minor, micro); OUTPUT: RETVAL void _load_library (class, namespace, version, search_path=NULL) const gchar *namespace const gchar *version const gchar_ornull *search_path PREINIT: GIRepository *repository; GError *error = NULL; CODE: if (search_path) g_irepository_prepend_search_path (search_path); repository = g_irepository_get_default (); g_irepository_require (repository, namespace, version, 0, &error); if (error) { gperl_croak_gerror (NULL, error); } void _register_types (class, namespace, package) const gchar *namespace const gchar *package PREINIT: GIRepository *repository; gint number, i; AV *constants; AV *global_functions; HV *namespaced_functions; HV *fields; AV *interfaces; AV *objects_with_vfuncs; PPCODE: repository = g_irepository_get_default (); constants = newAV (); global_functions = newAV (); namespaced_functions = newHV (); fields = newHV (); interfaces = newAV (); objects_with_vfuncs = newAV (); number = g_irepository_get_n_infos (repository, namespace); for (i = 0; i < number; i++) { GIBaseInfo *info; GIInfoType info_type; const gchar *name; gchar *full_package; GType type; info = g_irepository_get_info (repository, namespace, i); info_type = g_base_info_get_type (info); name = g_base_info_get_name (info); dwarn ("setting up %s.%s\n", namespace, name); if (info_type == GI_INFO_TYPE_CONSTANT) { av_push (constants, newSVpv (name, 0)); } if (info_type == GI_INFO_TYPE_FUNCTION) { av_push (global_functions, newSVpv (name, 0)); } if (info_type == GI_INFO_TYPE_INTERFACE) { av_push (interfaces, newSVpv (name, 0)); } if (info_type == GI_INFO_TYPE_OBJECT || info_type == GI_INFO_TYPE_INTERFACE || info_type == GI_INFO_TYPE_BOXED || info_type == GI_INFO_TYPE_STRUCT || info_type == GI_INFO_TYPE_UNION || info_type == GI_INFO_TYPE_ENUM || info_type == GI_INFO_TYPE_FLAGS) { store_methods (namespaced_functions, info, info_type); } if (info_type == GI_INFO_TYPE_BOXED || info_type == GI_INFO_TYPE_STRUCT || info_type == GI_INFO_TYPE_UNION) { store_fields (fields, info, info_type); } if (info_type == GI_INFO_TYPE_OBJECT) { store_objects_with_vfuncs (objects_with_vfuncs, info); } /* These are the types that we want to register with perl-Glib. */ if (info_type != GI_INFO_TYPE_OBJECT && info_type != GI_INFO_TYPE_INTERFACE && info_type != GI_INFO_TYPE_BOXED && info_type != GI_INFO_TYPE_STRUCT && info_type != GI_INFO_TYPE_UNION && info_type != GI_INFO_TYPE_ENUM && info_type != GI_INFO_TYPE_FLAGS) { g_base_info_unref ((GIBaseInfo *) info); continue; } type = get_gtype ((GIRegisteredTypeInfo *) info); if (!type) { ccroak ("Could not find GType for type %s::%s", namespace, name); } if (type == G_TYPE_NONE) { /* Try registering unregistered enums/flags. */ if (info_type == GI_INFO_TYPE_ENUM || info_type == GI_INFO_TYPE_FLAGS) { type = register_unregistered_enum (info); } /* If there is still no GType, stop this iteration and * go to the next item. */ if (!type || type == G_TYPE_NONE) { g_base_info_unref ((GIBaseInfo *) info); continue; } } full_package = g_strconcat (package, "::", name, NULL); dwarn (" registering as %s\n", full_package); switch (info_type) { case GI_INFO_TYPE_OBJECT: case GI_INFO_TYPE_INTERFACE: gperl_register_object (type, full_package); break; case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: gperl_register_boxed (type, full_package, NULL); break; case GI_INFO_TYPE_UNION: { GPerlBoxedWrapperClass *my_wrapper_class; GPerlBoxedWrapperClass *default_wrapper_class; default_wrapper_class = gperl_default_boxed_wrapper_class (); /* FIXME: We leak my_wrapper_class here. The problem * is that gperl_register_boxed does not copy the * contents of the wrapper class but instead assumes * that the memory passed in will always be valid. */ my_wrapper_class = g_new (GPerlBoxedWrapperClass, 1); *my_wrapper_class = *default_wrapper_class; my_wrapper_class->wrap = rebless_union_sv; gperl_register_boxed (type, full_package, my_wrapper_class); associate_union_members_with_gtype (info, package, type); break; } case GI_INFO_TYPE_ENUM: case GI_INFO_TYPE_FLAGS: gperl_register_fundamental (type, full_package); #if GI_CHECK_VERSION (1, 29, 17) { const gchar *domain = g_enum_info_get_error_domain (info); if (domain) { gperl_register_error_domain (g_quark_from_string (domain), type, full_package); } } #endif break; default: break; } g_free (full_package); g_base_info_unref ((GIBaseInfo *) info); } /* Use the empty string as the key to indicate "no namespace". */ gperl_hv_take_sv (namespaced_functions, "", 0, newRV_noinc ((SV *) global_functions)); EXTEND (SP, 5); PUSHs (sv_2mortal (newRV_noinc ((SV *) namespaced_functions))); PUSHs (sv_2mortal (newRV_noinc ((SV *) constants))); PUSHs (sv_2mortal (newRV_noinc ((SV *) fields))); PUSHs (sv_2mortal (newRV_noinc ((SV *) interfaces))); PUSHs (sv_2mortal (newRV_noinc ((SV *) objects_with_vfuncs))); # This is only semi-private, as Gtk3 needs it. But it doesn't seem generally # applicable, so it doesn't get an import() API. void _register_boxed_synonym (class, const gchar *reg_basename, const gchar *reg_name, const gchar *syn_gtype_function) PREINIT: GIRepository *repository; GIBaseInfo *reg_info; GModule *module; GType (*syn_gtype_function_pointer) (void) = NULL; GType reg_type, syn_type; CODE: repository = g_irepository_get_default (); reg_info = g_irepository_find_by_name (repository, reg_basename, reg_name); reg_type = reg_info ? get_gtype (reg_info) : 0; if (!reg_type) ccroak ("Could not lookup GType for type %s.%s", reg_basename, reg_name); /* The GType in question (e.g., GdkRectangle) hasn't been loaded yet, * so we cannot use g_type_name. It's also absent from the typelib, so * we cannot use g_irepository_find_by_name. Hence, use the name of * the GType creation function, look it up and call it. */ module = g_module_open (NULL, 0); g_module_symbol (module, syn_gtype_function, (gpointer *) &syn_gtype_function_pointer); syn_type = syn_gtype_function_pointer ? syn_gtype_function_pointer () : 0; g_module_close (module); if (!syn_type) ccroak ("Could not lookup GType from function %s", syn_gtype_function); dwarn ("registering synonym %s => %s", g_type_name (reg_type), g_type_name (syn_type)); gperl_register_boxed_synonym (reg_type, syn_type); g_base_info_unref (reg_info); SV * _fetch_constant (class, basename, constant) const gchar *basename const gchar *constant PREINIT: GIRepository *repository; GIConstantInfo *info; GITypeInfo *type_info; GIArgument value = {0,}; CODE: repository = g_irepository_get_default (); info = g_irepository_find_by_name (repository, basename, constant); if (!GI_IS_CONSTANT_INFO (info)) ccroak ("not a constant"); type_info = g_constant_info_get_type (info); /* FIXME: What am I suppossed to do with the return value? */ g_constant_info_get_value (info, &value); /* No PUTBACK/SPAGAIN needed here. */ RETVAL = arg_to_sv (&value, type_info, GI_TRANSFER_NOTHING, NULL); #if GI_CHECK_VERSION (1, 30, 1) g_constant_info_free_value (info, &value); #endif g_base_info_unref ((GIBaseInfo *) type_info); g_base_info_unref ((GIBaseInfo *) info); OUTPUT: RETVAL SV * _construct_boxed (class, package) const gchar *package PREINIT: GIRepository *repository; GType gtype; GIBaseInfo *info; gsize size; gpointer tmp_mem; CODE: gtype = gperl_boxed_type_from_package (package); if (!gtype) ccroak ("Could not find GType for package %s", package); repository = g_irepository_get_default (); info = g_irepository_find_by_gtype (repository, gtype); if (!info) { g_base_info_unref (info); ccroak ("Could not fetch information for package %s; " "perhaps it has not been loaded via " "Glib::Object::Introspection?", package); } size = g_struct_info_get_size (info); if (!size) { g_base_info_unref (info); ccroak ("Cannot create boxed struct of unknown size for package %s", package); } /* We allocate memory for the boxed type here with malloc(), but then * take a copy of it and discard the original so that the memory we * hand out is always allocated with the allocator used for the boxed * type. Maybe we should use g_alloca? */ tmp_mem = g_malloc0 (size); /* No PUTBACK/SPAGAIN needed here since the code that xsubpp generates * for OUTPUT does not refer to our local copy of the stack pointer * (but uses the ST macro). */ RETVAL = gperl_new_boxed_copy (tmp_mem, gtype); g_free (tmp_mem); g_base_info_unref (info); OUTPUT: RETVAL SV * _get_field (class, basename, namespace, field, invocant) const gchar *basename const gchar *namespace const gchar *field SV *invocant PREINIT: GIRepository *repository; GIBaseInfo *namespace_info; GIFieldInfo *field_info; GType invocant_type; gpointer boxed_mem; CODE: repository = g_irepository_get_default (); namespace_info = g_irepository_find_by_name (repository, basename, namespace); if (!namespace_info) ccroak ("Could not find information for namespace '%s'", namespace); field_info = get_field_info (namespace_info, field); if (!field_info) ccroak ("Could not find field '%s' in namespace '%s'", field, namespace) invocant_type = get_gtype (namespace_info); if (invocant_type == G_TYPE_NONE) { /* If the invocant has no associated GType, try to look at the * {$package}::_i11n_gtype SV. It gets set for members of * boxed unions. */ const gchar *package = get_package_for_basename (basename); if (package) invocant_type = find_union_member_gtype (package, namespace); } if (!g_type_is_a (invocant_type, G_TYPE_BOXED)) ccroak ("Unable to handle access to field '%s' for type '%s'", field, g_type_name (invocant_type)); boxed_mem = gperl_get_boxed_check (invocant, invocant_type); /* No PUTBACK/SPAGAIN needed here. */ RETVAL = get_field (field_info, boxed_mem, GI_TRANSFER_NOTHING); g_base_info_unref (field_info); g_base_info_unref (namespace_info); OUTPUT: RETVAL void _set_field (class, basename, namespace, field, invocant, new_value) const gchar *basename const gchar *namespace const gchar *field SV *invocant SV *new_value PREINIT: GIRepository *repository; GIBaseInfo *namespace_info; GIFieldInfo *field_info; GType invocant_type; gpointer boxed_mem; CODE: repository = g_irepository_get_default (); namespace_info = g_irepository_find_by_name (repository, basename, namespace); if (!namespace_info) ccroak ("Could not find information for namespace '%s'", namespace); field_info = get_field_info (namespace_info, field); if (!field_info) ccroak ("Could not find field '%s' in namespace '%s'", field, namespace) invocant_type = get_gtype (namespace_info); if (invocant_type == G_TYPE_NONE) { /* If the invocant has no associated GType, try to look at the * {$package}::_i11n_gtype SV. It gets set for members of * boxed unions. */ const gchar *package = get_package_for_basename (basename); if (package) invocant_type = find_union_member_gtype (package, namespace); } if (!g_type_is_a (invocant_type, G_TYPE_BOXED)) ccroak ("Unable to handle access to field '%s' for type '%s'", field, g_type_name (invocant_type)); boxed_mem = gperl_get_boxed_check (invocant, invocant_type); /* Conceptually, we need to always transfer ownership to the boxed * object for things like strings. The memory would then be freed by * the boxed free func. But to do this correctly, we would need to * free the memory that we are about to abandon by installing a new * pointer. We can't know what free function to use, though. So * g_field_info_set_field, and by extension set_field, simply refuse to * set any member that would require such memory management. */ set_field (field_info, boxed_mem, GI_TRANSFER_EVERYTHING, new_value); g_base_info_unref (field_info); g_base_info_unref (namespace_info); void _add_interface (class, basename, interface_name, target_package) const gchar *basename const gchar *interface_name const gchar *target_package PREINIT: GIRepository *repository; GIInterfaceInfo *info; GInterfaceInfo iface_info; GType gtype; CODE: repository = g_irepository_get_default (); info = g_irepository_find_by_name (repository, basename, interface_name); if (!GI_IS_INTERFACE_INFO (info)) ccroak ("not an interface"); iface_info.interface_init = generic_interface_init; iface_info.interface_finalize = generic_interface_finalize, iface_info.interface_data = info; gtype = gperl_object_type_from_package (target_package); if (!gtype) ccroak ("package '%s' is not registered with Glib-Perl", target_package); g_type_add_interface_static (gtype, get_gtype (info), &iface_info); /* info is unref'd in generic_interface_finalize */ void _install_overrides (class, basename, object_name, target_package) const gchar *basename const gchar *object_name const gchar *target_package PREINIT: GIRepository *repository; GIObjectInfo *info; GType gtype; gpointer klass; CODE: dwarn ("_install_overrides: %s.%s for %s\n", basename, object_name, target_package); repository = g_irepository_get_default (); info = g_irepository_find_by_name (repository, basename, object_name); if (!GI_IS_OBJECT_INFO (info)) ccroak ("not an object"); gtype = gperl_object_type_from_package (target_package); if (!gtype) ccroak ("package '%s' is not registered with Glib-Perl", target_package); klass = g_type_class_peek (gtype); if (!klass) ccroak ("internal problem: can't peek at type class for %s (%" G_GSIZE_FORMAT ")", g_type_name (gtype), gtype); generic_class_init (info, target_package, klass); g_base_info_unref (info); void _find_non_perl_parents (class, basename, object_name, target_package) const gchar *basename const gchar *object_name const gchar *target_package PREINIT: GIRepository *repository; GIObjectInfo *info; GType gtype, object_gtype; /* FIXME: we should export gperl_type_reg_quark from Glib */ GQuark reg_quark = g_quark_from_static_string ("__gperl_type_reg"); PPCODE: repository = g_irepository_get_default (); info = g_irepository_find_by_name (repository, basename, object_name); g_assert (info && GI_IS_OBJECT_INFO (info)); gtype = gperl_object_type_from_package (target_package); object_gtype = get_gtype (info); /* find all non-Perl parents up to and including the object type */ while ((gtype = g_type_parent (gtype))) { if (!g_type_get_qdata (gtype, reg_quark)) { const gchar *package = gperl_object_package_from_type (gtype); XPUSHs (sv_2mortal (newSVpv (package, 0))); } if (gtype == object_gtype) { break; } } g_base_info_unref (info); void _find_vfuncs_with_implementation (class, object_package, target_package) const gchar *object_package const gchar *target_package PREINIT: GIRepository *repository; GType object_gtype, target_gtype; gpointer object_klass, target_klass; GIObjectInfo *object_info; gint n_vfuncs, i; PPCODE: repository = g_irepository_get_default (); target_gtype = gperl_object_type_from_package (target_package); object_gtype = gperl_object_type_from_package (object_package); g_assert (target_gtype && object_gtype); target_klass = g_type_class_peek (target_gtype); object_klass = g_type_class_peek (object_gtype); g_assert (target_klass && object_klass); object_info = g_irepository_find_by_gtype (repository, object_gtype); g_assert (object_info && GI_IS_OBJECT_INFO (object_info)); n_vfuncs = g_object_info_get_n_vfuncs (object_info); for (i = 0; i < n_vfuncs; i++) { GIVFuncInfo *vfunc_info; const gchar *vfunc_name; gint field_offset; vfunc_info = g_object_info_get_vfunc (object_info, i); vfunc_name = g_base_info_get_name (vfunc_info); /* FIXME: g_vfunc_info_get_offset does not seem to work here. */ field_offset = get_vfunc_offset (object_info, vfunc_name); if (G_STRUCT_MEMBER (gpointer, target_klass, field_offset)) { XPUSHs (sv_2mortal (newSVpv (vfunc_name, 0))); } g_base_info_unref (vfunc_info); } g_base_info_unref (object_info); void _invoke_fallback_vfunc (class, vfunc_package, vfunc_name, target_package, ...) const gchar *vfunc_package const gchar *vfunc_name const gchar *target_package PREINIT: UV internal_stack_offset = 4; GIRepository *repository; GIObjectInfo *info; GType gtype; gpointer klass; GIVFuncInfo *vfunc_info; gint field_offset; gpointer func_pointer; PPCODE: dwarn ("_invoke_fallback_vfunc: %s.%s, target = %s\n", vfunc_package, vfunc_name, target_package); gtype = gperl_object_type_from_package (target_package); klass = g_type_class_peek (gtype); g_assert (klass); repository = g_irepository_get_default (); info = g_irepository_find_by_gtype ( repository, gperl_object_type_from_package (vfunc_package)); g_assert (info && GI_IS_OBJECT_INFO (info)); vfunc_info = g_object_info_find_vfunc (info, vfunc_name); g_assert (vfunc_info); /* FIXME: g_vfunc_info_get_offset does not seem to work here. */ field_offset = get_vfunc_offset (info, vfunc_name); func_pointer = G_STRUCT_MEMBER (gpointer, klass, field_offset); g_assert (func_pointer); invoke_c_code (vfunc_info, func_pointer, sp, ax, mark, items, internal_stack_offset, NULL, NULL, NULL); /* SPAGAIN since invoke_c_code probably modified the stack * pointer. so we need to make sure that our local variable * 'sp' is correct before the implicit PUTBACK happens. */ SPAGAIN; g_base_info_unref (vfunc_info); g_base_info_unref (info); void _use_generic_signal_marshaller_for (class, const gchar *package, const gchar *signal, SV *args_converter=NULL) CODE: #if GI_CHECK_VERSION (1, 33, 10) { GType gtype; GIRepository *repository; GIBaseInfo *container_info; GPerlI11nPerlSignalInfo *signal_info; ffi_cif *cif; ffi_closure *closure; GIBaseInfo *closure_marshal_info; gtype = gperl_type_from_package (package); if (!gtype) ccroak ("Could not find GType for package %s", package); repository = g_irepository_get_default (); container_info = g_irepository_find_by_gtype (repository, gtype); if (!container_info || !(GI_IS_OBJECT_INFO (container_info) || GI_IS_INTERFACE_INFO (container_info))) ccroak ("Could not find object/interface info for package %s", package); signal_info = g_new0 (GPerlI11nPerlSignalInfo, 1); // FIXME: ctor? signal_info->interface = get_signal_info (container_info, signal); if (args_converter) signal_info->args_converter = SvREFCNT_inc (args_converter); if (!signal_info) ccroak ("Could not find signal %s for package %s", signal, package); closure_marshal_info = g_irepository_find_by_name (repository, "GObject", "ClosureMarshal"); g_assert (closure_marshal_info); cif = g_new0 (ffi_cif, 1); closure = g_callable_info_prepare_closure (closure_marshal_info, cif, invoke_perl_signal_handler, signal_info); g_base_info_unref (closure_marshal_info); dwarn ("_use_generic_signal_marshaller_for: " "package %s, signal %s => closure %p\n", package, signal, closure); gperl_signal_set_marshaller_for (gtype, (gchar*) signal, (GClosureMarshal) closure); /* These should be freed when the signal marshaller is not needed * anymore. But gperl_signal_set_marshaller_for does not provide a * hook for resource freeing. * * g_callable_info_free_closure (signal_info, closure); * g_free (cif); * g_base_info_unref (signal_info->interface); * if (signal_info->args_converter) * SvREFCNT_dec (signal_info->args_converter); * g_free (signal_info); */ g_base_info_unref (container_info); } #else { PERL_UNUSED_VAR (args_converter); /* g_callable_info_prepare_closure, and thus * create_perl_callback_closure and invoke_perl_signal_handler, did not * work correctly for signals prior to commit * d8970fbc500a8b20853b564536251315587450d9 in * gobject-introspection. */ warn ("*** Cannot use generic signal marshallers for signal %s of %s " "unless gobject-introspection >= 1.33.10; " "any handlers connected to the signal " "might thus be invoked incorrectly\n", signal, package); } #endif void invoke (class, basename, namespace, function, ...) const gchar *basename const gchar_ornull *namespace const gchar *function PREINIT: UV internal_stack_offset = 4; GIRepository *repository; GIFunctionInfo *info; gpointer func_pointer = NULL; const gchar *symbol = NULL; PPCODE: repository = g_irepository_get_default (); info = get_function_info (repository, basename, namespace, function); symbol = g_function_info_get_symbol (info); if (!g_typelib_symbol (g_base_info_get_typelib((GIBaseInfo *) info), symbol, &func_pointer)) { g_base_info_unref ((GIBaseInfo *) info); ccroak ("Could not locate symbol %s", symbol); } invoke_c_code (info, func_pointer, sp, ax, mark, items, internal_stack_offset, get_package_for_basename (basename), namespace, function); /* SPAGAIN since invoke_c_code probably modified the stack pointer. * so we need to make sure that our implicit local variable 'sp' is * correct before the implicit PUTBACK happens. */ SPAGAIN; g_base_info_unref ((GIBaseInfo *) info); gint convert_sv_to_enum (class, const gchar *package, SV *sv) PREINIT: GType gtype; CODE: gtype = gperl_type_from_package (package); RETVAL = gperl_convert_enum (gtype, sv); OUTPUT: RETVAL SV * convert_enum_to_sv (class, const gchar *package, gint n) PREINIT: GType gtype; CODE: gtype = gperl_type_from_package (package); RETVAL = gperl_convert_back_enum (gtype, n); OUTPUT: RETVAL # --------------------------------------------------------------------------- # MODULE = Glib::Object::Introspection PACKAGE = Glib::Object::Introspection::GValueWrapper SV * new (class, const gchar *type_package, SV *perl_value) PREINIT: GType type; GValue *v; CODE: type = gperl_type_from_package (type_package); if (!type) ccroak ("Could not find GType for '%s'", type_package); v = g_new0 (GValue, 1); g_value_init (v, type); gperl_value_from_sv (v, perl_value); RETVAL = newSVGValueWrapper (v); OUTPUT: RETVAL void DESTROY (SV *sv) PREINIT: GValue *v; CODE: v = SvGValueWrapper (sv); g_value_unset (v); g_free (v); # --------------------------------------------------------------------------- # MODULE = Glib::Object::Introspection PACKAGE = Glib::Object::Introspection::_FuncWrapper void _invoke (SV *code, ...) PREINIT: GPerlI11nCCallbackInfo *wrapper; UV internal_stack_offset = 1; PPCODE: wrapper = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (SvRV (code))); if (!wrapper || !wrapper->func) ccroak ("invalid reference encountered"); invoke_c_code (wrapper->interface, wrapper->func, sp, ax, mark, items, internal_stack_offset, NULL, NULL, NULL); /* SPAGAIN since invoke_c_code probably modified the stack * pointer. so we need to make sure that our local variable * 'sp' is correct before the implicit PUTBACK happens. */ SPAGAIN; void DESTROY (SV *code) PREINIT: GPerlI11nCCallbackInfo *info; CODE: info = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (SvRV (code))); if (info) release_c_callback (info); Glib-Object-Introspection-0.019/gperl-i11n-callback.c000644 001750 000024 00000006406 12103264610 022451 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static GPerlI11nPerlCallbackInfo * create_perl_callback_closure (GICallableInfo *cb_info, SV *code) { GPerlI11nPerlCallbackInfo *info; info = g_new0 (GPerlI11nPerlCallbackInfo, 1); if (!gperl_sv_is_defined (code)) return info; info->interface = g_base_info_ref (cb_info); info->cif = g_new0 (ffi_cif, 1); info->closure = g_callable_info_prepare_closure (info->interface, info->cif, invoke_perl_code, info); /* FIXME: This should most likely use SvREFCNT_inc instead of * newSVsv. */ info->code = newSVsv (code); info->sub_name = NULL; /* These are only relevant for signal marshalling; if needed, they get * set in invoke_perl_signal_handler. */ info->swap_data = FALSE; info->args_converter = NULL; #ifdef PERL_IMPLICIT_CONTEXT info->priv = aTHX; #endif return info; } static void attach_perl_callback_data (GPerlI11nPerlCallbackInfo *info, SV *data) { /* FIXME: SvREFCNT_inc? */ info->data = newSVsv (data); } /* assumes ownership of sub_name */ static GPerlI11nPerlCallbackInfo * create_perl_callback_closure_for_named_sub (GICallableInfo *cb_info, gchar *sub_name) { GPerlI11nPerlCallbackInfo *info; info = g_new0 (GPerlI11nPerlCallbackInfo, 1); info->interface = g_base_info_ref (cb_info); info->cif = g_new0 (ffi_cif, 1); info->closure = g_callable_info_prepare_closure (info->interface, info->cif, invoke_perl_code, info); info->sub_name = sub_name; info->code = NULL; info->data = NULL; #ifdef PERL_IMPLICIT_CONTEXT info->priv = aTHX; #endif return info; } static void release_perl_callback (gpointer data) { GPerlI11nPerlCallbackInfo *info = data; dwarn ("releasing Perl callback info %p\n", info); /* g_callable_info_free_closure reaches into info->cif, so it needs to * be called before we free it. See * . */ if (info->closure) g_callable_info_free_closure (info->interface, info->closure); if (info->cif) g_free (info->cif); if (info->interface) g_base_info_unref ((GIBaseInfo*) info->interface); if (info->code) SvREFCNT_dec (info->code); if (info->data) SvREFCNT_dec (info->data); if (info->sub_name) g_free (info->sub_name); if (info->args_converter) SvREFCNT_dec (info->args_converter); g_free (info); } /* -------------------------------------------------------------------------- */ static GPerlI11nCCallbackInfo * create_c_callback_closure (GIBaseInfo *interface, gpointer func) { GPerlI11nCCallbackInfo *info; info = g_new0 (GPerlI11nCCallbackInfo, 1); if (!func) return info; info->interface = interface; g_base_info_ref (interface); info->func = func; return info; } static void attach_c_callback_data (GPerlI11nCCallbackInfo *info, gpointer data) { info->data = data; } static void release_c_callback (gpointer data) { GPerlI11nCCallbackInfo *info = data; dwarn ("releasing C callback info %p\n", info); /* FIXME: we cannot call the destroy notify here because it might be * our own release_perl_callback which would try to free the ffi stuff * that is currently running. */ /* if (info->destroy) */ /* info->destroy (info->data); */ if (info->interface) g_base_info_unref (info->interface); g_free (info); } Glib-Object-Introspection-0.019/gperl-i11n-croak.c000644 001750 000024 00000001274 12221722371 022016 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ /* Call Carp's croak() so that errors are reported at their location in the * user's program, not in Introspection.pm. Adapted from * . */ static void call_carp_croak (const char *msg) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (sv_2mortal (newSVpv(msg, 0))); PUTBACK; call_pv("Carp::croak", G_VOID | G_DISCARD); FREETMPS; LEAVE; } /* Similarly for Carp's carp(). */ static void call_carp_carp (const char *msg) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (sv_2mortal (newSVpv(msg, 0))); PUTBACK; call_pv("Carp::carp", G_VOID | G_DISCARD); FREETMPS; LEAVE; } Glib-Object-Introspection-0.019/gperl-i11n-enums.c000644 001750 000024 00000003261 12266654203 022053 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ #define FILL_VALUES(values) \ for (i = 0; i < n_values; i++) { \ GIValueInfo *value_info = g_enum_info_get_value (info, i); \ (values)[i].value = g_value_info_get_value (value_info); \ /* FIXME: Can we assume that the strings will stick around long enough? */ \ (values)[i].value_nick = g_base_info_get_name (value_info); \ (values)[i].value_name = g_base_info_get_attribute (value_info, "c:identifier"); \ if (!(values)[i].value_name) \ (values)[i].value_name = (values)[i].value_nick; \ g_base_info_unref (value_info); \ } static GType register_unregistered_enum (GIEnumInfo *info) { GType gtype = G_TYPE_NONE; gchar *full_name; GIInfoType info_type; void *values; /* Abort if there already is a GType under this name. */ full_name = synthesize_prefixed_gtype_name (info); if (g_type_from_name (full_name)) { g_free (full_name); return gtype; } info_type = g_base_info_get_type (info); /* We have to leak 'values' as g_enum_register_static and * g_flags_register_static assume that what we pass in will be valid * throughout the lifetime of the program. */ gint i, n_values = g_enum_info_get_n_values (info); if (info_type == GI_INFO_TYPE_ENUM) { values = g_new0 (GEnumValue, n_values+1); /* zero-terminated */ FILL_VALUES ((GEnumValue *) values); } else { values = g_new0 (GFlagsValue, n_values+1); /* zero-terminated */ FILL_VALUES ((GFlagsValue *) values); } if (info_type == GI_INFO_TYPE_ENUM) { gtype = g_enum_register_static (full_name, (GEnumValue *) values); } else { gtype = g_flags_register_static (full_name, (GFlagsValue *) values); } g_free (full_name); return gtype; } Glib-Object-Introspection-0.019/gperl-i11n-field.c000644 001750 000024 00000013011 12221722371 021772 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void store_fields (HV *fields, GIBaseInfo *info, GIInfoType info_type) { const gchar *namespace; AV *av; gint i; namespace = g_base_info_get_name (info); av = newAV (); switch (info_type) { case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: { gint n_fields = g_struct_info_get_n_fields ( (GIStructInfo *) info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; const gchar *field_name; field_info = g_struct_info_get_field ((GIStructInfo *) info, i); field_name = g_base_info_get_name ((GIBaseInfo *) field_info); av_push (av, newSVpv (field_name, 0)); g_base_info_unref ((GIBaseInfo *) field_info); } break; } case GI_INFO_TYPE_UNION: { gint n_fields = g_union_info_get_n_fields ((GIUnionInfo *) info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; const gchar *field_name; field_info = g_union_info_get_field ((GIUnionInfo *) info, i); field_name = g_base_info_get_name ((GIBaseInfo *) field_info); av_push (av, newSVpv (field_name, 0)); g_base_info_unref ((GIBaseInfo *) field_info); } break; } default: ccroak ("store_fields: unsupported info type %d", info_type); } gperl_hv_take_sv (fields, namespace, strlen (namespace), newRV_noinc ((SV *) av)); } /* This may call Perl code (via arg_to_sv), so it needs to be wrapped with * PUTBACK/SPAGAIN by the caller. */ static SV * get_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer) { GITypeInfo *field_type; GIBaseInfo *interface_info; GIArgument value; SV *sv = NULL; field_type = g_field_info_get_type (field_info); interface_info = g_type_info_get_interface (field_type); /* This case is not handled by g_field_info_set_field. */ if (!g_type_info_is_pointer (field_type) && g_type_info_get_tag (field_type) == GI_TYPE_TAG_INTERFACE && g_base_info_get_type (interface_info) == GI_INFO_TYPE_STRUCT) { gsize offset; offset = g_field_info_get_offset (field_info); value.v_pointer = mem + offset; sv = arg_to_sv (&value, field_type, GI_TRANSFER_NOTHING, NULL); } else if (g_field_info_get_field (field_info, mem, &value)) { sv = arg_to_sv (&value, field_type, transfer, NULL); } else { ccroak ("Could not get field '%s'", g_base_info_get_name (field_info)); } if (interface_info) g_base_info_unref (interface_info); g_base_info_unref ((GIBaseInfo *) field_type); return sv; } static void set_field (GIFieldInfo *field_info, gpointer mem, GITransfer transfer, SV *sv) { GITypeInfo *field_type; GIBaseInfo *interface_info; GITypeTag tag; GIInfoType info_type; GIArgument arg; field_type = g_field_info_get_type (field_info); tag = g_type_info_get_tag (field_type); interface_info = g_type_info_get_interface (field_type); info_type = interface_info ? g_base_info_get_type (interface_info) : GI_INFO_TYPE_INVALID; /* Structs are not handled by g_field_info_set_field. */ if (tag == GI_TYPE_TAG_INTERFACE && info_type == GI_INFO_TYPE_STRUCT) { /* FIXME: No GIArgInfo and no GPerlI11nInvocationInfo here. * What if the struct contains an object pointer, or a callback * field? */ gsize offset = g_field_info_get_offset (field_info); if (!g_type_info_is_pointer (field_type)) { /* By value */ gssize size; /* Enforce GI_TRANSFER_NOTHING since we will copy into * the memory that has already been allocated inside * 'mem' */ arg.v_pointer = sv_to_struct (GI_TRANSFER_NOTHING, interface_info, info_type, sv); size = g_struct_info_get_size (interface_info); g_memmove (mem + offset, arg.v_pointer, size); } else { /* Pointer */ GType gtype = get_gtype (interface_info); if (g_type_is_a (gtype, G_TYPE_BOXED)) { gpointer old = G_STRUCT_MEMBER (gpointer, mem, offset); /* GI_TRANSFER_NOTHING because we handle the * memory ourselves here. */ sv_to_interface (NULL, field_type, GI_TRANSFER_NOTHING, TRUE, sv, &arg, NULL); if (arg.v_pointer != old) { if (old) g_boxed_free (gtype, old); G_STRUCT_MEMBER (gpointer, mem, offset) = arg.v_pointer ? g_boxed_copy (gtype, arg.v_pointer) : NULL; } } else { g_assert (gtype == G_TYPE_INVALID || gtype == G_TYPE_NONE); /* We have no way to know how to manage the * memory here, so we just stuff the pointer in * directly. */ G_STRUCT_MEMBER (gpointer, mem, offset) = sv_to_struct (GI_TRANSFER_NOTHING, interface_info, info_type, sv); } } } /* Neither are void pointers. We put an RV to the SV into them, which * goes hand in hand with what get_field() is doing above via * arg_to_sv(). */ else if (tag == GI_TYPE_TAG_VOID && g_type_info_is_pointer (field_type)) { gsize offset = g_field_info_get_offset (field_info); sv_to_arg (sv, &arg, NULL, field_type, transfer, TRUE, NULL); G_STRUCT_MEMBER (gpointer, mem, offset) = arg.v_pointer; } else { sv_to_arg (sv, &arg, NULL, field_type, transfer, TRUE, NULL); if (!g_field_info_set_field (field_info, mem, &arg)) ccroak ("Could not set field '%s'", g_base_info_get_name (field_info)); } if (interface_info) g_base_info_unref (interface_info); g_base_info_unref (field_type); } Glib-Object-Introspection-0.019/gperl-i11n-gvalue.c000644 001750 000024 00000000737 11663370775 022225 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ /* Semi-private package for marshalling into GValues. */ #define GVALUE_WRAPPER_PACKAGE "Glib::Object::Introspection::GValueWrapper" static GValue * SvGValueWrapper (SV *sv) { return sv_derived_from (sv, GVALUE_WRAPPER_PACKAGE) ? INT2PTR (GValue*, SvIV (SvRV (sv))) : NULL; } static SV * newSVGValueWrapper (GValue *v) { SV *sv; sv = newSV (0); sv_setref_pv (sv, GVALUE_WRAPPER_PACKAGE, v); return sv; } Glib-Object-Introspection-0.019/gperl-i11n-info.c000644 001750 000024 00000014670 12266654203 021665 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static GIFunctionInfo * _find_enum_method (GIEnumInfo *info, const gchar *method) { #if GI_CHECK_VERSION (1, 29, 17) gint n_methods; gint i; n_methods = g_enum_info_get_n_methods (info); for (i = 0; i < n_methods; i++) { GIFunctionInfo *method_info = g_enum_info_get_method (info, i); if (strEQ (g_base_info_get_name (method_info), method)) return method_info; g_base_info_unref (method_info); } #endif return NULL; } /* Caller owns return value */ static GIFunctionInfo * get_function_info (GIRepository *repository, const gchar *basename, const gchar *namespace, const gchar *method) { dwarn ("%s: %s, %s, %s\n", G_STRFUNC, basename, namespace, method); if (namespace) { GIFunctionInfo *function_info = NULL; GIBaseInfo *namespace_info = g_irepository_find_by_name ( repository, basename, namespace); if (!namespace_info) ccroak ("Can't find information for namespace %s", namespace); switch (g_base_info_get_type (namespace_info)) { case GI_INFO_TYPE_OBJECT: function_info = g_object_info_find_method ( (GIObjectInfo *) namespace_info, method); break; case GI_INFO_TYPE_INTERFACE: function_info = g_interface_info_find_method ( (GIInterfaceInfo *) namespace_info, method); break; case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: function_info = g_struct_info_find_method ( (GIStructInfo *) namespace_info, method); break; case GI_INFO_TYPE_UNION: function_info = g_union_info_find_method ( (GIUnionInfo *) namespace_info, method); break; case GI_INFO_TYPE_ENUM: case GI_INFO_TYPE_FLAGS: function_info = _find_enum_method ( (GIEnumInfo *) namespace_info, method); break; default: ccroak ("Base info for namespace %s has incorrect type", namespace); } if (!function_info) ccroak ("Can't find information for method " "%s::%s", namespace, method); g_base_info_unref (namespace_info); return function_info; } else { GIBaseInfo *method_info = g_irepository_find_by_name ( repository, basename, method); if (!method_info) ccroak ("Can't find information for method %s", method); switch (g_base_info_get_type (method_info)) { case GI_INFO_TYPE_FUNCTION: return (GIFunctionInfo *) method_info; default: ccroak ("Base info for method %s has incorrect type", method); } } return NULL; } /* Caller owns return value */ static GIFieldInfo * get_field_info (GIBaseInfo *info, const gchar *field_name) { GIInfoType info_type; info_type = g_base_info_get_type (info); switch (info_type) { case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: { gint n_fields, i; n_fields = g_struct_info_get_n_fields ((GIStructInfo *) info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; field_info = g_struct_info_get_field ((GIStructInfo *) info, i); if (0 == strcmp (field_name, g_base_info_get_name (field_info))) { return field_info; } g_base_info_unref (field_info); } break; } case GI_INFO_TYPE_UNION: { gint n_fields, i; n_fields = g_union_info_get_n_fields ((GIStructInfo *) info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; field_info = g_union_info_get_field ((GIStructInfo *) info, i); if (0 == strcmp (field_name, g_base_info_get_name (field_info))) { return field_info; } g_base_info_unref (field_info); } break; } default: break; } return NULL; } /* Caller owns return value */ static GISignalInfo * get_signal_info (GIBaseInfo *container_info, const gchar *signal_name) { if (GI_IS_OBJECT_INFO (container_info)) { return g_object_info_find_signal (container_info, signal_name); } else if (GI_IS_INTERFACE_INFO (container_info)) { #if GI_CHECK_VERSION (1, 35, 4) return g_interface_info_find_signal (container_info, signal_name); #else { gint n_signals; gint i; n_signals = g_interface_info_get_n_signals (container_info); for (i = 0; i < n_signals; i++) { GISignalInfo *siginfo = g_interface_info_get_signal (container_info, i); if (strEQ (g_base_info_get_name (siginfo), signal_name)) return siginfo; g_base_info_unref (siginfo); } return NULL; } #endif } return NULL; } /* Caller owns return value. */ static gchar * synthesize_gtype_name (GIBaseInfo *info) { const gchar *namespace = g_base_info_get_namespace (info); const gchar *name = g_base_info_get_name (info); if (0 == strncmp (namespace, "GObject", 8) || 0 == strncmp (namespace, "GLib", 5)) { namespace = "G"; } return g_strconcat (namespace, name, NULL); } /* Caller owns return value. */ static gchar * synthesize_prefixed_gtype_name (GIBaseInfo *info) { const gchar *namespace = g_base_info_get_namespace (info); const gchar *name = g_base_info_get_name (info); if (0 == strncmp (namespace, "GObject", 8) || 0 == strncmp (namespace, "GLib", 5)) { namespace = "G"; } return g_strconcat ("GPerlI11n", namespace, name, NULL); } static GType get_gtype (GIRegisteredTypeInfo *info) { GType gtype = g_registered_type_info_get_g_type (info); /* Fall back to the registered type name, and if that doesn't work * either, construct the full name and the prefixed full name and try * them. */ if (!gtype || gtype == G_TYPE_NONE) { const gchar *type_name = g_registered_type_info_get_type_name (info); if (type_name) { gtype = g_type_from_name (type_name); } } if (!gtype || gtype == G_TYPE_NONE) { gchar *full_name = synthesize_gtype_name (info); gtype = g_type_from_name (full_name); g_free (full_name); } if (!gtype || gtype == G_TYPE_NONE) { gchar *full_name = synthesize_prefixed_gtype_name (info); gtype = g_type_from_name (full_name); g_free (full_name); } return gtype ? gtype : G_TYPE_NONE; } static const gchar * get_package_for_basename (const gchar *basename) { SV **svp; HV *basename_to_package = get_hv ("Glib::Object::Introspection::_BASENAME_TO_PACKAGE", 0); g_assert (basename_to_package); svp = hv_fetch (basename_to_package, basename, strlen (basename), 0); if (!svp || !gperl_sv_is_defined (*svp)) return NULL; return SvPV_nolen (*svp); } static gboolean is_forbidden_sub_name (const gchar *name) { HV *forbidden_sub_names = get_hv ("Glib::Object::Introspection::_FORBIDDEN_SUB_NAMES", 0); g_assert (forbidden_sub_names); return hv_exists (forbidden_sub_names, name, strlen (name)); } Glib-Object-Introspection-0.019/gperl-i11n-invoke-c.c000644 001750 000024 00000047671 12266540466 022461 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void _prepare_c_invocation_info (GPerlI11nInvocationInfo *iinfo, GICallableInfo *info, IV items, UV internal_stack_offset, const gchar *package, const gchar *namespace, const gchar *function); static void _clear_c_invocation_info (GPerlI11nInvocationInfo *iinfo); static void _check_n_args (GPerlI11nInvocationInfo *iinfo); static void _handle_automatic_arg (guint pos, GIArgument * arg, GPerlI11nInvocationInfo * invocation_info); static gpointer _allocate_out_mem (GITypeInfo *arg_type); static void _invoke_free_after_call_handlers (GPerlI11nInvocationInfo *iinfo); static void invoke_c_code (GICallableInfo *info, gpointer func_pointer, SV **sp, I32 ax, SV **mark, I32 items, /* these correspond to dXSARGS */ UV internal_stack_offset, const gchar *package, const gchar *namespace, const gchar *function) { ffi_cif cif; gpointer instance = NULL; guint i; GPerlI11nInvocationInfo iinfo = {0,}; guint n_return_values; GIArgument return_value; GError * local_error = NULL; gpointer local_error_address = &local_error; PERL_UNUSED_VAR (mark); _prepare_c_invocation_info (&iinfo, info, items, internal_stack_offset, package, namespace, function); _check_n_args (&iinfo); if (iinfo.is_method) { instance = instance_sv_to_pointer (info, ST (0 + iinfo.stack_offset)); iinfo.arg_types[0] = &ffi_type_pointer; iinfo.args[0] = &instance; } for (i = 0 ; i < iinfo.n_args ; i++) { GIArgInfo * arg_info; GITypeInfo * arg_type; GITransfer transfer; gboolean may_be_null = FALSE, is_skipped = FALSE; gint perl_stack_pos, ffi_stack_pos; SV *current_sv; arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i); /* In case of out and in-out args, arg_type is unref'ed after * the function has been invoked */ arg_type = g_arg_info_get_type (arg_info); transfer = g_arg_info_get_ownership_transfer (arg_info); may_be_null = g_arg_info_may_be_null (arg_info); #if GI_CHECK_VERSION (1, 29, 0) is_skipped = g_arg_info_is_skip (arg_info); #endif perl_stack_pos = i + iinfo.method_offset + iinfo.stack_offset + iinfo.dynamic_stack_offset; ffi_stack_pos = i + iinfo.method_offset; /* FIXME: Is this right? I'm confused about the relation of * the numbers in g_callable_info_get_arg and * g_arg_info_get_closure and g_arg_info_get_destroy. We used * to add method_offset, but that stopped being correct at some * point. */ iinfo.current_pos = i; /* + method_offset; */ dwarn (" arg %d, tag: %d (%s), is_pointer: %d, is_automatic: %d\n", i, g_type_info_get_tag (arg_type), g_type_tag_to_string (g_type_info_get_tag (arg_type)), g_type_info_is_pointer (arg_type), iinfo.is_automatic_arg[i]); /* Use undef for missing args (due to the checks above, these * must be nullable). */ current_sv = perl_stack_pos < items ? ST (perl_stack_pos) : &PL_sv_undef; switch (g_arg_info_get_direction (arg_info)) { case GI_DIRECTION_IN: if (iinfo.is_automatic_arg[i]) { iinfo.dynamic_stack_offset--; } else if (is_skipped) { iinfo.dynamic_stack_offset--; } else { sv_to_arg (current_sv, &iinfo.in_args[i], arg_info, arg_type, transfer, may_be_null, &iinfo); } iinfo.arg_types[ffi_stack_pos] = g_type_info_get_ffi_type (arg_type); iinfo.args[ffi_stack_pos] = &iinfo.in_args[i]; g_base_info_unref ((GIBaseInfo *) arg_type); break; case GI_DIRECTION_OUT: if (g_arg_info_is_caller_allocates (arg_info)) { iinfo.aux_args[i].v_pointer = _allocate_out_mem (arg_type); iinfo.out_args[i].v_pointer = &iinfo.aux_args[i]; iinfo.args[ffi_stack_pos] = &iinfo.aux_args[i]; } else { iinfo.out_args[i].v_pointer = &iinfo.aux_args[i]; iinfo.args[ffi_stack_pos] = &iinfo.out_args[i]; } iinfo.out_arg_infos[i] = arg_type; iinfo.arg_types[ffi_stack_pos] = &ffi_type_pointer; /* Adjust the dynamic stack offset so that this out * argument doesn't inadvertedly eat up an in argument. */ iinfo.dynamic_stack_offset--; break; case GI_DIRECTION_INOUT: iinfo.in_args[i].v_pointer = iinfo.out_args[i].v_pointer = &iinfo.aux_args[i]; if (iinfo.is_automatic_arg[i]) { iinfo.dynamic_stack_offset--; } else if (is_skipped) { iinfo.dynamic_stack_offset--; } else { /* We pass iinfo.in_args[i].v_pointer here, * not &iinfo.in_args[i], so that the value * pointed to is filled from the SV. */ sv_to_arg (current_sv, iinfo.in_args[i].v_pointer, arg_info, arg_type, transfer, may_be_null, &iinfo); } iinfo.out_arg_infos[i] = arg_type; iinfo.arg_types[ffi_stack_pos] = &ffi_type_pointer; iinfo.args[ffi_stack_pos] = &iinfo.in_args[i]; break; } g_base_info_unref ((GIBaseInfo *) arg_info); } /* do another pass to handle automatic args */ for (i = 0 ; i < iinfo.n_args ; i++) { GIArgInfo * arg_info; if (!iinfo.is_automatic_arg[i]) continue; arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i); switch (g_arg_info_get_direction (arg_info)) { case GI_DIRECTION_IN: _handle_automatic_arg (i, &iinfo.in_args[i], &iinfo); break; case GI_DIRECTION_INOUT: _handle_automatic_arg (i, &iinfo.aux_args[i], &iinfo); break; case GI_DIRECTION_OUT: /* handled later */ break; } g_base_info_unref ((GIBaseInfo *) arg_info); } if (iinfo.throws) { iinfo.args[iinfo.n_invoke_args - 1] = &local_error_address; iinfo.arg_types[iinfo.n_invoke_args - 1] = &ffi_type_pointer; } /* prepare and call the function */ if (FFI_OK != ffi_prep_cif (&cif, FFI_DEFAULT_ABI, iinfo.n_invoke_args, iinfo.return_type_ffi, iinfo.arg_types)) { _clear_c_invocation_info (&iinfo); ccroak ("Could not prepare a call interface"); } ffi_call (&cif, func_pointer, &return_value, iinfo.args); /* free call-scoped data */ _invoke_free_after_call_handlers (&iinfo); if (local_error) { gperl_croak_gerror (NULL, local_error); } /* * handle return values */ n_return_values = 0; /* place return value and output args on the stack */ if (iinfo.has_return_value #if GI_CHECK_VERSION (1, 29, 0) && !g_callable_info_skip_return ((GICallableInfo *) info) #endif ) { SV *value; value = SAVED_STACK_SV (arg_to_sv (&return_value, iinfo.return_type_info, iinfo.return_type_transfer, &iinfo)); if (value) { XPUSHs (sv_2mortal (value)); n_return_values++; } } /* out args */ for (i = 0 ; i < iinfo.n_args ; i++) { GIArgInfo * arg_info; if (iinfo.is_automatic_arg[i]) continue; arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i); #if GI_CHECK_VERSION (1, 29, 0) if (g_arg_info_is_skip (arg_info)) { g_base_info_unref ((GIBaseInfo *) arg_info); continue; } #endif switch (g_arg_info_get_direction (arg_info)) { case GI_DIRECTION_OUT: case GI_DIRECTION_INOUT: { GITransfer transfer; SV *sv; /* If we allocated the memory ourselves, we always own it. */ transfer = g_arg_info_is_caller_allocates (arg_info) ? GI_TRANSFER_CONTAINER : g_arg_info_get_ownership_transfer (arg_info); sv = SAVED_STACK_SV (arg_to_sv (iinfo.out_args[i].v_pointer, iinfo.out_arg_infos[i], transfer, &iinfo)); if (sv) { XPUSHs (sv_2mortal (sv)); n_return_values++; } g_base_info_unref ((GIBaseInfo*) iinfo.out_arg_infos[i]); break; } default: break; } g_base_info_unref ((GIBaseInfo *) arg_info); } _clear_c_invocation_info (&iinfo); dwarn (" number of return values: %d\n", n_return_values); PUTBACK; } /* ------------------------------------------------------------------------- */ static void _prepare_c_invocation_info (GPerlI11nInvocationInfo *iinfo, GICallableInfo *info, IV items, UV internal_stack_offset, const gchar *package, const gchar *namespace, const gchar *function) { guint i; dwarn ("C invoke: %s::%s::%s => %s\n" " n_args: %d\n", package, namespace, function, g_base_info_get_name (info), g_callable_info_get_n_args (info)); iinfo->interface = info; iinfo->target_package = package; iinfo->target_namespace = namespace; iinfo->target_function = function; iinfo->is_function = GI_IS_FUNCTION_INFO (info); iinfo->is_vfunc = GI_IS_VFUNC_INFO (info); iinfo->is_callback = (g_base_info_get_type (info) == GI_INFO_TYPE_CALLBACK); dwarn (" is_function = %d, is_vfunc = %d, is_callback = %d\n", iinfo->is_function, iinfo->is_vfunc, iinfo->is_callback); iinfo->stack_offset = internal_stack_offset; iinfo->is_constructor = FALSE; if (iinfo->is_function) { iinfo->is_constructor = g_function_info_get_flags (info) & GI_FUNCTION_IS_CONSTRUCTOR; } if (iinfo->is_constructor) { iinfo->stack_offset++; } iinfo->n_given_args = items - iinfo->stack_offset; iinfo->n_invoke_args = iinfo->n_args = g_callable_info_get_n_args ((GICallableInfo *) info); /* FIXME: can a vfunc not throw? */ iinfo->throws = FALSE; if (iinfo->is_function) { iinfo->throws = g_function_info_get_flags (info) & GI_FUNCTION_THROWS; } if (iinfo->throws) { iinfo->n_invoke_args++; } if (iinfo->is_vfunc) { iinfo->is_method = TRUE; } else if (iinfo->is_callback) { iinfo->is_method = FALSE; } else { iinfo->is_method = (g_function_info_get_flags (info) & GI_FUNCTION_IS_METHOD) && !iinfo->is_constructor; } if (iinfo->is_method) { iinfo->n_invoke_args++; } dwarn ("C invoke: %s\n" " n_args: %d, n_invoke_args: %d, n_given_args: %d\n" " is_constructor: %d, is_method: %d\n", iinfo->is_vfunc ? g_base_info_get_name (info) : g_function_info_get_symbol (info), iinfo->n_args, iinfo->n_invoke_args, iinfo->n_given_args, iinfo->is_constructor, iinfo->is_method); iinfo->return_type_info = g_callable_info_get_return_type ((GICallableInfo *) info); iinfo->has_return_value = GI_TYPE_TAG_VOID != g_type_info_get_tag (iinfo->return_type_info); iinfo->return_type_ffi = g_type_info_get_ffi_type (iinfo->return_type_info); iinfo->return_type_transfer = g_callable_info_get_caller_owns ((GICallableInfo *) info); /* allocate enough space for all args in both the out and in lists. * we'll only use as much as we need. since function argument lists * are typically small, this shouldn't be a big problem. */ if (iinfo->n_invoke_args) { gint n = iinfo->n_invoke_args; iinfo->in_args = gperl_alloc_temp (sizeof (GIArgument) * n); iinfo->out_args = gperl_alloc_temp (sizeof (GIArgument) * n); iinfo->out_arg_infos = gperl_alloc_temp (sizeof (GITypeInfo*) * n); iinfo->arg_types = gperl_alloc_temp (sizeof (ffi_type *) * n); iinfo->args = gperl_alloc_temp (sizeof (gpointer) * n); iinfo->aux_args = gperl_alloc_temp (sizeof (GIArgument) * n); iinfo->is_automatic_arg = gperl_alloc_temp (sizeof (gboolean) * n); } iinfo->method_offset = iinfo->is_method ? 1 : 0; iinfo->dynamic_stack_offset = 0; /* Make a first pass to mark args that are filled in automatically, and * thus have no counterpart on the Perl side. */ for (i = 0 ; i < iinfo->n_args ; i++) { GIArgInfo * arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i); GITypeInfo * arg_type = g_arg_info_get_type (arg_info); GITypeTag arg_tag = g_type_info_get_tag (arg_type); if (arg_tag == GI_TYPE_TAG_ARRAY) { gint pos = g_type_info_get_array_length (arg_type); if (pos >= 0) { dwarn (" pos %d is automatic (array length)\n", pos); iinfo->is_automatic_arg[pos] = TRUE; } } else if (arg_tag == GI_TYPE_TAG_INTERFACE) { GIBaseInfo * interface = g_type_info_get_interface (arg_type); GIInfoType info_type = g_base_info_get_type (interface); if (info_type == GI_INFO_TYPE_CALLBACK) { gint pos = g_arg_info_get_destroy (arg_info); if (pos >= 0) { dwarn (" pos %d is automatic (callback destroy notify)\n", pos); iinfo->is_automatic_arg[pos] = TRUE; } } g_base_info_unref ((GIBaseInfo *) interface); } g_base_info_unref ((GIBaseInfo *) arg_type); g_base_info_unref ((GIBaseInfo *) arg_info); } /* Make another pass to count the expected args. */ iinfo->n_expected_args = iinfo->method_offset; iinfo->n_nullable_args = 0; for (i = 0 ; i < iinfo->n_args ; i++) { GIArgInfo * arg_info = g_callable_info_get_arg ((GICallableInfo *) info, i); GITypeInfo * arg_type = g_arg_info_get_type (arg_info); GITypeTag arg_tag = g_type_info_get_tag (arg_type); gboolean is_out = GI_DIRECTION_OUT == g_arg_info_get_direction (arg_info); gboolean is_automatic = iinfo->is_automatic_arg[i]; gboolean is_skipped = FALSE; #if GI_CHECK_VERSION (1, 29, 0) is_skipped = g_arg_info_is_skip (arg_info); #endif if (!is_out && !is_automatic && !is_skipped) iinfo->n_expected_args++; /* Callback user data may always be NULL. */ if (g_arg_info_may_be_null (arg_info) || arg_tag == GI_TYPE_TAG_VOID) iinfo->n_nullable_args++; g_base_info_unref ((GIBaseInfo *) arg_type); g_base_info_unref ((GIBaseInfo *) arg_info); } /* If the return value is an array which comes with an outbound length * arg, then mark that length arg as automatic, too. */ if (g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_ARRAY) { gint pos = g_type_info_get_array_length (iinfo->return_type_info); if (pos >= 0) { GIArgInfo * arg_info = g_callable_info_get_arg ((GICallableInfo *) info, pos); if (GI_DIRECTION_OUT == g_arg_info_get_direction (arg_info)) { dwarn (" pos %d is automatic (array length)\n", pos); iinfo->is_automatic_arg[pos] = TRUE; } g_base_info_unref (arg_info); } } /* We need to undo the special handling that GInitiallyUnowned * descendants receive from gobject-introspection: values of this type * are always marked transfer=none, even for constructors. */ if (iinfo->is_constructor && g_type_info_get_tag (iinfo->return_type_info) == GI_TYPE_TAG_INTERFACE) { GIBaseInfo * interface = g_type_info_get_interface (iinfo->return_type_info); if (GI_IS_REGISTERED_TYPE_INFO (interface) && g_type_is_a (get_gtype (interface), G_TYPE_INITIALLY_UNOWNED)) { iinfo->return_type_transfer = GI_TRANSFER_EVERYTHING; } g_base_info_unref ((GIBaseInfo *) interface); } } static void _clear_c_invocation_info (GPerlI11nInvocationInfo *iinfo) { g_slist_free (iinfo->free_after_call); /* The actual callback infos might be needed later, so we cannot free * them here. */ g_slist_free (iinfo->callback_infos); g_slist_foreach (iinfo->array_infos, (GFunc) g_free, NULL); g_slist_free (iinfo->array_infos); g_base_info_unref ((GIBaseInfo *) iinfo->return_type_info); } /* ------------------------------------------------------------------------- */ static gchar * _format_target (GPerlI11nInvocationInfo *iinfo) { gchar *caller = NULL; if (iinfo->target_package && iinfo->target_namespace && iinfo->target_function) { caller = g_strconcat (iinfo->target_package, "::", iinfo->target_namespace, "::", iinfo->target_function, NULL); } else if (iinfo->target_package && iinfo->target_function) { caller = g_strconcat (iinfo->target_package, "::", iinfo->target_function, NULL); } else { caller = g_strconcat ("Callable ", g_base_info_get_name (iinfo->interface), NULL); } return caller; } static void _check_n_args (GPerlI11nInvocationInfo *iinfo) { if (iinfo->n_expected_args != iinfo->n_given_args) { /* Avoid the cost of formatting the target until we know we * need it. */ gchar *caller = NULL; if (iinfo->n_given_args < (iinfo->n_expected_args - iinfo->n_nullable_args)) { caller = _format_target (iinfo); ccroak ("%s: passed too few parameters " "(expected %d, got %d)", caller, iinfo->n_expected_args, iinfo->n_given_args); } else if (iinfo->n_given_args > iinfo->n_expected_args) { caller = _format_target (iinfo); cwarn ("*** %s: passed too many parameters " "(expected %d, got %d); ignoring excess", caller, iinfo->n_expected_args, iinfo->n_given_args); } if (caller) g_free (caller); } } /* ------------------------------------------------------------------------- */ static void _handle_automatic_arg (guint pos, GIArgument * arg, GPerlI11nInvocationInfo * invocation_info) { GSList *l; /* array length */ for (l = invocation_info->array_infos; l != NULL; l = l->next) { GPerlI11nArrayInfo *ainfo = l->data; if (pos == ainfo->length_pos) { dwarn (" setting automatic arg %d (array length) to %"G_GSIZE_FORMAT"\n", pos, ainfo->length); /* FIXME: Is it OK to always use v_size here? */ arg->v_size = ainfo->length; return; } } /* callback destroy notify */ for (l = invocation_info->callback_infos; l != NULL; l = l->next) { GPerlI11nPerlCallbackInfo *cinfo = l->data; if (pos == cinfo->destroy_pos) { dwarn (" setting automatic arg %d (destroy notify for calllback %p)\n", pos, cinfo); /* If the code pointer is NULL, then the user actually * specified undef for the callback or nothing at all, * in which case we must not install our destroy notify * handler. */ arg->v_pointer = cinfo->code ? release_perl_callback : NULL; return; } } ccroak ("Could not handle automatic arg %d", pos); } static gpointer _allocate_out_mem (GITypeInfo *arg_type) { GIBaseInfo *interface_info; GIInfoType type; gboolean is_boxed = FALSE; GType gtype = G_TYPE_INVALID; interface_info = g_type_info_get_interface (arg_type); g_assert (interface_info); type = g_base_info_get_type (interface_info); if (GI_IS_REGISTERED_TYPE_INFO (interface_info)) { gtype = get_gtype (interface_info); is_boxed = g_type_is_a (gtype, G_TYPE_BOXED); } g_base_info_unref (interface_info); switch (type) { case GI_INFO_TYPE_STRUCT: { /* No plain g_struct_info_get_size (interface_info) here so * that we get the GValue override. */ gsize size; gpointer mem; size = size_of_interface (arg_type); mem = g_malloc0 (size); if (is_boxed) { /* For a boxed type, malloc() might not be the right * allocator. For example, GtkTreeIter uses GSlice. * So use g_boxed_copy() to make a copy of the newly * allocated block using the correct allocator. */ gpointer real_mem = g_boxed_copy (gtype, mem); g_free (mem); mem = real_mem; } return mem; } default: g_assert_not_reached (); return NULL; } } /* ------------------------------------------------------------------------- */ typedef struct { GFunc func; gpointer data; } FreeClosure; static void free_after_call (GPerlI11nInvocationInfo *iinfo, GFunc func, gpointer data) { FreeClosure *closure = g_new (FreeClosure, 1); closure->func = func; closure->data = data; iinfo->free_after_call = g_slist_prepend (iinfo->free_after_call, closure); } static void _invoke_free_closure (FreeClosure *closure) { closure->func (closure->data, NULL); g_free (closure); } static void _invoke_free_after_call_handlers (GPerlI11nInvocationInfo *iinfo) { g_slist_foreach (iinfo->free_after_call, (GFunc) _invoke_free_closure, NULL); g_slist_free (iinfo->free_after_call); iinfo->free_after_call = NULL; } Glib-Object-Introspection-0.019/gperl-i11n-invoke-perl.c000644 001750 000024 00000032470 12266540466 023170 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void _prepare_perl_invocation_info (GPerlI11nInvocationInfo *iinfo, GICallableInfo *info, gpointer *args); static void _clear_perl_invocation_info (GPerlI11nInvocationInfo *iinfo); static void invoke_perl_code (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata) { GPerlI11nPerlCallbackInfo *info; GICallableInfo *cb_interface; GPerlI11nInvocationInfo iinfo = {0,}; guint args_offset = 0, i; guint in_inout; guint n_return_values, n_returned; I32 context; SV *first_sv = NULL, *last_sv = NULL; dGPERL_CALLBACK_MARSHAL_SP; PERL_UNUSED_VAR (cif); /* unwrap callback info struct from userdata */ info = (GPerlI11nPerlCallbackInfo *) userdata; cb_interface = (GICallableInfo *) info->interface; _prepare_perl_invocation_info (&iinfo, cb_interface, args); /* set perl context */ GPERL_CALLBACK_MARSHAL_INIT (info); ENTER; SAVETMPS; PUSHMARK (SP); if (info->args_converter) { /* if we are given an args converter, we will call it directly * after we pushed the original args onto the stack. we then * want to invoke the Perl code with whatever the args * converter returned. to achieve this, we do a double * PUSHMARK, which puts on the markstack two pointers to the * same place on the stack. after the args converter returns, * the markstack pointer is decremented, and the invocation of * the normal Perl code then sees the other entry we put on the * markstack. */ PUSHMARK (SP); } /* convert the implicit instance argument and push the first SV onto * the stack; depending on the "swap" setting, this might be the * instance or the user data. this is only relevant for signals. */ if (iinfo.is_signal) { SV *instance_sv, *data_sv; args_offset = 1; instance_sv = SAVED_STACK_SV (instance_pointer_to_sv ( cb_interface, CAST_RAW (args[0], gpointer))); data_sv = info->data ? SvREFCNT_inc (info->data) : NULL; first_sv = info->swap_data ? data_sv : instance_sv; last_sv = info->swap_data ? instance_sv : data_sv; dwarn (" info->data = %p, info->swap_data = %d\n", info->data, info->swap_data); dwarn (" instance = %p, data = %p, first = %p, last = %p\n", instance_sv, data_sv, first_sv, last_sv); if (first_sv) XPUSHs (sv_2mortal (first_sv)); } /* find arguments; use type information from interface to find in and * in-out args and their types, count in-out and out args, and find * suitable converters; push in and in-out arguments onto the perl * stack */ in_inout = 0; for (i = 0; i < iinfo.n_args; i++) { GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i); GITypeInfo *arg_type = g_arg_info_get_type (arg_info); GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info); GIDirection direction = g_arg_info_get_direction (arg_info); iinfo.current_pos = i; dwarn ("arg info: %s (%p)\n" " direction: %d\n" " is return value: %d\n" " is optional: %d\n" " may be null: %d\n" " transfer: %d\n", g_base_info_get_name (arg_info), arg_info, g_arg_info_get_direction (arg_info), g_arg_info_is_return_value (arg_info), g_arg_info_is_optional (arg_info), g_arg_info_may_be_null (arg_info), g_arg_info_get_ownership_transfer (arg_info)); dwarn ("arg type: %p\n" " is pointer: %d\n" " tag: %s (%d)\n", arg_type, g_type_info_is_pointer (arg_type), g_type_tag_to_string (g_type_info_get_tag (arg_type)), g_type_info_get_tag (arg_type)); if (direction == GI_DIRECTION_IN || direction == GI_DIRECTION_INOUT) { gpointer raw; GIArgument arg; SV *sv; /* If the arg is in-out, then the ffi arg is a pointer * to a pointer to a value, so we need to dereference * it once. */ raw = direction == GI_DIRECTION_INOUT ? *((gpointer *) args[i+args_offset]) : args[i+args_offset]; raw_to_arg (raw, &arg, arg_type); sv = SAVED_STACK_SV (arg_to_sv (&arg, arg_type, transfer, &iinfo)); /* If arg_to_sv returns NULL, we take that as 'skip * this argument'; happens for GDestroyNotify, for * example. */ if (sv) XPUSHs (sv_2mortal (sv)); } if (direction == GI_DIRECTION_INOUT || direction == GI_DIRECTION_OUT) { in_inout++; } g_base_info_unref ((GIBaseInfo *) arg_info); g_base_info_unref ((GIBaseInfo *) arg_type); } /* push the last SV onto the stack; this might be the user data or the * instance. this is only relevant for signals. */ if (last_sv) XPUSHs (sv_2mortal (last_sv)); PUTBACK; /* invoke the args converter with the original args on the stack. * since we created two identical entries on the markstack, the * call_method or call_sv below will invoke the Perl code with whatever * the args converter returned. */ if (info->args_converter) { call_sv (info->args_converter, G_ARRAY); SPAGAIN; } /* determine suitable Perl call context */ context = G_VOID | G_DISCARD; if (iinfo.has_return_value) { context = in_inout > 0 ? G_ARRAY : G_SCALAR; } else { if (in_inout == 1) { context = G_SCALAR; } else if (in_inout > 1) { context = G_ARRAY; } } /* do the call, demand #in-out+#out+#return-value return values */ n_return_values = iinfo.has_return_value ? in_inout + 1 : in_inout; n_returned = info->sub_name ? call_method (info->sub_name, context) : call_sv (info->code, context); if (n_return_values != 0 && n_returned != n_return_values) { ccroak ("callback returned %d values " "but is supposed to return %d values", n_returned, n_return_values); } /* call-scoped callback infos are freed by * Glib::Object::Introspection::_FuncWrapper::DESTROY */ SPAGAIN; /* convert in-out and out values and stuff them back into args */ if (in_inout > 0) { SV **returned_values; int out_index; returned_values = g_new0 (SV *, in_inout); /* pop scalars off the stack and put them into the array; * reverse the order since POPs pops items off of the end of * the stack. */ for (i = 0; i < in_inout; i++) { returned_values[in_inout - i - 1] = POPs; } out_index = 0; for (i = 0; i < iinfo.n_args; i++) { GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i); GITypeInfo *arg_type = g_arg_info_get_type (arg_info); GIDirection direction = g_arg_info_get_direction (arg_info); gpointer out_pointer = * (gpointer *) args[i+args_offset]; if (!out_pointer) { dwarn ("skipping out arg %d\n", i); g_base_info_unref (arg_info); g_base_info_unref (arg_type); continue; } if (direction == GI_DIRECTION_INOUT || direction == GI_DIRECTION_OUT) { GIArgument tmp_arg; GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info); /* g_arg_info_may_be_null (arg_info) is not * appropriate here as it describes whether the * out/inout arg itself may be NULL. But we're * asking here whether it is OK store NULL * inside the out/inout arg. This information * does not seem to be present in the typelib * (nor is there an annotation for it). */ gboolean may_be_null = TRUE; gboolean is_caller_allocated = g_arg_info_is_caller_allocates (arg_info); if (is_caller_allocated) { tmp_arg.v_pointer = out_pointer; } sv_to_arg (returned_values[out_index], &tmp_arg, arg_info, arg_type, transfer, may_be_null, &iinfo); if (!is_caller_allocated) { arg_to_raw (&tmp_arg, out_pointer, arg_type); } out_index++; } g_base_info_unref (arg_info); g_base_info_unref (arg_type); } g_free (returned_values); } /* store return value in resp, if any */ if (iinfo.has_return_value) { GIArgument arg; GITypeInfo *type_info; GITransfer transfer; gboolean may_be_null; type_info = iinfo.return_type_info; transfer = iinfo.return_type_transfer; may_be_null = g_callable_info_may_return_null (cb_interface); /* FIXME */ dwarn ("ret type: %p\n" " is pointer: %d\n" " tag: %d\n" " transfer: %d\n", type_info, g_type_info_is_pointer (type_info), g_type_info_get_tag (type_info), transfer); sv_to_arg (POPs, &arg, NULL, type_info, transfer, may_be_null, &iinfo); arg_to_raw (&arg, resp, type_info); } PUTBACK; _clear_perl_invocation_info (&iinfo); FREETMPS; LEAVE; /* FIXME: We can't just free everything here because ffi will use parts * of this after we've returned. * * if (info->free_after_use) { * release_callback (info); * } * * Gjs uses a global list of callback infos instead and periodically * frees unused ones. */ } /* ------------------------------------------------------------------------- */ #if GI_CHECK_VERSION (1, 33, 10) static void invoke_perl_signal_handler (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata) { GClosure *closure = CAST_RAW (args[0], GClosure*); GValue *return_value = CAST_RAW (args[1], GValue*); guint n_param_values = CAST_RAW (args[2], guint); const GValue *param_values = CAST_RAW (args[3], const GValue*); gpointer invocation_hint = CAST_RAW (args[4], gpointer); gpointer marshal_data = CAST_RAW (args[5], gpointer); GPerlI11nPerlSignalInfo *signal_info = userdata; GPerlClosure *perl_closure = (GPerlClosure *) closure; GPerlI11nPerlCallbackInfo *cb_info; GCClosure c_closure; PERL_UNUSED_VAR (cif); PERL_UNUSED_VAR (resp); PERL_UNUSED_VAR (marshal_data); dwarn ("invoke_perl_signal_handler: n args %d\n", g_callable_info_get_n_args (signal_info->interface)); cb_info = create_perl_callback_closure (signal_info->interface, perl_closure->callback); attach_perl_callback_data (cb_info, perl_closure->data); cb_info->swap_data = GPERL_CLOSURE_SWAP_DATA (perl_closure); if (signal_info->args_converter) cb_info->args_converter = SvREFCNT_inc (signal_info->args_converter); c_closure.closure = *closure; c_closure.callback = cb_info->closure; /* If marshal_data is non-NULL, gi_cclosure_marshal_generic uses it as * the callback. Hence we pass NULL so that c_closure.callback is * used. */ gi_cclosure_marshal_generic ((GClosure *) &c_closure, return_value, n_param_values, param_values, invocation_hint, NULL /* instead of marshal_data */); release_perl_callback (cb_info); } #endif /* -------------------------------------------------------------------------- */ static void _prepare_perl_invocation_info (GPerlI11nInvocationInfo *iinfo, GICallableInfo *info, gpointer *args) { guint i; dwarn ("Perl invoke: %s\n" " n_args: %d\n", g_base_info_get_name (info), g_callable_info_get_n_args (info)); iinfo->interface = info; /* When invoking Perl code, we currently always use a complete * description of the callable (from a record field or some callback * typedef) for functions, vfuncs and calllbacks. This implies that * there is no implicit invocant; it always appears explicitly in the * arg list. For signals, however, the invocant is implicit. */ iinfo->is_function = GI_IS_FUNCTION_INFO (info); iinfo->is_vfunc = GI_IS_VFUNC_INFO (info); iinfo->is_signal = GI_IS_SIGNAL_INFO (info); iinfo->is_callback = (g_base_info_get_type (info) == GI_INFO_TYPE_CALLBACK); dwarn (" is_function = %d, is_vfunc = %d, is_callback = %d, is_signal = %d\n", iinfo->is_function, iinfo->is_vfunc, iinfo->is_callback, iinfo->is_signal); iinfo->n_args = g_callable_info_get_n_args (info); /* FIXME: 'throws'? */ iinfo->return_type_info = g_callable_info_get_return_type (info); iinfo->has_return_value = GI_TYPE_TAG_VOID != g_type_info_get_tag (iinfo->return_type_info); iinfo->return_type_ffi = g_type_info_get_ffi_type (iinfo->return_type_info); iinfo->return_type_transfer = g_callable_info_get_caller_owns (info); iinfo->dynamic_stack_offset = 0; /* Find array length arguments and store their value in aux_args so * that array_to_sv can later fetch them. */ if (iinfo->n_args) { iinfo->aux_args = gperl_alloc_temp (sizeof (GIArgument) * iinfo->n_args); } for (i = 0 ; i < iinfo->n_args ; i++) { GIArgInfo *arg_info = g_callable_info_get_arg (info, i); GITypeInfo *arg_type = g_arg_info_get_type (arg_info); GITypeTag arg_tag = g_type_info_get_tag (arg_type); if (arg_tag == GI_TYPE_TAG_ARRAY) { gint pos = g_type_info_get_array_length (arg_type); if (pos >= 0) { GIArgInfo *length_arg_info = g_callable_info_get_arg (info, i); GITypeInfo *length_arg_type = g_arg_info_get_type (arg_info); raw_to_arg (args[pos], &iinfo->aux_args[pos], length_arg_type); dwarn (" pos %d is array length => %"G_GSIZE_FORMAT"\n", pos, iinfo->aux_args[pos].v_size); g_base_info_unref (length_arg_type); g_base_info_unref (length_arg_info); } } g_base_info_unref (arg_type); g_base_info_unref (arg_info); } } static void _clear_perl_invocation_info (GPerlI11nInvocationInfo *iinfo) { /* The actual callback infos might be needed later, so we cannot free * them here. */ g_slist_free (iinfo->callback_infos); g_base_info_unref ((GIBaseInfo *) iinfo->return_type_info); } Glib-Object-Introspection-0.019/gperl-i11n-marshal-arg.c000644 001750 000024 00000015327 12221722371 023121 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ /* transfer and may_be_null can be gotten from arg_info, but sv_to_arg is also * called from places which don't have access to a GIArgInfo. */ static void sv_to_arg (SV * sv, GIArgument * arg, GIArgInfo * arg_info, GITypeInfo * type_info, GITransfer transfer, gboolean may_be_null, GPerlI11nInvocationInfo * invocation_info) { GITypeTag tag = g_type_info_get_tag (type_info); if (!gperl_sv_is_defined (sv)) /* Interfaces and void types need to be able to handle undef * separately. */ if (!may_be_null && tag != GI_TYPE_TAG_INTERFACE && tag != GI_TYPE_TAG_VOID) { if (arg_info) { ccroak ("undefined value for mandatory argument '%s' encountered", g_base_info_get_name ((GIBaseInfo *) arg_info)); } else { ccroak ("undefined value encountered"); } } switch (tag) { case GI_TYPE_TAG_VOID: /* returns NULL if no match is found */ arg->v_pointer = sv_to_callback_data (sv, invocation_info); if (!arg->v_pointer && g_type_info_is_pointer (type_info) && gperl_sv_is_ref (sv)) { arg->v_pointer = SvRV (sv); } dwarn (" argument with no type information -> pointer %p\n", arg->v_pointer); break; case GI_TYPE_TAG_BOOLEAN: arg->v_boolean = SvTRUE (sv); break; case GI_TYPE_TAG_INT8: arg->v_int8 = (gint8) SvIV (sv); break; case GI_TYPE_TAG_UINT8: arg->v_uint8 = (guint8) SvUV (sv); break; case GI_TYPE_TAG_INT16: arg->v_int16 = (gint16) SvIV (sv); break; case GI_TYPE_TAG_UINT16: arg->v_uint16 = (guint16) SvUV (sv); break; case GI_TYPE_TAG_INT32: arg->v_int32 = (gint32) SvIV (sv); break; case GI_TYPE_TAG_UINT32: arg->v_uint32 = (guint32) SvUV (sv); break; case GI_TYPE_TAG_INT64: arg->v_int64 = SvGInt64 (sv); break; case GI_TYPE_TAG_UINT64: arg->v_uint64 = SvGUInt64 (sv); break; case GI_TYPE_TAG_FLOAT: arg->v_float = (gfloat) SvNV (sv); break; case GI_TYPE_TAG_DOUBLE: arg->v_double = SvNV (sv); break; case GI_TYPE_TAG_UNICHAR: arg->v_uint32 = g_utf8_get_char (SvGChar (sv)); break; case GI_TYPE_TAG_GTYPE: /* GType == gsize */ arg->v_size = gperl_type_from_package (SvPV_nolen (sv)); if (!arg->v_size) arg->v_size = g_type_from_name (SvPV_nolen (sv)); break; case GI_TYPE_TAG_ARRAY: arg->v_pointer = sv_to_array (transfer, type_info, sv, invocation_info); break; case GI_TYPE_TAG_INTERFACE: dwarn (" type %p -> interface\n", type_info); sv_to_interface (arg_info, type_info, transfer, may_be_null, sv, arg, invocation_info); break; case GI_TYPE_TAG_GLIST: case GI_TYPE_TAG_GSLIST: arg->v_pointer = sv_to_glist (transfer, type_info, sv, invocation_info); break; case GI_TYPE_TAG_GHASH: arg->v_pointer = sv_to_ghash (transfer, type_info, sv); break; case GI_TYPE_TAG_ERROR: if (gperl_sv_is_ref (sv)) { gperl_gerror_from_sv (sv, (GError **) &arg->v_pointer); g_assert (transfer == GI_TRANSFER_EVERYTHING); } else if (gperl_sv_is_defined (sv)) { arg->v_pointer = NULL; g_set_error ((GError **) &arg->v_pointer, 0, 0, "%s", SvPV_nolen (sv)); g_assert (transfer == GI_TRANSFER_EVERYTHING); } else { arg->v_pointer = NULL; } break; case GI_TYPE_TAG_UTF8: arg->v_string = gperl_sv_is_defined (sv) ? SvGChar (sv) : NULL; if (transfer >= GI_TRANSFER_CONTAINER) arg->v_string = g_strdup (arg->v_string); break; case GI_TYPE_TAG_FILENAME: /* FIXME: Should we use SvPVbyte_nolen here? */ arg->v_string = gperl_sv_is_defined (sv) ? SvPV_nolen (sv) : NULL; if (transfer >= GI_TRANSFER_CONTAINER) arg->v_string = g_strdup (arg->v_string); break; default: ccroak ("Unhandled info tag %d in sv_to_arg", tag); } } /* This may call Perl code (via interface_to_sv, glist_to_sv, ghash_to_sv or * array_to_sv), so it needs to be wrapped with PUTBACK/SPAGAIN by the * caller. */ static SV * arg_to_sv (GIArgument * arg, GITypeInfo * info, GITransfer transfer, GPerlI11nInvocationInfo *iinfo) { GITypeTag tag = g_type_info_get_tag (info); gboolean own = transfer >= GI_TRANSFER_CONTAINER; dwarn (" arg_to_sv: info %p with type tag %d (%s)\n", info, tag, g_type_tag_to_string (tag)); switch (tag) { case GI_TYPE_TAG_VOID: { /* returns NULL if no match is found */ SV *sv = callback_data_to_sv (arg->v_pointer, iinfo); if (sv) { SvREFCNT_inc (sv); } else { if (arg->v_pointer && g_type_info_is_pointer (info)) { sv = newRV (arg->v_pointer); } } dwarn (" argument with no type information -> SV %p\n", sv); return sv ? sv : &PL_sv_undef; } case GI_TYPE_TAG_BOOLEAN: return boolSV (arg->v_boolean); case GI_TYPE_TAG_INT8: return newSViv (arg->v_int8); case GI_TYPE_TAG_UINT8: return newSVuv (arg->v_uint8); case GI_TYPE_TAG_INT16: return newSViv (arg->v_int16); case GI_TYPE_TAG_UINT16: return newSVuv (arg->v_uint16); case GI_TYPE_TAG_INT32: return newSViv (arg->v_int32); case GI_TYPE_TAG_UINT32: return newSVuv (arg->v_uint32); case GI_TYPE_TAG_INT64: return newSVGInt64 (arg->v_int64); case GI_TYPE_TAG_UINT64: return newSVGUInt64 (arg->v_uint64); case GI_TYPE_TAG_FLOAT: return newSVnv (arg->v_float); case GI_TYPE_TAG_DOUBLE: return newSVnv (arg->v_double); case GI_TYPE_TAG_UNICHAR: { SV *sv; gchar buffer[6]; gint length = g_unichar_to_utf8 (arg->v_uint32, buffer); sv = newSVpv (buffer, length); SvUTF8_on (sv); return sv; } case GI_TYPE_TAG_GTYPE: { GType gtype = arg->v_size; const char *package; if (G_TYPE_INVALID == gtype || G_TYPE_NONE == gtype) return &PL_sv_undef; package = gperl_package_from_type (gtype); if (!package) package = g_type_name (gtype); return package ? newSVpv (package, 0) : &PL_sv_undef; } case GI_TYPE_TAG_ARRAY: return array_to_sv (info, arg->v_pointer, transfer, iinfo); case GI_TYPE_TAG_INTERFACE: return interface_to_sv (info, arg, own, iinfo); case GI_TYPE_TAG_GLIST: case GI_TYPE_TAG_GSLIST: return glist_to_sv (info, arg->v_pointer, transfer); case GI_TYPE_TAG_GHASH: return ghash_to_sv (info, arg->v_pointer, transfer); case GI_TYPE_TAG_ERROR: ccroak ("FIXME - GI_TYPE_TAG_ERROR"); break; case GI_TYPE_TAG_UTF8: { SV *sv = newSVGChar (arg->v_string); if (own) g_free (arg->v_string); return sv; } case GI_TYPE_TAG_FILENAME: { SV *sv = newSVpv (arg->v_string, 0); if (own) g_free (arg->v_string); return sv; } default: ccroak ("Unhandled info tag %d in arg_to_sv", tag); } return NULL; } Glib-Object-Introspection-0.019/gperl-i11n-marshal-array.c000644 001750 000024 00000012036 12266540466 023474 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void free_raw_array (gpointer raw_array) { dwarn ("free_raw_array %p\n", raw_array); g_free (raw_array); } /* This may call Perl code (via arg_to_sv), so it needs to be wrapped with * PUTBACK/SPAGAIN by the caller. */ static SV * array_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer, GPerlI11nInvocationInfo *iinfo) { GITypeInfo *param_info; gboolean is_zero_terminated; gsize item_size; GITransfer item_transfer; gssize length, i; AV *av; if (pointer == NULL) { return &PL_sv_undef; } is_zero_terminated = g_type_info_is_zero_terminated (info); param_info = g_type_info_get_param_type (info, 0); item_size = size_of_type_info (param_info); /* FIXME: What about an array containing arrays of strings, where the * outer array is GI_TRANSFER_EVERYTHING but the inner arrays are * GI_TRANSFER_CONTAINER? */ item_transfer = transfer == GI_TRANSFER_EVERYTHING ? GI_TRANSFER_EVERYTHING : GI_TRANSFER_NOTHING; if (is_zero_terminated) { length = g_strv_length (pointer); } else { length = g_type_info_get_array_fixed_size (info); if (length < 0) { guint length_pos = g_type_info_get_array_length (info); g_assert (iinfo && iinfo->aux_args); /* FIXME: Is it OK to always use v_size here? */ length = iinfo->aux_args[length_pos].v_size; } } if (length < 0) { ccroak ("Could not determine the length of the array"); } av = newAV (); dwarn (" C array: pointer %p, length %"G_GSSIZE_FORMAT", item size %"G_GSIZE_FORMAT", " "param_info %p with type tag %d (%s)\n", pointer, length, item_size, param_info, g_type_info_get_tag (param_info), g_type_tag_to_string (g_type_info_get_tag (param_info))); for (i = 0; i < length; i++) { GIArgument *arg; SV *value; arg = pointer + i * item_size; value = arg_to_sv (arg, param_info, item_transfer, iinfo); if (value) av_push (av, value); } if (transfer >= GI_TRANSFER_CONTAINER) g_free (pointer); g_base_info_unref ((GIBaseInfo *) param_info); return newRV_noinc ((SV *) av); } static gpointer sv_to_array (GITransfer transfer, GITypeInfo *type_info, SV *sv, GPerlI11nInvocationInfo *iinfo) { AV *av; GITransfer item_transfer; GITypeInfo *param_info; GITypeTag param_tag; gint i, length, length_pos; GPerlI11nArrayInfo *array_info = NULL; GArray *array; gpointer raw_array; gboolean is_zero_terminated = FALSE; gsize item_size; gboolean need_struct_value_semantics; dwarn ("%s: sv %p\n", G_STRFUNC, sv); /* Add an array info entry even before the undef check so that the * corresponding length arg is set to zero later by * _handle_automatic_arg. */ length_pos = g_type_info_get_array_length (type_info); if (length_pos >= 0) { array_info = g_new0 (GPerlI11nArrayInfo, 1); array_info->length_pos = length_pos; array_info->length = 0; iinfo->array_infos = g_slist_prepend (iinfo->array_infos, array_info); } if (!gperl_sv_is_defined (sv)) return NULL; if (!gperl_sv_is_array_ref (sv)) ccroak ("need an array ref to convert to GArray"); av = (AV *) SvRV (sv); item_transfer = transfer == GI_TRANSFER_CONTAINER ? GI_TRANSFER_NOTHING : transfer; param_info = g_type_info_get_param_type (type_info, 0); param_tag = g_type_info_get_tag (param_info); dwarn (" GArray: param_info %p with type tag %d (%s) and transfer %d\n", param_info, param_tag, g_type_tag_to_string (g_type_info_get_tag (param_info)), transfer); is_zero_terminated = g_type_info_is_zero_terminated (type_info); item_size = size_of_type_info (param_info); length = av_len (av) + 1; array = g_array_sized_new (is_zero_terminated, FALSE, item_size, length); /* Arrays containing non-basic types as non-pointers need to be treated * specially. Prime example: GValue *values = g_new0 (GValue, n); */ need_struct_value_semantics = /* is a compound type, and... */ !G_TYPE_TAG_IS_BASIC (param_tag) && /* ... a non-pointer is wanted */ !g_type_info_is_pointer (param_info); for (i = 0; i < length; i++) { SV **svp; svp = av_fetch (av, i, 0); if (svp && gperl_sv_is_defined (*svp)) { GIArgument arg; dwarn (" converting SV %p\n", *svp); /* FIXME: Is it OK to always allow undef here? */ sv_to_arg (*svp, &arg, NULL, param_info, item_transfer, TRUE, NULL); if (need_struct_value_semantics) { /* Copy from the memory area pointed to by * arg.v_pointer. */ g_array_insert_vals (array, i, arg.v_pointer, 1); } else { /* Copy from &arg, i.e. the memory area that is * arg. */ g_array_insert_val (array, i, arg); } } } dwarn (" -> array %p of size %d\n", array, array->len); if (length_pos >= 0) { array_info->length = length; } raw_array = g_array_free (array, FALSE); if (GI_TRANSFER_NOTHING == transfer) free_after_call (iinfo, (GFunc) free_raw_array, raw_array); g_base_info_unref ((GIBaseInfo *) param_info); return raw_array; } Glib-Object-Introspection-0.019/gperl-i11n-marshal-callback.c000644 001750 000024 00000013167 12266540466 024120 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static gpointer sv_to_callback (GIArgInfo * arg_info, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo * invocation_info) { GIBaseInfo *callback_interface_info; GPerlI11nPerlCallbackInfo *callback_info; GIScopeType scope; /* the destroy notify func is handled by _handle_automatic_arg */ dwarn (" Perl callback at %d (%s)\n", invocation_info->current_pos, g_base_info_get_name (arg_info)); callback_interface_info = g_type_info_get_interface (type_info); callback_info = create_perl_callback_closure (callback_interface_info, sv); callback_info->data_pos = g_arg_info_get_closure (arg_info); callback_info->destroy_pos = g_arg_info_get_destroy (arg_info); callback_info->free_after_use = FALSE; g_base_info_unref (callback_interface_info); dwarn (" Perl callback data at %d, destroy at %d\n", callback_info->data_pos, callback_info->destroy_pos); scope = (!gperl_sv_is_defined (sv)) ? GI_SCOPE_TYPE_CALL : g_arg_info_get_scope (arg_info); switch (scope) { case GI_SCOPE_TYPE_CALL: dwarn (" Perl callback has scope 'call'\n"); free_after_call (invocation_info, (GFunc) release_perl_callback, callback_info); break; case GI_SCOPE_TYPE_NOTIFIED: dwarn (" Perl callback has scope 'notified'\n"); /* This case is already taken care of by the notify * stuff above */ break; case GI_SCOPE_TYPE_ASYNC: dwarn (" Perl callback has scope 'async'\n"); /* FIXME: callback_info->free_after_use = TRUE; */ break; default: ccroak ("unhandled scope type %d encountered", g_arg_info_get_scope (arg_info)); } invocation_info->callback_infos = g_slist_prepend (invocation_info->callback_infos, callback_info); dwarn (" returning Perl closure %p from info %p\n", callback_info->closure, callback_info); return callback_info->closure; } static gpointer sv_to_callback_data (SV * sv, GPerlI11nInvocationInfo * invocation_info) { GSList *l; if (!invocation_info) return NULL; for (l = invocation_info->callback_infos; l != NULL; l = l->next) { GPerlI11nPerlCallbackInfo *callback_info = l->data; if (callback_info->data_pos == invocation_info->current_pos) { dwarn (" user data for Perl callback %p\n", callback_info); attach_perl_callback_data (callback_info, sv); /* If the user did not specify any code and data and if * there is no destroy notify function, then there is * no need for us to pass on our callback info struct * as C user data. Some libraries (e.g., vte) even * assert that the C user data be NULL if the C * function pointer is NULL. */ if (!gperl_sv_is_defined (callback_info->code) && !gperl_sv_is_defined (callback_info->data) && -1 == callback_info->destroy_pos) { dwarn (" handing over NULL"); return NULL; } return callback_info; } } if (invocation_info->is_callback) { GPerlI11nCCallbackInfo *wrapper = INT2PTR (GPerlI11nCCallbackInfo*, SvIV (sv)); dwarn (" user data for C callback %p\n", wrapper); return wrapper->data; } return NULL; } static SV * callback_to_sv (GICallableInfo *interface, gpointer func, GPerlI11nInvocationInfo *invocation_info) { GIArgInfo *arg_info; GPerlI11nCCallbackInfo *callback_info; HV *stash; SV *code_sv, *data_sv; GSList *l; for (l = invocation_info->callback_infos; l != NULL; l = l->next) { GPerlI11nCCallbackInfo *callback_info = l->data; if ((gint) invocation_info->current_pos == callback_info->destroy_pos) { dwarn (" destroy notify for C callback %p\n", callback_info); callback_info->destroy = func; /* release_c_callback is called from * Glib::Object::Introspection::_FuncWrapper::DESTROY */ return NULL; } } arg_info = g_callable_info_get_arg (invocation_info->interface, invocation_info->current_pos); dwarn (" C callback at %d (%s)\n", invocation_info->current_pos, g_base_info_get_name (arg_info)); callback_info = create_c_callback_closure (interface, func); callback_info->data_pos = g_arg_info_get_closure (arg_info); callback_info->destroy_pos = g_arg_info_get_destroy (arg_info); g_base_info_unref (arg_info); if (func) { data_sv = newSViv (PTR2IV (callback_info)); stash = gv_stashpv ("Glib::Object::Introspection::_FuncWrapper", TRUE); code_sv = sv_bless (newRV_noinc (data_sv), stash); } else { data_sv = code_sv = &PL_sv_undef; } callback_info->data_sv = data_sv; dwarn (" C callback data at %d, destroy at %d\n", callback_info->data_pos, callback_info->destroy_pos); invocation_info->callback_infos = g_slist_prepend (invocation_info->callback_infos, callback_info); dwarn (" returning C closure %p from info %p\n", code_sv, callback_info); return code_sv; } static SV * callback_data_to_sv (gpointer data, GPerlI11nInvocationInfo * invocation_info) { GSList *l; if (!invocation_info) return NULL; for (l = invocation_info->callback_infos; l != NULL; l = l->next) { GPerlI11nCCallbackInfo *callback_info = l->data; if (callback_info->data_pos == (gint) invocation_info->current_pos) { dwarn (" user data for C callback %p\n", callback_info); attach_c_callback_data (callback_info, data); return callback_info->data_sv; } } if (data && invocation_info->is_callback) { GPerlI11nPerlCallbackInfo *wrapper = data; dwarn (" user data for Perl callback %p\n", wrapper); return wrapper->data; } return NULL; } Glib-Object-Introspection-0.019/gperl-i11n-marshal-hash.c000644 001750 000024 00000011054 12103264610 023260 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ /* This may call Perl code (via arg_to_sv), so it needs to be wrapped with * PUTBACK/SPAGAIN by the caller. */ static SV * ghash_to_sv (GITypeInfo *info, gpointer pointer, GITransfer transfer) { GITypeInfo *key_param_info, *value_param_info; #ifdef NOISY GITypeTag key_type_tag, value_type_tag; #endif gpointer key_p, value_p; GITransfer item_transfer; GHashTableIter iter; HV *hv; if (pointer == NULL) { return &PL_sv_undef; } item_transfer = transfer == GI_TRANSFER_EVERYTHING ? GI_TRANSFER_EVERYTHING : GI_TRANSFER_NOTHING; key_param_info = g_type_info_get_param_type (info, 0); value_param_info = g_type_info_get_param_type (info, 1); #ifdef NOISY key_type_tag = g_type_info_get_tag (key_param_info); value_type_tag = g_type_info_get_tag (value_param_info); #endif dwarn (" GHashTable: pointer %p\n" " key type tag %d (%s)\n" " value type tag %d (%s)\n", pointer, key_type_tag, g_type_tag_to_string (key_type_tag), value_type_tag, g_type_tag_to_string (value_type_tag)); hv = newHV (); g_hash_table_iter_init (&iter, pointer); while (g_hash_table_iter_next (&iter, &key_p, &value_p)) { GIArgument arg = { 0, }; SV *key_sv, *value_sv; dwarn (" converting key pointer %p\n", key_p); arg.v_pointer = key_p; key_sv = arg_to_sv (&arg, key_param_info, item_transfer, NULL); if (key_sv == NULL) break; dwarn (" converting value pointer %p\n", value_p); arg.v_pointer = value_p; value_sv = arg_to_sv (&arg, value_param_info, item_transfer, NULL); if (value_sv == NULL) break; (void) hv_store_ent (hv, key_sv, value_sv, 0); } g_base_info_unref ((GIBaseInfo *) key_param_info); g_base_info_unref ((GIBaseInfo *) value_param_info); return newRV_noinc ((SV *) hv); } static gpointer sv_to_ghash (GITransfer transfer, GITypeInfo *type_info, SV *sv) { HV *hv; HE *he; GITransfer item_transfer; gpointer hash; GITypeInfo *key_param_info, *value_param_info; GITypeTag key_type_tag; GHashFunc hash_func; GEqualFunc equal_func; I32 n_keys; dwarn ("%s: sv %p\n", G_STRFUNC, sv); if (!gperl_sv_is_defined (sv)) return NULL; if (!gperl_sv_is_hash_ref (sv)) ccroak ("need an hash ref to convert to GHashTable"); hv = (HV *) SvRV (sv); item_transfer = GI_TRANSFER_NOTHING; switch (transfer) { case GI_TRANSFER_EVERYTHING: item_transfer = GI_TRANSFER_EVERYTHING; break; case GI_TRANSFER_CONTAINER: /* nothing special to do */ break; case GI_TRANSFER_NOTHING: /* FIXME: need to free hash after call */ break; } key_param_info = g_type_info_get_param_type (type_info, 0); value_param_info = g_type_info_get_param_type (type_info, 1); key_type_tag = g_type_info_get_tag (key_param_info); switch (key_type_tag) { case GI_TYPE_TAG_FILENAME: case GI_TYPE_TAG_UTF8: hash_func = g_str_hash; equal_func = g_str_equal; break; default: hash_func = NULL; equal_func = NULL; break; } dwarn (" GHashTable with transfer %d\n" " key_param_info %p with type tag %d (%s)\n" " value_param_info %p with type tag %d (%s)\n", transfer, key_param_info, g_type_info_get_tag (key_param_info), g_type_tag_to_string (g_type_info_get_tag (key_param_info)), value_param_info, g_type_info_get_tag (value_param_info), g_type_tag_to_string (g_type_info_get_tag (value_param_info))); hash = g_hash_table_new (hash_func, equal_func); n_keys = hv_iterinit (hv); if (n_keys == 0) goto out; while ((he = hv_iternext (hv)) != NULL) { SV *sv; GIArgument arg = { 0, }; gpointer key_p, value_p; key_p = value_p = NULL; sv = hv_iterkeysv (he); if (sv && gperl_sv_is_defined (sv)) { dwarn (" converting key SV %p\n", sv); /* FIXME: Is it OK to always allow undef here? */ sv_to_arg (sv, &arg, NULL, key_param_info, item_transfer, TRUE, NULL); key_p = arg.v_pointer; } sv = hv_iterval (hv, he); if (sv && gperl_sv_is_defined (sv)) { dwarn (" converting value SV %p\n", sv); sv_to_arg (sv, &arg, NULL, key_param_info, item_transfer, TRUE, NULL); value_p = arg.v_pointer; } if (key_p != NULL && value_p != NULL) g_hash_table_insert (hash, key_p, value_p); } out: dwarn (" -> hash %p of size %d\n", hash, g_hash_table_size (hash)); g_base_info_unref ((GIBaseInfo *) key_param_info); g_base_info_unref ((GIBaseInfo *) value_param_info); return hash; } Glib-Object-Introspection-0.019/gperl-i11n-marshal-interface.c000644 001750 000024 00000024673 12266540466 024330 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static gpointer instance_sv_to_pointer (GICallableInfo *info, SV *sv) { // We do *not* own container. GIBaseInfo *container = g_base_info_get_container (info); GIInfoType info_type = g_base_info_get_type (container); gpointer pointer = NULL; /* FIXME: Much of this code is duplicated in sv_to_interface. */ dwarn (" instance_sv_to_pointer: container name: %s, info type: %d\n", g_base_info_get_name (container), info_type); switch (info_type) { case GI_INFO_TYPE_OBJECT: case GI_INFO_TYPE_INTERFACE: pointer = gperl_get_object (sv); dwarn (" -> object pointer: %p\n", pointer); break; case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: case GI_INFO_TYPE_UNION: { GType type = get_gtype ((GIRegisteredTypeInfo *) container); if (!type || type == G_TYPE_NONE) { dwarn (" unboxed type\n"); pointer = sv_to_struct (GI_TRANSFER_NOTHING, container, info_type, sv); } else { dwarn (" boxed type: %s (%"G_GSIZE_FORMAT")\n", g_type_name (type), type); pointer = gperl_get_boxed_check (sv, type); } dwarn (" -> boxed pointer: %p\n", pointer); break; } default: ccroak ("instance_sv_to_pointer: Don't know how to handle info type %d", info_type); } return pointer; } /* This may call Perl code (via gperl_new_boxed, gperl_sv_from_value, * struct_to_sv), so it needs to be wrapped with PUTBACK/SPAGAIN by the * caller. */ static SV * instance_pointer_to_sv (GICallableInfo *info, gpointer pointer) { // We do *not* own container. GIBaseInfo *container = g_base_info_get_container (info); GIInfoType info_type = g_base_info_get_type (container); SV *sv = NULL; /* FIXME: Much of this code is duplicated in interface_to_sv. */ dwarn (" instance_pointer_to_sv: container name: %s, info type: %d\n", g_base_info_get_name (container), info_type); switch (info_type) { case GI_INFO_TYPE_OBJECT: case GI_INFO_TYPE_INTERFACE: sv = gperl_new_object (pointer, FALSE); dwarn (" -> object SV: %p\n", sv); break; case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: case GI_INFO_TYPE_UNION: { GType type = get_gtype ((GIRegisteredTypeInfo *) container); if (!type || type == G_TYPE_NONE) { dwarn (" unboxed type\n"); sv = struct_to_sv (container, info_type, pointer, FALSE); } else { dwarn (" boxed type: %s (%"G_GSIZE_FORMAT")\n", g_type_name (type), type); sv = gperl_new_boxed (pointer, type, FALSE); } dwarn (" -> boxed pointer: %p\n", pointer); break; } default: ccroak ("instance_pointer_to_sv: Don't know how to handle info type %d", info_type); } return sv; } static void sv_to_interface (GIArgInfo * arg_info, GITypeInfo * type_info, GITransfer transfer, gboolean may_be_null, SV * sv, GIArgument * arg, GPerlI11nInvocationInfo * invocation_info) { GIBaseInfo *interface; GIInfoType info_type; interface = g_type_info_get_interface (type_info); if (!interface) ccroak ("Could not convert sv %p to pointer", sv); info_type = g_base_info_get_type (interface); dwarn (" interface %p (%s) of type %d\n", interface, g_base_info_get_name (interface), info_type); switch (info_type) { case GI_INFO_TYPE_OBJECT: case GI_INFO_TYPE_INTERFACE: if (may_be_null && !gperl_sv_is_defined (sv)) { arg->v_pointer = NULL; } else { arg->v_pointer = gperl_get_object_check (sv, get_gtype (interface)); } if (arg->v_pointer) { GObject *object = arg->v_pointer; if (transfer == GI_TRANSFER_NOTHING && object->ref_count == 1 && SvTEMP (sv) && SvREFCNT (SvRV (sv)) == 1) { cwarn ("*** Asked to hand out object without ownership transfer, " "but object is about to be destroyed; " "adding an additional reference for safety"); transfer = GI_TRANSFER_EVERYTHING; } if (transfer >= GI_TRANSFER_CONTAINER) { g_object_ref (arg->v_pointer); } } break; case GI_INFO_TYPE_UNION: case GI_INFO_TYPE_STRUCT: case GI_INFO_TYPE_BOXED: { gboolean need_value_semantics = arg_info && g_arg_info_is_caller_allocates (arg_info) && !g_type_info_is_pointer (type_info); GType type = get_gtype ((GIRegisteredTypeInfo *) interface); if (!type || type == G_TYPE_NONE) { const gchar *namespace, *name, *package; GType parent_type; dwarn (" unboxed type\n"); g_assert (!need_value_semantics); /* Find out whether this untyped struct is a member of * a boxed union before using raw hash-to-struct * conversion. */ name = g_base_info_get_name (interface); namespace = g_base_info_get_namespace (interface); package = get_package_for_basename (namespace); parent_type = package ? find_union_member_gtype (package, name) : 0; if (parent_type && parent_type != G_TYPE_NONE) { arg->v_pointer = gperl_get_boxed_check ( sv, parent_type); if (GI_TRANSFER_EVERYTHING == transfer) arg->v_pointer = g_boxed_copy (parent_type, arg->v_pointer); } else { arg->v_pointer = sv_to_struct (transfer, interface, info_type, sv); } } else if (type == G_TYPE_CLOSURE) { /* FIXME: User cannot supply user data. */ dwarn (" closure type\n"); g_assert (!need_value_semantics); arg->v_pointer = gperl_closure_new (sv, NULL, FALSE); } else if (type == G_TYPE_VALUE) { GValue *gvalue = SvGValueWrapper (sv); dwarn (" value type\n"); if (!gvalue) ccroak ("Cannot convert arbitrary SV to GValue"); if (need_value_semantics) { g_value_init (arg->v_pointer, G_VALUE_TYPE (gvalue)); g_value_copy (gvalue, arg->v_pointer); } else { if (GI_TRANSFER_EVERYTHING == transfer) { arg->v_pointer = g_new0 (GValue, 1); g_value_init (arg->v_pointer, G_VALUE_TYPE (gvalue)); g_value_copy (gvalue, arg->v_pointer); } else { arg->v_pointer = gvalue; } } } else { dwarn (" boxed type: %s, name=%s, caller-allocates=%d, is-pointer=%d\n", g_type_name (type), g_base_info_get_name (interface), g_arg_info_is_caller_allocates (arg_info), g_type_info_is_pointer (type_info)); if (need_value_semantics) { if (may_be_null && !gperl_sv_is_defined (sv)) { /* Do nothing. */ } else { gsize n_bytes = g_struct_info_get_size (interface); gpointer mem = gperl_get_boxed_check (sv, type); g_memmove (arg->v_pointer, mem, n_bytes); } } else { if (may_be_null && !gperl_sv_is_defined (sv)) { arg->v_pointer = NULL; } else { arg->v_pointer = gperl_get_boxed_check (sv, type); if (GI_TRANSFER_EVERYTHING == transfer) arg->v_pointer = g_boxed_copy ( type, arg->v_pointer); } } } break; } case GI_INFO_TYPE_ENUM: { GType type = get_gtype ((GIRegisteredTypeInfo *) interface); if (G_TYPE_NONE == type) { ccroak ("Could not handle unknown enum type %s", g_base_info_get_name (interface)); } /* FIXME: Check storage type? */ arg->v_long = gperl_convert_enum (type, sv); break; } case GI_INFO_TYPE_FLAGS: { GType type = get_gtype ((GIRegisteredTypeInfo *) interface); if (G_TYPE_NONE == type) { ccroak ("Could not handle unknown flags type %s", g_base_info_get_name (interface)); } /* FIXME: Check storage type? */ arg->v_long = gperl_convert_flags (type, sv); break; } case GI_INFO_TYPE_CALLBACK: arg->v_pointer = sv_to_callback (arg_info, type_info, sv, invocation_info); break; default: ccroak ("sv_to_interface: Could not handle info type %s (%d)", g_info_type_to_string (info_type), info_type); } g_base_info_unref ((GIBaseInfo *) interface); } /* This may call Perl code (via gperl_new_boxed, gperl_sv_from_value, * struct_to_sv), so it needs to be wrapped with PUTBACK/SPAGAIN by the * caller. */ static SV * interface_to_sv (GITypeInfo* info, GIArgument *arg, gboolean own, GPerlI11nInvocationInfo *iinfo) { GIBaseInfo *interface; GIInfoType info_type; SV *sv = NULL; dwarn (" interface_to_sv: arg %p, info %p\n", arg, info); interface = g_type_info_get_interface (info); if (!interface) ccroak ("Could not convert arg %p to SV", arg); info_type = g_base_info_get_type (interface); dwarn (" info type: %d (%s)\n", info_type, g_info_type_to_string (info_type)); switch (info_type) { case GI_INFO_TYPE_OBJECT: case GI_INFO_TYPE_INTERFACE: sv = gperl_new_object (arg->v_pointer, own); break; case GI_INFO_TYPE_UNION: case GI_INFO_TYPE_STRUCT: case GI_INFO_TYPE_BOXED: { /* FIXME: What about pass-by-value here? */ GType type; type = get_gtype ((GIRegisteredTypeInfo *) interface); if (!type || type == G_TYPE_NONE) { dwarn (" unboxed type\n"); sv = struct_to_sv (interface, info_type, arg->v_pointer, own); } else if (type == G_TYPE_VALUE) { dwarn (" value type\n"); sv = gperl_sv_from_value (arg->v_pointer); if (own) g_boxed_free (type, arg->v_pointer); } else { dwarn (" boxed type: %"G_GSIZE_FORMAT" (%s)\n", type, g_type_name (type)); sv = gperl_new_boxed (arg->v_pointer, type, own); } break; } case GI_INFO_TYPE_ENUM: { GType type = get_gtype ((GIRegisteredTypeInfo *) interface); if (G_TYPE_NONE == type) { ccroak ("Could not handle unknown enum type %s", g_base_info_get_name (interface)); } /* FIXME: Is it right to just use v_long here? */ sv = gperl_convert_back_enum (type, arg->v_long); break; } case GI_INFO_TYPE_FLAGS: { GType type = get_gtype ((GIRegisteredTypeInfo *) interface); if (G_TYPE_NONE == type) { ccroak ("Could not handle unknown flags type %s", g_base_info_get_name (interface)); } /* FIXME: Is it right to just use v_long here? */ sv = gperl_convert_back_flags (type, arg->v_long); break; } case GI_INFO_TYPE_CALLBACK: sv = callback_to_sv (interface, arg->v_pointer, iinfo); break; default: ccroak ("interface_to_sv: Don't know how to handle info type %s (%d)", g_info_type_to_string (info_type), info_type); } g_base_info_unref ((GIBaseInfo *) interface); return sv; } Glib-Object-Introspection-0.019/gperl-i11n-marshal-list.c000644 001750 000024 00000006612 12103264610 023314 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void free_list (GList *list) { dwarn ("free_list %p\n", list); g_list_free (list); } static void free_slist (GSList *list) { dwarn ("free_slist %p\n", list); g_slist_free (list); } /* This may call Perl code (via arg_to_sv), so it needs to be wrapped with * PUTBACK/SPAGAIN by the caller. */ static SV * glist_to_sv (GITypeInfo* info, gpointer pointer, GITransfer transfer) { GITypeInfo *param_info; GITransfer item_transfer; gboolean is_slist; GSList *i; AV *av; SV *value; if (pointer == NULL) { return &PL_sv_undef; } /* FIXME: What about an array containing arrays of strings, where the * outer array is GI_TRANSFER_EVERYTHING but the inner arrays are * GI_TRANSFER_CONTAINER? */ item_transfer = GI_TRANSFER_EVERYTHING == transfer ? GI_TRANSFER_EVERYTHING : GI_TRANSFER_NOTHING; param_info = g_type_info_get_param_type (info, 0); dwarn (" G(S)List: pointer %p, param_info %p with type tag %d (%s)\n", pointer, param_info, g_type_info_get_tag (param_info), g_type_tag_to_string (g_type_info_get_tag (param_info))); is_slist = GI_TYPE_TAG_GSLIST == g_type_info_get_tag (info); av = newAV (); for (i = pointer; i; i = i->next) { GIArgument arg = {0,}; dwarn (" converting pointer %p\n", i->data); arg.v_pointer = i->data; value = arg_to_sv (&arg, param_info, item_transfer, NULL); if (value) av_push (av, value); } if (transfer >= GI_TRANSFER_CONTAINER) { if (is_slist) g_slist_free (pointer); else g_list_free (pointer); } g_base_info_unref ((GIBaseInfo *) param_info); return newRV_noinc ((SV *) av); } static gpointer sv_to_glist (GITransfer transfer, GITypeInfo * type_info, SV * sv, GPerlI11nInvocationInfo *iinfo) { AV *av; GITransfer item_transfer; gpointer list = NULL; GITypeInfo *param_info; gboolean is_slist; gint i, length; dwarn ("%s: sv %p\n", G_STRFUNC, sv); if (!gperl_sv_is_defined (sv)) return NULL; if (!gperl_sv_is_array_ref (sv)) ccroak ("need an array ref to convert to GList"); av = (AV *) SvRV (sv); item_transfer = GI_TRANSFER_EVERYTHING == transfer ? GI_TRANSFER_EVERYTHING : GI_TRANSFER_NOTHING; param_info = g_type_info_get_param_type (type_info, 0); dwarn (" G(S)List: param_info %p with type tag %d (%s) and transfer %d\n", param_info, g_type_info_get_tag (param_info), g_type_tag_to_string (g_type_info_get_tag (param_info)), transfer); is_slist = GI_TYPE_TAG_GSLIST == g_type_info_get_tag (type_info); length = av_len (av) + 1; for (i = 0; i < length; i++) { SV **svp; svp = av_fetch (av, i, 0); if (svp && gperl_sv_is_defined (*svp)) { GIArgument arg; dwarn (" converting SV %p\n", *svp); /* FIXME: Is it OK to always allow undef here? */ sv_to_arg (*svp, &arg, NULL, param_info, item_transfer, TRUE, NULL); /* ENHANCEME: Could use g_[s]list_prepend and * later _reverse for efficiency. */ if (is_slist) list = g_slist_append (list, arg.v_pointer); else list = g_list_append (list, arg.v_pointer); } } if (GI_TRANSFER_NOTHING == transfer) free_after_call (iinfo, is_slist ? ((GFunc)free_slist) : ((GFunc)free_list), list); dwarn (" -> list %p of length %d\n", list, g_list_length (list)); g_base_info_unref ((GIBaseInfo *) param_info); return list; } Glib-Object-Introspection-0.019/gperl-i11n-marshal-raw.c000644 001750 000024 00000006366 12221722371 023144 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void raw_to_arg (gpointer raw, GIArgument *arg, GITypeInfo *info) { GITypeTag tag = g_type_info_get_tag (info); switch (tag) { case GI_TYPE_TAG_VOID: if (g_type_info_is_pointer (info)) { arg->v_pointer = CAST_RAW (raw, gpointer); } else { /* do nothing */ } break; case GI_TYPE_TAG_BOOLEAN: arg->v_boolean = CAST_RAW (raw, gboolean); break; case GI_TYPE_TAG_INT8: arg->v_int8 = CAST_RAW (raw, gint8); break; case GI_TYPE_TAG_UINT8: arg->v_uint8 = CAST_RAW (raw, guint8); break; case GI_TYPE_TAG_INT16: arg->v_int16 = CAST_RAW (raw, gint16); break; case GI_TYPE_TAG_UINT16: arg->v_uint16 = CAST_RAW (raw, guint16); break; case GI_TYPE_TAG_INT32: arg->v_int32 = CAST_RAW (raw, gint32); break; case GI_TYPE_TAG_UINT32: case GI_TYPE_TAG_UNICHAR: arg->v_uint32 = CAST_RAW (raw, guint32); break; case GI_TYPE_TAG_INT64: arg->v_int64 = CAST_RAW (raw, gint64); break; case GI_TYPE_TAG_UINT64: arg->v_uint64 = CAST_RAW (raw, guint64); break; case GI_TYPE_TAG_FLOAT: arg->v_float = CAST_RAW (raw, gfloat); break; case GI_TYPE_TAG_DOUBLE: arg->v_double = CAST_RAW (raw, gdouble); break; case GI_TYPE_TAG_GTYPE: arg->v_size = CAST_RAW (raw, GType); break; case GI_TYPE_TAG_ARRAY: case GI_TYPE_TAG_INTERFACE: case GI_TYPE_TAG_GLIST: case GI_TYPE_TAG_GSLIST: case GI_TYPE_TAG_GHASH: case GI_TYPE_TAG_ERROR: arg->v_pointer = CAST_RAW (raw, gpointer); break; case GI_TYPE_TAG_UTF8: case GI_TYPE_TAG_FILENAME: arg->v_string = CAST_RAW (raw, gchar*); break; default: ccroak ("Unhandled info tag %d in raw_to_arg", tag); } } static void arg_to_raw (GIArgument *arg, gpointer raw, GITypeInfo *info) { GITypeTag tag = g_type_info_get_tag (info); switch (tag) { case GI_TYPE_TAG_VOID: /* do nothing */ break; case GI_TYPE_TAG_BOOLEAN: * (gboolean *) raw = arg->v_boolean; break; case GI_TYPE_TAG_INT8: * (gint8 *) raw = arg->v_int8; break; case GI_TYPE_TAG_UINT8: * (guint8 *) raw = arg->v_uint8; break; case GI_TYPE_TAG_INT16: * (gint16 *) raw = arg->v_int16; break; case GI_TYPE_TAG_UINT16: * (guint16 *) raw = arg->v_uint16; break; case GI_TYPE_TAG_INT32: * (gint32 *) raw = arg->v_int32; break; case GI_TYPE_TAG_UINT32: case GI_TYPE_TAG_UNICHAR: * (guint32 *) raw = arg->v_uint32; break; case GI_TYPE_TAG_INT64: * (gint64 *) raw = arg->v_int64; break; case GI_TYPE_TAG_UINT64: * (guint64 *) raw = arg->v_uint64; break; case GI_TYPE_TAG_FLOAT: * (gfloat *) raw = arg->v_float; break; case GI_TYPE_TAG_DOUBLE: * (gdouble *) raw = arg->v_double; break; case GI_TYPE_TAG_GTYPE: * (GType *) raw = arg->v_size; break; case GI_TYPE_TAG_ARRAY: case GI_TYPE_TAG_INTERFACE: case GI_TYPE_TAG_GLIST: case GI_TYPE_TAG_GSLIST: case GI_TYPE_TAG_GHASH: case GI_TYPE_TAG_ERROR: * (gpointer *) raw = arg->v_pointer; break; case GI_TYPE_TAG_UTF8: case GI_TYPE_TAG_FILENAME: * (gchar **) raw = arg->v_string; break; default: ccroak ("Unhandled info tag %d in arg_to_raw", tag); } } Glib-Object-Introspection-0.019/gperl-i11n-marshal-struct.c000644 001750 000024 00000011357 12266540466 023707 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static gchar * get_struct_package (GIBaseInfo* info) { const gchar *basename, *package, *name; basename = g_base_info_get_namespace (info); package = get_package_for_basename (basename); if (!package) return NULL; name = g_base_info_get_name (info); return g_strconcat (package, "::", name, NULL); } /* FIXME: Should g-i offer API for this? */ static gboolean is_struct_disguised (GIBaseInfo* info) { return 0 == g_struct_info_get_n_fields (info) && 0 == g_struct_info_get_size (info); } /* This may call Perl code (via get_field), so it needs to be wrapped with * PUTBACK/SPAGAIN by the caller. */ static SV * struct_to_sv (GIBaseInfo* info, GIInfoType info_type, gpointer pointer, gboolean own) { HV *hv; dwarn ("%s: pointer %p\n", G_STRFUNC, pointer); if (pointer == NULL) { return &PL_sv_undef; } if (is_struct_disguised (info)) { SV *sv; gchar *package; dwarn (" disguised struct\n"); g_assert (!own); package = get_struct_package (info); g_assert (package); sv = newSV (0); sv_setref_pv (sv, package, pointer); g_free (package); return sv; } hv = newHV (); switch (info_type) { case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: { gint i, n_fields = g_struct_info_get_n_fields ((GIStructInfo *) info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; SV *sv; field_info = g_struct_info_get_field ((GIStructInfo *) info, i); /* FIXME: Check GIFieldInfoFlags. */ /* FIXME: Is it right to use GI_TRANSFER_NOTHING * here? */ sv = get_field (field_info, pointer, GI_TRANSFER_NOTHING); if (gperl_sv_is_defined (sv)) { const gchar *name; name = g_base_info_get_name ( (GIBaseInfo *) field_info); gperl_hv_take_sv (hv, name, strlen (name), sv); } g_base_info_unref ((GIBaseInfo *) field_info); } break; } case GI_INFO_TYPE_UNION: ccroak ("%s: unions not handled yet", G_STRFUNC); default: ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type); } if (own) { /* FIXME: Is it correct to just call g_free here? What if the * thing was allocated via GSlice? */ g_free (pointer); } return newRV_noinc ((SV *) hv); } static gpointer sv_to_struct (GITransfer transfer, GIBaseInfo * info, GIInfoType info_type, SV * sv) { HV *hv; gsize size = 0; GITransfer field_transfer; gpointer pointer = NULL; dwarn ("%s: sv %p\n", G_STRFUNC, sv); if (!gperl_sv_is_defined (sv)) return NULL; if (is_struct_disguised (info)) { gchar *package; dwarn (" disguised struct\n"); package = get_struct_package (info); g_assert (package); if (!gperl_sv_is_ref (sv) || !sv_derived_from (sv, package)) ccroak ("Cannot convert scalar %p to an object of type %s", sv, package); g_free (package); return INT2PTR (void *, SvIV ((SV *) SvRV (sv))); } if (!gperl_sv_is_hash_ref (sv)) ccroak ("need a hash ref to convert to struct of type %s", g_base_info_get_name (info)); hv = (HV *) SvRV (sv); switch (info_type) { case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: size = g_struct_info_get_size ((GIStructInfo *) info); break; case GI_INFO_TYPE_UNION: size = g_union_info_get_size ((GIStructInfo *) info); break; default: g_assert_not_reached (); } dwarn (" size: %"G_GSIZE_FORMAT"\n", size); field_transfer = GI_TRANSFER_NOTHING; dwarn (" transfer: %d\n", transfer); switch (transfer) { case GI_TRANSFER_EVERYTHING: field_transfer = GI_TRANSFER_EVERYTHING; /* fall through */ case GI_TRANSFER_CONTAINER: /* FIXME: What if there's a special allocator for the record? * Like GSlice? */ pointer = g_malloc0 (size); break; default: pointer = gperl_alloc_temp (size); break; } switch (info_type) { case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: { gint i, n_fields = g_struct_info_get_n_fields ((GIStructInfo *) info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; const gchar *field_name; SV **svp; field_info = g_struct_info_get_field ( (GIStructInfo *) info, i); /* FIXME: Check GIFieldInfoFlags. */ field_name = g_base_info_get_name ( (GIBaseInfo *) field_info); svp = hv_fetch (hv, field_name, strlen (field_name), 0); if (svp && gperl_sv_is_defined (*svp)) { set_field (field_info, pointer, field_transfer, *svp); } g_base_info_unref ((GIBaseInfo *) field_info); } break; } case GI_INFO_TYPE_UNION: ccroak ("%s: unions not handled yet", G_STRFUNC); default: ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type); } return pointer; } Glib-Object-Introspection-0.019/gperl-i11n-method.c000644 001750 000024 00000002713 12221722371 022176 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ #define PUSH_METHODS(prefix, av, info) \ gint i, n_methods = g_ ## prefix ## _info_get_n_methods (info); \ for (i = 0; i < n_methods; i++) { \ GIFunctionInfo *function_info; \ const gchar *function_name; \ function_info = g_ ## prefix ## _info_get_method (info, i); \ function_name = g_base_info_get_name (function_info); \ av_push (av, newSVpv (function_name, 0)); \ g_base_info_unref (function_info); \ } static void store_methods (HV *namespaced_functions, GIBaseInfo *info, GIInfoType info_type) { const gchar *namespace; AV *av; namespace = g_base_info_get_name (info); av = newAV (); switch (info_type) { case GI_INFO_TYPE_OBJECT: { PUSH_METHODS (object, av, info); break; } case GI_INFO_TYPE_INTERFACE: { PUSH_METHODS (interface, av, info); break; } case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: { PUSH_METHODS (struct, av, info); break; } case GI_INFO_TYPE_UNION: { PUSH_METHODS (union, av, info); break; } case GI_INFO_TYPE_ENUM: case GI_INFO_TYPE_FLAGS: { #if GI_CHECK_VERSION (1, 29, 17) PUSH_METHODS (enum, av, info); #endif break; } default: ccroak ("store_methods: unsupported info type %d", info_type); } gperl_hv_take_sv (namespaced_functions, namespace, strlen (namespace), newRV_noinc ((SV *) av)); } Glib-Object-Introspection-0.019/gperl-i11n-size.c000644 001750 000024 00000007055 12103264610 021670 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ /* These three are basically copied from pygi's pygi-info.c. :-( */ static gsize size_of_type_tag (GITypeTag type_tag) { switch(type_tag) { case GI_TYPE_TAG_BOOLEAN: return sizeof (gboolean); case GI_TYPE_TAG_INT8: case GI_TYPE_TAG_UINT8: return sizeof (gint8); case GI_TYPE_TAG_INT16: case GI_TYPE_TAG_UINT16: return sizeof (gint16); case GI_TYPE_TAG_INT32: case GI_TYPE_TAG_UINT32: return sizeof (gint32); case GI_TYPE_TAG_INT64: case GI_TYPE_TAG_UINT64: return sizeof (gint64); case GI_TYPE_TAG_FLOAT: return sizeof (gfloat); case GI_TYPE_TAG_DOUBLE: return sizeof (gdouble); case GI_TYPE_TAG_GTYPE: return sizeof (GType); case GI_TYPE_TAG_UNICHAR: return sizeof (gunichar); case GI_TYPE_TAG_VOID: case GI_TYPE_TAG_UTF8: case GI_TYPE_TAG_FILENAME: case GI_TYPE_TAG_ARRAY: case GI_TYPE_TAG_INTERFACE: case GI_TYPE_TAG_GLIST: case GI_TYPE_TAG_GSLIST: case GI_TYPE_TAG_GHASH: case GI_TYPE_TAG_ERROR: ccroak ("Unable to determine the size of '%s'", g_type_tag_to_string (type_tag)); break; } return 0; } static gsize size_of_interface (GITypeInfo *type_info) { gsize size = 0; GIBaseInfo *info; GIInfoType info_type; info = g_type_info_get_interface (type_info); info_type = g_base_info_get_type (info); switch (info_type) { case GI_INFO_TYPE_STRUCT: if (g_type_info_is_pointer (type_info)) { size = sizeof (gpointer); } else { /* FIXME: Remove this workaround once * gobject-introspection is fixed: * . */ GType type = get_gtype (info); if (type == G_TYPE_VALUE) { size = sizeof (GValue); } else { size = g_struct_info_get_size ((GIStructInfo *) info); } } break; case GI_INFO_TYPE_UNION: if (g_type_info_is_pointer (type_info)) { size = sizeof (gpointer); } else { size = g_union_info_get_size ((GIUnionInfo *) info); } break; case GI_INFO_TYPE_ENUM: case GI_INFO_TYPE_FLAGS: if (g_type_info_is_pointer (type_info)) { size = sizeof (gpointer); } else { GITypeTag type_tag; type_tag = g_enum_info_get_storage_type ((GIEnumInfo *) info); size = size_of_type_tag (type_tag); } break; case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_OBJECT: case GI_INFO_TYPE_INTERFACE: case GI_INFO_TYPE_CALLBACK: size = sizeof (gpointer); break; default: g_assert_not_reached (); break; } g_base_info_unref (info); return size; } static gsize size_of_type_info (GITypeInfo *type_info) { GITypeTag type_tag; type_tag = g_type_info_get_tag (type_info); switch (type_tag) { case GI_TYPE_TAG_BOOLEAN: case GI_TYPE_TAG_INT8: case GI_TYPE_TAG_UINT8: case GI_TYPE_TAG_INT16: case GI_TYPE_TAG_UINT16: case GI_TYPE_TAG_INT32: case GI_TYPE_TAG_UINT32: case GI_TYPE_TAG_INT64: case GI_TYPE_TAG_UINT64: case GI_TYPE_TAG_FLOAT: case GI_TYPE_TAG_DOUBLE: case GI_TYPE_TAG_GTYPE: case GI_TYPE_TAG_UNICHAR: if (g_type_info_is_pointer (type_info)) { return sizeof (gpointer); } else { return size_of_type_tag (type_tag); } case GI_TYPE_TAG_INTERFACE: return size_of_interface (type_info); case GI_TYPE_TAG_ARRAY: case GI_TYPE_TAG_VOID: case GI_TYPE_TAG_UTF8: case GI_TYPE_TAG_FILENAME: case GI_TYPE_TAG_GLIST: case GI_TYPE_TAG_GSLIST: case GI_TYPE_TAG_GHASH: case GI_TYPE_TAG_ERROR: return sizeof (gpointer); } return 0; } Glib-Object-Introspection-0.019/gperl-i11n-union.c000644 001750 000024 00000004431 12266540466 022061 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ #define UNION_REBLESSERS_HV "Glib::Object::Introspection::_REBLESSERS" #define UNION_MEMBER_TYPE_SUFFIX "::_i11n_gtype" static SV * rebless_union_sv (GType type, const char *package, gpointer mem, gboolean own) { SV *sv, **reblesser_p; HV *reblessers; sv = gperl_default_boxed_wrapper_class ()->wrap (type, package, mem, own); reblessers = get_hv (UNION_REBLESSERS_HV, 0); g_assert (reblessers); reblesser_p = hv_fetch (reblessers, package, strlen (package), 0); if (reblesser_p && gperl_sv_is_defined (*reblesser_p)) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (sv_2mortal (SvREFCNT_inc (sv))); PUTBACK; call_sv (*reblesser_p, G_DISCARD); FREETMPS; LEAVE; } return sv; } static void associate_union_members_with_gtype (GIUnionInfo *info, const gchar *package, GType type) { gint i, n_fields; n_fields = g_union_info_get_n_fields (info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; GITypeInfo *field_type; GIBaseInfo *field_interface; const gchar *type_name; gchar *full_name; SV *sv; field_info = g_union_info_get_field (info, i); field_type = g_field_info_get_type (field_info); field_interface = g_type_info_get_interface (field_type); /* If this field has a basic type, then we cannot associate its * parent's GType with it. */ if (!field_interface) { g_base_info_unref ((GIBaseInfo *) field_type); g_base_info_unref ((GIBaseInfo *) field_info); continue; } type_name = g_base_info_get_name (field_interface); full_name = g_strconcat (package, "::", type_name, UNION_MEMBER_TYPE_SUFFIX, NULL); dwarn ("associating %s with GType %"G_GSIZE_FORMAT"\n", type_name, type); sv = get_sv (full_name, GV_ADD); sv_setuv (sv, type); g_free (full_name); g_base_info_unref ((GIBaseInfo *) field_interface); g_base_info_unref ((GIBaseInfo *) field_type); g_base_info_unref ((GIBaseInfo *) field_info); } } static GType find_union_member_gtype (const gchar *package, const gchar *namespace) { gchar *type_sv_name; SV *type_sv; type_sv_name = g_strconcat (package, "::", namespace, UNION_MEMBER_TYPE_SUFFIX, NULL); type_sv = get_sv (type_sv_name, 0); g_free (type_sv_name); return type_sv ? SvUV (type_sv) : G_TYPE_NONE; } Glib-Object-Introspection-0.019/gperl-i11n-vfunc-interface.c000644 001750 000024 00000004472 12175005707 024006 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void generic_interface_init (gpointer iface, gpointer data) { GIInterfaceInfo *info = data; GIStructInfo *struct_info; gint n, i; struct_info = g_interface_info_get_iface_struct (info); n = g_interface_info_get_n_vfuncs (info); for (i = 0; i < n; i++) { GIVFuncInfo *vfunc_info; const gchar *vfunc_name; GIFieldInfo *field_info; gint field_offset; GITypeInfo *field_type_info; GIBaseInfo *field_interface_info; gchar *perl_method_name; GPerlI11nPerlCallbackInfo *callback_info; vfunc_info = g_interface_info_get_vfunc (info, i); vfunc_name = g_base_info_get_name (vfunc_info); perl_method_name = g_ascii_strup (vfunc_name, -1); if (is_forbidden_sub_name (perl_method_name)) { /* If the method name coincides with the name of one of * perl's special subs, add "_VFUNC". */ gchar *replacement = g_strconcat (perl_method_name, "_VFUNC", NULL); g_free (perl_method_name); perl_method_name = replacement; } /* We use the field information here rather than the vfunc * information so that the Perl invoker does not have to deal * with an implicit invocant. */ field_info = get_field_info (struct_info, vfunc_name); g_assert (field_info); field_offset = g_field_info_get_offset (field_info); field_type_info = g_field_info_get_type (field_info); field_interface_info = g_type_info_get_interface (field_type_info); /* callback_info takes over ownership of perl_method_name. */ callback_info = create_perl_callback_closure_for_named_sub ( field_interface_info, perl_method_name); dwarn ("generic_interface_init: installing vfunc %s.%s as %s at offset %d (vs. %d) inside %p\n", g_base_info_get_name (info), vfunc_name, perl_method_name, field_offset, g_vfunc_info_get_offset (vfunc_info), iface); G_STRUCT_MEMBER (gpointer, iface, field_offset) = callback_info->closure; g_base_info_unref (field_interface_info); g_base_info_unref (field_type_info); g_base_info_unref (field_info); g_base_info_unref (vfunc_info); } g_base_info_unref (struct_info); } static void generic_interface_finalize (gpointer iface, gpointer data) { GIInterfaceInfo *info = data; PERL_UNUSED_VAR (iface); dwarn ("releasing interface info\n"); g_base_info_unref ((GIBaseInfo *) info); } Glib-Object-Introspection-0.019/gperl-i11n-vfunc-object.c000644 001750 000024 00000006727 12221722371 023314 0ustar00brianstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void store_objects_with_vfuncs (AV *objects_with_vfuncs, GIObjectInfo *info) { if (g_object_info_get_n_vfuncs (info) <= 0) return; av_push (objects_with_vfuncs, newSVpv (g_base_info_get_name (info), 0)); } /* ------------------------------------------------------------------------- */ static void generic_class_init (GIObjectInfo *info, const gchar *target_package, gpointer class) { GIStructInfo *struct_info; gint n, i; struct_info = g_object_info_get_class_struct (info); n = g_object_info_get_n_vfuncs (info); for (i = 0; i < n; i++) { GIVFuncInfo *vfunc_info; const gchar *vfunc_name; GIFieldInfo *field_info; gint field_offset; GITypeInfo *field_type_info; GIBaseInfo *field_interface_info; gchar *perl_method_name; GPerlI11nPerlCallbackInfo *callback_info; vfunc_info = g_object_info_get_vfunc (info, i); vfunc_name = g_base_info_get_name (vfunc_info); perl_method_name = g_ascii_strup (vfunc_name, -1); if (is_forbidden_sub_name (perl_method_name)) { /* If the method name coincides with the name of one of * perl's special subs, add "_VFUNC". */ gchar *replacement = g_strconcat (perl_method_name, "_VFUNC", NULL); g_free (perl_method_name); perl_method_name = replacement; } { /* If there is no implementation of this vfunc at INIT * time, we assume that the intention is to provide no * implementation and we thus skip setting up the class * struct member. */ HV * stash = gv_stashpv (target_package, 0); GV * slot = gv_fetchmethod (stash, perl_method_name); if (!slot) { dwarn ("generic_class_init: skipping vfunc %s.%s because it has no implementation\n", g_base_info_get_name (info), vfunc_name); g_base_info_unref (vfunc_info); g_free (perl_method_name); continue; } } /* We use the field information here rather than the vfunc * information so that the Perl invoker does not have to deal * with an implicit invocant. */ field_info = get_field_info (struct_info, vfunc_name); g_assert (field_info); field_offset = g_field_info_get_offset (field_info); field_type_info = g_field_info_get_type (field_info); field_interface_info = g_type_info_get_interface (field_type_info); /* callback_info takes over ownership of perl_method_name. */ callback_info = create_perl_callback_closure_for_named_sub ( field_interface_info, perl_method_name); dwarn ("generic_class_init: installing vfunc %s.%s as %s at offset %d (vs. %d) inside %p\n", g_base_info_get_name (info), vfunc_name, perl_method_name, field_offset, g_vfunc_info_get_offset (vfunc_info), class); G_STRUCT_MEMBER (gpointer, class, field_offset) = callback_info->closure; g_base_info_unref (field_interface_info); g_base_info_unref (field_type_info); g_base_info_unref (field_info); g_base_info_unref (vfunc_info); } g_base_info_unref (struct_info); } /* ------------------------------------------------------------------------- */ static gint get_vfunc_offset (GIObjectInfo *info, const gchar *vfunc_name) { GIStructInfo *struct_info; GIFieldInfo *field_info; gint field_offset; struct_info = g_object_info_get_class_struct (info); g_assert (struct_info); field_info = get_field_info (struct_info, vfunc_name); g_assert (field_info); field_offset = g_field_info_get_offset (field_info); g_base_info_unref (field_info); g_base_info_unref (struct_info); return field_offset; } Glib-Object-Introspection-0.019/lib/000755 001750 000024 00000000000 12266655504 017454 5ustar00brianstaff000000 000000 Glib-Object-Introspection-0.019/LICENSE000644 001750 000024 00000063474 11672542633 017727 0ustar00brianstaff000000 000000 GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! Glib-Object-Introspection-0.019/Makefile.PL000644 001750 000024 00000022265 12222106322 020644 0ustar00brianstaff000000 000000 # Copyright (C) 2010-2013 Torsten Schoenfeld # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library 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 Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA BEGIN { require 5.008; } use strict; use warnings; use ExtUtils::MakeMaker; use File::Spec; use Config; use Cwd; my %RUNTIME_REQ_PM = ( 'Glib' => 1.280, ); my %CONFIG_REQ_PM = ( 'ExtUtils::Depends' => 0.300, 'ExtUtils::PkgConfig' => 1.000, 'Glib' => $RUNTIME_REQ_PM{Glib}, ); my %BUILD_REQ = ( 'gobject-introspection-1.0' => '0.10.0', 'gmodule-2.0' => '2.0.0', 'libffi' => '3.0.0', ); my @xs_files = qw(GObjectIntrospection.xs); my %pm_files = ( 'lib/Glib/Object/Introspection.pm' => '$(INST_LIBDIR)/Introspection.pm', ); my %pod_files = ( 'lib/Glib/Object/Introspection.pm' => '$(INST_MAN3DIR)/Glib::Object::Introspection.$(MAN3EXT)', ); my %meta_merge = ( q(meta-spec) => { version => '2', url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', }, author => ['Glib::Object::Introspection Team '], release_status => 'unstable', # valid values: https://metacpan.org/module/CPAN::Meta::Spec#license license => 'lgpl_2_1', resources => { license => 'http://www.gnu.org/licenses/lgpl-2.1.html', homepage => 'http://gtk2-perl.sourceforge.net', x_MailingList => 'https://mail.gnome.org/mailman/listinfo/gtk-perl-list', bugtracker => { web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Glib-Object-Introspection', mailto => 'bug-Glib-Object-Introspection [at] rt.cpan.org', }, repository => { url => 'git://git.gnome.org/perl-Glib-Object-Introspection', type => 'git', web => 'http://git.gnome.org/browse/perl-Glib-Object-Introspection', }, }, prereqs => { configure => { requires => {%CONFIG_REQ_PM}, # no direct ref for 5.14 compatibility }, runtime => { requires => {%RUNTIME_REQ_PM}, # no direct ref for 5.14 compatibility }, }, no_index => { file => \@xs_files, package => [ 'MY', 'Glib::Object::Introspection::_FuncWrapper' ], }, ); my $dep_success = eval <<__EOE__; use ExtUtils::Depends $CONFIG_REQ_PM{'ExtUtils::Depends'}; use ExtUtils::PkgConfig $CONFIG_REQ_PM{'ExtUtils::PkgConfig'}; use Glib $CONFIG_REQ_PM{'Glib'}; use Glib::MakeHelper; 1; __EOE__ if (!$dep_success) { warn $@; exit 0; } my %cfg; my $cfg_success = eval { %cfg = ExtUtils::PkgConfig->find ( "gobject-introspection-1.0 >= $BUILD_REQ{'gobject-introspection-1.0'}"); 1; }; if (!$cfg_success) { warn $@; exit 0; } $cfg_success = eval { my %cfg_gmod = ExtUtils::PkgConfig->find ( "gmodule-2.0 >= $BUILD_REQ{'gmodule-2.0'}"); $cfg{cflags} .= " $cfg_gmod{cflags}"; $cfg{libs} .= " $cfg_gmod{libs}"; 1; }; if (!$cfg_success) { warn $@; exit 0; } $cfg_success = eval { my %cfg_ffi = ExtUtils::PkgConfig->find ( "libffi >= $BUILD_REQ{'libffi'}"); $cfg{cflags} .= " $cfg_ffi{cflags}"; $cfg{libs} .= " $cfg_ffi{libs}"; 1; }; if (!$cfg_success) { warn $@; exit 0; } mkdir 'build', 0777; compile_test_libraries(); ExtUtils::PkgConfig->write_version_macros ( "build/gi-version.h", "gobject-introspection-1.0" => "GI", ); my $deps = ExtUtils::Depends->new ('Glib::Object::Introspection' => 'Glib'); $deps->set_inc ($cfg{cflags}); $deps->set_libs ($cfg{libs}); $deps->add_pm (%pm_files); $deps->add_xs (@xs_files); $deps->save_config ('build/IFiles.pm'); WriteMakefile( NAME => 'Glib::Object::Introspection', VERSION_FROM => 'lib/Glib/Object/Introspection.pm', ABSTRACT_FROM => 'lib/Glib/Object/Introspection.pm', PREREQ_PM => \%CONFIG_REQ_PM, XSPROTOARG => '-noprototypes', MAN3PODS => \%pod_files, META_MERGE => \%meta_merge, $deps->get_makefile_vars, ); sub compile_test_libraries { chdir 'build'; my $build_dir = cwd(); local $| = 1; print 'Trying to build test libraries... '; my $success = eval { my $gidatadir = ExtUtils::PkgConfig->variable ('gobject-introspection-1.0', 'gidatadir'); die 'Could not find gobject-introspection-1.0' unless defined $gidatadir; my $testsdir = $gidatadir . '/tests'; my $have_cairo_gobject = !system (qw/pkg-config --exists cairo-gobject/); my %cairo_flags = ExtUtils::PkgConfig->find ('cairo'); my %cairo_gobject_flags = $have_cairo_gobject ? ExtUtils::PkgConfig->find ('cairo-gobject') : (cflags => '', libs => ''); my %gio_flags = ExtUtils::PkgConfig->find ('gio-2.0'); my @commands; my $c_flags = qq(-shared -fPIC); my $gir_cmd = qq(LD_LIBRARY_PATH=$build_dir:\$LD_LIBRARY_PATH g-ir-scanner); my $prefix = q(); my $pipe = qq(1>/dev/null 2>/dev/null); if ($^O eq 'MSWin32') { my @path = File::Spec->path; my $found = 0; foreach my $base (map { File::Spec->catfile ($_, 'g-ir-scanner') } @path) { if (-f $base) { $gir_cmd = qq(python $base); $found = 1; last; } } return 0 unless $found; $c_flags = qq(-shared); $pipe = qq(1>NUL 2>NUL); # XXX: We need the lib prefix for --library argument to G-O-I on Win32, # else DLL resolution fails... $prefix = 'lib'; } push @commands, qq(gcc $c_flags -g \\ $cairo_flags{cflags} $cairo_gobject_flags{cflags} $gio_flags{cflags} \\ $testsdir/regress.c \\ $cairo_flags{libs} $cairo_gobject_flags{libs} $gio_flags{libs} \\ -o libregress.$Config{dlext} $pipe); push @commands, qq($gir_cmd \\ --include=cairo-1.0 --include=Gio-2.0 \\ --namespace=Regress --nsversion=1.0 \\ --quiet --warn-all --warn-error \\ --library=${prefix}regress \\ --output=Regress-1.0.gir \\ $testsdir/regress.h $testsdir/regress.c \\ $pipe); push @commands, qq(g-ir-compiler Regress-1.0.gir -o Regress-1.0.typelib \\ $pipe); push @commands, qq(gcc $c_flags -g \\ $gio_flags{cflags} \\ $testsdir/gimarshallingtests.c \\ $gio_flags{libs} \\ -o libgimarshallingtests.$Config{dlext} $pipe); push @commands, qq($gir_cmd \\ --include=Gio-2.0 \\ --namespace=GIMarshallingTests \\ --symbol-prefix=gi_marshalling_tests --nsversion=1.0 \\ --quiet --warn-all --warn-error \\ --library=${prefix}gimarshallingtests \\ --output=GIMarshallingTests-1.0.gir \\ $testsdir/gimarshallingtests.h $testsdir/gimarshallingtests.c \\ $pipe); push @commands, qq(g-ir-compiler GIMarshallingTests-1.0.gir \\ -o GIMarshallingTests-1.0.typelib $pipe); if ($^O eq 'MSWin32') { my $path = $ENV{PATH}; # XXX: G-O-I defaults to CC=cc $ENV{CC} = 'gcc' unless exists $ENV{CC}; $ENV{PATH} .= ';' . $build_dir; foreach my $command (@commands) { # XXX: Cmd.exe do not support \ as line break ... $command =~ s/\\\n//mg; $command =~ s/\s\s+/ /mg; system ($command) == 0 or return 0; } $ENV{PATH} = $path; } else { foreach my $command (@commands) { system ($command) == 0 or return 0; } } 1; }; print $success ? "OK\n" : "not OK\n"; if ($@) { print "Error: $@"; print "Continuing without test library support...\n"; } chdir '..'; } package MY; # so that "SUPER" works right sub test { my $inherited = shift->SUPER::test(@_); if ($^O eq 'MSWin32') { # put "build" into PATH for the tests # FIXME: Might need tweaking for nmake... $inherited =~ s/(test_dynamic :: pure_all\n\t)/.IMPORT: PATH\nPATH += ;build\n.EXPORT: PATH\n$1/; } else { # put "build" into LD_LIBRARY_PATH for the tests $inherited =~ s/(test_dynamic :: pure_all)\n\t/$1\n\tLD_LIBRARY_PATH=\${LD_LIBRARY_PATH}:build /; } $inherited; } sub postamble { my $additional_deps = "\n\n\$(OBJECT) : gperl-i11n-*.c\n\n"; if ($^O eq 'MSWin32') { # FIXME: Might need tweaking for nmake... $additional_deps = "\n\n\$(OBJECT) : \$(wildcard gperl-i11n-*.c)\n\n"; } return Glib::MakeHelper->postamble_clean () . $additional_deps; } Glib-Object-Introspection-0.019/MANIFEST000644 001750 000024 00000002056 12266655505 020043 0ustar00brianstaff000000 000000 GObjectIntrospection.xs gperl-i11n-callback.c gperl-i11n-croak.c gperl-i11n-enums.c gperl-i11n-field.c gperl-i11n-gvalue.c gperl-i11n-info.c gperl-i11n-invoke-c.c gperl-i11n-invoke-perl.c gperl-i11n-marshal-arg.c gperl-i11n-marshal-array.c gperl-i11n-marshal-callback.c gperl-i11n-marshal-hash.c gperl-i11n-marshal-interface.c gperl-i11n-marshal-list.c gperl-i11n-marshal-raw.c gperl-i11n-marshal-struct.c gperl-i11n-method.c gperl-i11n-size.c gperl-i11n-union.c gperl-i11n-vfunc-interface.c gperl-i11n-vfunc-object.c lib/Glib/Object/Introspection.pm LICENSE Makefile.PL MANIFEST MANIFEST.SKIP NEWS perl-Glib-Object-Introspection.doap README t/00-basic-types.t t/arg-checks.t t/arrays.t t/boxed.t t/cairo-integration.t t/callbacks.t t/closures.t t/constants.t t/enums.t t/hashes.t t/inc/setup.pl t/interface-implementation.t t/objects.t t/structs.t t/values.t t/vfunc-chaining.t t/vfunc-ref-counting.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Glib-Object-Introspection-0.019/MANIFEST.SKIP000644 001750 000024 00000000165 12047544237 020603 0ustar00brianstaff000000 000000 ~$ blib \.bak$ \.bs$ build \.git \.gitignore$ Makefile$ Makefile\.old$ MYMETA\..*$ GObjectIntrospection.c$ TAGS \.o$ Glib-Object-Introspection-0.019/META.json000644 001750 000024 00000003614 12266655505 020334 0ustar00brianstaff000000 000000 { "abstract" : "Dynamically create Perl language bindings", "author" : [ "Glib::Object::Introspection Team " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.86, CPAN::Meta::Converter version 2.133380", "license" : [ "lgpl_2_1" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Glib-Object-Introspection", "no_index" : { "directory" : [ "t", "inc" ], "file" : [ "GObjectIntrospection.xs" ], "package" : [ "MY", "Glib::Object::Introspection::_FuncWrapper" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::Depends" : "0.3", "ExtUtils::MakeMaker" : "0", "ExtUtils::PkgConfig" : "1", "Glib" : "1.28" } }, "runtime" : { "requires" : { "ExtUtils::Depends" : "0.3", "ExtUtils::PkgConfig" : "1", "Glib" : "1.28" } } }, "release_status" : "unstable", "resources" : { "bugtracker" : { "mailto" : "bug-Glib-Object-Introspection [at] rt.cpan.org", "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Glib-Object-Introspection" }, "homepage" : "http://gtk2-perl.sourceforge.net", "license" : [ "http://www.gnu.org/licenses/lgpl-2.1.html" ], "repository" : { "type" : "git", "url" : "git://git.gnome.org/perl-Glib-Object-Introspection", "web" : "http://git.gnome.org/browse/perl-Glib-Object-Introspection" }, "x_MailingList" : "https://mail.gnome.org/mailman/listinfo/gtk-perl-list" }, "version" : "0.019" } Glib-Object-Introspection-0.019/META.yml000644 001750 000024 00000002110 12266655504 020151 0ustar00brianstaff000000 000000 --- abstract: 'Dynamically create Perl language bindings' author: - 'Glib::Object::Introspection Team ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::Depends: 0.3 ExtUtils::MakeMaker: 0 ExtUtils::PkgConfig: 1 Glib: 1.28 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.86, CPAN::Meta::Converter version 2.133380' license: lgpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Glib-Object-Introspection no_index: directory: - t - inc file: - GObjectIntrospection.xs package: - MY - Glib::Object::Introspection::_FuncWrapper requires: ExtUtils::Depends: 0.3 ExtUtils::PkgConfig: 1 Glib: 1.28 resources: MailingList: https://mail.gnome.org/mailman/listinfo/gtk-perl-list bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Glib-Object-Introspection homepage: http://gtk2-perl.sourceforge.net license: http://www.gnu.org/licenses/lgpl-2.1.html repository: git://git.gnome.org/perl-Glib-Object-Introspection version: 0.019 Glib-Object-Introspection-0.019/NEWS000644 001750 000024 00000014455 12266655364 017422 0ustar00brianstaff000000 000000 Overview of changes in Glib::Object::Introspection 0.019 ======================================================== * Fix spelling of two internal functions * Fix off-by-one error in internal string comparison Overview of changes in Glib::Object::Introspection 0.018 ======================================================== * Fix registering unregistered enums. * Mark a few tests as known to fail so that they do not abort installation. Overview of changes in Glib::Object::Introspection 0.017 ======================================================== * Register unregistered enums so that, e.g., GSpawnFlags and VtePtyFlags become usable. * Pass on NULL user data in C invocations if appropriate Overview of changes in Glib::Object::Introspection 0.016 ======================================================== * Add support for unicode character arguments to Perl callbacks. * Avoid misusing the macro PL_na, thus preventing issues when Glib::Object::Introspection is used in conjunction with certain XS modules, among them XML::Parser and String::Approx. * Fix build on MinGW with dmake. Overview of changes in Glib::Object::Introspection 0.015 ======================================================== * Add support for array arguments to Perl callbacks. * Allow Perl code to return Glib::Error objects. * Register error domains. * Support conversion to raw structs from unregistered libraries. Overview of changes in Glib::Object::Introspection 0.014 ======================================================== * Implement generic signal marshalling. * Implement a generic constructor for boxed types and install it as Glib::Boxed::new. * Generate error messages when functions are passed an incorrect number of parameters. * Avoid using vfunc names that coincide with special Perl subs. This fixes double-frees occurring for subclasses of Gtk3::Widget. * Rework the way fallback vfuncs are installed. * Correctly marshal out/in-out args when invoking Perl code and fix some other related bugs. This makes it possible to implement complicated interfaces such as Gtk3::TreeModel. * Allow enums and flags to have class functions. * Add API to manually convert between SVs and enums. * Plug a few memory leaks. Overview of changes in Glib::Object::Introspection 0.013 ======================================================== * SV -> object: do some type checking * Fix building with perl <= 5.14 * Convert invalid or void GTypes to undef. Overview of changes in Glib::Object::Introspection 0.012 ======================================================== * Support more struct types when writing fields. * Handle disguised structures. * Avoid invalid memory access during callback destruction. * Use the correct allocator for caller-allocated boxed out-args. * Add semi-private API wrapping gperl_register_boxed_synonym. Overview of changes in Glib::Object::Introspection 0.011 ======================================================== * Improve handling of boxed unions, like GdkEvent. * Add support for building the test libs on MSWin32. * Properly specify our dependencies. Overview of changes in Glib::Object::Introspection 0.010 ======================================================== * Correctly place the linker flags when building the test libs. * Fix compilation of the test libs against recent gobject-introspection * updated README file similar to Cairo (RT#74870) * Created %meta_merge which follows v2 of meta-spec Overview of changes in Glib::Object::Introspection 0.009 ======================================================== * Allow setting boxed fields to undef. * Do not pass on an incorrect destroy notify func if there is no callback. * Do not crash on inexistent GTypes on perl 5.8.x. Overview of changes in Glib::Object::Introspection 0.008 ======================================================== * When looking up GTypes, also try by name. * Make constants work on perl 5.8.x. Overview of changes in Glib::Object::Introspection 0.007 ======================================================== * Do not assume filenames are UTF8-encoded; pass the strings on unaltered in both directions, C to Perl and Perl to C. Before passing a filename on to something which expects UTF8 (like widgets), users now have to ensure that it is UTF8-encoded. Glib::filename_to_unicode provides one way to do this. Overview of changes in Glib::Object::Introspection 0.006 ======================================================== * Remove an unneeded argument of an internal function * Plug a leak in the wrapper for constants * Fix compilation of the test lib on x86-64 Overview of changes in Glib::Object::Introspection 0.005 ======================================================== * Use the overloaded '==' operator directly when comparing flags * Make t/enums.t more robust * Implement check_gi_version * Implement test skipping * Update FSF address in license blurbs Overview of changes in Glib::Object::Introspection 0.004 ======================================================== * Fix building test libraries on Ubuntu 11.10. They (Ubuntu devs) added --as-needed to the default linker flags, and that breaks building the test libraries for reasons I don't understand at the moment. So simply add --no-as-needed for now. * Properly check for definedness throughout; Use gperl_sv_is_defined instead of a direct comparison against &PL_sv_undef. Overview of changes in Glib::Object::Introspection 0.003 ======================================================== * Nothing, except for adding the NEWS entries that were forgotten for release 0.002. Overview of changes in Glib::Object::Introspection 0.002 ======================================================== * Add support for implementing interfaces. * Add support for implementing object vfuncs. * Add support for callbacks in callbacks. * Add support for caller-allocated out arguments. * Add support for nested structs. * Add support for calling functions on structs. * Add support for reading and writing fields of boxed types. * Add support for flattening array ref returns. * Add support for handling 'sentinel booleans'. * Handle skipping arguments and return values. * Fix ownership handling for GInitiallyUnowned. * Expand the documentation. * Fix build and test suite issues. Overview of changes in Glib::Object::Introspection 0.001 ======================================================== * Initial release. Glib-Object-Introspection-0.019/perl-Glib-Object-Introspection.doap000644 001750 000024 00000001443 11663370775 025440 0ustar00brianstaff000000 000000 Glib::Object::Introspection Dynamically create Perl language bindings Torsten Schönfeld tsch Glib-Object-Introspection-0.019/README000644 001750 000024 00000007042 11775137260 017567 0ustar00brianstaff000000 000000 Glib::Object::Introspection =========================== Glib::Object::Introspection uses the gobject-introspection and libffi projects to dynamically create Perl bindings for a wide variety of libraries. Examples include gtk+, webkit, libsoup and many more. INSTALLATION ------------ To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES ------------ Glib::Object::Introspection needs this C library: gobject-introspection-1.0 >= 0.10.0 and these Perl modules: ExtUtils::Depends >= 0.300 ExtUtils::PkgConfig >= 1.000 Glib >= 1.240 HOW TO CONTACT US ----------------- Homepage: http://gtk2-perl.sourceforge.net/ Mailing list: gtk-perl-list [at] gnome.org Mailing list archives: https://mail.gnome.org/archives/gtk-perl-list/ IRC: irc://irc.gnome.org/#gtk-perl E-mail bug submission via CPAN's RT: bug-Glib-Object-Introspection [at] rt.cpan.org Web bug submission via gnome.org's bugzilla: http://bugzilla.gnome.org/enter_bug.cgi?product=gnome-perl Please do not contact any of the maintainers directly unless they ask you to. The first point of contact for questions/problems/issues should always be the mailing list. BUG REPORTS ----------- For help with problems, please contact the mailing list (above). If you already know you have a bug, please file it with one of the bug trackers below. With any problems and/or bug reports, it's always helpful for the developers to have the following information: - A small script that demonstrates the problem; this is not required, however, it will get your issue looked at much faster than a description of the problem alone. - Version of Perl (perl -v) - Versions of Gtk2-Perl modules (Glib/Gtk2/Pango/Cairo) - Optional, but nice to have: versions of GTK+ libraries on your system (libglib, libgtk+, libpango, libcairo, etc.) There are multiple project bug trackers, please choose the one you are most comfortable with using and/or already have an account for. Request Tracker: - submitting bugs via the Web (requires a PAUSE account/Bitcard): https://rt.cpan.org/Public/Bug/Report.html?Queue=Glib-Object-Introspection - submitting bugs via e-mail (open to anyone with e-mail): bug-Glib-Object-Introspection [at] rt.cpan.org Gnome's bugtracker: - report bugs to the 'gnome-perl' product (requires login) http://bugzilla.gnome.org/enter_bug.cgi?product=gnome-perl PATCH SUBMISSION GUIDELINES --------------------------- You can send us patches by... - E-mailing it to the mailing list (above); please use a pastebin service of some kind for longer patchfiles (over say 20k in size). - Those with gnome.org Git ID's can push trivial patches to git directly; if you're not sure what a trivial patch is, please ask first on the mailing list prior to pushing your commit. OBTAINING SOURCE FROM THE GNOME.ORG GIT REPO -------------------------------------------- Assuming you already have the 'git' command installed on your system, you can use the 'git://' protocol: git clone git://git.gnome.org/perl-Glib-Object-Introspection Or, read-only access via HTTP: git clone http://git.gnome.org/browse/perl-Glib-Object-Introspection To update an existing clone of the source: git pull Most Linux distros package the 'git' command in a package called 'git-core'. COPYRIGHT AND LICENSE --------------------- Copyright (C) 2005-2012 Torsten Schoenfeld See the LICENSE file in the top-level directory of this distribution for the full license terms. Glib-Object-Introspection-0.019/t/000755 001750 000024 00000000000 12266655504 017151 5ustar00brianstaff000000 000000 Glib-Object-Introspection-0.019/t/00-basic-types.t000644 001750 000024 00000004275 11723003500 021762 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use utf8; use POSIX qw(FLT_MIN FLT_MAX DBL_MIN DBL_MAX); plan tests => 34; ok (Regress::test_boolean (1)); ok (!Regress::test_boolean (0)); is (Regress::test_int8 (-127), -127); is (Regress::test_uint8 (255), 255); is (Regress::test_int16 (-32767), -32767); is (Regress::test_uint16 (65535), 65535); is (Regress::test_int32 (-2147483647), -2147483647); is (Regress::test_uint32 (4294967295), 4294967295); is (Regress::test_int64 ('-9223372036854775807'), '-9223372036854775807'); is (Regress::test_uint64 ('18446744073709551615'), '18446744073709551615'); delta_ok (Regress::test_float (FLT_MIN), FLT_MIN); delta_ok (Regress::test_float (FLT_MAX), FLT_MAX); delta_ok (Regress::test_double (DBL_MIN), DBL_MIN); delta_ok (Regress::test_double (DBL_MAX), DBL_MAX); is (Regress::test_unichar ('ℵ'), 'ℵ'); my $time = time (); is (Regress::test_timet ($time), $time); is (Regress::test_gtype ('Glib::Object'), 'Glib::Object'); is (Regress::test_gtype ('GIRepository'), 'Glib::Object::_Unregistered::GIRepository'); is (Regress::test_gtype ('Inexistant'), undef); my $expected_const_string = 'const ♥ utf8'; my $expected_nonconst_string = 'nonconst ♥ utf8'; is (Regress::test_utf8_const_return (), $expected_const_string); is (Regress::test_utf8_nonconst_return (), $expected_nonconst_string); Regress::test_utf8_const_in (Regress::test_utf8_const_return ()); is (Regress::test_utf8_out (), $expected_nonconst_string); is (Regress::test_utf8_inout (Regress::test_utf8_const_return ()), Regress::test_utf8_nonconst_return ()); Regress::test_utf8_null_in (undef); is (Regress::test_utf8_null_out (), undef); my $filenames = Regress::test_filename_return (); is (scalar @$filenames, 2); is (Glib::filename_to_unicode ($filenames->[0]), 'åäö'); is ($filenames->[1], '/etc/fstab'); is (Regress::test_int_out_utf8 ('Παν語'), 4); my ($one, $two) = Regress::test_multi_double_args (my $pi = 3.1415); delta_ok ($one, 2*$pi); delta_ok ($two, 3*$pi); ($one, $two) = Regress::test_utf8_out_out (); is ($one, 'first'); is ($two, 'second'); ($one, $two) = Regress::test_utf8_out_nonconst_return (); is ($one, 'first'); is ($two, 'second'); Glib-Object-Introspection-0.019/t/arg-checks.t000644 001750 000024 00000000521 12103264610 021323 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 5; { is (Regress::test_int8 (-127), -127); } { is (eval { Regress::test_int8 () }, undef); like ($@, qr/too few/); } { local $SIG{__WARN__} = sub { like ($_[0], qr/too many/) }; is (Regress::test_int8 (127, 'bla'), 127); } Glib-Object-Introspection-0.019/t/arrays.t000644 001750 000024 00000004374 11663370775 020653 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use utf8; plan tests => 29; ok (Regress::test_strv_in ([ '1', '2', '3' ])); my $int_array = [ 1, 2, 3 ]; is (Regress::test_array_int_in ($int_array), 6); is_deeply (Regress::test_array_int_out (), [0, 1, 2, 3, 4]); is_deeply (Regress::test_array_int_inout ($int_array), [3, 4]); is (Regress::test_array_gint8_in ($int_array), 6); is (Regress::test_array_gint16_in ($int_array), 6); is (Regress::test_array_gint32_in ($int_array), 6); is (Regress::test_array_gint64_in ($int_array), 6); is (Regress::test_array_gtype_in ([ 'Glib::Object', 'Glib::Int64' ]), "[GObject,gint64,]"); is (Regress::test_array_fixed_size_int_in ([ 1, 2, 3, 4, 5 ]), 15); is_deeply (Regress::test_array_fixed_size_int_out (), [ 0, 1, 2, 3, 4 ]); is_deeply (Regress::test_array_fixed_size_int_return (), [ 0, 1, 2, 3, 4 ]); is_deeply (Regress::test_strv_out_container (), [ '1', '2', '3' ]); is_deeply (Regress::test_strv_out (), [ 'thanks', 'for', 'all', 'the', 'fish' ]); is_deeply (Regress::test_strv_out_c (), [ 'thanks', 'for', 'all', 'the', 'fish' ]); is_deeply (Regress::test_strv_outarg (), [ '1', '2', '3' ]); is_deeply (Regress::test_array_int_full_out (), [0, 1, 2, 3, 4]); is_deeply (Regress::test_array_int_none_out (), [1, 2, 3, 4, 5]); Regress::test_array_int_null_in (undef); is (Regress::test_array_int_null_out, undef); my $test_list = [1, 2, 3]; is_deeply (Regress::test_glist_nothing_return (), $test_list); is_deeply (Regress::test_glist_nothing_return2 (), $test_list); is_deeply (Regress::test_glist_container_return (), $test_list); is_deeply (Regress::test_glist_everything_return (), $test_list); Regress::test_glist_nothing_in ($test_list); Regress::test_glist_nothing_in2 ($test_list); Regress::test_glist_null_in (undef); is (Regress::test_glist_null_out (), undef); is_deeply (Regress::test_gslist_nothing_return (), $test_list); is_deeply (Regress::test_gslist_nothing_return2 (), $test_list); is_deeply (Regress::test_gslist_container_return (), $test_list); is_deeply (Regress::test_gslist_everything_return (), $test_list); Regress::test_gslist_nothing_in ($test_list); Regress::test_gslist_nothing_in2 ($test_list); Regress::test_gslist_null_in (undef); is (Regress::test_gslist_null_out (), undef); Glib-Object-Introspection-0.019/t/boxed.t000644 001750 000024 00000006324 12103264610 020424 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use Scalar::Util qw/weaken/; plan tests => 47; # Use the provided constructor. { my $boxed = GI::BoxedStruct->new; isa_ok ($boxed, 'GI::BoxedStruct'); is ($boxed->long_, 0); is ($boxed->g_strv, undef); is ($boxed->long_ (42), 0); $boxed->inv; weaken $boxed; is ($boxed, undef); } # Use our generic constructor. { my $boxed = Glib::Boxed::new ('GI::BoxedStruct', {long_ => 42}); isa_ok ($boxed, 'GI::BoxedStruct'); is ($boxed->long_, 42); is ($boxed->g_strv, undef); $boxed->inv; $boxed = Glib::Boxed::new ('GI::BoxedStruct', long_ => 42); isa_ok ($boxed, 'GI::BoxedStruct'); is ($boxed->long_, 42); is ($boxed->g_strv, undef); $boxed->inv; } SKIP: { skip 'new stuff', 6 unless check_gi_version (0, 12, 0); my $boxed = GI::BoxedStruct::returnv (); isa_ok ($boxed, 'GI::BoxedStruct'); is ($boxed->long_, 42); is_deeply ($boxed->g_strv, [qw/0 1 2/]); $boxed->inv; weaken $boxed; is ($boxed, undef); # make sure we haven't destroyed the static object isa_ok (GI::BoxedStruct::returnv (), 'GI::BoxedStruct'); isa_ok (GI::BoxedStruct::returnv ()->copy, 'GI::BoxedStruct'); } SKIP: { skip 'new stuff', 5 unless check_gi_version (0, 12, 0); my $boxed = GI::BoxedStruct::out (); isa_ok ($boxed, 'GI::BoxedStruct'); is ($boxed->long_, 42); # $boxed->g_strv contains garbage weaken $boxed; is ($boxed, undef); # make sure we haven't destroyed the static object isa_ok (GI::BoxedStruct::out (), 'GI::BoxedStruct'); isa_ok (GI::BoxedStruct::out ()->copy, 'GI::BoxedStruct'); } SKIP: { skip 'new stuff', 4 unless check_gi_version (0, 12, 0); my $boxed_out = GI::BoxedStruct::out (); my $boxed = GI::BoxedStruct::inout ($boxed_out); isa_ok ($boxed, 'GI::BoxedStruct'); is ($boxed->long_, 0); is ($boxed_out->long_, 42); # $boxed->g_strv contains garbage weaken $boxed; is ($boxed, undef); } # --------------------------------------------------------------------------- # SKIP: { skip 'new stuff', 5 unless check_gi_version (0, 12, 0); my $boxed = Regress::TestSimpleBoxedA::const_return (); isa_ok ($boxed, 'Regress::TestSimpleBoxedA'); isa_ok ($boxed, 'Glib::Boxed'); my $copy = $boxed->copy; ok ($boxed->equals ($copy)); weaken $boxed; is ($boxed, undef); weaken $copy; is ($copy, undef); } { my $boxed = Regress::TestBoxed->new; isa_ok ($boxed, 'Regress::TestBoxed'); isa_ok ($boxed, 'Glib::Boxed'); my $copy = $boxed->copy; isa_ok ($boxed, 'Regress::TestBoxed'); isa_ok ($boxed, 'Glib::Boxed'); ok ($boxed->equals ($copy)); weaken $boxed; is ($boxed, undef); weaken $copy; is ($copy, undef); $boxed = Regress::TestBoxed->new_alternative_constructor1 (23); isa_ok ($boxed, 'Regress::TestBoxed'); isa_ok ($boxed, 'Glib::Boxed'); weaken $boxed; is ($boxed, undef); $boxed = Regress::TestBoxed->new_alternative_constructor2 (23, 42); isa_ok ($boxed, 'Regress::TestBoxed'); isa_ok ($boxed, 'Glib::Boxed'); weaken $boxed; is ($boxed, undef); $boxed = Regress::TestBoxed->new_alternative_constructor3 ("perl"); isa_ok ($boxed, 'Regress::TestBoxed'); isa_ok ($boxed, 'Glib::Boxed'); weaken $boxed; is ($boxed, undef); } Glib-Object-Introspection-0.019/t/cairo-integration.t000644 001750 000024 00000001414 11663370775 022760 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; my $have_cairo_gobject = eval 'use Cairo::GObject; 1'; plan $have_cairo_gobject ? (tests => 8) : (skip_all => 'Need Cairo::GObject'); my $cr = Regress::test_cairo_context_full_return (); isa_ok ($cr, 'Cairo::Context'); is ($cr->status, 'success'); Regress::test_cairo_context_none_in ($cr); my $surf = Regress::test_cairo_surface_none_return (); isa_ok ($surf, 'Cairo::Surface'); is ($surf->status, 'success'); $surf = Regress::test_cairo_surface_full_return (); isa_ok ($surf, 'Cairo::Surface'); is ($surf->status, 'success'); Regress::test_cairo_surface_none_in ($surf); $surf = Regress::test_cairo_surface_full_out (); isa_ok ($surf, 'Cairo::Surface'); is ($surf->status, 'success'); Glib-Object-Introspection-0.019/t/callbacks.t000644 001750 000024 00000001411 12103264610 021232 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 25; my $data = 42; my $result = 23; my $callback = sub { is @_, 1; is $_[0], $data; return $result; }; is (Regress::test_callback_user_data ($callback, $data), $result); is (Regress::test_callback_destroy_notify ($callback, $data), $result); is (Regress::test_callback_destroy_notify ($callback, $data), $result); is (Regress::test_callback_thaw_notifications (), 46); Regress::test_callback_async ($callback, $data); Regress::test_callback_async ($callback, $data); is (Regress::test_callback_thaw_async (), $result); my $obj = Regress::TestObj->new_callback ($callback, $data); isa_ok ($obj, 'Regress::TestObj'); is (Regress::test_callback_thaw_notifications (), 23); Glib-Object-Introspection-0.019/t/closures.t000644 001750 000024 00000000357 11663370775 021206 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 3; is (Regress::test_closure (sub { return 23; }), 23); is (Regress::test_closure_one_arg (sub { is (shift, 42); return 23; }, 42), 23); Glib-Object-Introspection-0.019/t/constants.t000644 001750 000024 00000000541 11663370775 021356 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use utf8; plan tests => 6; is (GI::CONSTANT_NUMBER, 42); is (GI::CONSTANT_UTF8, 'const ♥ utf8'); is (Regress::INT_CONSTANT, 4422); delta_ok (Regress::DOUBLE_CONSTANT, 44.22); is (Regress::STRING_CONSTANT, "Some String"); is (Regress::Mixed_Case_Constant, 4423); Glib-Object-Introspection-0.019/t/enums.t000644 001750 000024 00000000711 12266540466 020464 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 4; is (Regress::test_enum_param ('value1'), 'value1'); is (Regress::test_unsigned_enum_param ('value2'), 'value2'); ok (Regress::global_get_flags_out () == ['flag1', 'flag3']); SKIP: { skip 'non-GType flags tests', 1 unless (check_gi_version (0, 10, 3)); GI::no_type_flags_in ([qw/value2/]); is (GI::no_type_flags_returnv (), [qw/value2/]); } Glib-Object-Introspection-0.019/t/hashes.t000644 001750 000024 00000002012 11663370775 020610 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use utf8; plan tests => 8; is(Regress::test_ghash_null_return(), undef); is_deeply(Regress::test_ghash_nothing_return(), { foo => 'bar', baz => 'bat', qux => 'quux' }); is_deeply(Regress::test_ghash_nothing_return2(), { foo => 'bar', baz => 'bat', qux => 'quux' }); is_deeply(Regress::test_ghash_container_return(), { foo => 'bar', baz => 'bat', qux => 'quux' }); is_deeply(Regress::test_ghash_everything_return(), { foo => 'bar', baz => 'bat', qux => 'quux' }); Regress::test_ghash_null_in(undef); is(Regress::test_ghash_null_out(), undef); Regress::test_ghash_nothing_in({ foo => 'bar', baz => 'bat', qux => 'quux' }); Regress::test_ghash_nothing_in2({ foo => 'bar', baz => 'bat', qux => 'quux' }); is_deeply(Regress::test_ghash_nested_everything_return(), { wibble => { foo => 'bar', baz => 'bat', qux => 'quux', }, }); is_deeply(Regress::test_ghash_nested_everything_return2(), { wibble => { foo => 'bar', baz => 'bat', qux => 'quux', }, }); Glib-Object-Introspection-0.019/t/inc/000755 001750 000024 00000000000 12266655504 017722 5ustar00brianstaff000000 000000 Glib-Object-Introspection-0.019/t/interface-implementation.t000644 001750 000024 00000001540 11663370775 024325 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 7; { package NoImplementation; use Glib::Object::Subclass 'Glib::Object', interfaces => [ 'GI::Interface' ]; } { my $foo = NoImplementation->new; local $@; eval { $foo->test_int8_in (23) }; like ($@, qr/TEST_INT8_IN/); } { package GoodImplementation; use Glib::Object::Subclass 'Glib::Object', interfaces => [ 'GI::Interface' ]; sub TEST_INT8_IN { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); Test::More::isa_ok ($self, 'GI::Interface'); } } { my $foo = GoodImplementation->new; $foo->test_int8_in (23); pass; } { package InheritedImplementation; use Glib::Object::Subclass 'GoodImplementation'; } { my $foo = InheritedImplementation->new; $foo->test_int8_in (23); pass; } Glib-Object-Introspection-0.019/t/objects.t000644 001750 000024 00000004442 11663370775 020777 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use Scalar::Util qw/weaken/; plan tests => 41; my $obj = Regress::TestObj->constructor; isa_ok ($obj, 'Regress::TestObj'); isa_ok ($obj, 'Glib::Object'); $obj = Regress::TestObj->new ($obj); isa_ok ($obj, 'Regress::TestObj'); isa_ok ($obj, 'Glib::Object'); weaken $obj; is ($obj, undef); $obj = Regress::TestObj->new_from_file ($0); isa_ok ($obj, 'Regress::TestObj'); isa_ok ($obj, 'Glib::Object'); $obj->set_bare (Regress::TestObj->constructor); is ($obj->instance_method, -1); is (Regress::TestObj::static_method (23), 23); $obj->forced_method; my ($y, $z, $q) = $obj->torture_signature_0 (23, 'perl', 42); is ($y, 23); is ($z, 46); is ($q, 46); is (eval { $obj->torture_signature_1 (23, 'perl', 41); 1 }, undef); like ($@, qr/odd/); # skipping return values SKIP: { skip 'new stuff', 3 unless check_gi_version (0, 12, 0); my ($b, $d, $sum) = $obj->skip_return_val (23, 42, 57, 13, 17); is ($b, 24); is ($d, 58); is ($sum, 13+170); } # skipping parameters SKIP: { skip 'new stuff', 10 unless check_gi_version (0, 12, 0); my ($success, $b, $d, $sum); ($success, $b, $d, $sum) = $obj->skip_param (23, 57, 13, 17); ok ($success); is ($b, 24); is ($d, 58); is ($sum, 13+170); ($success, $d, $sum) = $obj->skip_out_param (23, 42, 57, 13, 17); ok ($success); is ($d, 58); is ($sum, 13+170); ($success, $b, $sum) = $obj->skip_inout_param (23, 42, 13, 17); ok ($success); is ($b, 24); is ($sum, 13+170); } is ($obj->do_matrix ('perl'), 42); Regress::func_obj_null_in ($obj); Regress::func_obj_null_in (undef); is (Regress::TestObj::null_out (), undef); # inheritance my $sub = Regress::TestSubObj->new; isa_ok ($sub, 'Regress::TestSubObj'); isa_ok ($sub, 'Regress::TestObj'); isa_ok ($sub, 'Glib::Object'); $sub->unset_bare; is ($sub->instance_method, 0); # unusual prefix my $wi = Regress::TestWi8021x->new; isa_ok ($wi, 'Regress::TestWi8021x'); isa_ok ($wi, 'Glib::Object'); $wi->set_testbool (1); ok ($wi->get_testbool); is (Regress::TestWi8021x::static_method (23), 46); # floating objects SKIP: { my $fl = Regress::TestFloating->new; isa_ok ($fl, 'Regress::TestFloating'); isa_ok ($fl, 'Glib::InitiallyUnowned'); isa_ok ($fl, 'Glib::Object'); weaken $fl; is ($fl, undef); } Glib-Object-Introspection-0.019/t/structs.t000644 001750 000024 00000002271 11663370775 021053 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 6; SKIP: { skip 'new stuff', 2 unless check_gi_version (0, 12, 0); my $expected_struct = {long_ => 6, int8 => 7}; my $struct = GI::SimpleStruct::returnv (); is_deeply ($struct, $expected_struct); GI::SimpleStruct::inv ($struct); GI::SimpleStruct::method ($struct); undef $struct; is_deeply (GI::SimpleStruct::returnv (), $expected_struct); } SKIP: { skip 'new stuff', 2 unless check_gi_version (0, 12, 0); my $expected_struct = {long_ => 42}; my $struct = GI::PointerStruct::returnv (); is_deeply ($struct, $expected_struct); GI::PointerStruct::inv ($struct); undef $struct; is_deeply (GI::PointerStruct::returnv (), $expected_struct); } { my $expected_struct = { some_int => 23, some_int8 => 42, some_double => 11, some_enum => 'value1'}; is_deeply (Regress::TestStructA::clone ($expected_struct), $expected_struct); } { my $expected_struct = { some_int8 => 32, nested_a => { some_int => 23, some_int8 => 42, some_double => 11, some_enum => 'value1'}}; is_deeply (Regress::TestStructB::clone ($expected_struct), $expected_struct); } Glib-Object-Introspection-0.019/t/values.t000644 001750 000024 00000000365 11663370775 020645 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 2; SKIP: { skip 'SV → GValue not implemented', 1; is (Regress::test_int_value_arg (23), 23); } is (Regress::test_value_return (23), 23); Glib-Object-Introspection-0.019/t/vfunc-chaining.t000644 001750 000024 00000006511 12175005707 022231 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 34; { package GoodImplementation; use Glib::Object::Subclass 'GI::Object'; sub METHOD_INT8_IN { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); Test::More::is ($int8, 23); } sub METHOD_INT8_OUT { my ($self) = @_; Test::More::isa_ok ($self, __PACKAGE__); return 42; } } { my $foo = GoodImplementation->new; $foo->method_int8_in (23); pass; is ($foo->method_int8_out, 42); $foo->method_with_default_implementation (23); is ($foo->get ('int'), 23); } { package GoodChaining; use Glib::Object::Subclass 'GI::Object'; sub METHOD_INT8_IN { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); Test::More::is ($int8, 23); # cannot chain up since GI::Object does not provide a default # implementation } sub METHOD_INT8_OUT { my ($self) = @_; Test::More::isa_ok ($self, __PACKAGE__); # cannot chain up since GI::Object does not provide a default # implementation return 42; } sub METHOD_WITH_DEFAULT_IMPLEMENTATION { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); Test::More::is ($int8, 23); return $self->SUPER::METHOD_WITH_DEFAULT_IMPLEMENTATION ($int8); } } { my $foo = GoodChaining->new; $foo->method_int8_in (23); pass; $foo->method_with_default_implementation (23); is ($foo->get ('int'), 23); } { package PerlInheritance; use Glib::Object::Subclass 'GoodImplementation'; } { my $foo = PerlInheritance->new; $foo->method_int8_in (23); pass; is ($foo->method_int8_out, 42); $foo->method_with_default_implementation (23); is ($foo->get ('int'), 23); } { package PerlInheritanceWithChaining; use Glib::Object::Subclass 'GoodChaining'; sub METHOD_INT8_IN { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); Test::More::is ($int8, 23); return $self->SUPER::METHOD_INT8_IN ($int8); } sub METHOD_INT8_OUT { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); return $self->SUPER::METHOD_INT8_OUT (); } sub METHOD_WITH_DEFAULT_IMPLEMENTATION { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); Test::More::is ($int8, 23); return $self->SUPER::METHOD_WITH_DEFAULT_IMPLEMENTATION ($int8); } } { my $foo = PerlInheritanceWithChaining->new; $foo->method_int8_in (23); pass; is ($foo->method_int8_out, 42); $foo->method_with_default_implementation (23); is ($foo->get ('int'), 23); } { package BadChaininig; use Glib::Object::Subclass 'GI::Object'; sub METHOD_INT8_IN { my ($self, $int8) = @_; Test::More::isa_ok ($self, __PACKAGE__); Test::More::is ($int8, 23); return $self->SUPER::METHOD_INT8_IN ($int8); } } { my $foo = BadChaininig->new; local $@; eval { $foo->method_int8_in (23) }; like ($@, qr/METHOD_INT8_IN/); } =for segfault This segfaults currently because the call to method_int8_in tries to invoke the corresponding vfunc slot in the class struct for NoImplementation. But that's NULL since NoImplementation doesn't provide an implementation. { package NoImplementation; use Glib::Object::Subclass 'GI::Object'; } { my $foo = NoImplementation->new; local $@; eval { $foo->method_int8_in (23) }; like ($@, qr/method_int8_in/); } =cut Glib-Object-Introspection-0.019/t/vfunc-ref-counting.t000644 001750 000024 00000014141 12266540466 023056 0ustar00brianstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use Scalar::Util; plan skip_all => 'Need gobject-introspection 1.35.5' unless check_gi_version (1, 35, 5); plan tests => 68; my @packages = qw/WeakNonFloater WeakFloater StrongNonFloater StrongFloater/; my %package_to_subclass = ( WeakNonFloater => 'NonFloatingObjectSubclass', WeakFloater => 'FloatingObjectSubclass', StrongNonFloater => 'NonFloatingObjectSubclass', StrongFloater => 'FloatingObjectSubclass', ); my %package_to_warner = ( WeakNonFloater => sub { die $_[0] if -1 == index $_[0], 'Asked to hand out object' }, WeakFloater => sub { die $_[0] if -1 == index $_[0], 'Asked to hand out object' }, StrongNonFloater => sub { die $_[0] }, StrongFloater => sub { die $_[0] }, ); my %package_to_ref_count_offset = ( WeakNonFloater => 0, WeakFloater => 0, StrongNonFloater => 1, StrongFloater => 1, ); my %package_to_ref_gone = ( WeakNonFloater => Glib::TRUE, WeakFloater => Glib::TRUE, StrongNonFloater => Glib::FALSE, StrongFloater => Glib::FALSE, ); my %package_to_floating = ( WeakNonFloater => Glib::FALSE, WeakFloater => Glib::TRUE, StrongNonFloater => Glib::FALSE, StrongFloater => Glib::TRUE, ); # Test that the invocant is not leaked. foreach my $package (@packages) { { my $nf = $package->new; $nf->get_ref_info_for_vfunc_return_object_transfer_full; Scalar::Util::weaken ($nf); is ($nf, undef, "no leak for $package"); } } # Test transfer-none&return/out semantics. foreach my $package (@packages) { local $SIG{__WARN__} = $package_to_warner{$package}; foreach my $method (qw/get_ref_info_for_vfunc_return_object_transfer_none get_ref_info_for_vfunc_out_object_transfer_none/) { my $nf = $package->new; my ($ref_count, $is_floating) = $nf->$method; is ($ref_count, 1, "transfer-none&return/out: ref count for $package"); ok (!$is_floating, "transfer-none&return/out: floating for $package"); } } # Test transfer-full&return/out semantics. foreach my $package (@packages) { foreach my $method (qw/get_ref_info_for_vfunc_return_object_transfer_full get_ref_info_for_vfunc_out_object_transfer_full/) { my $nf = $package->new; my ($ref_count, $is_floating) = $nf->$method; is ($ref_count, 1 + $package_to_ref_count_offset{$package}, "transfer-full&return/out: ref count for $package"); ok (!$is_floating, "transfer-full&return/out: floating for $package"); is ($nf->is_ref_gone, $package_to_ref_gone{$package}, "transfer-full&return/out: ref gone for $package"); } } # Test transfer-none&in semantics. foreach my $package (@packages) { { my $nf = $package->new; my ($ref_count, $is_floating) = $nf->get_ref_info_for_vfunc_in_object_transfer_none ($package_to_subclass{$package}); TODO: { local $TODO = $package =~ /^Weak/ ? 'ref count test unreliable due to unpredictable behavior of perl-Glib' : undef; is ($ref_count, 1 + $package_to_ref_count_offset{$package}, "transfer-none&in: ref count for $package"); } is ($is_floating, $package_to_floating{$package}, "transfer-none&in: floating for $package"); is ($nf->is_ref_gone, $package_to_ref_gone{$package}, "transfer-none&in: ref gone for $package"); } } # Test transfer-full&in semantics. foreach my $package (@packages) { { my $nf = $package->new; my ($ref_count, $is_floating) = $nf->get_ref_info_for_vfunc_in_object_transfer_full ($package_to_subclass{$package}); TODO: { local $TODO = $package =~ /^Weak/ ? 'ref count test unreliable due to unpredictable behavior of perl-Glib' : undef; is ($ref_count, 0 + $package_to_ref_count_offset{$package}, "transfer-full&in: ref count for $package"); } ok (!$is_floating, "transfer-full&in: floating for $package"); is ($nf->is_ref_gone, $package_to_ref_gone{$package}, "transfer-full&in: ref gone for $package"); } } # --------------------------------------------------------------------------- # { package NonFloatingObjectSubclass; use Glib::Object::Subclass 'Glib::Object'; } { package FloatingObjectSubclass; use Glib::Object::Subclass 'Glib::InitiallyUnowned'; } { package Base; use Glib::Object::Subclass 'GI::Object'; sub VFUNC_RETURN_OBJECT_TRANSFER_NONE { my ($self) = @_; my $o = $self->_create; $self->_store ($o); return $o; } sub VFUNC_RETURN_OBJECT_TRANSFER_FULL { my ($self) = @_; my $o = $self->_create; $self->_store ($o); return $o; } sub VFUNC_OUT_OBJECT_TRANSFER_NONE { my ($self) = @_; my $o = $self->_create; $self->_store ($o); return $o; } sub VFUNC_OUT_OBJECT_TRANSFER_FULL { my ($self) = @_; my $o = $self->_create; $self->_store ($o); return $o; } sub VFUNC_IN_OBJECT_TRANSFER_NONE { my ($self, $o) = @_; $self->_store ($o); } sub VFUNC_IN_OBJECT_TRANSFER_FULL { my ($self, $o) = @_; $self->_store ($o); } sub is_ref_gone { my ($self) = @_; not defined $self->_retrieve; } } { package WeakNonFloater; use Glib::Object::Subclass 'Base'; sub _create { NonFloatingObjectSubclass->new; } sub _store { my ($self, $o) = @_; Scalar::Util::weaken ($self->{_ref} = $o); } sub _retrieve { my ($self) = @_; $self->{_ref}; } } { package WeakFloater; use Glib::Object::Subclass 'Base'; sub _create { FloatingObjectSubclass->new; } sub _store { my ($self, $o) = @_; Scalar::Util::weaken ($self->{_ref} = $o); } sub _retrieve { my ($self) = @_; $self->{_ref}; } } { package StrongNonFloater; use Glib::Object::Subclass 'Base'; sub _create { NonFloatingObjectSubclass->new; } sub _store { my ($self, $o) = @_; $self->{_ref} = $o; } sub _retrieve { my ($self) = @_; $self->{_ref}; } } { package StrongFloater; use Glib::Object::Subclass 'Base'; sub _create { FloatingObjectSubclass->new; } sub _store { my ($self, $o) = @_; $self->{_ref} = $o; } sub _retrieve { my ($self) = @_; $self->{_ref}; } } Glib-Object-Introspection-0.019/t/inc/setup.pl000644 001750 000024 00000002165 12103264610 021403 0ustar00brianstaff000000 000000 use Config; use Glib::Object::Introspection; use Test::More; unless (-e qq(build/libregress.$Config{dlext}) && -e qq(build/libgimarshallingtests.$Config{dlext})) { plan skip_all => 'Need the test libraries'; } if ($^O eq 'MSWin32') { unless (defined $ENV{PATH} && $ENV{PATH} =~ m/\bbuild\b/) { plan skip_all => 'Need "build" in PATH'; } } else { unless (defined $ENV{LD_LIBRARY_PATH} && $ENV{LD_LIBRARY_PATH} =~ m/\bbuild\b/) { plan skip_all => 'Need "build" in LD_LIBRARY_PATH'; } } Glib::Object::Introspection->setup( basename => 'Regress', version => '1.0', package => 'Regress', search_path => 'build'); Glib::Object::Introspection->setup( basename => 'GIMarshallingTests', version => '1.0', package => 'GI', search_path => 'build'); # Inspired by Test::Number::Delta sub delta_ok ($$;$) { my ($a, $b, $msg) = @_; ok (abs ($a - $b) < 1e-6, $msg); } sub check_gi_version { my ($x, $y, $z) = @_; #return !system ('pkg-config', "--atleast-version=$x.$y.$z", 'gobject-introspection-1.0'); return Glib::Object::Introspection->CHECK_VERSION ($x, $y, $z); } 1; Glib-Object-Introspection-0.019/lib/Glib/000755 001750 000024 00000000000 12266655504 020331 5ustar00brianstaff000000 000000 Glib-Object-Introspection-0.019/lib/Glib/Object/000755 001750 000024 00000000000 12266655504 021537 5ustar00brianstaff000000 000000 Glib-Object-Introspection-0.019/lib/Glib/Object/Introspection.pm000644 001750 000024 00000043400 12266655405 024736 0ustar00brianstaff000000 000000 # Copyright (C) 2010-2013 Torsten Schoenfeld # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library 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 Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA package Glib::Object::Introspection; use strict; use warnings; use Glib; our $VERSION = '0.019'; use Carp; $Carp::Internal{(__PACKAGE__)}++; require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); my @OBJECT_PACKAGES_WITH_VFUNCS; our %_FORBIDDEN_SUB_NAMES = map { $_ => 1 } qw/AUTOLOAD CLONE DESTROY BEGIN UNITCHECK CHECK INIT END/; our %_BASENAME_TO_PACKAGE; our %_REBLESSERS; sub _create_invoker_sub { my ($basename, $namespace, $name, $shift_package_name, $flatten_array_ref_return, $handle_sentinel_boolean) = @_; if ($flatten_array_ref_return) { return sub { shift if $shift_package_name; my $ref = __PACKAGE__->invoke($basename, $namespace, $name, @_); return if not defined $ref; return wantarray ? @$ref : $ref->[$#$ref]; }; } elsif ($handle_sentinel_boolean) { return sub { shift if $shift_package_name; my ($bool, @stuff) = __PACKAGE__->invoke($basename, $namespace, $name, @_); return $bool ? @stuff[0..$#stuff] # slice to correctly behave in scalar context : (); }; } else { return sub { shift if $shift_package_name; return __PACKAGE__->invoke($basename, $namespace, $name, @_); }; } } sub setup { my ($class, %params) = @_; my $basename = $params{basename}; my $version = $params{version}; my $package = $params{package}; my $search_path = $params{search_path} || undef; my $name_corrections = $params{name_corrections} || {}; $_BASENAME_TO_PACKAGE{$basename} = $package; my %shift_package_name_for = exists $params{class_static_methods} ? map { $_ => 1 } @{$params{class_static_methods}} : (); my %flatten_array_ref_return_for = exists $params{flatten_array_ref_return_for} ? map { $_ => 1 } @{$params{flatten_array_ref_return_for}} : (); my %handle_sentinel_boolean_for = exists $params{handle_sentinel_boolean_for} ? map { $_ => 1 } @{$params{handle_sentinel_boolean_for}} : (); my @use_generic_signal_marshaller_for = exists $params{use_generic_signal_marshaller_for} ? @{$params{use_generic_signal_marshaller_for}} : (); if (exists $params{reblessers}) { $_REBLESSERS{$_} = $params{reblessers}->{$_} for keys %{$params{reblessers}} } __PACKAGE__->_load_library($basename, $version, $search_path); my ($functions, $constants, $fields, $interfaces, $objects_with_vfuncs) = __PACKAGE__->_register_types($basename, $package); no strict qw(refs); no warnings qw(redefine); foreach my $namespace (keys %{$functions}) { my $is_namespaced = $namespace ne ""; NAME: foreach my $name (@{$functions->{$namespace}}) { my $auto_name = $is_namespaced ? $package . '::' . $namespace . '::' . $name : $package . '::' . $name; my $corrected_name = exists $name_corrections->{$auto_name} ? $name_corrections->{$auto_name} : $auto_name; if (defined &{$corrected_name}) { next NAME; } *{$corrected_name} = _create_invoker_sub ( $basename, $is_namespaced ? $namespace : undef, $name, $shift_package_name_for{$corrected_name}, $flatten_array_ref_return_for{$corrected_name}, $handle_sentinel_boolean_for{$corrected_name}); } } foreach my $name (@{$constants}) { my $auto_name = $package . '::' . $name; my $corrected_name = exists $name_corrections->{$auto_name} ? $name_corrections->{$auto_name} : $auto_name; # Install a sub which, on the first invocation, calls _fetch_constant and # then overrides itself with a constant sub returning that value. *{$corrected_name} = sub { my $value = __PACKAGE__->_fetch_constant($basename, $name); { *{$corrected_name} = sub { $value }; } return $value; }; } foreach my $namespace (keys %{$fields}) { foreach my $field_name (@{$fields->{$namespace}}) { my $auto_name = $package . '::' . $namespace . '::' . $field_name; my $corrected_name = exists $name_corrections->{$auto_name} ? $name_corrections->{$auto_name} : $auto_name; *{$corrected_name} = sub { my ($invocant, $new_value) = @_; my $old_value = __PACKAGE__->_get_field($basename, $namespace, $field_name, $invocant); # If a new value is provided, even if it is undef, update the field. if (scalar @_ > 1) { __PACKAGE__->_set_field($basename, $namespace, $field_name, $invocant, $new_value); } return $old_value; }; } } # Monkey-patch Glib with a generic constructor for boxed types. Glib cannot # provide this on its own because it does not know how big the struct of a # boxed type is. FIXME: This sort of violates encapsulation. { if (! defined &{Glib::Boxed::new}) { *{Glib::Boxed::new} = sub { my ($class, @rest) = @_; my $boxed = Glib::Object::Introspection->_construct_boxed ($class); my $fields = 1 == @rest ? $rest[0] : { @rest }; foreach my $field (keys %$fields) { if ($boxed->can ($field)) { $boxed->$field ($fields->{$field}); } } return $boxed; } } } foreach my $name (@{$interfaces}) { my $adder_name = $package . '::' . $name . '::_ADD_INTERFACE'; *{$adder_name} = sub { my ($class, $target_package) = @_; __PACKAGE__->_add_interface($basename, $name, $target_package); }; } foreach my $object_name (@{$objects_with_vfuncs}) { my $object_package = $package . '::' . $object_name; my $installer_name = $object_package . '::_INSTALL_OVERRIDES'; *{$installer_name} = sub { my ($target_package) = @_; # Delay hooking up the vfuncs until INIT so that we can see whether the # package defines the relevant subs or not. FIXME: Shouldn't we only do # the delay dance if ${^GLOBAL_PHASE} eq 'START'? push @OBJECT_PACKAGES_WITH_VFUNCS, [$basename, $object_name, $target_package]; }; } foreach my $packaged_signal (@use_generic_signal_marshaller_for) { __PACKAGE__->_use_generic_signal_marshaller_for (@$packaged_signal); } } sub INIT { no strict qw(refs); # Hook up the implemented vfuncs first. foreach my $target (@OBJECT_PACKAGES_WITH_VFUNCS) { my ($basename, $object_name, $target_package) = @{$target}; __PACKAGE__->_install_overrides($basename, $object_name, $target_package); } # And then, for each vfunc in our ancestry that has an implementation, add a # wrapper sub to our immediate parent. We delay this step until after all # Perl overrides are in place because otherwise, the override code would see # the fallback vfuncs (via gv_fetchmethod) we are about to set up, and it # would mistake them for an actual implementation. This would then lead it # to put Perl callbacks into the vfunc slots regardless of whether the Perl # class in question actually provides implementations. my %implementer_packages_seen; foreach my $target (@OBJECT_PACKAGES_WITH_VFUNCS) { my ($basename, $object_name, $target_package) = @{$target}; my @non_perl_parent_packages = __PACKAGE__->_find_non_perl_parents($basename, $object_name, $target_package); # For each non-Perl parent, look at all the vfuncs it and its parents # provide. For each vfunc which has an implementation in the parent # (i.e. the corresponding struct pointer is not NULL), install a fallback # sub which invokes the vfunc implementation. This assumes that # @non_perl_parent_packages contains the parents in "ancestorial" order, # i.e. the first entry must be the immediate parent. IMPLEMENTER: for (my $i = 0; $i < @non_perl_parent_packages; $i++) { my $implementer_package = $non_perl_parent_packages[$i]; next IMPLEMENTER if $implementer_packages_seen{$implementer_package}++; for (my $j = $i; $j < @non_perl_parent_packages; $j++) { my $provider_package = $non_perl_parent_packages[$j]; my @vfuncs = __PACKAGE__->_find_vfuncs_with_implementation( $provider_package, $implementer_package); VFUNC: foreach my $vfunc_name (@vfuncs) { my $perl_vfunc_name = uc $vfunc_name; if (exists $_FORBIDDEN_SUB_NAMES{$perl_vfunc_name}) { $perl_vfunc_name .= '_VFUNC'; } my $full_perl_vfunc_name = $implementer_package . '::' . $perl_vfunc_name; next VFUNC if defined &{$full_perl_vfunc_name}; *{$full_perl_vfunc_name} = sub { __PACKAGE__->_invoke_fallback_vfunc($provider_package, $vfunc_name, $implementer_package, @_); } } } } } @OBJECT_PACKAGES_WITH_VFUNCS = (); } package Glib::Object::Introspection::_FuncWrapper; use overload '&{}' => sub { my ($func) = @_; return sub { Glib::Object::Introspection::_FuncWrapper::_invoke($func, @_) } }, fallback => 1; package Glib::Object::Introspection; 1; __END__ =head1 NAME Glib::Object::Introspection - Dynamically create Perl language bindings =head1 SYNOPSIS use Glib::Object::Introspection; Glib::Object::Introspection->setup( basename => 'Gtk', version => '3.0', package => 'Gtk3'); # now GtkWindow, to mention just one example, is available as # Gtk3::Window, and you can call gtk_window_new as Gtk3::Window->new =head1 ABSTRACT Glib::Object::Introspection uses the gobject-introspection and libffi projects to dynamically create Perl bindings for a wide variety of libraries. Examples include gtk+, webkit, libsoup and many more. =head1 DESCRIPTION =head2 C<< Glib::Object::Introspection->setup >> To allow Glib::Object::Introspection to create bindings for a library, it must have installed a typelib file, for example C<$prefix/lib/girepository-1.0/Gtk-3.0.typelib>. In your code you then simply call C<< Glib::Object::Introspection->setup >> to set everything up. This method takes a couple of key-value pairs as arguments. These three are mandatory: =over =item basename => $basename The basename of the library that should be wrapped. If your typelib is called C, then the basename is 'Gtk'. =item version => $version The particular version of the library that should be wrapped, in string form. For C, it is '3.0'. =item package => $package The name of the Perl package where every class and method of the library should be rooted. If a library with basename 'Gtk' contains an object 'GtkWindow', and you pick as the package 'Gtk3', then that object will be available as 'Gtk3::Window'. =back The rest are optional: =over =item search_path => $search_path A path that should be used when looking for typelibs. If you use typelibs from system directories, or if your environment is set up correctly, then this should not be necessary. =item name_corrections => { auto_name => new_name, ... } A hash ref that is used to rename functions and methods. Use this if you don't like the automatically generated mapping for a function or method. For example, if C is automatically represented as C but you want C then pass name_corrections => { 'Glib::IO::file_hash' => 'Glib::IO::File::hash' } =item class_static_methods => [ function1, ... ] An array ref of function names that you want to be treated as class-static methods. That is, if you want be able to call C as C<< Gtk3::Window->list_toplevels >>, then pass class_static_methods => [ 'Gtk3::Window::list_toplevels' ] The function names refer to those after name corrections. =item flatten_array_ref_return_for => [ function1, ... ] An array ref of function names that return an array ref that you want to be flattened so that they return plain lists. For example flatten_array_ref_return_for => [ 'Gtk3::Window::list_toplevels' ] The function names refer to those after name corrections. Functions occuring in C may also occur in C. =item handle_sentinel_boolean_for => [ function1, ... ] An array ref of function names that return multiple values, the first of which is to be interpreted as indicating whether the rest of the returned values are valid. This frequently occurs with functions that have out arguments; the boolean then indicates whether the out arguments have been written. With C, the first return value is taken to be the sentinel boolean. If it is true, the rest of the original return values will be returned, and otherwise an empty list will be returned. handle_sentinel_boolean_for => [ 'Gtk3::TreeSelection::get_selected' ] The function names refer to those after name corrections. Functions occuring in C may also occur in C. =item use_generic_signal_marshaller_for => [ [package1, signal1, [arg_converter1]], ... ] Use an introspection-based generic signal marshaller for the signal C of type C. If given, use the code reference C to convert the arguments that are passed to the signal handler. In contrast to L's normal signal marshaller, the generic signal marshaller supports, among other things, pointer arrays and out arguments. =item reblessers => { package => \&reblesser, ... } Tells G:O:I to invoke I whenever a Perl object is created for an object of type I. Currently, this only applies to boxed unions. The reblesser gets passed the pre-created Perl object and needs to return the modified Perl object. For example: sub Gtk3::Gdk::Event::_rebless { my ($event) = @_; return bless $event, lookup_real_package_for ($event); } =back =head2 C<< Glib::Object::Introspection->invoke >> To invoke specific functions manually, you can use the low-level C<< Glib::Object::Introspection->invoke >>. Glib::Object::Introspection->invoke( $basename, $namespace, $function, @args) =over =item * $basename is the basename of a library, like 'Gtk'. =item * $namespace refers to a namespace inside that library, like 'Window'. Use undef here if you want to call a library-global function. =item * $function is the name of the function you want to invoke. It can also refer to the name of a constant. =item * @args are the arguments that should be passed to the function. For a method, this should include the invocant. For a constructor, this should include the package name. =back C<< Glib::Object::Introspection->invoke >> returns whatever the function being invoked returns. =head2 Overrides To override the behavior of a specific function or method, create an appropriately named sub in the correct package and have it call C<< Glib::Object::Introspection->invoke >>. Say you want to override C, then do this: sub Gtk3::Window::list_toplevels { # ...do something... my $ref = Glib::Object::Introspection->invoke ( 'Gtk', 'Window', 'list_toplevels', @_); # ...do something... return wantarray ? @$ref : $ref->[$#$ref]; } The sub's name and package must be those after name corrections. =head2 Converting a Perl variable to a GValue If you need to marshal into a GValue, then Glib::Object::Introspection cannot do this automatically because the type information is missing. If you do have this information in your module, however, you can use Glib::Object::Introspection::GValueWrapper to do the conversion. In the wrapper for a function that expects a GValue, do this: ... my $type = ...; # somehow get the package name that # corresponds to the correct GType my $real_value = Glib::Object::Introspection::GValueWrapper->new ($type, $value); # now use Glib::Object::Introspection->invoke and # substitute $real_value where you'd use $value ... =head2 Handling extendable enumerations If you need to handle extendable enumerations for which more than the pre-defined values might be valid, then use C<< Glib::Object::Introspection->convert_enum_to_sv >> and C<< Glib::Object::Introspection->convert_sv_to_enum >>. They will raise an exception on unknown values; catching it then allows you to implement fallback behavior. Glib::Object::Introspection->convert_enum_to_sv (package, enum_value) Glib::Object::Introspection->convert_sv_to_enum (package, sv) =head1 SEE ALSO =over =item gobject-introspection: L =item libffi: L =back =head1 AUTHORS =encoding utf8 =over =item Emmanuele Bassi =item muppet =item Torsten Schönfeld =back =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the terms of the Lesser General Public License (LGPL). For more information, see http://www.fsf.org/licenses/lgpl.txt =cut