Glib-Object-Introspection-0.042/000755 001750 000024 00000000000 13027323176 017535 5ustar00bdmanningstaff000000 000000 Glib-Object-Introspection-0.042/bin/000755 001750 000024 00000000000 13027323176 020305 5ustar00bdmanningstaff000000 000000 Glib-Object-Introspection-0.042/GObjectIntrospection.xs000644 001750 000024 00000107156 13014575125 024220 0ustar00bdmanningstaff000000 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. * * See the LICENSE file in the top-level directory of this distribution for the * full license terms. * */ #include "build/gi-version.h" #include #include #include #include /* #define NOISY */ #ifdef NOISY # define dwarn(msg...) G_STMT_START { \ g_printerr ("%s: ", G_STRFUNC); \ g_printerr (msg); \ } G_STMT_END #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; gint data_pos; gint 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; gint length_pos; } GPerlI11nArrayInfo; /* The next three structs store information that the different marshallers * might need to communicate to each other. This struct is the basis used for * invoking C and Perl code. */ typedef struct { GICallableInfo *interface; gboolean is_function; gboolean is_vfunc; gboolean is_callback; gboolean is_signal; /* The number of args described by the typelib. */ guint n_args; /* The current position under investigation in the list of typelib * args. */ guint current_pos; /* Information about the args from the typelib. */ GIArgInfo * arg_infos; GITypeInfo * arg_types; /* An array of places for storing out out/in-out or automatic args. */ GIArgument * aux_args; gboolean has_return_value; ffi_type * return_type_ffi; GITypeInfo return_type_info; GITransfer return_type_transfer; GSList * callback_infos; GSList * array_infos; GSList * free_after_call; } GPerlI11nInvocationInfo; /* This struct is used when invoking C code. */ typedef struct { GPerlI11nInvocationInfo base; const gchar *target_package; const gchar *target_namespace; const gchar *target_function; gboolean is_constructor; gboolean is_method; gboolean throws; /* The number of args that need to be given to the C function. */ guint n_invoke_args; /* The number of args for which no value is required. */ guint n_nullable_args; /* The number of necessary args, i.e. those that are not automatic or * nullable. */ guint n_expected_args; /* The number of args given by the caller. */ guint n_given_args; gpointer * args; ffi_type ** arg_types_ffi; GIArgument * in_args; GIArgument * out_args; gboolean * is_automatic_arg; guint constructor_offset; guint method_offset; guint stack_offset; gint dynamic_stack_offset; } GPerlI11nCInvocationInfo; /* This struct is used when invoking Perl code. */ typedef struct { GPerlI11nInvocationInfo base; } GPerlI11nPerlInvocationInfo; /* 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 */ static void prepare_invocation_info (GPerlI11nInvocationInfo *iinfo, GICallableInfo *info); static void clear_invocation_info (GPerlI11nInvocationInfo *iinfo); static void free_after_call (GPerlI11nInvocationInfo *iinfo, GFunc func, gpointer data); static void invoke_free_after_call_handlers (GPerlI11nInvocationInfo *iinfo); #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); /* 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, GPerlI11nInvocationInfo *iinfo); 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" #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) { dwarn (" -> constant\n"); av_push (constants, newSVpv (name, 0)); } if (info_type == GI_INFO_TYPE_FUNCTION) { dwarn (" -> global function\n"); av_push (global_functions, newSVpv (name, 0)); } if (info_type == GI_INFO_TYPE_INTERFACE) { dwarn (" -> interface\n"); 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) { dwarn (" looking for methods\n"); 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) { dwarn (" looking for fields\n"); store_fields (fields, info, info_type); } if (info_type == GI_INFO_TYPE_OBJECT) { dwarn (" looking for vfuncs\n"); 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 ("%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) { 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 ("%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 ("%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 ("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 SV * get_value (SV *sv) PREINIT: GValue *v; CODE: v = SvGValueWrapper (sv); RETVAL = gperl_sv_from_value (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.042/gperl-i11n-callback.c000644 001750 000024 00000006335 12516304773 023325 0ustar00bdmanningstaff000000 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 ("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 ("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.042/gperl-i11n-croak.c000644 001750 000024 00000001274 12221715323 022653 0ustar00bdmanningstaff000000 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.042/gperl-i11n-enums.c000644 001750 000024 00000003416 12435270235 022710 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ #define FILL_VALUES(values, value_type) \ { gint i; \ for (i = 0; i < n_values; i++) { \ GIValueInfo *value_info = g_enum_info_get_value (info, i); \ (values)[i].value = (value_type) 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; gint n_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. */ 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, gint); } else { values = g_new0 (GFlagsValue, n_values+1); /* zero-terminated */ FILL_VALUES ((GFlagsValue *) values, guint); } 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.042/gperl-i11n-field.c000644 001750 000024 00000014146 12460715064 022650 0ustar00bdmanningstaff000000 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; GITypeTag field_tag; GIBaseInfo *interface_info; GIInfoType interface_type; GIArgument value; SV *sv = NULL; field_type = g_field_info_get_type (field_info); field_tag = g_type_info_get_tag (field_type); interface_info = g_type_info_get_interface (field_type); interface_type = interface_info ? g_base_info_get_type (interface_info) : GI_INFO_TYPE_INVALID; /* Non-pointer structs are not handled by g_field_info_get_field. */ if (!g_type_info_is_pointer (field_type) && field_tag == GI_TYPE_TAG_INTERFACE && interface_type == GI_INFO_TYPE_STRUCT) { gint offset = g_field_info_get_offset (field_info); value.v_pointer = G_STRUCT_MEMBER_P (mem, offset); sv = arg_to_sv (&value, field_type, GI_TRANSFER_NOTHING, NULL); } /* Neither are void pointers. We retrieve the RV to the SV that * set_field put into them. */ else if (field_tag == GI_TYPE_TAG_VOID && g_type_info_is_pointer (field_type)) { gint offset = g_field_info_get_offset (field_info); value.v_pointer = G_STRUCT_MEMBER (gpointer, mem, offset); sv = value.v_pointer ? newRV (value.v_pointer) : &PL_sv_undef; } 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; GITypeTag field_tag; GIBaseInfo *interface_info; GIInfoType interface_type; GIArgument arg; field_type = g_field_info_get_type (field_info); field_tag = g_type_info_get_tag (field_type); interface_info = g_type_info_get_interface (field_type); interface_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 (field_tag == GI_TYPE_TAG_INTERFACE && interface_type == GI_INFO_TYPE_STRUCT) { /* FIXME: No GIArgInfo and no GPerlI11nInvocationInfo here. * What if the struct contains an object pointer, or a callback * field? */ gint offset = g_field_info_get_offset (field_info); if (!g_type_info_is_pointer (field_type)) { /* By value */ gsize 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, interface_type, sv); size = g_struct_info_get_size (interface_info); g_memmove (G_STRUCT_MEMBER_P (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, interface_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. */ else if (field_tag == GI_TYPE_TAG_VOID && g_type_info_is_pointer (field_type)) { gint offset = g_field_info_get_offset (field_info); if (!gperl_sv_is_ref (sv)) ccroak ("Can only put references into void fields"); G_STRUCT_MEMBER (gpointer, mem, offset) = SvRV (sv); } 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.042/gperl-i11n-gvalue.c000644 001750 000024 00000000737 11664366520 023055 0ustar00bdmanningstaff000000 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.042/gperl-i11n-info.c000644 001750 000024 00000015743 13014575125 022522 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static GIFunctionInfo * _find_struct_method (GIStructInfo *info, const gchar *method) { /* g_struct_info_find_method is broken for class structs like * GtkWidgetClass, so we search manually. See * . */ gint n_methods; gint i; n_methods = g_struct_info_get_n_methods (info); for (i = 0; i < n_methods; i++) { GIFunctionInfo *method_info = g_struct_info_get_method (info, i); if (strEQ (g_base_info_get_name (method_info), method)) return method_info; g_base_info_unref (method_info); } return NULL; } 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\n", 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 = _find_struct_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.042/gperl-i11n-invoke-c.c000644 001750 000024 00000050515 13014575125 023276 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void _prepare_c_invocation_info (GPerlI11nCInvocationInfo *iinfo, GICallableInfo *info, IV items, UV internal_stack_offset, const gchar *package, const gchar *namespace, const gchar *function); static void _clear_c_invocation_info (GPerlI11nCInvocationInfo *iinfo); static void _check_n_args (GPerlI11nCInvocationInfo *iinfo); static void _handle_automatic_arg (guint pos, GIArgInfo * arg_info, GITypeInfo * arg_type, GIArgument * arg, GPerlI11nCInvocationInfo * invocation_info); static gpointer _allocate_out_mem (GITypeInfo *arg_type); 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; GPerlI11nCInvocationInfo iinfo; guint n_return_values; #if GI_CHECK_VERSION (1, 32, 0) GIFFIReturnValue ffi_return_value; #endif gpointer return_value_p; 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.base); iinfo.arg_types_ffi[0] = &ffi_type_pointer; iinfo.args[0] = &instance; } /* * --- handle arguments ----------------------------------------------- */ for (i = 0 ; i < iinfo.base.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 = &(iinfo.base.arg_infos[i]); arg_type = &(iinfo.base.arg_types[i]); 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 = (gint) i + (gint) iinfo.constructor_offset + (gint) iinfo.method_offset + (gint) iinfo.stack_offset + iinfo.dynamic_stack_offset; ffi_stack_pos = (gint) i + (gint) iinfo.method_offset; g_assert (perl_stack_pos >= 0 && ffi_stack_pos >= 0); /* 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.base.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.base); } iinfo.arg_types_ffi[ffi_stack_pos] = g_type_info_get_ffi_type (arg_type); iinfo.args[ffi_stack_pos] = &iinfo.in_args[i]; break; case GI_DIRECTION_OUT: if (g_arg_info_is_caller_allocates (arg_info)) { iinfo.base.aux_args[i].v_pointer = _allocate_out_mem (arg_type); iinfo.out_args[i].v_pointer = &iinfo.base.aux_args[i]; iinfo.args[ffi_stack_pos] = &iinfo.base.aux_args[i]; } else { iinfo.out_args[i].v_pointer = &iinfo.base.aux_args[i]; iinfo.args[ffi_stack_pos] = &iinfo.out_args[i]; } iinfo.arg_types_ffi[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.base.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.base); } iinfo.arg_types_ffi[ffi_stack_pos] = &ffi_type_pointer; iinfo.args[ffi_stack_pos] = &iinfo.in_args[i]; break; } } /* do another pass to handle automatic args */ for (i = 0 ; i < iinfo.base.n_args ; i++) { GIArgInfo * arg_info; GITypeInfo * arg_type; if (!iinfo.is_automatic_arg[i]) continue; arg_info = &(iinfo.base.arg_infos[i]); arg_type = &(iinfo.base.arg_types[i]); switch (g_arg_info_get_direction (arg_info)) { case GI_DIRECTION_IN: _handle_automatic_arg (i, arg_info, arg_type, &iinfo.in_args[i], &iinfo); break; case GI_DIRECTION_INOUT: _handle_automatic_arg (i, arg_info, arg_type, &iinfo.base.aux_args[i], &iinfo); break; case GI_DIRECTION_OUT: /* handled later */ break; } } if (iinfo.throws) { iinfo.args[iinfo.n_invoke_args - 1] = &local_error_address; iinfo.arg_types_ffi[iinfo.n_invoke_args - 1] = &ffi_type_pointer; } /* * --- prepare & call ------------------------------------------------- */ /* prepare and call the function */ if (FFI_OK != ffi_prep_cif (&cif, FFI_DEFAULT_ABI, iinfo.n_invoke_args, iinfo.base.return_type_ffi, iinfo.arg_types_ffi)) { _clear_c_invocation_info (&iinfo); ccroak ("Could not prepare a call interface"); } #if GI_CHECK_VERSION (1, 32, 0) return_value_p = &ffi_return_value; #else return_value_p = &return_value; #endif /* Wrap the call in PUTBACK/SPAGAIN because the C function might end up * calling Perl code (via a vfunc), which might reallocate the stack * and hence invalidate 'sp'. */ PUTBACK; ffi_call (&cif, func_pointer, return_value_p, iinfo.args); SPAGAIN; /* free call-scoped data */ invoke_free_after_call_handlers (&iinfo.base); if (local_error) { _clear_c_invocation_info (&iinfo); gperl_croak_gerror (NULL, local_error); } /* * --- handle return values ------------------------------------------- */ #if GI_CHECK_VERSION (1, 32, 0) /* libffi has special semantics for return value storage; see `man * ffi_call`. We use gobject-introspection's extraction helper. */ gi_type_info_extract_ffi_return_value (&iinfo.base.return_type_info, &ffi_return_value, &return_value); #endif n_return_values = 0; /* place return value and output args on the stack */ if (iinfo.base.has_return_value #if GI_CHECK_VERSION (1, 29, 0) && !g_callable_info_skip_return ((GICallableInfo *) info) #endif ) { SV *value; dwarn ("return value: type = %p\n", &iinfo.base.return_type_info); value = SAVED_STACK_SV (arg_to_sv (&return_value, &iinfo.base.return_type_info, iinfo.base.return_type_transfer, &iinfo.base)); if (value) { XPUSHs (sv_2mortal (value)); n_return_values++; } } /* out args */ for (i = 0 ; i < iinfo.base.n_args ; i++) { GIArgInfo * arg_info; if (iinfo.is_automatic_arg[i]) continue; arg_info = &(iinfo.base.arg_infos[i]); #if GI_CHECK_VERSION (1, 29, 0) if (g_arg_info_is_skip (arg_info)) { continue; } #endif switch (g_arg_info_get_direction (arg_info)) { case GI_DIRECTION_OUT: case GI_DIRECTION_INOUT: { GITransfer transfer; SV *sv; dwarn ("out/inout arg at pos %d\n", i); /* 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.base.arg_types[i]), transfer, &iinfo.base)); if (sv) { XPUSHs (sv_2mortal (sv)); n_return_values++; } break; } default: break; } } _clear_c_invocation_info (&iinfo); dwarn ("n_return_values = %d\n", n_return_values); PUTBACK; } /* ------------------------------------------------------------------------- */ static void _prepare_c_invocation_info (GPerlI11nCInvocationInfo *iinfo, GICallableInfo *info, IV items, UV internal_stack_offset, const gchar *package, const gchar *namespace, const gchar *function) { guint i; prepare_invocation_info ((GPerlI11nInvocationInfo *) iinfo, info); dwarn ("%s::%s::%s => %s\n", package, namespace, function, g_base_info_get_name (info)); iinfo->target_package = package; iinfo->target_namespace = namespace; iinfo->target_function = function; iinfo->stack_offset = (guint) internal_stack_offset; g_assert (items >= iinfo->stack_offset); iinfo->n_given_args = ((guint) items) - iinfo->stack_offset; iinfo->n_invoke_args = iinfo->base.n_args; iinfo->is_constructor = FALSE; if (iinfo->base.is_function) { iinfo->is_constructor = g_function_info_get_flags (info) & GI_FUNCTION_IS_CONSTRUCTOR; } /* FIXME: can a vfunc not throw? */ iinfo->throws = FALSE; if (iinfo->base.is_function) { iinfo->throws = g_function_info_get_flags (info) & GI_FUNCTION_THROWS; } if (iinfo->throws) { /* Add one for the implicit GError arg. */ iinfo->n_invoke_args++; } if (iinfo->base.is_vfunc) { iinfo->is_method = TRUE; } else if (iinfo->base.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) { /* Add one for the implicit invocant arg. */ iinfo->n_invoke_args++; } dwarn (" args = %u, given = %u, invoke = %u\n", iinfo->base.n_args, iinfo->n_given_args, iinfo->n_invoke_args); dwarn (" symbol = %s\n", iinfo->base.is_vfunc ? g_base_info_get_name (info) : g_function_info_get_symbol (info)); dwarn (" is_constructor = %d, is_method = %d, throws = %d\n", iinfo->is_constructor, iinfo->is_method, iinfo->throws); /* 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) { guint n = iinfo->n_invoke_args; iinfo->in_args = gperl_alloc_temp (sizeof (GIArgument) * n); iinfo->out_args = gperl_alloc_temp (sizeof (GIArgument) * n); iinfo->arg_types_ffi = gperl_alloc_temp (sizeof (ffi_type *) * n); iinfo->args = gperl_alloc_temp (sizeof (gpointer) * n); iinfo->is_automatic_arg = gperl_alloc_temp (sizeof (gboolean) * n); } /* If we call a constructor, we skip the initial package name resulting * from the "Package->new" syntax. If we call a method, we handle the * invocant separately. */ iinfo->constructor_offset = iinfo->is_constructor ? 1 : 0; 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->base.n_args ; i++) { GIArgInfo * arg_info = &(iinfo->base.arg_infos[i]); GITypeInfo * arg_type = &(iinfo->base.arg_types[i]); 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); } } /* Make another pass to count the expected args. */ iinfo->n_expected_args = iinfo->constructor_offset + iinfo->method_offset; iinfo->n_nullable_args = 0; for (i = 0 ; i < iinfo->base.n_args ; i++) { GIArgInfo * arg_info = &(iinfo->base.arg_infos[i]); GITypeInfo * arg_type = &(iinfo->base.arg_types[i]); 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++; } /* 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->base.return_type_info) == GI_TYPE_TAG_ARRAY) { gint pos = g_type_info_get_array_length (&iinfo->base.return_type_info); if (pos >= 0) { GIArgInfo * arg_info = &(iinfo->base.arg_infos[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; } } } /* 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. * * FIXME: This is not correct for GtkWindow and its descendants, as * gtk+ keeps an internal reference to each window. Hence, * constructors like gtk_window_new return a non-floating object and do * not pass ownership of a reference on to us. But the sink func * currently registered for GInitiallyUnowned (sink_initially_unowned * in GObject.xs in Glib) is actually inadvertently conforming to this * requirement. It runs ref_sink+unref regardless of whether the * object is floating or not. So, in the non-floating window case, it * does nothing, resulting in an extra reference taken, despite the * request to transfer ownership. * * If we ever encounter a constructor of a GInitiallyUnowned descendant * that returns a non-floating object and passes ownership of a * reference on to us, or a constructor of a GInitiallyUnowned * descendant that returns a floating object but passes no reference on * to us, then we need to revisit this. */ if (iinfo->is_constructor && g_type_info_get_tag (&iinfo->base.return_type_info) == GI_TYPE_TAG_INTERFACE) { GIBaseInfo * interface = g_type_info_get_interface (&iinfo->base.return_type_info); if (GI_IS_REGISTERED_TYPE_INFO (interface) && g_type_is_a (get_gtype (interface), G_TYPE_INITIALLY_UNOWNED)) { iinfo->base.return_type_transfer = GI_TRANSFER_EVERYTHING; } g_base_info_unref ((GIBaseInfo *) interface); } } static void _clear_c_invocation_info (GPerlI11nCInvocationInfo *iinfo) { clear_invocation_info ((GPerlI11nInvocationInfo *) iinfo); } /* ------------------------------------------------------------------------- */ static gchar * _format_target (GPerlI11nCInvocationInfo *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->base.interface), NULL); } return caller; } static void _check_n_args (GPerlI11nCInvocationInfo *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 %u, got %u)", 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 %u, got %u); ignoring excess", caller, iinfo->n_expected_args, iinfo->n_given_args); } if (caller) g_free (caller); } } /* ------------------------------------------------------------------------- */ static void _handle_automatic_arg (guint pos, GIArgInfo * arg_info, GITypeInfo * arg_type, GIArgument * arg, GPerlI11nCInvocationInfo * invocation_info) { GSList *l; /* array length */ for (l = invocation_info->base.array_infos; l != NULL; l = l->next) { GPerlI11nArrayInfo *ainfo = l->data; if (((gint) pos) == ainfo->length_pos) { SV *conversion_sv; dwarn (" setting automatic arg %d (array length) to %"G_GSIZE_FORMAT"\n", pos, ainfo->length); conversion_sv = newSVuv (ainfo->length); sv_to_arg (conversion_sv, arg, arg_info, arg_type, GI_TRANSFER_NOTHING, FALSE, NULL); SvREFCNT_dec (conversion_sv); return; } } /* callback destroy notify */ for (l = invocation_info->base.callback_infos; l != NULL; l = l->next) { GPerlI11nPerlCallbackInfo *cinfo = l->data; if (((gint) 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; } } Glib-Object-Introspection-0.042/gperl-i11n-invoke-perl.c000644 001750 000024 00000033720 13014575125 024015 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void _prepare_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo, GICallableInfo *info, gpointer *args); static void _clear_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo); static void _fill_ffi_return_value (GITypeInfo *return_info, gpointer resp, GIArgument *arg); static void invoke_perl_code (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata) { GPerlI11nPerlCallbackInfo *info; GICallableInfo *cb_interface; GPerlI11nPerlInvocationInfo iinfo; guint args_offset = 0, i; guint in_inout; guint n_return_values; I32 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.base.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.base.n_args; i++) { GIArgInfo *arg_info = &(iinfo.base.arg_infos[i]); GITypeInfo *arg_type = &(iinfo.base.arg_types[i]); GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info); GIDirection direction = g_arg_info_get_direction (arg_info); iinfo.base.current_pos = i; dwarn ("arg %d: info = %p (%s)\n", i, arg_info, g_base_info_get_name (arg_info)); dwarn (" dir = %d, is retval = %d, is optional = %d, may be null = %d, transfer = %d\n", direction, g_arg_info_is_return_value (arg_info), g_arg_info_is_optional (arg_info), g_arg_info_may_be_null (arg_info), transfer); dwarn (" arg type = %p, is pointer = %d, tag = %d (%s)\n", arg_type, g_type_info_is_pointer (arg_type), g_type_info_get_tag (arg_type), g_type_tag_to_string (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.base)); /* 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++; } } /* 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.base.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.base.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 < 0 || ((guint) n_returned) != n_return_values)) { ccroak ("callback returned %d values " "but is supposed to return %u 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.base.n_args; i++) { GIArgInfo *arg_info = &(iinfo.base.arg_infos[i]); GITypeInfo *arg_type = &(iinfo.base.arg_types[i]); 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); 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); dwarn ("out/inout arg, pos = %d, is_caller_allocated = %d\n", i, is_caller_allocated); 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.base); if (!is_caller_allocated) { arg_to_raw (&tmp_arg, out_pointer, arg_type); } out_index++; } } g_free (returned_values); } /* store return value in resp, if any */ if (iinfo.base.has_return_value) { GIArgument arg; GITypeInfo *type_info; GITransfer transfer; gboolean may_be_null; type_info = &iinfo.base.return_type_info; transfer = iinfo.base.return_type_transfer; may_be_null = g_callable_info_may_return_null (cb_interface); /* FIXME */ dwarn ("return value: type = %p\n", type_info); dwarn (" is pointer = %d, tag = %d (%s), transfer = %d\n", g_type_info_is_pointer (type_info), g_type_info_get_tag (type_info), g_type_tag_to_string (g_type_info_get_tag (type_info)), transfer); sv_to_arg (POPs, &arg, NULL, type_info, transfer, may_be_null, &iinfo.base); _fill_ffi_return_value (type_info, resp, &arg); } 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 ("%s, n_args = %d\n", g_base_info_get_name (signal_info->interface), 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 (GPerlI11nPerlInvocationInfo *iinfo, GICallableInfo *info, gpointer *args) { guint i; prepare_invocation_info ((GPerlI11nInvocationInfo *) iinfo, info); dwarn ("%s, n_args = %d\n", g_base_info_get_name (info), g_callable_info_get_n_args (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. */ /* FIXME: 'throws'? */ /* Find array length arguments and store their value in aux_args so * that array_to_sv can later fetch them. */ for (i = 0 ; i < iinfo->base.n_args ; i++) { GITypeInfo *arg_type = &(iinfo->base.arg_types[i]); 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) { GITypeInfo *length_arg_type = &(iinfo->base.arg_types[pos]); raw_to_arg (args[pos], &iinfo->base.aux_args[pos], length_arg_type); dwarn (" pos %d is array length => %"G_GSIZE_FORMAT"\n", pos, iinfo->base.aux_args[pos].v_size); } } } } static void _clear_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo) { clear_invocation_info ((GPerlI11nInvocationInfo *) iinfo); } /* ------------------------------------------------------------------------- */ /* Copied from pygobject's pygi-closure.c. */ static void _fill_ffi_return_value (GITypeInfo *return_info, gpointer resp, GIArgument *arg) { if (!resp) return; switch (g_type_info_get_tag (return_info)) { case GI_TYPE_TAG_BOOLEAN: *((ffi_sarg *) resp) = arg->v_boolean; break; case GI_TYPE_TAG_INT8: *((ffi_sarg *) resp) = arg->v_int8; break; case GI_TYPE_TAG_UINT8: *((ffi_arg *) resp) = arg->v_uint8; break; case GI_TYPE_TAG_INT16: *((ffi_sarg *) resp) = arg->v_int16; break; case GI_TYPE_TAG_UINT16: *((ffi_arg *) resp) = arg->v_uint16; break; case GI_TYPE_TAG_INT32: *((ffi_sarg *) resp) = arg->v_int32; break; case GI_TYPE_TAG_UINT32: *((ffi_arg *) resp) = arg->v_uint32; break; case GI_TYPE_TAG_INT64: *((ffi_sarg *) resp) = arg->v_int64; break; case GI_TYPE_TAG_UINT64: *((ffi_arg *) resp) = arg->v_uint64; break; case GI_TYPE_TAG_FLOAT: *((gfloat *) resp) = arg->v_float; break; case GI_TYPE_TAG_DOUBLE: *((gdouble *) resp) = arg->v_double; break; case GI_TYPE_TAG_GTYPE: *((ffi_arg *) resp) = arg->v_size; break; case GI_TYPE_TAG_UNICHAR: *((ffi_arg *) resp) = arg->v_uint32; break; case GI_TYPE_TAG_INTERFACE: { GIBaseInfo *interface_info; interface_info = g_type_info_get_interface (return_info); switch (g_base_info_get_type (interface_info)) { case GI_INFO_TYPE_ENUM: *(ffi_sarg *) resp = arg->v_int; break; case GI_INFO_TYPE_FLAGS: *(ffi_arg *) resp = arg->v_uint; break; default: *(ffi_arg *) resp = (ffi_arg) arg->v_pointer; break; } break; } default: *(ffi_arg *) resp = (ffi_arg) arg->v_pointer; break; } } Glib-Object-Introspection-0.042/gperl-i11n-invoke.c000644 001750 000024 00000005667 13014575125 023066 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void prepare_invocation_info (GPerlI11nInvocationInfo *iinfo, GICallableInfo *info) { gint orig_n_args; guint i; dwarn ("%s\n", g_base_info_get_name (info)); iinfo->interface = info; 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); iinfo->is_signal = GI_IS_SIGNAL_INFO (info); dwarn (" is_function = %d, is_vfunc = %d, is_callback = %d\n", iinfo->is_function, iinfo->is_vfunc, iinfo->is_callback); orig_n_args = g_callable_info_get_n_args (info); g_assert (orig_n_args >= 0); iinfo->n_args = (guint) orig_n_args; dwarn (" n_args = %u\n", iinfo->n_args); if (iinfo->n_args) { iinfo->arg_infos = gperl_alloc_temp (sizeof (GITypeInfo) * iinfo->n_args); iinfo->arg_types = gperl_alloc_temp (sizeof (GITypeInfo) * iinfo->n_args); iinfo->aux_args = gperl_alloc_temp (sizeof (GIArgument) * iinfo->n_args); } else { iinfo->arg_infos = NULL; iinfo->arg_types = NULL; iinfo->aux_args = NULL; } for (i = 0 ; i < iinfo->n_args ; i++) { g_callable_info_load_arg (info, (gint) i, &(iinfo->arg_infos[i])); g_arg_info_load_type (&(iinfo->arg_infos[i]), &(iinfo->arg_types[i])); } g_callable_info_load_return_type (info, &iinfo->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->callback_infos = NULL; iinfo->array_infos = NULL; iinfo->free_after_call = NULL; } static void clear_invocation_info (GPerlI11nInvocationInfo *iinfo) { g_slist_free (iinfo->free_after_call); iinfo->free_after_call = NULL; /* The actual callback infos might be needed later, so we cannot free * them here. */ g_slist_free (iinfo->callback_infos); iinfo->callback_infos = NULL; g_slist_foreach (iinfo->array_infos, (GFunc) g_free, NULL); g_slist_free (iinfo->array_infos); iinfo->array_infos = 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) { /* We free the FreeClosures themselves directly after invoking them. The list is freed in clear_invocation_info. */ g_slist_foreach (iinfo->free_after_call, (GFunc) _invoke_free_closure, NULL); } Glib-Object-Introspection-0.042/gperl-i11n-marshal-arg.c000644 001750 000024 00000015060 12516304773 023762 0ustar00bdmanningstaff000000 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); dwarn ("type info = %p, arg info = %p, tag = %d (%s)\n", type_info, arg_info, tag, g_type_tag_to_string (tag)); if (!gperl_sv_is_defined (sv)) { /* Interfaces, booleans and void types need to be able to * handle undef separately.*/ if (!may_be_null && tag != GI_TYPE_TAG_INTERFACE && tag != GI_TYPE_TAG_BOOLEAN && 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); dwarn (" -> 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: 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 ("info = %p, 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); } dwarn (" -> 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); g_assert (length >= 0); sv = newSVpv (buffer, (STRLEN) 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.042/gperl-i11n-marshal-array.c000644 001750 000024 00000022043 13014575125 024321 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ /* Arrays containing non-basic types as non-pointers need to be treated * specially. Prime example: GValue *values = g_new0 (GValue, n); */ static gboolean _need_struct_value_semantics (GIArrayType array_type, GITypeInfo *param_info, GITypeTag param_tag) { gboolean is_flat, need_struct_value_semantics; is_flat = /* is a raw array, and ... */ (GI_ARRAY_TYPE_C == array_type || GI_ARRAY_TYPE_ARRAY == array_type) && /* ... contains a compound type, and... */ !G_TYPE_TAG_IS_BASIC (param_tag) && /* ... contains non-pointers */ !g_type_info_is_pointer (param_info); need_struct_value_semantics = is_flat; if (GI_TYPE_TAG_INTERFACE == param_tag) { /* FIXME: Try to use the invocation info here to avoid getting * the interface info again? */ GIBaseInfo *interface_info = g_type_info_get_interface (param_info); switch (g_base_info_get_type (interface_info)) { case GI_INFO_TYPE_ENUM: case GI_INFO_TYPE_FLAGS: need_struct_value_semantics = FALSE; default: break; } g_base_info_unref (interface_info); } return need_struct_value_semantics; } static void _free_raw_array (gpointer raw_array) { dwarn ("%p\n", raw_array); g_free (raw_array); } static void _free_array (GArray *array) { dwarn ("%p\n", array); g_array_free (array, TRUE); } static void _free_ptr_array (GPtrArray *array) { dwarn ("%p\n", array); g_ptr_array_free (array, TRUE); } static void _free_byte_array (GByteArray *array) { dwarn ("%p\n", array); g_byte_array_free (array, TRUE); } /* 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) { GIArrayType array_type; gpointer array = NULL, elements = NULL; GITypeInfo *param_info; GITypeTag param_tag; gsize item_size; GITransfer item_transfer; gboolean need_struct_value_semantics; gssize length = -1, i; AV *av; dwarn ("pointer %p\n", pointer); if (pointer == NULL) { return &PL_sv_undef; } array_type = g_type_info_get_array_type (info); #define GET_LENGTH_AND_ELEMENTS(type, len_field, data_field) { \ array = pointer; \ length = ((type *) array)->len_field; \ elements = ((type *) array)->data_field; } switch (array_type) { case GI_ARRAY_TYPE_C: array = pointer; elements = pointer; if (g_type_info_is_zero_terminated (info)) { length = g_strv_length (elements); } else { length = g_type_info_get_array_fixed_size (info); if (length < 0) { SV *conversion_sv; gint length_pos = g_type_info_get_array_length (info); g_assert (iinfo && iinfo->aux_args); conversion_sv = arg_to_sv (&(iinfo->aux_args[length_pos]), &(iinfo->arg_types[length_pos]), GI_TRANSFER_NOTHING, NULL); length = SvIV (conversion_sv); SvREFCNT_dec (conversion_sv); } } break; case GI_ARRAY_TYPE_ARRAY: GET_LENGTH_AND_ELEMENTS (GArray, len, data); break; case GI_ARRAY_TYPE_PTR_ARRAY: GET_LENGTH_AND_ELEMENTS (GPtrArray, len, pdata); break; case GI_ARRAY_TYPE_BYTE_ARRAY: GET_LENGTH_AND_ELEMENTS (GByteArray, len, data); break; default: ccroak ("Unhandled array type %d", array_type); } #undef GET_LENGTH_AND_ELEMENTS if (length < 0) { ccroak ("Could not determine the length of the array"); } /* 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; param_info = g_type_info_get_param_type (info, 0); param_tag = g_type_info_get_tag (param_info); item_size = size_of_type_info (param_info); av = newAV (); need_struct_value_semantics = _need_struct_value_semantics (array_type, param_info, param_tag); dwarn ("type %d, array %p, elements %p\n", array_type, array, elements); dwarn ("length %"G_GSSIZE_FORMAT", item size %"G_GSIZE_FORMAT", param_info %p, param_tag %d (%s)\n", length, item_size, param_info, param_tag, g_type_tag_to_string (param_tag)); for (i = 0; i < length; i++) { GIArgument arg; SV *value; gpointer element = elements + ((gsize) i) * item_size; dwarn (" element %"G_GSSIZE_FORMAT": %p\n", i, element); if (need_struct_value_semantics) { raw_to_arg (&element, &arg, param_info); } else { raw_to_arg (element, &arg, param_info); } value = arg_to_sv (&arg, param_info, item_transfer, iinfo); if (value) av_push (av, value); } if (transfer >= GI_TRANSFER_CONTAINER) { switch (array_type) { case GI_ARRAY_TYPE_C: _free_raw_array (array); break; case GI_ARRAY_TYPE_ARRAY: _free_array (array); break; case GI_ARRAY_TYPE_PTR_ARRAY: _free_ptr_array (array); break; case GI_ARRAY_TYPE_BYTE_ARRAY: _free_byte_array (array); break; } } g_base_info_unref ((GIBaseInfo *) param_info); dwarn (" -> AV %p of length %"G_GSIZE_FORMAT"\n", av, av_len (av) + 1); return newRV_noinc ((SV *) av); } static gpointer sv_to_array (GITransfer transfer, GITypeInfo *type_info, SV *sv, GPerlI11nInvocationInfo *iinfo) { AV *av; GIArrayType array_type; GITransfer item_transfer; GITypeInfo *param_info; GITypeTag param_tag; gint length_pos; gsize i, length; GPerlI11nArrayInfo *array_info = NULL; gpointer array = NULL; gpointer return_array; GFunc return_array_free_func; gboolean is_zero_terminated = FALSE; gsize item_size; gboolean need_struct_value_semantics; dwarn ("sv %p\n", 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"); array_type = g_type_info_get_array_type (type_info); 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 ("type %d, param_info %p, param_tag %d (%s), transfer %d\n", array_type, param_info, param_tag, g_type_tag_to_string (param_tag), transfer); need_struct_value_semantics = _need_struct_value_semantics (array_type, param_info, param_tag); is_zero_terminated = g_type_info_is_zero_terminated (type_info); item_size = size_of_type_info (param_info); length = (gsize) (av_len (av) + 1); /* av_len always returns at least -1 */ switch (array_type) { case GI_ARRAY_TYPE_C: case GI_ARRAY_TYPE_ARRAY: array = g_array_sized_new (is_zero_terminated, FALSE, item_size, length); break; case GI_ARRAY_TYPE_PTR_ARRAY: array = g_ptr_array_sized_new (length); g_ptr_array_set_size (array, length); break; case GI_ARRAY_TYPE_BYTE_ARRAY: array = g_byte_array_sized_new (length); g_byte_array_set_size (array, length); break; } for (i = 0; i < length; i++) { SV **svp; svp = av_fetch (av, i, 0); dwarn (" element %"G_GSIZE_FORMAT": svp = %p\n", i, svp); if (svp && gperl_sv_is_defined (*svp)) { GIArgument arg; /* FIXME: Is it OK to always allow undef here? */ sv_to_arg (*svp, &arg, NULL, param_info, item_transfer, TRUE, NULL); switch (array_type) { case GI_ARRAY_TYPE_C: case GI_ARRAY_TYPE_ARRAY: 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); } break; case GI_ARRAY_TYPE_PTR_ARRAY: ((GPtrArray *) array)->pdata[i] = arg.v_pointer; break; case GI_ARRAY_TYPE_BYTE_ARRAY: ((GByteArray *) array)->data[i] = arg.v_uint8; break; } } } if (length_pos >= 0) { array_info->length = length; } return_array = array; return_array_free_func = NULL; switch (array_type) { case GI_ARRAY_TYPE_C: return_array = g_array_free (array, FALSE); return_array_free_func = (GFunc) _free_raw_array; break; case GI_ARRAY_TYPE_ARRAY: return_array_free_func = (GFunc) _free_array; break; case GI_ARRAY_TYPE_PTR_ARRAY: return_array_free_func = (GFunc) _free_ptr_array; break; case GI_ARRAY_TYPE_BYTE_ARRAY: return_array_free_func = (GFunc) _free_byte_array; break; } if (GI_TRANSFER_NOTHING == transfer) { free_after_call (iinfo, return_array_free_func, return_array); } g_base_info_unref ((GIBaseInfo *) param_info); dwarn (" -> array %p of length %"G_GSIZE_FORMAT"\n", return_array, length); return return_array; } Glib-Object-Introspection-0.042/gperl-i11n-marshal-callback.c000644 001750 000024 00000012725 13014575125 024745 0ustar00bdmanningstaff000000 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 ("pos = %d, name = %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 (" 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 (" scope = 'call'\n"); free_after_call (invocation_info, (GFunc) release_perl_callback, callback_info); break; case GI_SCOPE_TYPE_NOTIFIED: dwarn (" scope = 'notified'\n"); /* This case is already taken care of by the notify * stuff above */ break; case GI_SCOPE_TYPE_ASYNC: dwarn (" 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 (" -> 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 == ((gint) 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; } } g_callable_info_load_arg (invocation_info->interface, (gint) invocation_info->current_pos, &arg_info); dwarn ("C callback: pos = %d, name = %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); 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 (" 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 (" -> SV %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.042/gperl-i11n-marshal-hash.c000644 001750 000024 00000010575 12516304773 024142 0ustar00bdmanningstaff000000 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; dwarn ("pointer = %p\n", pointer); 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 (" key tag = %d (%s), value tag = %d (%s)\n", 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 (" 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 (" 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 ("sv = %p\n", 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 (" transfer = %d, key info = %p, key tag = %d (%s), value info = %p, value 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); dwarn (" key SV %p\n", sv); if (sv && gperl_sv_is_defined (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); dwarn (" value SV %p\n", sv); if (sv && gperl_sv_is_defined (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.042/gperl-i11n-marshal-interface.c000644 001750 000024 00000037223 13014575125 025151 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ void _store_enum (GIEnumInfo * info, gint value, GIArgument * arg); gint _retrieve_enum (GIEnumInfo * info, GIArgument * arg); static gpointer instance_sv_to_class_struct_pointer (SV *sv, GPerlI11nInvocationInfo *iinfo) { gpointer pointer = NULL; GType class_type = 0; dwarn (" -> gtype struct?\n"); if (gperl_sv_is_ref (sv)) { /* instance? */ const char *package = sv_reftype (SvRV (sv), TRUE); class_type = gperl_type_from_package (package); } else { /* package? */ class_type = gperl_type_from_package (SvPV_nolen (sv)); } dwarn (" class_type = %s (%lu), is_classed = %d\n", g_type_name (class_type), class_type, G_TYPE_IS_CLASSED (class_type)); if (G_TYPE_IS_CLASSED (class_type)) { pointer = g_type_class_peek (class_type); if (!pointer) { /* If peek() produced NULL, the class has not been * instantiated yet and needs to be created. */ pointer = g_type_class_ref (class_type); free_after_call (iinfo, (GFunc) g_type_class_unref, pointer); } dwarn (" type class = %p\n", pointer); } return pointer; } static gpointer instance_sv_to_pointer (GICallableInfo *info, SV *sv, GPerlI11nInvocationInfo *iinfo) { // 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 ("container name = %s, info type = %d (%s)\n", g_base_info_get_name (container), info_type, g_info_type_to_string (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) { if (g_struct_info_is_gtype_struct (container)) { pointer = instance_sv_to_class_struct_pointer (sv, iinfo); } if (!pointer) { dwarn (" -> untyped record\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 (" -> record pointer: %p\n", pointer); break; } default: ccroak ("Don't know how to handle info type %d for instance SV", 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 ("container name = %s, info type = %d (%s)\n", g_base_info_get_name (container), 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 (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 (" -> untyped record\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 (" -> record pointer: %p\n", pointer); break; } default: ccroak ("Don't know how to handle info type %d for instance pointer", 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), type = %d (%s)\n", interface, g_base_info_get_name (interface), info_type, g_info_type_to_string (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 { /* GParamSpecs are represented as classes of * fundamental type, but gperl_get_object_check cannot * handle this. So we do it here. */ if (info_type == GI_INFO_TYPE_OBJECT && g_object_info_get_fundamental (interface)) { GType type = G_TYPE_FUNDAMENTAL (get_gtype (interface)); switch (type) { case G_TYPE_PARAM: arg->v_pointer = SvGParamSpec (sv); break; default: ccroak ("sv_to_interface: Don't know how to handle fundamental type %s (%lu)\n", g_type_name (type), type); } } else { arg->v_pointer = gperl_get_object_check (sv, get_gtype (interface)); if (arg->v_pointer && transfer == GI_TRANSFER_NOTHING && ((GObject *) arg->v_pointer)->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 (" -> untyped record\n"); g_assert (!need_value_semantics); /* Find out whether this untyped record 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\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\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 if (g_type_is_a (type, G_TYPE_BOXED)) { 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); } } } #if GLIB_CHECK_VERSION (2, 24, 0) else if (g_type_is_a (type, G_TYPE_VARIANT)) { dwarn (" -> variant type\n"); g_assert (!need_value_semantics); arg->v_pointer = SvGVariant (sv); if (GI_TRANSFER_EVERYTHING == transfer) g_variant_ref (arg->v_pointer); } #endif else { ccroak ("Cannot convert SV to record value of unknown type %s (%" G_GSIZE_FORMAT ")", g_type_name (type), type); } break; } case GI_INFO_TYPE_ENUM: { gint value; 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)); } value = gperl_convert_enum (type, sv); _store_enum (interface, value, arg); break; } case GI_INFO_TYPE_FLAGS: { gint value; 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)); } value = gperl_convert_flags (type, sv); _store_enum (interface, value, arg); 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 ("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: /* GParamSpecs are represented as classes of fundamental type, * but gperl_new_object cannot handle this. So we do it * here. */ if (g_object_info_get_fundamental (interface)) { GType type = G_TYPE_FUNDAMENTAL (get_gtype (interface)); switch (type) { case G_TYPE_PARAM: sv = newSVGParamSpec (arg->v_pointer); /* does ref & sink */ /* FIXME: What if own=true and the pspec is not * floating? Then we would leak. We do not * have the API to detect this. But it is * probably also quite rare. */ break; default: ccroak ("interface_to_sv: Don't know how to handle fundamental type %s (%lu)\n", g_type_name (type), type); } } else { sv = gperl_new_object (arg->v_pointer, own); } break; 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 (" -> untyped record\n"); sv = struct_to_sv (interface, info_type, arg->v_pointer, own); } else if (type == G_TYPE_VALUE) { dwarn (" -> value\n"); sv = gperl_sv_from_value (arg->v_pointer); if (own) g_boxed_free (type, arg->v_pointer); } else if (g_type_is_a (type, G_TYPE_BOXED)) { dwarn (" -> boxed: type=%"G_GSIZE_FORMAT" (%s)\n", type, g_type_name (type)); sv = gperl_new_boxed (arg->v_pointer, type, own); } #if GLIB_CHECK_VERSION (2, 24, 0) else if (g_type_is_a (type, G_TYPE_VARIANT)) { dwarn (" -> variant\n"); sv = own ? newSVGVariant_noinc (arg->v_pointer) : newSVGVariant (arg->v_pointer); } #endif else { ccroak ("Cannot convert record value of unknown type %s (%" G_GSIZE_FORMAT ") to SV", g_type_name (type), type); } break; } case GI_INFO_TYPE_ENUM: { gint value; 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)); } value = _retrieve_enum (interface, arg); sv = gperl_convert_back_enum (type, value); break; } case GI_INFO_TYPE_FLAGS: { gint value; 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)); } value = _retrieve_enum (interface, arg); sv = gperl_convert_back_flags (type, value); 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; } /* ------------------------------------------------------------------------- */ void _store_enum (GIEnumInfo * info, gint value, GIArgument * arg) { GITypeTag tag = g_enum_info_get_storage_type (info); switch (tag) { case GI_TYPE_TAG_BOOLEAN: arg->v_boolean = (gboolean) value; break; case GI_TYPE_TAG_INT8: arg->v_int8 = (gint8) value; break; case GI_TYPE_TAG_UINT8: arg->v_uint8 = (guint8) value; break; case GI_TYPE_TAG_INT16: arg->v_int16 = (gint16) value; break; case GI_TYPE_TAG_UINT16: arg->v_uint16 = (guint16) value; break; case GI_TYPE_TAG_INT32: arg->v_int32 = (gint32) value; break; case GI_TYPE_TAG_UINT32: arg->v_uint32 = (guint32) value; break; case GI_TYPE_TAG_INT64: arg->v_int64 = (gint64) value; break; case GI_TYPE_TAG_UINT64: arg->v_uint64 = (guint64) value; break; default: ccroak ("Unhandled enumeration type %s (%d) encountered", g_type_tag_to_string (tag), tag); } } gint _retrieve_enum (GIEnumInfo * info, GIArgument * arg) { GITypeTag tag = g_enum_info_get_storage_type (info); switch (tag) { case GI_TYPE_TAG_BOOLEAN: return (gint) arg->v_boolean; case GI_TYPE_TAG_INT8: return (gint) arg->v_int8; case GI_TYPE_TAG_UINT8: return (gint) arg->v_uint8; case GI_TYPE_TAG_INT16: return (gint) arg->v_int16; case GI_TYPE_TAG_UINT16: return (gint) arg->v_uint16; case GI_TYPE_TAG_INT32: return (gint) arg->v_int32; case GI_TYPE_TAG_UINT32: return (gint) arg->v_uint32; case GI_TYPE_TAG_INT64: return (gint) arg->v_int64; case GI_TYPE_TAG_UINT64: return (gint) arg->v_uint64; default: ccroak ("Unhandled enumeration type %s (%d) encountered", g_type_tag_to_string (tag), tag); return 0; } } Glib-Object-Introspection-0.042/gperl-i11n-marshal-list.c000644 001750 000024 00000006615 12516304773 024172 0ustar00bdmanningstaff000000 000000 /* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */ static void free_list (GList *list) { dwarn ("%p\n", list); g_list_free (list); } static void free_slist (GSList *list) { dwarn ("%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 ("pointer = %p, param_info = %p, param 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 (" element %p: %p\n", i, 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); dwarn (" -> AV = %p, length = %ld\n", av, av_len (av) + 1); 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 ("sv = %p\n", 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 (" param_info = %p, param tag = %d (%s), 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); dwarn (" element %d: svp = %p\n", i, svp); if (svp && gperl_sv_is_defined (*svp)) { GIArgument arg; /* 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, length = %d\n", list, g_list_length (list)); g_base_info_unref ((GIBaseInfo *) param_info); return list; } Glib-Object-Introspection-0.042/gperl-i11n-marshal-raw.c000644 001750 000024 00000006366 12221715323 024001 0ustar00bdmanningstaff000000 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.042/gperl-i11n-marshal-struct.c000644 001750 000024 00000011514 12516304773 024535 0ustar00bdmanningstaff000000 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 ("pointer = %p\n", 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); dwarn (" field %d (%s)\n", i, g_base_info_get_name (field_info)); /* 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 ("sv = %p\n", 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); dwarn (" field %d (%s)\n", i, field_name); 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.042/gperl-i11n-method.c000644 001750 000024 00000002713 12221715323 023033 0ustar00bdmanningstaff000000 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.042/gperl-i11n-size.c000644 001750 000024 00000007055 12104044206 022524 0ustar00bdmanningstaff000000 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.042/gperl-i11n-union.c000644 001750 000024 00000004453 12516304773 022720 0ustar00bdmanningstaff000000 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 ("%s::%s => %"G_GSIZE_FORMAT" (%s)\n", package, type_name, type, g_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.042/gperl-i11n-vfunc-interface.c000644 001750 000024 00000004431 12516304773 024643 0ustar00bdmanningstaff000000 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 ("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 ("info = %p\n", info); g_base_info_unref ((GIBaseInfo *) info); } Glib-Object-Introspection-0.042/gperl-i11n-vfunc-object.c000644 001750 000024 00000006677 12561765005 024166 0ustar00bdmanningstaff000000 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 || !GvCV (slot)) { dwarn ("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 ("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.042/lib/000755 001750 000024 00000000000 13027323176 020303 5ustar00bdmanningstaff000000 000000 Glib-Object-Introspection-0.042/LICENSE000644 001750 000024 00000063474 11664370324 020562 0ustar00bdmanningstaff000000 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.042/Makefile.PL000644 001750 000024 00000022571 13014575125 021515 0ustar00bdmanningstaff000000 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. # # See the LICENSE file in the top-level directory of this distribution for the # full license terms. BEGIN { require 5.008; } use strict; use warnings; use ExtUtils::MakeMaker; use File::Spec; use Config; use Cwd; my %RUNTIME_REQ_PM = ( 'Glib' => 1.320, ); 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 @exe_files = qw(bin/perli11ndoc); 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', release_status => 'stable', # 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', x_IRC => "irc://irc.gimp.org/#gtk-perl", 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, EXE_FILES => \@exe_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 $lib_ext; if ( $^O =~ /darwin/ ) { $lib_ext = $Config{so}; } else { $lib_ext = $Config{dlext}; } 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.$lib_ext $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.$lib_ext $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(@_); my $target = qr/test_dynamic :: (?:pure_all|subdirs-test_dynamic)\n\t/; if ($^O eq 'MSWin32') { # put "build" into PATH for the tests # FIXME: Might need tweaking for nmake... $inherited =~ s/($target)/.IMPORT: PATH\nPATH += ;build\n.EXPORT: PATH\n$1/; } else { # put "build" into LD_LIBRARY_PATH for the tests $inherited =~ s/($target)/${1}LD_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.042/MANIFEST000644 001750 000024 00000002157 13027323176 020673 0ustar00bdmanningstaff000000 000000 bin/perli11ndoc 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-invoke.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/param-specs.t t/structs.t t/values.t t/variants.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.042/MANIFEST.SKIP000644 001750 000024 00000000165 12060470574 021436 0ustar00bdmanningstaff000000 000000 ~$ blib \.bak$ \.bs$ build \.git \.gitignore$ Makefile$ Makefile\.old$ MYMETA\..*$ GObjectIntrospection.c$ TAGS \.o$ Glib-Object-Introspection-0.042/META.json000644 001750 000024 00000004027 13027323176 021161 0ustar00bdmanningstaff000000 000000 { "abstract" : "Dynamically create Perl language bindings", "author" : [ "unknown", "Glib::Object::Introspection Team " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.150005", "license" : [ "unknown", "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.32" } }, "runtime" : { "requires" : { "ExtUtils::Depends" : "0.3", "ExtUtils::PkgConfig" : "1", "Glib" : "1.32" } } }, "release_status" : "stable", "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_IRC" : "irc://irc.gimp.org/#gtk-perl", "x_MailingList" : "https://mail.gnome.org/mailman/listinfo/gtk-perl-list" }, "version" : "0.042", "x_serialization_backend" : "JSON::PP version 2.27300" } Glib-Object-Introspection-0.042/META.yml000644 001750 000024 00000002311 13027323176 021003 0ustar00bdmanningstaff000000 000000 --- abstract: 'Dynamically create Perl language bindings' author: - unknown - 'Glib::Object::Introspection Team ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::Depends: '0.3' ExtUtils::MakeMaker: '0' ExtUtils::PkgConfig: '1' Glib: '1.32' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.18, CPAN::Meta::Converter version 2.150005' license: unknown 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.32' resources: IRC: irc://irc.gimp.org/#gtk-perl 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.042' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Glib-Object-Introspection-0.042/NEWS000644 001750 000024 00000026103 13027322164 020232 0ustar00bdmanningstaff000000 000000 Overview of changes in Glib::Object::Introspection 0.042 ======================================================== * perli11ndoc: put special classes and records into their own category * perli11ndoc: list functions of enums and bitfields * perli11ndoc: fix the synopsis formatting for class struct functions * perli11ndoc: correctly display array and callback parameters/return values/fields * Fix "occuring" typo in POD (Bugzilla #775169) Overview of changes in Glib::Object::Introspection 0.041 ======================================================== ∗ Tweak the test environment to work with newer ExtUtils::MakeMaker * Use the stack in favor of heap allocation during marshalling * Use custom code to find struct methods in order to avoid a bug * Remove an unused internal variable * Add support for object class functions * Add support for marshalling GParamSpec * Add Glib::Object::Introspection::GValueWrapper::get_value Overview of changes in Glib::Object::Introspection 0.040 ======================================================== * Makefile.PL: Make G:O:I dependent on Glib version >= 1.320 * Makefile.PL: Module marked as "stable"; no code changes since 0.033 Overview of changes in Glib::Object::Introspection 0.033 ======================================================== * perli11ndoc: Add a path bar to the results display Overview of changes in Glib::Object::Introspection 0.032 ======================================================== * Makefile.PL/setup.pl: change library extensions on OS X * Docs: include an edited version of Gtk2::api * perli11ndoc: hush a warning when run in text mode without args * perli11ndoc: display a synopsis for callables * perli11ndoc: make Control+k focus the search entry * perli11ndoc: make Right/Left expand/collapse rows in the tree view * perli11ndoc: make the result text view readonly * Croak in setup for unhandled modificaion combinations * perli11ndoc: when filtering, show children of matching elements Overview of changes in Glib::Object::Introspection 0.031 ======================================================== * Add perli11ndoc, an interactive documentation viewer * Added perli11ndoc to MANIFEST Overview of changes in Glib::Object::Introspection 0.030 ======================================================== * Avoid repeating setting up a library as this can lead to issues. * Add some missing version guards to the tests * Added t/variants.t to MANIFEST Overview of changes in Glib::Object::Introspection 0.029 ======================================================== * Hook up the generic Glib::Boxed constructor on load, not in setup() * Add support for marshalling GVariants. * Add support for marshalling GArrays, GPtrArrays and GByteArrays. * Support flat arrays when converting from C to Perl. Overview of changes in Glib::Object::Introspection 0.028 ======================================================== * Harmonize the format of type names in error messages * Add a FIXME about a corner case of GInitiallyUnowned handling Overview of changes in Glib::Object::Introspection 0.027 ======================================================== * Fix compilation problems when NOISY is defined * Move the handling of void record fields into the field accessors * Rename a few variables for clarity Overview of changes in Glib::Object::Introspection 0.026 ======================================================== * Fix t/enums.t for older versions of Test::More Overview of changes in Glib::Object::Introspection 0.025 ======================================================== * Fix many argument conversion bugs on 64bit big-endian architectures. * Added 'x_IRC' metadata tag so MetaCPAN displays a link to the IRC channel Overview of changes in Glib::Object::Introspection 0.024 ======================================================== * Fix a stack handling bug for Perl vfuncs. Overview of changes in Glib::Object::Introspection 0.023 ======================================================== * Fix return value handling on big-endian architectures. Overview of changes in Glib::Object::Introspection 0.022 ======================================================== * Reset the 'release_status' flag to 'stable' so CPAN will index the release. This reverts a change made in 61345ca2. There are no functional changes from release 0.021. Overview of changes in Glib::Object::Introspection 0.021 ======================================================== * Clarify a statement about typelib files in the docs * Mention GI_TYPELIB_PATH in the docs for "search_path" * Remove address in GPL notices, refer to LICENSE file Overview of changes in Glib::Object::Introspection 0.020 ======================================================== * Allow undefined values for boolean arguments (and interpret them as "false"). * Fix a few internal signed/unsigned integer mismatches. 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.042/perl-Glib-Object-Introspection.doap000644 001750 000024 00000001443 11664366520 026270 0ustar00bdmanningstaff000000 000000 Glib::Object::Introspection Dynamically create Perl language bindings Torsten Schönfeld tsch Glib-Object-Introspection-0.042/README000644 001750 000024 00000007061 12516304773 020425 0ustar00bdmanningstaff000000 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.310 # FIXME: 1.320 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.042/t/000755 001750 000024 00000000000 13027323176 020000 5ustar00bdmanningstaff000000 000000 Glib-Object-Introspection-0.042/t/00-basic-types.t000644 001750 000024 00000004404 12301027544 022621 0ustar00bdmanningstaff000000 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 => 36; ok (Regress::test_boolean (1)); ok (!Regress::test_boolean (0)); ok (!Regress::test_boolean ('')); ok (!Regress::test_boolean (undef)); 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.042/t/arg-checks.t000644 001750 000024 00000000740 12435270235 022174 0ustar00bdmanningstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 8; { is (Regress::test_int8 (-127), -127); isa_ok (Regress::TestObj->constructor, 'Regress::TestObj'); } { is (eval { Regress::test_int8 () }, undef); like ($@, qr/too few/); is (eval { Regress::TestObj::constructor }, 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.042/t/arrays.t000644 001750 000024 00000016307 12561765005 021500 0ustar00bdmanningstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use utf8; plan tests => 68; 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]); # FIXME: This leaks. See . 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); # ----------------------------------------------------------------------------- my $int_array_ref = [-1..2]; my $boxed_array_ref = [map { Glib::Boxed::new ('GI::BoxedStruct', long_ => $_) } (1, 2, 3)]; my $string_array_ref = [qw/0 1 2/]; my $byte_array_ref = [0, ord '1', 0xFF, ord '3']; # Init-like. SKIP: { skip 'init-like', 1 unless check_gi_version (1, 32, 0); is_deeply ([GI::init_function ([qw/a b c/])], [Glib::TRUE, [qw/a b/]]); } # Fixed size. is_deeply (GI::array_fixed_int_return (), $int_array_ref); is_deeply (GI::array_fixed_short_return (), $int_array_ref); GI::array_fixed_int_in ($int_array_ref); GI::array_fixed_short_in ($int_array_ref); is_deeply (GI::array_fixed_out (), $int_array_ref); is_deeply (GI::array_fixed_out_struct (), [{long_ => 7, int8 => 6}, {long_ => 6, int8 => 7}]); is_deeply (GI::array_fixed_inout ($int_array_ref), [reverse @$int_array_ref]); # Variable size. SKIP: { skip 'variable size', 7 unless check_gi_version (1, 36, 0); is_deeply (GI::array_return (), $int_array_ref); is_deeply ([GI::array_return_etc (23, 42)], [[23, 0, 1, 42], 23+42]); GI::array_in ($int_array_ref); GI::array_in_len_before ($int_array_ref); GI::array_in_len_zero_terminated ($int_array_ref); GI::array_string_in ([qw/foo bar/]); GI::array_uint8_in ([map { ord } qw/a b c d/]); GI::array_struct_in ($boxed_array_ref); GI::array_struct_value_in ($boxed_array_ref); GI::array_struct_take_in ($boxed_array_ref); is ($boxed_array_ref->[2]->long_, 3); GI::array_simple_struct_in ([map { { long_ => $_ } } (1, 2, 3)]); GI::multi_array_key_value_in ([qw/one two three/], [map { Glib::Object::Introspection::GValueWrapper->new ('Glib::Int', $_) } (1, 2, 3)]); GI::array_enum_in ([qw/value1 value2 value3/]); GI::array_in_guint64_len ($int_array_ref); GI::array_in_guint8_len ($int_array_ref); is_deeply (GI::array_out (), $int_array_ref); is_deeply ([GI::array_out_etc (23, 42)], [[23, 0, 1, 42], 23+42]); is_deeply (GI::array_inout ($int_array_ref), [-2..2]); is_deeply ([GI::array_inout_etc (23, $int_array_ref, 42)], [[23, -1, 0, 1, 42], 23+42]); GI::array_in_nonzero_nonlen (23, [map { ord } qw/a b c d/]); } # Zero-terminated. SKIP: { skip 'zero-terminated', 5 unless check_gi_version (1, 32, 0); is_deeply (GI::array_zero_terminated_return (), $string_array_ref); is (GI::array_zero_terminated_return_null (), undef); is_deeply ([map { $_->long_ } @{GI::array_zero_terminated_return_struct ()}], [42, 43, 44]); GI::array_zero_terminated_in ($string_array_ref); is_deeply (GI::array_zero_terminated_out (), $string_array_ref); is_deeply (GI::array_zero_terminated_inout ($string_array_ref), [qw/-1 0 1 2/]); # The variant stuff is tested in variants.t. } # GArray. SKIP: { skip 'GArray', 11 unless check_gi_version (1, 34, 0); is_deeply (GI::garray_int_none_return (), $int_array_ref); is_deeply (GI::garray_uint64_none_return (), [0, "18446744073709551615"]); is_deeply (GI::garray_utf8_none_return (), $string_array_ref); is_deeply (GI::garray_utf8_container_return (), $string_array_ref); is_deeply (GI::garray_utf8_full_return (), $string_array_ref); GI::garray_int_none_in ($int_array_ref); GI::garray_uint64_none_in ([0, "18446744073709551615"]); GI::garray_utf8_none_in ($string_array_ref); is_deeply (GI::garray_utf8_none_out (), $string_array_ref); is_deeply (GI::garray_utf8_container_out (), $string_array_ref); is_deeply (GI::garray_utf8_full_out (), $string_array_ref); # FIXME: is_deeply (GI::garray_utf8_full_out_caller_allocated (), $string_array_ref); is_deeply (GI::garray_utf8_none_inout ($string_array_ref), [-2..1]); is_deeply (GI::garray_utf8_container_inout ($string_array_ref), [-2..1]); # FIXME: This leaks. See . is_deeply (GI::garray_utf8_full_inout ($string_array_ref), [-2..1]); } # GPtrArray. SKIP: { skip 'GPtrArray', 9 unless check_gi_version (0, 12, 0); is_deeply (GI::gptrarray_utf8_none_return (), $string_array_ref); is_deeply (GI::gptrarray_utf8_container_return (), $string_array_ref); is_deeply (GI::gptrarray_utf8_full_return (), $string_array_ref); GI::gptrarray_utf8_none_in ($string_array_ref); is_deeply (GI::gptrarray_utf8_none_out (), $string_array_ref); is_deeply (GI::gptrarray_utf8_container_out (), $string_array_ref); is_deeply (GI::gptrarray_utf8_full_out (), $string_array_ref); is_deeply (GI::gptrarray_utf8_none_inout ($string_array_ref), [-2..1]); is_deeply (GI::gptrarray_utf8_container_inout ($string_array_ref), [-2..1]); # FIXME: This leaks. See . is_deeply (GI::gptrarray_utf8_full_inout ($string_array_ref), [-2..1]); } # GByteArray. SKIP: { skip 'GByteArray', 1 unless check_gi_version (0, 12, 0); is_deeply (GI::bytearray_full_return (), $byte_array_ref); GI::bytearray_none_in ($byte_array_ref); } Glib-Object-Introspection-0.042/t/boxed.t000644 001750 000024 00000006324 12104044206 021260 0ustar00bdmanningstaff000000 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.042/t/cairo-integration.t000644 001750 000024 00000001414 11664366520 023610 0ustar00bdmanningstaff000000 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.042/t/callbacks.t000644 001750 000024 00000001411 12104044206 022066 0ustar00bdmanningstaff000000 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.042/t/closures.t000644 001750 000024 00000000357 11664366520 022036 0ustar00bdmanningstaff000000 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.042/t/constants.t000644 001750 000024 00000000541 11664366520 022206 0ustar00bdmanningstaff000000 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.042/t/enums.t000644 001750 000024 00000000733 12446204424 021315 0ustar00bdmanningstaff000000 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'); cmp_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/]); cmp_ok (GI::no_type_flags_returnv (), '==', [qw/value2/]); } Glib-Object-Introspection-0.042/t/hashes.t000644 001750 000024 00000002012 11664366520 021440 0ustar00bdmanningstaff000000 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.042/t/inc/000755 001750 000024 00000000000 13027323176 020551 5ustar00bdmanningstaff000000 000000 Glib-Object-Introspection-0.042/t/interface-implementation.t000644 001750 000024 00000001540 11664366520 025155 0ustar00bdmanningstaff000000 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.042/t/objects.t000644 001750 000024 00000004442 11664366520 021627 0ustar00bdmanningstaff000000 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.042/t/param-specs.t000644 001750 000024 00000000755 13014575125 022406 0ustar00bdmanningstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 7; GI::param_spec_in_bool (Glib::ParamSpec->boolean ('mybool', 'mybool', 'mybool', Glib::FALSE, [])); pass; my $ps1 = GI::param_spec_return; isa_ok ($ps1, 'Glib::Param::String'); is ($ps1->get_name, 'test_param'); is ($ps1->get_default_value, '42'); my $ps2 = GI::param_spec_out; isa_ok ($ps2, 'Glib::Param::String'); is ($ps2->get_name, 'test_param'); is ($ps2->get_default_value, '42'); Glib-Object-Introspection-0.042/t/structs.t000644 001750 000024 00000002271 11664366520 021703 0ustar00bdmanningstaff000000 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.042/t/values.t000644 001750 000024 00000001021 13014575125 021455 0ustar00bdmanningstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; plan tests => 3; { my $wrapper = Glib::Object::Introspection::GValueWrapper->new ('Glib::Int', 23); is (Regress::test_int_value_arg ($wrapper), 23); } is (Regress::test_value_return (23), 23); SKIP: { skip 'more GValue tests', 1 unless check_gi_version (1, 38, 0); my $wrapper = Glib::Object::Introspection::GValueWrapper->new ('Glib::Int', 42); GI::gvalue_in_with_modification ($wrapper); is ($wrapper->get_value, 24); } Glib-Object-Introspection-0.042/t/variants.t000644 001750 000024 00000001121 12561765005 022012 0ustar00bdmanningstaff000000 000000 #!/usr/bin/env perl BEGIN { require './t/inc/setup.pl' }; use strict; use warnings; use utf8; if (check_gi_version (1, 32, 0)) { plan tests => 6; } else { plan skip_all => 'Need gobject-introspection 1.32.0'; } my $v1 = Glib::Variant->new ("i", 27); my $v2 = Glib::Variant->new ("s", "Hello"); check_variants (GI::array_gvariant_none_in ([$v1, $v2])); check_variants (GI::array_gvariant_container_in ([$v1, $v2])); check_variants (GI::array_gvariant_full_in ([$v1, $v2])); sub check_variants { my ($v1, $v2) = @{$_[0]}; is ($v1->get ("i"), 27); is ($v2->get ("s"), "Hello"); } Glib-Object-Introspection-0.042/t/vfunc-chaining.t000644 001750 000024 00000006511 12105370643 023064 0ustar00bdmanningstaff000000 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.042/t/vfunc-ref-counting.t000644 001750 000024 00000014141 12260450412 023675 0ustar00bdmanningstaff000000 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.042/t/inc/setup.pl000644 001750 000024 00000002326 12567151652 022257 0ustar00bdmanningstaff000000 000000 use Config; use Glib::Object::Introspection; use Test::More; my $lib_ext; if ( $^O =~ /darwin/ ) { $lib_ext = $Config{so}; } else { $lib_ext = $Config{dlext}; } unless (-e qq(build/libregress.$lib_ext) && -e qq(build/libgimarshallingtests.$lib_ext)) { 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.042/lib/Glib/000755 001750 000024 00000000000 13027323176 021160 5ustar00bdmanningstaff000000 000000 Glib-Object-Introspection-0.042/lib/Glib/Object/000755 001750 000024 00000000000 13027323176 022366 5ustar00bdmanningstaff000000 000000 Glib-Object-Introspection-0.042/lib/Glib/Object/Introspection.pm000644 001750 000024 00000064302 13027322200 025554 0ustar00bdmanningstaff000000 000000 # Copyright (C) 2010-2014 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. # # See the LICENSE file in the top-level directory of this distribution for the # full license terms. package Glib::Object::Introspection; use strict; use warnings; use Glib; our $VERSION = '0.042'; use Carp; $Carp::Internal{(__PACKAGE__)}++; require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); my @OBJECT_PACKAGES_WITH_VFUNCS; my %SEEN; 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 && $handle_sentinel_boolean) { croak sprintf "Cannot handle the options flatten_array_ref and handle_sentinel_boolean " . "at the same time for %s%s::%s", $_BASENAME_TO_PACKAGE{$basename}, defined $namespace ? "::$namespace" : '', $name; } 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} || {}; # Avoid repeating setting up a library as this can lead to issues, e.g., due # to types being registered more than once with perl-Glib. In particular, # the lazy-loading mechanism of Glib::Object is not prepared to handle # repeated type registrations. if ($SEEN{$basename}{$version}{$package}++) { return; } $_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; }; } } 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); } return; } 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 = (); } # 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; } } } 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__ =encoding utf8 =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 FOR LIBRARY USERS To allow Glib::Object::Introspection to create bindings for a library, the library 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 >> with the following key-value pairs to set everything up: =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 class 'GtkWindow', and you pick as the package 'Gtk3', then that class will be available as 'Gtk3::Window'. =back The Perl wrappers created by C follow the conventions of the L module and old hand-written bindings like L. You can use the included tool C to view the documentation of all installed libraries organized and displayed in accordance with these conventions. The guiding principles underlying the conventions are described in the following. =head2 Namespaces and Objects The namespaces of the C libraries are mapped to Perl packages according to the C option specified, for example: gtk_ => Gtk3 gdk_ => Gtk3::Gdk gdk_pixbuf_ => Gtk3::Gdk::Pixbuf pango_ => Pango Classes, interfaces and boxed and fundamental types get their own namespaces, in a way, as the concept of the GType is completely replaced in the Perl bindings by the Perl package name. GtkButton => Gtk3::Button GdkPixbuf => Gtk3::Gdk::Pixbuf GtkScrolledWindow => Gtk3::ScrolledWindow PangoFontDescription => Pango::FontDescription With this package mapping and Perl's built-in method lookup, the bindings can do object casting for you. This gives us a rather comfortably object-oriented syntax, using normal Perl object semantics: in C: GtkWidget * b; b = gtk_check_button_new_with_mnemonic ("_Something"); gtk_toggle_button_set_active (GTK_TOGGLE_BUTTON (b), TRUE); gtk_widget_show (b); in Perl: my $b = Gtk3::CheckButton->new_with_mnemonic ('_Something'); $b->set_active (1); $b->show; You see from this that cast macros are not necessary and that you don't need to type namespace prefixes quite so often, so your code is a lot shorter. =head2 Flags and Enums Flags and enum values are handled as strings, because it's much more readable than numbers, and because it's automagical thanks to the GType system. Values are referred to by their nicknames; basically, strip the common prefix, lower-case it, and optionally convert '_' to '-': GTK_WINDOW_TOPLEVEL => 'toplevel' GTK_BUTTONS_OK_CANCEL => 'ok-cancel' (or 'ok_cancel') Flags are a special case. You can't (sensibly) bitwise-or these string-constants, so you provide a reference to an array of them instead. Anonymous arrays are useful here, and an empty anonymous array is a simple way to say 'no flags'. FOO_BAR_BAZ | FOO_BAR_QUU | FOO_BAR_QUUX => [qw/baz quu qux/] 0 => [] In some cases you need to see if a bit is set in a bitfield; methods returning flags therefore return an overloaded object. See L for more details on which operations are allowed on these flag objects, but here is a quick example: in C: /* event->state is a bitfield */ if (event->state & GDK_CONTROL_MASK) g_printerr ("control was down\n"); in Perl: # $event->state is a special object warn "control was down\n" if $event->state & "control-mask"; But this also works: warn "control was down\n" if $event->state * "control-mask"; warn "control was down\n" if $event->state >= "control-mask"; warn "control and shift were down\n" if $event->state >= ["control-mask", "shift-mask"]; =head2 Memory Handling The functions for ref'ing and unref'ing objects and free'ing boxed structures are not even mapped to Perl, because it's all handled automagically by the bindings. Objects will be kept alive so long as you have a Perl scalar pointing to it or the object is referenced in another way, e.g. from a container. The only thing you have to be careful about is the lifespan of non reference counted structures, which means most things derived from C. If it comes from a signal callback it might be good only until you return, or if it's the insides of another object then it might be good only while that object lives. If in doubt you can C. Structs from C or C are yours and live as long as referred to from Perl. =head2 Callbacks Use normal Perl callback/closure tricks with callbacks. The most common use you'll have for callbacks is with the L C method: $widget->signal_connect (event => \&event_handler, $user_data); $button->signal_connect (clicked => sub { warn "hi!\n" }); $user_data is optional, and with Perl closures you don't often need it (see L). The userdata is held in a scalar, initialized from what you give in C etc. It's passed to the callback in usual Perl "call by reference" style which means the callback can modify its last argument, ie. $_[-1], to modify the held userdata. This is a little subtle, but you can use it for some "state" associated with the connection. $widget->signal_connect (activate => \&my_func, 1); sub my_func { print "activation count: $_[-1]\n"; $_[-1] ++; } Because the held userdata is a new scalar there's no change to the variable (etc.) you originally passed to C. If you have a parent object in the userdata (or closure) you have to be careful about circular references preventing parent and child being destroyed. See L about this generally. Toplevel widgets like C always need an explicit C<< $widget->destroy >> so their C signal is a good place to break circular references. But for other widgets it's usually friendliest to avoid circularities in the first place, either by using weak references in the userdata, or possibly locating a parent dynamically with C<< $widget->get_ancestor >>. =head2 Exception handling Anything that uses GError in C will C on failure, setting $@ to a magical exception object, which is overloaded to print as the returned error message. The ideology here is that GError is to be used for runtime exceptions, and C is how you do that in Perl. You can catch a croak very easily by wrapping the function in an eval: eval { my $pixbuf = Gtk3::Gdk::Pixbuf->new_from_file ($filename); $image->set_from_pixbuf ($pixbuf); }; if ($@) { print "$@\n"; # prints the possibly-localized error message if (Glib::Error::matches ($@, 'Gtk3::Gdk::Pixbuf::Error', 'unknown-format')) { change_format_and_try_again (); } elsif (Glib::Error::matches ($@, 'Glib::File::Error', 'noent')) { change_source_dir_and_try_again (); } else { # don't know how to handle this die $@; } } This has the added advantage of letting you bunch things together as you would with a try/throw/catch block in C++ -- you get cleaner code. By using Glib::Error exception objects, you don't have to rely on string matching on a possibly localized error message; you can match errors by explicit and predictable conditions. See L for more information. =head2 Output arguments, lists, hashes In C you can only return one value from a function, and it is a common practice to modify pointers passed in to simulate returning multiple values. In Perl, you can return lists; any functions which modify arguments are changed to return them instead. Arguments and return values that have the types GList or GSList or which are C arrays of values will be converted to and from references to normal Perl arrays. The same holds for GHashTable and references to normal Perl hashes. =head2 Object class functions Object class functions like C can be called either with a package name or with an instance of the package. For example: Gtk3::WidgetClass::find_style_property ('Gtk3::Button', 'image-spacing') my $button = Gtk3::Button->new; Gtk3::WidgetClass::find_style_property ($button, 'image-spacing') =head1 DESCRIPTION FOR LIBRARY BINDING AUTHORS =head2 C<< Glib::Object::Introspection->setup >> C<< Glib::Object::Introspection->setup >> takes a few optional arguments that augment the generated API: =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 contains a properly set C variable, 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 occurring 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 occurring 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 $wrapper = Glib::Object::Introspection::GValueWrapper->new ($type, $value); # now use Glib::Object::Introspection->invoke and # substitute $wrapper where you'd use $value ... If you need to call a function that expects an already set-up GValue and modifies it, use C on the wrapper afterwards to obtain the value. For example: my $wrapper = Glib::Object::Introspection::GValueWrapper->new ('Glib::Boolean', 0); $box->child_get_property ($label, 'expand', $gvalue); my $value = $gvalue->get_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 perl-Glib: L =item gobject-introspection: L =item libffi: L =back =head1 AUTHORS =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 Glib-Object-Introspection-0.042/bin/perli11ndoc000755 001750 000024 00000150415 13025753436 022366 0ustar00bdmanningstaff000000 000000 #!perl use strict; use warnings; use v5.10; # for '//' use open qw/:utf8 :std/; use utf8; use Config qw//; use File::Find qw//; use File::Spec qw//; use XML::LibXML qw//; { my $have_display; BEGIN { if (!@ARGV) { local $@; $have_display = eval 'use Gtk3; Gtk3::init_check ()'; } } my $parser = GirParser->new; if (!@ARGV && $have_display) { my @girs = find_girs (); my $gui = GirGUI->new ($parser, @girs); $gui->run; exit; } if (!@ARGV) { die 'Usage: perli11ndoc [::[::]]'; } my $pattern = $ARGV[0]; my ($lib_pattern, @element_patterns) = split /::/, $pattern; my $gir = find_gir ($lib_pattern); $parser->open ($gir); if (!@element_patterns) { print $parser->format_namespace; } else { print $parser->format_search_results (@element_patterns); } } # ------------------------------------------------------------------------------ sub find_gir { my ($lib_pattern) = @_; if ($lib_pattern !~ /^([^\d\-]+)-?(\d(?:\.\d)?)?$/) { die "Cannot recognize the library name\n"; } my $name_wanted = $1; my $version_wanted = $2; if (defined $version_wanted && $version_wanted !~ /\./) { $version_wanted .= '.0'; } my $match_func = sub { if (defined $version_wanted) { return $_ eq "$name_wanted-$version_wanted.gir"; } else { return $_ =~ /^\Q$name_wanted\E-\d+\.\d+\.gir$/; } }; my @girs = find_girs ($match_func); if (@girs == 0) { die "Could not find any matching GIR file\n"; } if (@girs > 1) { my $girs_string = join (', ', map { $_->{path} } @girs); die "Found multiple matching GIR files: $girs_string; please be more specific\n"; } return $girs[0]->{path}; } sub find_girs { my ($match_func) = @_; $match_func //= sub { 1 }; my @prefixes = ('/usr'); my @env_vars = ( {name => 'LD_LIBRARY_PATH', extra_depth => 1}, # //lib => / {name => 'GI_TYPELIB_PATH', extra_depth => 2}, # //lib/girepository-1.0 => / ); foreach my $env_var (@env_vars) { next unless exists $ENV{$env_var->{name}}; my @dirs = split /$Config::Config{path_sep}/, $ENV{$env_var->{name}}; foreach my $dir (@dirs) { my @dir_parts = File::Spec->splitdir ($dir); my $prefix = File::Spec->catdir ( @dir_parts[0 .. ($#dir_parts-$env_var->{extra_depth})]); if (-d $prefix) { push @prefixes, Cwd::abs_path ($prefix); } } } my %seen; my @search_dirs = grep { !$seen{$_}++ && -d $_ } map { $_ . '/share/gir-1.0' } @prefixes; my @girs; File::Find::find (sub { if ($_ =~ m/\.gir$/ && $match_func->($_)) { push @girs, {path => $File::Find::name, dir => $File::Find::dir, file => $_}; } }, @search_dirs); return @girs; } # ------------------------------------------------------------------------------ # --- GirParser ---------------------------------------------------------------- # ------------------------------------------------------------------------------ package GirParser; use strict; use warnings; sub new { my ($class) = @_; return bless {}, $class } sub open { my ($self, $gir) = @_; $self->{gir} = $gir; $self->{parser} = XML::LibXML->new; $self->{dom} = $self->{parser}->load_xml (location => $gir); $self->{xpc} = XML::LibXML::XPathContext->new; $self->{xpc}->registerNs ('core', 'http://www.gtk.org/introspection/core/1.0'); $self->{repository} = $self->{dom}->documentElement; my $namespace_list = $self->{xpc}->find ('core:namespace', $self->{repository}); if ($namespace_list->size != 1) { die 'Can only handle a single namespace'; } $self->{namespace} = $namespace_list->pop; $self->{basename} = $self->construct_basename; } sub construct_basename { my ($self) = @_; my $name = $self->find_attribute ($self->{namespace}, 'name'); my $version = $self->find_attribute ($self->{namespace}, 'version'); $version =~ s/.0$//; $version = '' if $version eq '1'; return $name . $version; } # ------------------------------------------------------------------------------ sub find_attribute { my ($self, $element, $attribute) = @_; my $attribute_list = $element->find ("\@$attribute"); return undef if $attribute_list->size != 1; return $attribute_list->pop->value; } sub find_full_element_name { my ($self, $element) = @_; my $name = $self->find_attribute ($element, 'name'); return () unless defined $name; if ($name =~ /\./) { die "Unexpected fully qualified name '$name' encountered; aborting\n"; } my $package = ''; my $current_element = $element; while (1) { my $parent = $current_element->parentNode; last unless defined $parent; if ($parent->nodeName eq 'namespace') { $package = $self->{basename} . '::' . $package; last; } $package = $self->find_attribute ($parent, 'name') . '::' . $package; $current_element = $parent; } my $full_name = $package . $name; $package =~ s/::$//; return ($package, $name, $full_name); } sub find_node_by_path { my ($self, $path) = @_; my $match_list = $self->{xpc}->find ($path, $self->{namespace}); if ($match_list->size < 1) { die "Cannot find a matching element for the path $path\n"; } if ($match_list->size > 1) { die "Found more than one matching element for the path $path\n"; } return $match_list->pop; } sub find_parameters_and_return_value { my ($self, $element) = @_; my (@in, @out); my $parameter_list = $self->{xpc}->find ('core:parameters/core:parameter', $element); foreach my $parameter ($parameter_list->get_nodelist) { my $direction = $self->find_attribute ($parameter, 'direction') // 'in'; if ($direction eq 'inout' || $direction eq 'out') { push @out, $parameter; } if ($direction eq 'inout' || $direction eq 'in') { push @in, $parameter; } } my $retval = undef; my $retval_list = $self->{xpc}->find ('core:return-value', $element); if ($retval_list->size == 1) { $retval = $retval_list->[0]; if (defined $retval) { if ($self->find_type_name ($retval) eq 'none') { $retval = undef; } } } return (\@in, $retval, \@out); } sub find_type_name { my ($self, $element) = @_; # arrays my $array_list = $self->{xpc}->find ('core:array', $element); if ($array_list->size == 1) { my $array = $array_list->pop; my $prefix = 'reference to array of '; my $child_type_name = $self->find_type_name ($array); return $prefix . $child_type_name; } # callbacks my $callback_list = $self->{xpc}->find ('core:callback', $element); if ($callback_list->size == 1) { my $callback = $callback_list->pop; my ($in, $retval, $out) = $self->find_parameters_and_return_value ($callback); my $in_list = join ', ', map { $self->find_type_name ($_) } @$in; my $out_list = join ', ', map { $self->find_type_name ($_) } ($retval, @$out); return "callback (in: $in_list; out: $out_list)"; } # bare types my $type_list = $self->{xpc}->find ('core:type', $element); return '[unknown type]' unless $type_list->size == 1; my $type = $type_list->pop; return $self->find_attribute ($type, 'name'); } # ------------------------------------------------------------------------------ sub enumerate_namespace { my ($self, $descend) = @_; $descend //= 0; my @class_and_interface_sub_categories = ( [Constructors => 'core:constructor'], [Methods => 'core:method'], [Functions => 'core:function'], [Signals => 'glib:signal'], [Properties => 'core:property'], [Fields => 'core:field'], ['Virtual methods' => 'core:virtual-method'], ); my @record_sub_categories = ( [Constructors => 'core:constructor'], [Methods => 'core:method'], [Functions => 'core:function'], [Fields => 'core:field'], ); my @enum_and_bitfield_sub_categories = ( [Functions => 'core:function'], ); my @categories = ( [Classes => 'core:class', \@class_and_interface_sub_categories, sub { shift =~ /Accessible$/ }], [Interfaces => 'core:interface', \@class_and_interface_sub_categories], [Records => 'core:record', \@record_sub_categories, sub { shift =~ /(?:Class|Iface|Interface|Private)$/ }], [Enumerations => 'core:enumeration', \@enum_and_bitfield_sub_categories], [Bitfields => 'core:bitfield', \@enum_and_bitfield_sub_categories], [Functions => 'core:function'], [Callbacks => 'core:callback'], [Constants => 'core:constant'], [Aliases => 'core:alias', undef, sub { shift =~ /_autoptr$/ }], ['Classes for accessibility' => 'core:class', \@class_and_interface_sub_categories, sub { shift !~ /Accessible$/ }], ['Records for object classes' => 'core:record', \@record_sub_categories, sub { shift !~ /Class$/ }], ['Records for interfaces' => 'core:record', \@record_sub_categories, sub { shift !~ /(?:Iface|Interface)$/ }], ); my @results; foreach my $category (@categories) { my $heading = $category->[0]; my $path = $category->[1]; my $sub_categories = $category->[2] // undef; my $skip = $category->[3] // sub { 0 }; # accept all by default my $list = $self->{xpc}->find ($path, $self->{namespace}); next if $list->size == 0; my @entries; foreach my $node ($list->get_nodelist) { my $node_path = $node->nodePath; my $name = $self->find_attribute ($node, 'name'); next if $skip->($name); my @sub_results; if ($descend && defined $sub_categories) { foreach my $sub_category (@$sub_categories) { my $sub_heading = $sub_category->[0]; my $sub_path = $sub_category->[1]; my $sub_list = $self->{xpc}->find ($sub_path, $node); next if $sub_list->size == 0; my @sub_entries; foreach my $sub_node ($sub_list->get_nodelist) { my $sub_path = $sub_node->nodePath; my $sub_name = $self->find_attribute ($sub_node, 'name'); push @sub_entries, {path => $sub_path, name => $sub_name}; } push @sub_results, [$sub_heading => \@sub_entries]; } } push @entries, {path => $node_path, name => $name, sub_results => \@sub_results}; } next unless @entries; push @results, [$heading => \@entries]; } return \@results; } sub format_namespace { my ($self) = @_; my $text = ''; my $name = $self->find_attribute ($self->{namespace}, 'name'); my $version = $self->find_attribute ($self->{namespace}, 'version'); $text .= "NAMESPACE\n\n $name $version => " . $self->{basename} . "\n\n"; my $results = $self->enumerate_namespace; foreach my $results (@$results) { my $heading = uc $results->[0]; my $entries = $results->[1]; next unless @$entries; $text .= "$heading\n\n"; foreach my $entry (@$entries) { $text .= ' ' . $entry->{name} . "\n"; } $text .= "\n"; } $text =~ s/\n\n\Z/\n/; return $text; } # ------------------------------------------------------------------------------ sub format_search_results { my ($self, @search_terms) = @_; die 'Can only handle up to two search terms' if @search_terms > 2; my $query = @search_terms == 1 ? "*[\@name='$search_terms[0]']" : "*[\@name='$search_terms[0]']/*[\@name='$search_terms[1]']"; my $match_list = $self->{xpc}->find ($query, $self->{namespace}); if ($match_list->size == 0) { die "Cannot find a matching element for the search terms @search_terms\n"; } my @matches = $match_list->get_nodelist; if (@matches > 1) { my $matches_string = join (', ', map { $self->format_full_element_name ($_) } @matches); die "Found two many matches: $matches_string; please be more specific\n"; } my $match = $matches[0]; return $self->format_node ($match); } sub format_node_by_path { my ($self, $path) = @_; my $node = $self->find_node_by_path ($path); return $self->format_node ($node); } sub format_node_name_by_path { my ($self, $path) = @_; my $node = $self->find_node_by_path ($path); return $self->format_full_element_name ($node); } sub format_node { my ($self, $node) = @_; my %categories = ( alias => 'format_alias', bitfield => 'format_bitfield', callback => 'format_callback', class => 'format_class', constant => 'format_constant', constructor => 'format_constructor', enumeration => 'format_enumeration', field => 'format_field', function => 'format_function', method => 'format_method', property => 'format_property', interface => 'format_interface', record => 'format_record', 'glib:signal' => 'format_signal', 'virtual-method' => 'format_virtual_method', ); my $type = $node->nodeName; my $handler = $categories{$type}; if (!defined $handler) { die "Unknown node type '$type' encountered; aborting\n"; } return $self->$handler ($node); } # ------------------------------------------------------------------------------ sub format_alias { my ($self, $element) = @_; my $text = ''; my $full_name = $self->format_full_element_name ($element); my $type_name = $self->find_type_name ($element); my $full_type_name = $self->format_full_type_name ($type_name); $text .= "ALIAS\n\n $full_name = $full_type_name\n"; $text .= $self->format_description ($element); return $text; } # ------------------------------------------------------------------------------ sub format_bitfield { my ($self, $element) = @_; return $self->format_bitfield_and_enumeration ($element, 'BITFIELD'); } sub format_enumeration { my ($self, $element) = @_; return $self->format_bitfield_and_enumeration ($element, 'ENUMERATION'); } sub format_bitfield_and_enumeration { my ($self, $element, $heading) = @_; my $text = ''; my $full_name = $self->format_full_element_name ($element); $text .= "$heading\n\n $full_name\n"; $text .= $self->format_description ($element); $text .= $self->format_sub_members ($element); $text .= $self->format_sub_functions ($element, 'FUNCTIONS'); return $text; } # ------------------------------------------------------------------------------ sub format_callable { my ($self, $element, $heading, $synopsis_format, $flags_formatter) = @_; $flags_formatter //= 'format_callable_flags'; my $text = ''; my ($package, $name, $full_name) = $self->find_full_element_name ($element); my $flags = $self->$flags_formatter ($element); $text .= "$heading\n\n $full_name$flags\n"; my ($in, $retval, $out) = $self->find_parameters_and_return_value ($element); # --- synopsis --- my @in_names = map { '$' . $self->find_attribute ($_, 'name') } @$in; my @out_names = map { '$' . $self->find_attribute ($_, 'name') } @$out; if (defined $retval) { unshift @out_names, '$retval'; } my $in_list = join ', ', @in_names; my $in_list_pre_comma = @in_names > 0 ? ", $in_list" : ''; my $in_list_post_comma = @in_names > 0 ? "$in_list, " : ''; my $out_list = join ', ', @out_names; my $out_list_parens = @out_names > 1 ? "($out_list)" : $out_list; my $out_list_assign = @out_names > 0 ? "$out_list_parens = " : ''; my $synopsis = $synopsis_format; $synopsis =~ s/\[\[PACKAGE\]\]/$package/g; $synopsis =~ s/\[\[NAME\]\]/$name/g; $synopsis =~ s/\[\[NAME_UC\]\]/uc $name/ge; $synopsis =~ s/\[\[FULL_NAME\]\]/$full_name/g; $synopsis =~ s/\[\[IN_LIST\]\]/$in_list/g; $synopsis =~ s/\[\[IN_LIST_PRE_COMMA\]\]/$in_list_pre_comma/g; $synopsis =~ s/\[\[IN_LIST_POST_COMMA\]\]/$in_list_post_comma/g; $synopsis =~ s/\[\[OUT_LIST\]\]/$out_list/g; $synopsis =~ s/\[\[OUT_LIST_PARENS\]\]/$out_list_parens/g; $synopsis =~ s/\[\[OUT_LIST_ASSIGN\]\]/$out_list_assign/g; $text .= "\nSYNOPSIS\n\n $synopsis\n"; # --- description --- $text .= $self->format_description ($element); # --- in --- if (@$in) { $text .= "\nPARAMETERS\n\n"; foreach my $parameter (@$in) { my $name = $self->find_attribute ($parameter, 'name'); my $type_name = $self->find_type_name ($parameter); my $full_type_name = $self->format_full_type_name ($type_name); $text .= " • $name: $full_type_name\n"; my $doc = $self->format_docs ($parameter, ' '); if (defined $doc) { $text .= "$doc\n"; } $text .= "\n"; } $text =~ s/\n\n\Z/\n/; } # --- retval & out --- my $retval_type_name = 'none'; if (defined $retval) { $retval_type_name = $self->find_type_name ($retval); } if ($retval_type_name ne 'none' || @$out) { $text .= "\nRETURN VALUES\n\n"; if ($retval_type_name ne 'none') { my $full_retval_type_name = $self->format_full_type_name ($retval_type_name); $text .= " • $full_retval_type_name\n"; my $doc = $self->format_docs ($retval, ' '); if (defined $doc) { $text .= "$doc\n\n"; } } if (@$out) { foreach my $parameter (@$out) { my $name = $self->find_attribute ($parameter, 'name'); my $type_name = $self->find_type_name ($parameter); my $full_type_name = $self->format_full_type_name ($type_name); $text .= " • $name: $full_type_name\n"; my $doc = $self->format_docs ($parameter, ' '); if (defined $doc) { $text .= "$doc\n\n"; } } } $text =~ s/\n\n\Z/\n/; } return $text; } sub format_callback { my ($self, $element) = @_; my $synopsis_format = <<'__EOS__'; sub { my ([[IN_LIST]]) = @_; ... return [[OUT_LIST_PARENS]]; } __EOS__ return $self->format_callable ($element, 'CALLBACK', $synopsis_format); } sub format_constructor { my ($self, $element) = @_; my $synopsis_format = '$object = [[PACKAGE]]->[[NAME]] ([[IN_LIST]])'; return $self->format_callable ($element, 'CONSTRUCTOR', $synopsis_format); } sub format_function { my ($self, $element) = @_; my $synopsis_format = '[[OUT_LIST_ASSIGN]][[FULL_NAME]] ([[IN_LIST]])'; return $self->format_callable ($element, 'FUNCTION', $synopsis_format); } sub format_method { my ($self, $element) = @_; my $synopsis_format = '[[OUT_LIST_ASSIGN]]$object->[[NAME]] ([[IN_LIST]])'; # Treat methods of class structs as functions. { my $parent = $element->parentNode; if ($parent->nodeName eq 'record' && defined $self->find_attribute ($parent, 'glib:is-gtype-struct-for')) { $synopsis_format = '[[OUT_LIST_ASSIGN]][[FULL_NAME]] ($package[[IN_LIST_PRE_COMMA]])'; } } return $self->format_callable ($element, 'METHOD', $synopsis_format); } sub format_signal { my ($self, $element) = @_; my $synopsis_format = <<'__EOS__'; $object->signal_connect ('[[NAME]]' => sub { my ($object, [[IN_LIST_POST_COMMA]]$data) = @_; ... return [[OUT_LIST_PARENS]]; }, $data); __EOS__ return $self->format_callable ($element, 'SIGNAL', $synopsis_format, 'format_signal_flags'); } sub format_virtual_method { my ($self, $element) = @_; my $synopsis_format = <<'__EOS__'; sub [[NAME_UC]] { my ($object[[IN_LIST_PRE_COMMA]]) = @_; ... return [[OUT_LIST_PARENS]]; } __EOS__ return $self->format_callable ($element, 'VIRTUAL METHOD', $synopsis_format, 'format_virtual_method_flags'); } # ------------------------------------------------------------------------------ sub format_class { my ($self, $element) = @_; my $format_hierarchy_and_interfaces = sub { my @parents; my $current_element = $element; while (1) { my $parent_name = $self->find_attribute ($current_element, 'parent'); last unless defined $parent_name; unshift @parents, $self->format_full_type_name ($parent_name); # Stop if the parent is fully qualified, i.e., if it points elsewhere. last if $parent_name =~ /\./; my $parent_list = $self->{xpc}->find ("core:class[\@name='$parent_name']", $self->{namespace}); if ($parent_list->size != 1) { die "Found no or too many classes with name '$parent_name'\n"; } $current_element = $parent_list->pop; } my @children; my $name = $self->find_attribute ($element, 'name'); my $children_list = $self->{xpc}->find ("core:class[\@parent='$name']", $self->{namespace}); foreach my $child ($children_list->get_nodelist) { push @children, $self->format_full_element_name ($child); } my $hierarchy_text = ''; if (@parents || @children) { push @parents, $self->format_full_element_name ($element); $hierarchy_text = "\nHIERARCHY\n\n"; my $hook = '╰── '; # thanks, devhelp my $spacer = ' ' x length $hook; for (my $i = 0; $i < @parents; $i++) { $hierarchy_text .= ' ' . ($i > 0 ? (($spacer x ($i-1)) . $hook) : '') . $parents[$i] . "\n"; } foreach my $child (@children) { $hierarchy_text .= ' ' . $spacer x $#parents . $hook . $child . "\n"; } } my $impl_list = $self->{xpc}->find ('core:implements', $element); my $impl_text = $self->format_full_type_names ($impl_list, 'IMPLEMENTED INTERFACES'); return $hierarchy_text . $impl_text; }; return $self->format_class_and_interface ($element, 'CLASS', $format_hierarchy_and_interfaces); } sub format_interface { my ($self, $element) = @_; my $format_prerequisites_and_implementations = sub { my $prereq_list = $self->{xpc}->find ('core:prerequisite', $element); my $prereq_text = $self->format_full_type_names ($prereq_list, 'PREREQUISITES'); my $name = $self->find_attribute ($element, 'name'); my $impl_list = $self->{xpc}->find ("core:class[./core:implements[\@name='$name']]", $self->{namespace}); my $impl_text = $self->format_full_type_names ($impl_list, 'KNOWN IMPLEMENTATIONS'); return $prereq_text . $impl_text; }; return $self->format_class_and_interface ($element, 'INTERFACE', $format_prerequisites_and_implementations); } sub format_class_and_interface { my ($self, $element, $heading, $intro) = @_; my $text = ''; my $full_name = $self->format_full_element_name ($element); $text .= "$heading\n\n $full_name\n"; $text .= $intro->(); $text .= $self->format_description ($element); $text .= $self->format_sub_constructors ($element); $text .= $self->format_sub_methods ($element); $text .= $self->format_sub_functions ($element, 'CLASS FUNCTIONS'); $text .= $self->format_sub_signals ($element); $text .= $self->format_sub_properties ($element); $text .= $self->format_sub_fields ($element); $text .= $self->format_sub_virtual_methods ($element); return $text; } # ------------------------------------------------------------------------------ sub format_constant { my ($self, $element) = @_; my $text = ''; my $full_name = $self->format_full_element_name ($element); my $value = $self->find_attribute ($element, 'value'); my $type_name = $self->find_type_name ($element); my $full_type_name = $self->format_full_type_name ($type_name); $text .= "CONSTANT\n\n $full_name = $value ($full_type_name)\n"; $text .= $self->format_description ($element); return $text; } # ------------------------------------------------------------------------------ sub format_field { my ($self, $element) = @_; my $text = ''; my $full_name = $self->format_full_element_name ($element); my $type_name = $self->find_type_name ($element); my $full_type_name = $self->format_full_type_name ($type_name); my $flags = $self->format_field_flags ($element); $text .= "FIELD\n\n $full_name: $full_type_name$flags\n"; $text .= $self->format_description ($element); return $text; } # ------------------------------------------------------------------------------ sub format_property { my ($self, $element) = @_; my $text = ''; my $full_name = $self->format_full_element_name ($element); my $type_name = $self->find_type_name ($element); my $full_type_name = $self->format_full_type_name ($type_name); my $flags = $self->format_property_flags ($element); $text .= "PROPERTY\n\n $full_name: $full_type_name$flags\n"; $text .= $self->format_description ($element); return $text; } # ------------------------------------------------------------------------------ sub format_record { my ($self, $element) = @_; my $text = ''; my $full_name = $self->format_full_element_name ($element); $text .= "RECORD\n\n $full_name\n"; $text .= $self->format_description ($element); $text .= $self->format_sub_fields ($element); $text .= $self->format_sub_constructors ($element); $text .= $self->format_sub_methods ($element); $text .= $self->format_sub_functions ($element, 'FUNCTIONS'); return $text; } # ------------------------------------------------------------------------------ sub format_sub_constructors { my ($self, $element) = @_; my $text = ''; my $ctor_list = $self->{xpc}->find ('core:constructor', $element); if ($ctor_list->size > 0) { $text .= "\nCONSTRUCTORS\n\n"; foreach my $ctor ($ctor_list->get_nodelist) { my $name = $self->find_attribute ($ctor, 'name'); my $flags = $self->format_callable_flags ($ctor, qw/introspectable version/); $text .= " • $name$flags\n"; } } return $text; } sub format_sub_fields { my ($self, $element) = @_; my $text = ''; my $field_list = $self->{xpc}->find ('core:field', $element); if ($field_list->size > 0) { $text .= "\nFIELDS\n\n"; foreach my $field ($field_list->get_nodelist) { my $name = $self->find_attribute ($field, 'name'); my $type_name = $self->find_type_name ($field); my $full_type_name = $self->format_full_type_name ($type_name); my $flags = $self->format_field_flags ($field, qw/introspectable/); $text .= " • $name: $full_type_name$flags\n"; } } return $text; } sub format_sub_functions { my ($self, $element, $heading) = @_; my $text = ''; my $function_list = $self->{xpc}->find ('core:function', $element); if ($function_list->size > 0) { $text .= "\n$heading\n\n"; foreach my $function ($function_list->get_nodelist) { my $name = $self->find_attribute ($function, 'name'); my $flags = $self->format_callable_flags ($function, qw/introspectable version/); $text .= " • $name$flags\n"; } } return $text; } sub format_sub_members { my ($self, $element) = @_; my $text = ''; my $member_list = $self->{xpc}->find ('core:member', $element); if ($member_list->size > 0) { $text .= "\nMEMBERS\n"; foreach my $member ($member_list->get_nodelist) { my $name = $self->find_attribute ($member, 'name'); my $value = $self->find_attribute ($member, 'value'); $text .= "\n • $name = $value\n"; my $doc = $self->format_docs ($member, ' '); if (defined $doc) { $text .= "$doc\n"; } } } return $text; } sub format_sub_methods { my ($self, $element) = @_; my $text = ''; my $method_list = $self->{xpc}->find ('core:method', $element); if ($method_list->size > 0) { $text .= "\nMETHODS\n\n"; foreach my $method ($method_list->get_nodelist) { my $name = $self->find_attribute ($method, 'name'); my $flags = $self->format_callable_flags ($method, qw/introspectable version/); $text .= " • $name$flags\n"; } } return $text; } sub format_sub_properties { my ($self, $element) = @_; my $text = ''; my $property_list = $self->{xpc}->find ('core:property', $element); if ($property_list->size > 0) { $text .= "\nPROPERTIES\n\n"; foreach my $property ($property_list->get_nodelist) { my $name = $self->find_attribute ($property, 'name'); my $type_name = $self->find_type_name ($property); my $full_type_name = $self->format_full_type_name ($type_name); my $flags = $self->format_property_flags ($property, qw/version/); $text .= " • $name: $full_type_name$flags\n"; } } return $text; } sub format_sub_signals { my ($self, $element) = @_; my $text = ''; my $signal_list = $self->{xpc}->find ('glib:signal', $element); if ($signal_list->size > 0) { $text .= "\nSIGNALS\n\n"; foreach my $signal ($signal_list->get_nodelist) { my $name = $self->find_attribute ($signal, 'name'); my $flags = $self->format_signal_flags ($signal, qw/version/); $text .= " • $name$flags\n"; } } return $text; } sub format_sub_virtual_methods { my ($self, $element) = @_; my $text = ''; my $vfunc_list = $self->{xpc}->find ('core:virtual-method', $element); if ($vfunc_list->size > 0) { $text .= "\nVIRTUAL METHODS\n\n"; foreach my $vfunc ($vfunc_list->get_nodelist) { my $name = $self->find_attribute ($vfunc, 'name'); my $flags = $self->format_virtual_method_flags ($vfunc); $text .= " • $name$flags\n"; } } return $text; } # ------------------------------------------------------------------------------ sub format_deprecation_docs { my ($self, $element) = @_; my $deprecated = $self->find_attribute ($element, 'deprecated') // 0; return undef unless $deprecated; my $text = ''; my $version = $self->find_attribute ($element, 'deprecated-version'); if (defined $version) { $text .= "Deprecated since: $version."; } my $doc_dep_list = $self->{xpc}->find ('core:doc-deprecated', $element); if ($doc_dep_list->size == 1) { $text .= ' ' . $doc_dep_list->pop->textContent; } return undef if $text eq ''; return $text; } sub format_description { my ($self, $element) = @_; my $docs = $self->format_docs ($element); return defined $docs ? "\nDESCRIPTION\n\n$docs\n" : ''; } sub format_docs { my ($self, $element, $indent) = @_; $indent //= ' '; my $text = ''; # The normal docs. my $docs_list = $self->{xpc}->find ('core:doc', $element); if ($docs_list->size == 1) { $text .= $docs_list->pop->textContent; } # The version constraint. my $ver = $self->format_version_constraint ($element); $text .= "\n\n$ver\n" if defined $ver; # The deprecation docs. my $dep = $self->format_deprecation_docs ($element); $text .= "\n\n$dep\n" if defined $dep; return undef if $text eq ''; # Extract code blocks so that they are not wrapped. my $code_block_pattern = qr/\|\[\n?(.*?)\n?\]\|/s; my $empty_code_block = '|[]|'; my $empty_code_block_pattern = qr/\|\[\]\|/; my @code_blocks = $text =~ m/$code_block_pattern/g; $text =~ s/$code_block_pattern/$empty_code_block/g; # Remove leading white space as fill() otherwise takes it for starting a new # paragraph. Do this after the code block extraction to preserve their # indentation. $text =~ s/^[ \t]+//mg; require Text::Wrap; my $formatted_text = Text::Wrap::fill ($indent, $indent, $text); while ($formatted_text =~ m/$empty_code_block_pattern/g) { my $code_block = shift @code_blocks; $code_block =~ s/^/$indent/mg; my $divider = '-' x (76-length($indent)); my $formatted_code_block = "\n$indent$divider\n$code_block\n$indent$divider"; $formatted_text =~ s/(?:\n)?(?:$indent)?$empty_code_block_pattern/$formatted_code_block/; } return $formatted_text; } sub format_full_element_name { my ($self, $element) = @_; my (undef, undef, $full_name) = $self->find_full_element_name ($element); return $full_name; } sub format_full_type_name { my ($self, $name) = @_; if ($name =~ /\./) { # fully qualified $name =~ s/\./::/g; return $name; } if ($name =~ /^[A-Z]/) { # local return $self->{basename} . '::' . $name; } return $name; # global } sub format_full_type_names { my ($self, $list, $heading) = @_; my $text = ''; if ($list->size > 0) { $text .= "\n$heading\n\n"; foreach my $node ($list->get_nodelist) { my $type_name = $self->find_attribute ($node, 'name'); my $full_type_name = $self->format_full_type_name ($type_name); $text .= " • $full_type_name\n"; } } return $text; } sub format_version_constraint { my ($self, $element) = @_; my $version = $self->find_attribute ($element, 'version'); return undef if !defined $version; return "Since: $version."; } # ------------------------------------------------------------------------------ sub format_flags { my ($self, $element, $available, $wanted) = @_; $wanted //= []; my @texts; foreach my $flag (@$available) { my $name = $flag->[0]; my $default = $flag->[1]; my $formatter = $flag->[2]; if (@$wanted) { next unless grep { $_ eq $name } @$wanted; } my $value = $self->find_attribute ($element, $name) // $default; my $text = $formatter->($value); push @texts, $text if defined $text; } return '' unless @texts; return ' [' . join (', ', @texts) . ']'; } sub format_callable_flags { my ($self, $element, @wanted) = @_; # name, default, formatter my @available = ( ['introspectable', 1, sub { !$_[0] ? 'NOT INTROSPECTABLE' : undef }], ['deprecated', 0, sub { $_[0] ? "deprecated" : undef }], ['moved-to', undef, sub { defined $_[0] ? "moved to $_[0]" : undef }], ['shadowed-by', undef, sub { defined $_[0] ? "shadowed by $_[0]" : undef }], # FIXME: Format $_[0] properly. ['throws', 0, sub { $_[0] ? "throws" : undef }], ['version', undef, sub { defined $_[0] ? "available since $_[0]" : undef }], ['shadows', undef, sub { defined $_[0] ? "shadows $_[0]" : undef }], # FIXME: Format $_[0] properly. ); return $self->format_flags ($element, \@available, \@wanted); } sub format_field_flags { my ($self, $element, @wanted) = @_; # name, default, formatter my @available = ( ['introspectable', 1, sub { !$_[0] ? 'NOT INTROSPECTABLE' : undef }], ['readable', 1, sub { $_[0] ? 'readable' : undef }], ['writable', 1, sub { $_[0] ? 'writable' : undef }], ); return $self->format_flags ($element, \@available, \@wanted); } sub format_property_flags { my ($self, $element, @wanted) = @_; my @available = ( ['deprecated', 0, sub { $_[0] ? "deprecated" : undef }], ['version', undef, sub { defined $_[0] ? "available since $_[0]" : undef }], ['readable', 1, sub { $_[0] ? 'readable' : undef }], ['writable', 0, sub { $_[0] ? 'writable' : undef }], ); return $self->format_flags ($element, \@available, \@wanted); } sub format_signal_flags { my ($self, $element, @wanted) = @_; # name, default, formatter my @available = ( ['deprecated', 0, sub { $_[0] ? "deprecated" : undef }], ['version', undef, sub { defined $_[0] ? "available since $_[0]" : undef }], ['when', undef, sub { defined $_[0] ? "$_[0]" : undef }], ['no-recurse', 0, sub { $_[0] ? "no recurse" : undef }], ['detailed', 0, sub { $_[0] ? "detailed" : undef }], ); return $self->format_flags ($element, \@available, \@wanted); } sub format_virtual_method_flags { my ($self, $element, @wanted) = @_; my $name = $self->find_attribute ($element, 'name'); my @available = ( ['introspectable', 1, sub { !$_[0] ? 'NOT INTROSPECTABLE' : undef }], ['invoker', undef, sub { defined $_[0] && $_[0] ne $name ? "invoked by $_[0]" : undef }], ['version', undef, sub { defined $_[0] ? "available since $_[0]" : undef }], ); return $self->format_flags ($element, \@available, \@wanted); } # ------------------------------------------------------------------------------ # --- GirGUI ---------------------------------------------------------------- # ------------------------------------------------------------------------------ package GirGUI; use strict; use warnings; use File::Basename qw//; sub TRUE () {1} sub FALSE () {0} sub FILE_MENU_COL_TEXT () { 0 } sub FILE_MENU_COL_FILE () { 1 } sub FILE_MENU_COL_DIR () { 2 } sub FILE_MENU_COL_PATH () { 3 } sub FILE_MENU_COL_IS_SENSITIVE () { 4 } sub GIR_VIEW_COL_TEXT () { 0 } sub GIR_VIEW_COL_PATH () { 1 } sub GIR_VIEW_COL_IS_CATEGORY () { 2 } sub GIR_VIEW_COL_IS_VISIBLE () { 3 } sub new { my ($class, $parser, @girs) = @_; if (!Gtk3::CHECK_VERSION (3, 10, 0)) { die "Need gtk+ >= 3.10 for the GUI\n"; } my $self = bless { parser => $parser, }, $class; my $window = Gtk3::Window->new; $self->setup_file_menu (@girs); $self->setup_gir_view; $self->setup_search_entry; $self->setup_path_bar; $self->setup_result_view; my $gir_view_window = Gtk3::ScrolledWindow->new; $gir_view_window->add ($self->{gir_view}); my $result_view_window = Gtk3::ScrolledWindow->new; $result_view_window->add ($self->{result_view}); my $side_box = Gtk3::Box->new ('vertical', 2); $side_box->pack_start ($self->{file_menu}, FALSE, FALSE, 0); $side_box->pack_start ($gir_view_window, TRUE, TRUE, 0); $side_box->pack_start ($self->{search_entry}, FALSE, FALSE, 0); $side_box->set (margin => 2); my $result_box = Gtk3::Box->new ('vertical', 0); $result_box->pack_start ($self->{path_bar}, FALSE, FALSE, 0); $result_box->pack_start ($result_view_window, TRUE, TRUE, 0); my $paned = Gtk3::Paned->new ('horizontal'); $paned->pack1 ($side_box, TRUE, TRUE); $paned->pack2 ($result_box, TRUE, TRUE); $paned->set_position (300); $window->add ($paned); $window->signal_connect (delete_event => sub { $self->quit; }); $window->set_default_geometry (900, 800); my $accel_group = Gtk3::AccelGroup->new; $accel_group->connect (Gtk3::Gdk::KEY_q (), qw/control-mask/, [], sub { $self->quit; return Gtk3::EVENT_STOP (); }); $accel_group->connect (Gtk3::Gdk::KEY_k (), qw/control-mask/, [], sub { $self->{search_entry}->grab_focus; return Gtk3::EVENT_STOP (); }); $window->add_accel_group ($accel_group); $self->{window} = $window; return $self; } sub filter_gir_view { my ($self, $criterion) = @_; my $view = $self->{gir_view}; my $model = $self->{gir_model}; my $filter_model = $self->{gir_filter_model}; if (!defined $criterion || $criterion eq '') { # Make everything visible. $model->foreach (sub { my (undef, undef, $iter) = @_; $model->set ($iter, GIR_VIEW_COL_IS_VISIBLE, TRUE); return FALSE; # continue }); # Scroll to selected element. my $selection = $view->get_selection; my ($selected_model, $selected_iter) = $selection->get_selected; if (defined $selected_iter) { my $selected_path = $selected_model->get_path ($selected_iter); $view->scroll_to_cell ($selected_path, undef, FALSE, 0.5, 0.5); } } else { my $re; if ($criterion =~ m|\A/.+/\z|) { $criterion =~ s|\A/(.+)/\z|$1|; $re = qr/$criterion/; } else { $re = qr/\Q$criterion\E/i; } my $check_tree; $check_tree = sub { my ($iter) = @_; my @children = map { $model->iter_nth_child ($iter, $_) } 0..$model->iter_n_children ($iter); foreach my $child (@children) { my ($text, $is_cat) = $model->get ($child, GIR_VIEW_COL_TEXT, GIR_VIEW_COL_IS_CATEGORY); if ($is_cat || $text !~ $re) { # no match $model->set ($child, GIR_VIEW_COL_IS_VISIBLE, FALSE); $check_tree->($child); # descend } else { # match # Make the element and all its parents visible. my $cur = $child; do { $model->set ($cur, GIR_VIEW_COL_IS_VISIBLE, TRUE); } while (defined ($cur = $model->iter_parent ($cur))); # Expand the matching element and all its parents. $view->expand_to_path ( $filter_model->convert_child_path_to_path ( $model->get_path ($child))); # No need to descend as we want all children of matching elements to # be visible. (All elements are visible by default.) } } }; $check_tree->(undef); # start with the virtual root node } } sub display_results { my ($self, $results) = @_; $self->{result_buffer}->set_text ($results); } sub run { my ($self) = @_; $self->{window}->show_all; Gtk3::main (); } sub setup_file_menu { my ($self, @girs) = @_; my $file_model = Gtk3::TreeStore->new (qw/Glib::String Glib::String Glib::String Glib::String Glib::Boolean/); my $file_menu = Gtk3::ComboBox->new_with_model ($file_model); my $renderer = Gtk3::CellRendererText->new; $file_menu->pack_start ($renderer, TRUE); $file_menu->set_attributes ($renderer, text => FILE_MENU_COL_TEXT, sensitive => FILE_MENU_COL_IS_SENSITIVE); $file_menu->set_id_column (FILE_MENU_COL_PATH); my $prompt = '