Glib-1.320/000755 001750 000024 00000000000 12636025764 013502 5ustar00bdmanningstaff000000 000000 Glib-1.320/apidoc.pl000644 001750 000024 00000002621 11701512040 015253 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl -w $header = shift @ARGV; $footer = shift @ARGV; $data = shift @ARGV; die "usage: $0 header footer xsfiles...\n" unless $data; # load the data from xsdocparse... predeclare its vars to keep perl # happy about "possible typo" warnings. our ($xspods, $data); require $data; $/ = undef; open IN, $header or die "can't open $header: $!\n"; $text = ; close IN; print $text; # just dump all of the xs pods in the order we found them. foreach my $p (@{ $xspods }) { print join("\n", @{ $p->{lines} })."\n\n"; } open IN, $footer or die "can't open $footer: $!\n"; $text = ; close IN; print $text; __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/AUTHORS000644 001750 000024 00000003011 11664366512 014544 0ustar00bdmanningstaff000000 000000 The Gtk2-Perl Team - contact us at gtk-perl-list@gnome.org ========================================================== muppet scott at asofyet dot org Ross McFarland rwmcfa1 at neces dot com Goran Thyni goran at kirra dot net Joern Reder joern at zyn dot de Chas Owens alas at wilma dot widomaker dot com Guillaume Cottenceau gc at mandrakesoft dot com Marc Lehmann pcg at goof dot com Torsten Schoenfeld kaffeetisch at web dot de Emmanuele Bassi ebassi at gnome dot org Contributors - the people who sent us patches ============================================= Brett Kosinski brettk at frodo dot dyn dot gno dot org Thierry Vignaud tvignaud at mandrakesoft dot com James Curbo hannibal at adtrw dot org Bjarne Steinsb bosteins at broadpark dot no Jacek Konieczny jajcus at bnet dot pl Albert Chin china at thewrittenword dot com Steven Walter stevenrwalter at gmail dot com Aristotle Pagaltzis pagaltzis at gmx dot de Wim Lewis wiml at users dot sourceforge dot net Michael G Schwern schwern at gmail dot com Serguei Trouchelle STRO at cpan dot org Andres Knig andk cpan org several important bits of gtk2-perl were heavily inspired by pygtk, gtk-perl, and a good read-through of the gtk+ source code, so credit goes to those guys as well -- thanks! Copyright (C) 2003-2005 by the gtk2-perl team. gtk2-perl is covered by the LGPL -- see the file LICENSE for details. Glib-1.320/ChangeLog.pre-git000644 001750 000024 00000436633 11706207712 016631 0ustar00bdmanningstaff000000 000000 === ChangeLog discontinued === With the move to git, we stop maintaining a separate ChangeLog and rely on proper commit messages instead. Web view of changes: . 2009-03-31 Torsten Schoenfeld * t/a.t: The g_log bug got fixed upstream, so don't skip its test when glib >= 2.20.1. 2009-03-29 Torsten Schoenfeld * t/a.t: Include 's390' in the list of platforms for which the problematic g_log test needs to be skipped. 2009-03-29 Torsten Schoenfeld * copyright.pod * Glib.pm * NEWS * README: Stable release 1.221. 2009-03-29 Torsten Schoenfeld * t/a.t: Using multiple log levels breaks g_log on some platforms, so don't do it on those platforms. Tracked down by Wim Lewis, and reported here: . 2009-03-24 Torsten Schoenfeld * Glib.exports: Add gperl_option_context_get_type and gperl_option_group_get_type to the export list so that dependent modules link correctly on MSWin32. Patch by Martin Schlemmer. (GNOME #576372) 2009-03-24 Torsten Schoenfeld * t/h.t: Correct a skip count. Patch by Stefan B. (RT #44428) 2009-03-19 Torsten Schoenfeld * Makefile.PL: Space-separate the libs and cflags strings from gobject and gthread to avoid unwanted concatenation. Patch by Daniel Macks. (RT #44055) 2009-03-19 Torsten Schoenfeld * MakeHelper.pm (postamble_docs_full): Use qq// instead of qq{} to quote the copyright string in order to avoid problems with dmake. Patch by Martin Schlemmer. (GNOME #573099) 2009-03-17 Torsten Schoenfeld * Glib.pm * Makefile.PL * NEWS * README: Stable release 1.220. 2009-03-08 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.214. 2009-03-08 Torsten Schoenfeld * GClosure.xs (gperl_callback_invoke): Fix a giant leak by properly unsetting all GValues used for the callback arguments. Patch by Kevin Ryde. 2009-03-08 Torsten Schoenfeld * GenPod.pm (xsub_to_pod): Don't wrap the argument types of xsubs with a superfluous pair of '=over' and '=back'. 2009-03-08 Torsten Schoenfeld * GenPod.pm (podify_enums_and_flags): Don't generate 'ENUMS AND FLAGS' entries for Glib::Enum and Glib::Flags since they don't have values anyway. 2009-03-01 Torsten Schoenfeld * t/7.t * GSignal.xs (gperl_signal_connect): Don't leak the GClosure object when an invalid signal name is passed in. Patch by Kevin Ryde. 2009-03-01 Torsten Schoenfeld * GType.xs (gperl_fundamental_type_from_obj): Check the SV for definedness before passing it to SvRV. This fixes a test failure on MSWin32 in t/c.t. 2009-03-01 Torsten Schoenfeld * t/filename.t: Add more tests for Glib::filename_to_uri. Patch by Kevin Ryde. 2009-02-22 Torsten Schoenfeld * GBoxed.xs * GType.xs: Fix errors reported by podchecker. 2009-02-21 Torsten Schoenfeld * Makefile.PL: Tell the CPAN indexer to ignore the package 'MY' used by Glib::MakeHelper. 2009-02-21 Torsten Schoenfeld * GenPod.pm (xsdoc2pod): Instead of relying on one final '=cut', close every opened POD paragraph separately. This fixes POD errors that occurred when '=for position COPYRIGHT' was used. Original patch by Ryan Niebur. 2009-02-18 Torsten Schoenfeld * GBookmarkFile.xs: Don't document Glib::BookmarkFile::set_added, set_modified, and set_visited as functions; they're methods. * t/h.t: Test Glib::BookmarkFile::set_added, set_modified, and set_visited and their associated getters. 2009-02-18 Torsten Schoenfeld * Glib.pm: Use an '=encoding utf8' directive for the AUTHORS POD section so that non-ASCII characters are handled correctly. 2009-02-13 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.213. 2009-02-11 Torsten Schoenfeld * GError.xs: Document that Glib::Error->location returns raw bytes. Patch by Kevin Ryde. 2009-02-11 Torsten Schoenfeld * Glib.pm: In the documentation for filename_from_uri, hint at path separator issue. Patch by Kevin Ryde. 2009-02-11 Torsten Schoenfeld * GOption.xs (copy_string): Fix C99-ism. Patch by Kevin Ryde. 2009-02-06 Torsten Schoenfeld * t/filename.t: Test Glib->filename_to_uri with hostname == undef. 2009-02-05 Torsten Schoenfeld * MakeHelper.pm: Deprecate Glib::MakeHelper->get_configure_requires_yaml in favor of EU::MM's new META_MERGE and META_ADD features. 2009-02-05 Torsten Schoenfeld * Makefile.PL: Unconditionally use META_MERGE; so you now need ExtUtils::MakeMaker >= 6.46 to roll a Glib tarball with a proper META.yml. Also, tell the CPAN indexer (via META.yml) to not index xsapi.pod.head and xsapi.pod.foot. 2009-02-05 Torsten Schoenfeld * GClosure.xs (gperl_closure_marshal): Synchronize the way signals with no return value are handled with how it's done in gperl_signal_class_closure_marshal. This means that Perl handlers for these kinds of signals are now always called in void context, as they should be. 2009-02-05 Torsten Schoenfeld * MANIFEST * GType.xs (gperl_signal_class_closure_marshal) * t/signal_marshal.t: Correctly handle signals with no return type when invoking signal class closures. Patch by Kevin Ryde. 2009-02-05 Torsten Schoenfeld * GType.xs (gperl_register_fundamental_full): Handle wrapper_class_by_type being NULL gracefully. Patch by Kevin Ryde. 2009-02-05 Torsten Schoenfeld * Glib.xs: In Glib::filename_from_uri and filename_to_uri, use the gchar converters for the hostname. Patch by Kevin Ryde. 2009-02-05 Torsten Schoenfeld * GClosure.xs (gperl_callback_invoke): Use the <"%s", pointer> pattern when passing an error string pointer to croak(). 2009-02-05 Torsten Schoenfeld * GType.xs * t/c.t: Make the various Glib::Flags methods more robust with respect to receiving undefined input. Patch by Kevin Ryde. 2009-02-05 Torsten Schoenfeld * GBoxed.xs (gperl_register_boxed) * GObject.xs (gperl_register_object) * GType.xs (gperl_register_fundamental): When inserting into the package → type hash tables, use g_hash_table_replace instead of _insert so that the new string pointer is used as the key. Patch by Kevin Ryde. 2009-02-05 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.212. 2009-02-03 Torsten Schoenfeld * t/a.t * GLog.xs: Make sure that messages with % chars in them make it through Glib::log() and friends safely. 2009-02-02 Torsten Schoenfeld * ParseXSDoc.pm (xsdocparse): Always use Data::Dumper on MSWin32 for serialization. Storable seems to consistently fail there, stating 'Magic number checking on storable file failed'. 2009-02-02 Torsten Schoenfeld * Glib.xs * GSignal.xs: Hush some compiler warnings. 2009-01-20 Torsten Schoenfeld * Glib.pm: Add documentation for Glib->filename_to_uri and filename_from_uri. Patch by Kevin Ryde. 2009-01-18 Torsten Schoenfeld * GParamSpec.xs * t/e.t: Add Glib::ParamSpec->value_cmp. Patch by Kevin Ryde. 2009-01-18 Torsten Schoenfeld * t/e.t: Use UTF-8 instead of ISO-8859-1 to encode umlauts. 2009-01-18 Torsten Schoenfeld * GParamSpec.xs * t/e.t: Add Glib::ParamSpec->value_validate. Patch by Kevin Ryde. 2009-01-18 Torsten Schoenfeld * t/options.t: Don't use UTF-8 umlauts unconditionally as this causes trouble on non-UTF-8 locales. 2009-01-18 Torsten Schoenfeld * MakeHelper.pm: Add Glib::MakeHelper->postamble_precompiled_headers to generate a make target for precompiling headers. * Makefile.PL: Use the above to create a 'precompiled-headers' target that precompiles gperl.h. This speeds up the compilation of Glib by 16% on my machine. 2008-12-30 Torsten Schoenfeld * GType.xs * t/c.t: Allow calling Glib::Flags::as_arrayref directly, as an alternative to the @{} syntax. Patch by Kevin Ryde. 2008-11-24 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.211. 2008-11-22 Torsten Schoenfeld * Glib.xs * GOption.xs (added) * gperl.h * Makefile.PL * MANIFEST * t/options.t (added) * typemap: Add Glib::OptionContext and Glib::OptionGroup, wrapping glib's command line option parser. 2008-11-22 Torsten Schoenfeld * gperl-private.h: Don't include perl.h. This header is always included after gperl.h which includes everything already. And including perl.h alone doesn't work and isn't enough anyway. 2008-11-15 Torsten Schoenfeld * GBoxed.xs (gperl_register_boxed): Use the copy of the passed-in package name for the key of info_by_package to avoid problems when the package name is dynamically allocated. * GBoxed.xs (gperl_register_boxed) * GObject.xs (gperl_register_object) * GType.xs (gperl_register_fundamental): Always insert into the lookup tables in the correct order to avoid prematurely freeing the package name. 2008-11-12 Torsten Schoenfeld * GObject.xs: Add newlines at the end of debugging messages that lack them to keep perl from adding line number information. 2008-11-03 Torsten Schoenfeld * GType.xs (gperl_type_from_package): Also try gperl_param_spec_type_from_package on the package. 2008-11-03 Torsten Schoenfeld * Glib.pm * Makefile.PL * NEWS * README: Unstable release 1.210. 2008-11-03 Torsten Schoenfeld * GType.xs (add_interfaces): Fail loudly and with a clear error message when we encounter an unknown interface when registering a new type. 2008-11-03 Torsten Schoenfeld * t/lazy-loader.t -> t/lazy_loader.t: Rename this test to blend in with the others which use underscores to separate words. 2008-11-03 Torsten Schoenfeld * Glib.exports * gperl.h: Properly export gperl_param_spec_type_from_package and gperl_register_param_spec, they are meant to be public. 2008-11-02 Torsten Schoenfeld * GType.xs: Use gperl_register_fundamental_alias to register the "Glib::Uint" backwards-compatibility alias. 2008-11-02 Torsten Schoenfeld * GBoxed.xs * GObject.xs * GType.xs * Glib.exports * gperl.h: Provide gperl_register_boxed_alias, gperl_register_fundamental_alias, and gperl_register_object_alias to register aliases for other registered types. An alias is a package name that will resolve to the specified type, while the type will still resolve to its originally registered package when going the other way. 2008-11-01 Torsten Schoenfeld * t/9.t * GMainLoop.xs: Wrap g_child_watch_add as Glib::Child::watch_add. Patch by Kevin Ryde. 2008-11-01 Torsten Schoenfeld * GMainLoop.xs * Glib.pm: Add constants Glib::SOURCE_CONTINUE and SOURCE_REMOVE for use in source-type callbacks. Patch by Kevin Ryde. 2008-10-19 Torsten Schoenfeld * Makefile.PL: ExtUtils::MakeMaker 6.46 removed support for EXTRA_META in favor of the new META_MERGE and META_ADD. Adapt. 2008-09-20 Torsten Schoenfeld * Glib.pm * Makefile.PL * NEWS * README: Stable release 1.200. 2008-09-20 Torsten Schoenfeld * TODO: Remove the entry about hushing about documentation generation. That's done. 2008-09-07 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.193. 2008-09-07 Torsten Schoenfeld * GClosure.xs (gperl_callback_invoke): Instead of putting a mortal copy of the user data on the stack, increment its ref count and mortalize it. This ensure that modifications to $_[-1] in the callback actually change the user data. Patch by Kevin Ryde. * MANIFEST * GObject.xs * t/lazy-loader.t: Make sure the lazy loader can handle being invoked on packages which aren't registered with the Glib type system. This can happen when a non-registered package is setup to inherit from a registered package, and when then some method is invoked on the non-registered package. This gets rid of the spurious "asked to lazy-load Foo, but that package is not registered" warnings. 2008-09-06 Torsten Schoenfeld * GParamSpec.xs: * GValue.xs: Handle NULL GParamSpecs in newSVGParamSpec by returning undef. Consequently, remove the NULL handling in _gperl_sv_from_value_internal. This partly reverts the commit from 2008-08-18 and brings newSVGParamSpec in line with the other SV* constructors. * GObject.xs * t/5.t: Fix the stack handling in Glib::Object::get to be robust against stack movement due to reallocation. This can happen if a subclass' GET_PROPERTY triggers a stack resize. Patch by Kevin Ryde. 2008-08-31 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.192. 2008-08-31 Torsten Schoenfeld * MakeHelper.pm (postamble_docs_full): Fix the POD index generation. For five months now, broken index pages (like Glib::index) were being created due to shell command quoting issues. 2008-08-23 Torsten Schoenfeld * GType.xs (gperl_convert_flag_one, gperl_convert_flags): Improve the wording of the error messages for invalid flags a bit. * t/4.t: Prettify a bit by using ok(), pass(), and fail() functions. 2008-08-18 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.191. 2008-08-18 Torsten Schoenfeld * t/e.t * GValue.xs (_gperl_sv_from_value_internal): Handle NULL GParamSpecs gracefully by returning undef. * GParamSpec.xs (newSVGParamSpec): Croak on NULL GParamSpecs. 2008-08-17 Torsten Schoenfeld * GParamSpec.xs: Add hierarchy POD sections to the various Glib::ParamSpec subclasses. 2008-08-16 Torsten Schoenfeld * GenPod.pm: Document how to hide arguments with "=for arg". Cope with _noinc_ornull type variants. 2008-08-03 Torsten Schoenfeld * GObject.xs (g_object_new): Check that we got a correct number of arguments. * t/2.t: Fix a typo uncovered by the above change. 2008-07-13 Torsten Schoenfeld * GType.xs * t/c.t: In the overloaded flags operators, don't choke on undef in the swap argument. This happens when a normal 'x' operator is used for handling 'x='. Patch by Kevin Ryde. 2008-06-22 Torsten Schoenfeld * Glib.pm * Makefile.PL * NEWS * README: Unstable release 1.190. 2008-06-13 Torsten Schoenfeld * GObject.xs (gperl_get_object_check): Croak on objects that don't carry magic. 2008-06-01 Torsten Schoenfeld * GType.xs: Fix typo in error message output by Glib::Flags::new. * GUtils.xs * t/1.t: Provide Glib::strerror and Glib::strsignal. Patch by Kevin Ryde. 2008-05-31 Torsten Schoenfeld * GSignal.xs: In the xsub for g_signal_add_emission_hook, make sure that the type class exists before we try to fetch information about one of its signals. 2008-05-23 Torsten Schoenfeld * GType.xs * t/c.t: Add Glib::Flags::new, a constructor for flags objects that can be used with the overloaded operators. Patch by Kevin Ryde and muppet. 2008-05-22 Torsten Schoenfeld * GType.xs * Glib.pm * t/c.t: Overload '!=' and 'ne' for flags values for consistency. 2008-05-20 Torsten Schoenfeld * GClosure.xs (gperl_callback_invoke): Put a mortal copy of the user data on the stack to avoid prematurely destroying it in certain cases. Patch by Kevin Ryde. * t/c.t: Test that empty flags values ([], undef) work. * GType.xs (gperl_convert_flag_one): Don't call gperl_type_flags_get_values needlessly. 2008-05-04 Torsten Schoenfeld * GBoxed.xs * GType.xs: Use const char* to store the return value of sv_reftype. * Subclass.pm: Improve the documentation of GET_PROPERTY and SET_PROPERTY. (Patch by Kevin Ryde) 2008-04-19 muppet * xs/GType.xs * t/c.t: Register Glib::Enum and Glib::Flags. Remove special case logic for these from Glib::Type::register(). 2008-03-30 Torsten Schoenfeld * Glib.pm * Makefile.PL * NEWS * README: Stable release 1.182, requiring ExtUtils::Depends >= 0.300. 2008-03-30 Torsten Schoenfeld * GType.xs: For the 64 bit integer converters: use g_ascii_strtoll, g_ascii_strtoull, and _atoi64 when available. Only use _strtoi64 and _strtoui64 if _MSC_VER >= 1300. * GenPod.pm: Add setters set_copyright, set_year, set_authors, and set_main_mod for the corresponding package variables. * MakeHelper.pm (postamble_docs_full): Use more portable ways to quote commands and strings, partly by using the new functions mentioned above. (postamble_rpms): Don't do anything unless $ENV{GPERL_BUILD_RPMS} is set. (quiet_rule): Use two lines for the prettified commands so that long commands don't get even longer. (do_pod_files): Prettify information message. * t/1.t * t/filename.t * t/g.t: Fix failures on MSWin32. * ParseXSDoc.pm (clean_out_empty_pods): Stop being chatty. 2008-03-22 Torsten Schoenfeld * Makefile.PL: Trap exceptions thrown by EU::PkgConfig->find. When one occurs, exit with status 0 to indicate to CPAN testers that their system isn't supported. 2008-03-14 Torsten Schoenfeld * Glib.pm * NEWS * README: Stable release 1.181. 2008-03-14 Torsten Schoenfeld * Makefile.PL: Remove the no_index specification from EXTRA_META because the YAML implementations currently in use don't seem to support this syntax yet. * Makefile.PL (MY::postamble): Handle the EU::Depends object $glib being undefined gracefully. * Makefile.PL: Don't warn about this release being unstable because it isn't. * copyright.pod: Update for 2008. 2008-03-10 Torsten Schoenfeld * Glib.pm * NEWS * README: Stable release 1.180. 2008-02-24 Torsten Schoenfeld * Makefile.PL: Tell the compiler to always look for headers in '.' first so that ours are preferred in case of name clashes. (Suggestion by Daniel Macks in RT #32883) * MakeHelper.pm: Add a hyphen to the NAME section of POD indices. (Suggested by Quentin Sculo) 2008-02-24 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.174. 2008-02-24 Torsten Schoenfeld * MakeHelper.pm: Rework the BLIB_DONE stuff to not rely on Makefile conditionals. We should now build fine with any `make´ again. Also fix some incorrect and add missing dependencies for various documentation files. 2008-02-12 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.173. 2008-01-17 Torsten Schoenfeld * GType.xs * t/c.t: Make Glib::Type::list_values return the value of each enum/flags entry in addition to the name and nickname. (Patch by Kevin Ryde) * t/9.t * t/filename.t: Hopefully fix test failures on Windows. 2008-01-16 Torsten Schoenfeld * t/4.t: Test Glib::Type->list_ancestors and Glib::Type->package_from_cname. 2008-01-09 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.172. 2008-01-09 Torsten Schoenfeld * ParseXSDoc.pm (parse_file): When parsing an #else pre-processor directive, make sure we have actually seen and parsed a corresponding #if before trying to negate its entry. This can happen when our parsing heurestics fail. The result was an exception: "Modification of non-creatable array value attempted." 2008-01-09 muppet * GType.xs: Defer the instantiation of a newly-registered object class's class until after we've parsed the list of signals, properties, and interfaces to add to it. This allows perl-derived GObjects to override GInterfaces that are implemented by parent classes. Previously, the early instantiation confused GLib and caused the call to g_type_class_add_interface() to complain that the given type already conforms to the interface, because the type system considered the initialization of the class to be complete. Note that we do not currently have a way of chaining up to a parent's GInterface implementation, as can be done in C via g_type_interface_peek_parent(). Black magic may be required for that. 2008-01-07 muppet * GObject.xs: Load GInterface types immediately, instead of leaving them for lazy loading. Otherwise, it is possible to get into situations in which a GInterface has not triggered its lazy loading by the time it is needed. 2008-01-07 Torsten Schoenfeld * CodeGen.pm * GBoxed.xs * GError.xs * GObject.xs * GSignal.xs * GType.xs * GValue.xs * Glib.exports * Glib.xs * gperl.h * typemap: Rename gperl_sv_defined to gperl_sv_is_defined. * GBoxed.xs * GError.xs * GType.xs * gperl.h: Add new macros: gperl_sv_is_array_ref, gperl_sv_is_code_ref, and gperl_sv_is_hash_ref. * GObject.xs (class_info_finish_loading): When handling a class' @ISA, instead of simple av_fetch calls and a final av_clear, use repeated av_shift calls. Invoking av_clear on an @ISA array seems to break the caching magic associated with it when running under perl 5.10.0. This in turn breaks our lazy-loading scheme. 2008-01-07 muppet * GSignal.xs, t/signal_emission_hooks.t: Bind and test g_signal_get_invocation_hint(). 2007-12-30 Torsten Schoenfeld * gperl_marshal.h: Mention in the POD that dGPERL_CALLBACK_MARSHAL_SP should always come last in a list of declarations. 2007-12-22 Torsten Schoenfeld * gperl.h (SvGObject) * t/2.t: Use gperl_get_object_check instead of gperl_get_object so that inproper usage of Glib::Object methods results in an error message and not in a segfault. * CodeGen.pm (gen_boxed_stuff): Correctly cast the return value of the Sv$classname macros for boxed types so as to avoid handing out void* pointers. 2007-12-16 Torsten Schoenfeld * Glib.pm * NEWS * README: Unstable release 1.171. 2007-12-16 Torsten Schoenfeld * GBookmarkFile.xs: Hush compiler warning. * CodeGen.pm * gperl.h * typemap: Replace the last occurences of SvOK with gperl_sv_defined. 2007-11-20 Torsten Schoenfeld * Glib.exports * Glib.xs * gperl.h: Add gperl_sv_defined, which checks an SV for definedness just like Perl's defined() does. * GBoxed.xs * GError.xs * GObject.xs * GSignal.xs * GType.xs * GValue.xs * Glib.xs: Use gperl_sv_defined instead of SvOK to check SVs for definedness. This keeps Glib from erroneously thinking your scalars are undefined, for example when using tied hashes. * MANIFEST * t/tied_definedness.t: Test that values from tied hashes get through the definedness checks. 2007-11-18 Torsten Schoenfeld * GError.xs (gperl_gerror_from_sv): Fix the check for undefined domain keys in GError hashes. * GType.xs (add_interfaces): Fix the check for undefined interface names. 2007-11-15 Torsten Schoenfeld * Glib.exports: Add SvGKeyFile. (Reported by spicy jack) 2007-10-28 Torsten Schoenfeld * Glib.pm * Makefile.PL * NEWS * README: Unstable release 1.170. 2007-10-28 Torsten Schoenfeld * GType.xs: Define and use PORTABLE_LL_FORMAT and PORTABLE_ULL_FORMAT. 2007-10-18 Torsten Schoenfeld * AUTHORS * MakeHelper.pm (postamble_docs_full): When constructing the add_types call, make sure to properly quote the paths. (Patch by Andres König) 2007-10-14 Torsten Schoenfeld * Makefile.PL: Use BEGIN { require 5.008; } instead of use 5.008; so automatic CPAN testers know which perl version we need. Also get rid of the MY package by prefixing the relevant subs with `MY::´. 2007-10-08 Torsten Schoenfeld * GObject.xs (Glib::Object::CLONE): Check that perl_gobjects != NULL before working with it, to avoid an assertion. 2007-10-07 Torsten Schoenfeld * MakeHelper.pm * t/make_helper.t: Add Glib::MakeHelper::get_configure_requires_yaml to generate YAML suitable for use with EU::MM's EXTRA_META. * Makefile.PL: Use the above to tell EU::MM to generate a correct configure_requires entry. Also output a no_index entry to tell the CPAN indexer what to ignore. 2007-09-24 kaffeetisch * CodeGen.pm * GenPod.pm * MakeHelper.pm * Makefile.PL: Prettify build output by summarizing what is done instead of printing executed command lines, and by removing unnecessarily verbose output. Use `make NOECHO=" "´ if you want to see the command lines. * MakeHelper.pm: Implement custom Makefile rule generators in MY that print stuff like [ XS File.xs ] instead of the overly long command lines. Again, use `make NOECHO=" "´ if you want to see the command lines. 2007-09-16 kaffeetisch * Glib.pm * Makefile.PL * NEWS * README: Stable release 1.160. 2007-09-15 kaffeetisch * GKeyFile.xs * GMainLoop.xs * GUtils.xs * gperl.h * t/1.t * t/9.t * t/g.t: Change version checks to refer to glib 2.14 instead of 2.13. 2007-08-13 kaffeetisch * Glib.pm * NEWS * README: Unstable release 1.153. 2007-08-13 kaffeetisch * GMainLoop.xs * GObject.xs * GType.xs * GenPod.pm: Output a warning if a type name isn't recognized by the doc parser. Add 'package' and 'list' to the basic types and fix the remaining type name issues the new warning uncovered. * GenPod.pm * ParseXSDoc.pm: Parse preprocessor conditionals in the XS code to add Since: tags to methods' POD. * GenPod.pm * ParseXSDoc.pm: Make it possible to document specific packages in different POD files by providing a new =for object variant. * t/1.t * t/9.t * t/filename.t: Fix win32 test failures. 2007-08-01 kaffeetisch * gperl.h * typemap: Add char_own_ornull and gchar_own_ornull typemaps. 2007-07-08 kaffeetisch * Glib.pm * NEWS * README: Unstable release 1.152. 2007-07-07 kaffeetisch * GObject.xs: Register G_TYPE_INTERFACES as Glib::Interfaces to avoid having it appear under Glib::Object::_Unregistered in hierarchies in the generated POD. * GMainLoop.xs * t/9.t: Wrap g_main_context_is_owner and g_timeout_add_seconds. 2007-06-24 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.151. 2007-06-23 kaffeetisch * GUtils.xs * gperl.h * typemap * t/1.t: Wrap g_get_user_special_dir and provide converters for the new enum GUserDirectory. * t/g.t: In floating point tests, don't check for equality. Instead, check that numbers don't differ too much from their expected values. 2007-06-10 kaffeetisch * GKeyFile.xs, t/g.t: Wrap g_key_file_load_from_dirs. 2007-02-24 kaffeetisch * MakeHelper.pm: Use BSD make syntax for the BLIB_DONE stuff on BSD systems, unless the environment variable FORCE_GMAKE is set. 2007-01-08 kaffeetisch * Glib.pm, Makefile.PL, NEWS, README, copyright.pod: Unstable release 1.150. 2007-01-07 kaffeetisch * GenPod.pm: Only mark those objects as deprecated that have a non-empty list of replacements; this avoids marking each and every object as deprecated. Move up the deprecation message in the POD to make it more prominent. Also, hush the "podifying Foo" messages. 2007-01-06 Emmanuele Bassi * ParseXSDoc.pm: * GenPod.pm: Add a "deprecated_by" key to the apidoc parser; you should use this to mark an object deprecated in favour of another. Also add a __deprecated__ marker for functions and methods. 2006-12-30 kaffeetisch * Glib.xs: Call g_threads_init before g_type_init. Required (and probably enforced in the near future) by recent glib versions. 2006-12-02 kaffeetisch * NEWS: Merge from stable-1-14. * Makefile.PL: Check that glib >= 2.12.0, not 2.11.0, before including GBookmarkFile.xs. 2006-11-23 kaffeetisch * GType.xs, gperl.h: Revert the G_OS_WIN32 change and just use WIN32 instead. G_OS_WIN32 doesn't seem to be defined on most win32 boxes. * AUTHORS, GType.xs: Use _strtoi64 and and _strtoui64 on win32 if compiling with MSVC; patch from Serguei Trouchelle. 2006-11-05 kaffeetisch * GType.xs, gperl.h: Use G_OS_WIN32 instead of WIN32 or _WIN32. 2006-10-21 kaffeetisch * GBookmarkFile.xs: Remove a custom "=for signature" directive that incorrectly specified a boolean return value for remove_item. 2006-10-17 kaffeetisch * Glib.xs, MANIFEST, ppport.h: Get rid of ppport.h, we don't seem to need it. 2006-10-03 kaffeetisch * CodeGen.pm, GenPod.pm, ParseXSDoc.pm: Fix POD errors. (Mainly =cut's not followed by a blank line.) 2006-09-13 kaffeetisch * GBoxed.xs (gperl_new_boxed_copy): Check for NULL before passing the boxed pointer to g_boxed_copy. * GType.xs: Add macros, PORTABLE_STRTOLL and PORTABLE_STRTOULL, to centralize the preprocessor madness for 64bit integer support. On win32, which apparently lacks strtoll or similar, use strtol and strtoul for now to make it at least compile. * t/7.t: Apply a patch from Michael G Schwern that introduces helper functions which make this complicated test easier to read. * t/filename.t: Remove two debug prints that were causing perl warnings. 2006-09-09 kaffeetisch * t/4.t, t/5.t, t/6.t, t/7.t, t/9.t: In hand-rolled test output, use '-' instead of '#' as the comment designator. In TAP (Test Anything Protocol), the protocol we use, '#' is for directives and '-' is for comments. 2006-09-04 kaffeetisch * Glib.pm, Makefile.PL, NEWS, README: Stable release 1.140. 2006-09-04 kaffeetisch * t/9.t: Don't test Glib::main_depth on glib <= 2.4.0, where it first appeared. * t/g.t: Fix skip count. 2006-08-29 kaffeetisch * README: Add a bug reports section. 2006-08-07 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.132. 2006-08-07 kaffeetisch * GKeyFile.xs, Glib.xs: Remove outdated FIXME comments. * GMainLoop.xs (async_watcher_install): Add FIXME comment about a leak. * GObject.xs: Remove FIXME comment about gperl_object_check_type's semantics. We can't do anything about anymore. * GSignal.xs (foreach_closure_matched): Fix to use guint instead of int for the return type. * Glib.pm: Don't use indirect object syntax. * TODO: Update. * typemap: Add custom typemaps for guchar* to avoid compiler warnings. * t/g.t: Change version checks to refer to stable releases only. 2006-07-23 kaffeetisch * Glib.pm, Makefile.PL, NEWS, README: Unstable release 1.131. 2006-07-23 kaffeetisch * GError.xs, GKeyFile.xs, Glib.xs, gperl-gtypes.h, gperl-gtypes.c, gperl.h: Change version checks to check for 2.12 instead of 2.11. 2006-07-19 Emmanuele Bassi * GObject.xs: Bind g_object_class_find_property()... * t/4.t: ... and test it. 2006-07-14 kaffeetisch * Glib.pm, NEWS, README, copyright.pod: Unstable release 1.130. 2006-07-14 kaffeetisch * MakeHelper.pm: Turn a few 'use Config's into 'require Config's. Also remove some loud MSVC/nmake bashing. :-) 2006-06-20 Emmanuele Bassi A GBookmarkFile.xs A t/h.t * GBookmarkFile.xs: Bind GBookmarkFile, a parser for desktop bookmarks, that comes with GLib 2.11/2.12. * t/h.t: Test suite for Glib::BookmarkFile. * GError.xs: * Glib.xs: * MANIFEST: * Makefile.PL: * doctypes: * gperl-gtypes.[hc]: * gperl.h: * typemap: Build glue for Glib::BookmarkFile. * Makefile.PL: * Glib.pm: Update $VERSION to 1.130 and warn the user. 2006/06/19 kaffeetisch * GKeyFile.xs, t/g.t: Bind and test g_key_file_set_double, g_key_file_get_double, g_key_file_set_double_list, and g_key_file_get_double_list. Fix a few API doc glitches. 2006/06/19 kaffeetisch * GObject.xs: Register GInitiallyUnowned as Glib::InitiallyUnowned. 2006/05/21 kaffeetisch * GObject.xs (class_info_finish_loading): Free the list returned by g_type_interfaces when we're finished with it. 2006/03/12 kaffeetisch * Glib.pm, Makefile.PL, NEWS, README: Stable release 1.120. 2006/03/06 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.118. 2006/03/04 kaffeetisch * gperl-private.h, MANIFEST: Add a new header file for private functions that are used in more than one xs file. For now these are _gperl_sv_from_value_internal, _gperl_fetch_wrapper_key, and some new threading-safety stuff described below. * Glib.xs, gperl-private.h: Add _gperl_set_master_interp and _gperl_get_master_interp to get and set a global master interpreter that can be used to setup perl's thread-local storage. For convenience, the new macro GPERL_SET_CONTEXT encapsulates this setup step. Inspired by Dobrica Pavlinusic's approach in the Fuse module. * Glib.xs: Call _gperl_set_master_interp in BOOT to set the global master interpreter to the value of PERL_GET_INTERP. * GObject.xs (gobject_destroy_wrapper): Use GPERL_SET_CONTEXT to prevent a segfault that occured when this function was called from a different thread. Apparently, PL_in_clean_objs tries to access invalid memory if you don't setup perl's context correctly. * GLog.xs (gperl_log_handler): Use GPERL_SET_CONTEXT to replace the hack that put the value of PERL_GET_CONTEXT into the user data. The result should be the same: correctly setup perl's context before calling warn() to avoid segfaults when called from a different thread. * GType.xs, GObject.xs: Include gperl-private.h to get rid of the "extern" declarations. 2006/02/27 kaffeetisch * Glib.pm, Makefile.PL, NEWS, README: Unstable release 1.117. 2006/02/14 kaffeetisch * GType.xs: Add a missing semicolon that caused compilation failures on perl 5.8.8. 2006/02/13 kaffeetisch * Glib.pm, Makefile.PL, NEWS, README: Unstable release 1.116. 2006/02/13 kaffeetisch * MANIFEST, README.api-changes: Remove this outdated file. 2006/02/11 muppetman * GObject.xs: SvLEN() is the length of the SV's buffer; SvCUR() is the length of the SV's string. Use SvCUR() instead of SvLEN()-1 in _gperl_fetch_wrapper_key(), or we get garbage key names with perl 5.8.8, resulting in failures in t/f.t related to properties with no getter or setter. * ParseXSDoc.pm: Data::Dumper uses a lot of memory, and causes the docgen for Gtk2 to use up to 10MB. Switch the serialization code over to Storable, using store_fd(), instead. Runs a bit faster, too. Also allow passing by reference to parse_xsub(), to avoid copying potentially large xsub bodies. 2006/01/30 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.115. 2006/01/28 muppetman * MakeHelper.pm: Slightly reduce the potentially ludicrous line length of the xsdocparse command. 2006/01/22 muppetman * GObject.xs: Honor the "don't warn about unregistered subclasses of this type" flags. Use those flags to avoid creating _Unregistered names for what are typically private implementation classes. This leaves the method a little misnamed, but oh well. Updated the pod accordingly. Also remove unused code. 2006/01/22 kaffeetisch * AUTHORS, Makefile.PL: Apply a patch from Wim Lewis that makes sure we don't use threading stuff if perl isn't configured to handle threads. 2006/01/21 muppetman * GObject.xs: Hide CLONE from the docs; it's not something user code should call. 2006/01/18 kaffeetisch * GObject.xs: Modify the MAKE_UNDEAD and REVIVE_UNDEAD macros so no casts are needed when using them. 2006/01/18 kaffeetisch * Glib.pm: Fix a typo. 2006/01/16 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.114. 2006/01/16 kaffeetisch * GObject.xs: Apply patch from Rafael Garcia-Suarez that fixes the undead object macros on 64-bit platforms. 2006/01/16 kaffeetisch * GObject.xs (class_info_finish_loading): Hush a compiler warning. 2006/01/16 kaffeetisch * GLog.xs (gperl_log_handler): Add a comment describing a rare threading-related crash. 2006/01/15 muppetman * Glib.pm, GObject.xs, GType.xs: Change the way GObject type mappings are initialized. Previously, gperl_register_object() would not only map a GType to a perl package name, but would set up the @ISA entry for that type by introspection; if the parent type was not yet registered, the mapping would go into a "pending isa" list, and the code would walk that list on each registration. This left a nice loophole that was triggered by the addition of GInitiallyUnowned into libgobject -- if a type's parent is unknown to the bindings, that type simply doesn't get its ancestry set up correctly. This ended up breaking all nontrivial gtk2-perl programs. Shame on me for thinking up such a fragile scheme. Changed the code in various subtle ways. Added the idea of "lazy loading", inspired by Gtk-Perl. gperl_register_object() still registers the association of a GType and a package name, but adds to @ISA only "Glib::Object::_LazyLoader". ISA setup is performed by the internal function class_info_finish_loading(), which replaces the _LazyLoader name in @ISA with the class's parent and implemented interfaces (preserving manually appended and prepended entries). This is triggered one of two ways: either by calling gperl_object_package_from_type(), which happens when you bless an object; or via an AUTOLOAD, isa, or can invocation in _LazyLoader, which happens when you try to invoke methods on the class. When a class is set up, all of its parents are checked as well, so this happens fairly quickly. This should be completely transparent to all existing code, as the new _LazyLoader stuff in private, and the external interfaces have not changed. The one spot that could break is calling UNIVERSAL::(can|isa) on a Glib::Object-derived package name before that class has been set up. In addition, instead of giving up on unknown classes, we now create fake names for them in a "safe" namespace, along the lines of Glib::Object::_Unregistered::$c_type_name, and treat them normally. For foreign types, this still effectively means they can be treated as the first known parent, but the value of ref() will be different (but you shouldn't have been relying on that, anyway). 2006/01/13 muppetman * GObject.xs: Ignoring the undead flag in _gperl_fetch_wrapper_key() resulted in crashes when manipulating properties of objects with undead wrappers. * Glib.pm, Glib.xs, t/filename.t: Bind, test, and document g_filename_display_name and g_filename_display_basename. 2006/01/01 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.113. 2005/12/19 kaffeetisch * GObject.xs (gperl_register_object): Move around the loop that puts interface packages into @ISA so it gets run on every call to gperl_register_object. With the old code, you ran into problems when a GInterface was registered after the last GObject had been registered. 2005/12/12 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.112. 2005/12/12 kaffeetisch * GType.xs: Hush a compiler warning. * MANIFEST.SKIP: Use the more correct G.+\.c$ instead of G*\.c$. 2005/11/30 ebassi * GKeyFile.xs: fix the argument types in order to allow 'undef' values. * t/g.t: new tests for the functions allowing undefined values. 2005/11/18 kaffeetisch * GType.xs Register the fundamentals for gint64 and guint64 as Glib::Int64 and Glib::UInt64 respectively. 2005/11/14 kaffeetisch * Glib.pm, NEWS, README: Unstable release 1.111. 2005/11/13 muppetman * GValue.xs, GObject.xs: The GObject property interface passes around pointers to boxed objects, but does not transfer ownership of them. Thus, the old code was letting perl hold on to dead pointers. We basically need to be able to specify whether to copy boxed objects when converting from GValue to SV. Since gperl_sv_from_value() is public and API frozen, add a new private function, _gperl_sv_from_value_internal(), and call this from both gperl_sv_from_value() and Glib::Object::get(). Fixes http://bugzilla.gnome.org/show_bug.cgi?id=319204 and several other hard-to-diagnose intermittent bugs. 2005/11/12 kaffeetisch * xsapi.pod.head: Fix a few typos. 2005/10/18 kaffeetisch * Glib.pm, MANIFEST, MANIFEST.SKIP, Makefile.PL, NEWS, README: Unstable release 1.110. 2005/10/17 kaffeetisch * GParamSpec.xs, GType.xs, GValue.xs, gperl.h, typemap, t/64bit.t: Use custom converters for gint64 and guint64 that transform 64 bit integers to and from strings if perl's IV type isn't big enough. * AUTHORS, Glib.pm: Add some documentation about the above; include a write up by A. Pagaltzis about the various big integer modules for Perl. * GSignal.xs (newSVGSignalQuery) (gperl_signal_emission_hook): Fix some signedness warnings. * GParamSpec.xs (gperl_param_spec_type_from_package): Fix a variable-data-in-struct-construction warning. 2005/10/15 kaffeetisch * GObject.xs (gperl_register_object): Free the interfaces list after use. 2005/10/14 muppetman * GObject.xs, AUTHORS: Patch from Steven Walter fixes nasty reference counting bug that could leave Perl wrappers pointing at dead C objects in some situations. Because we have no C containers in glib-object, we can't really add tests for this. 2005/10/05 kaffeetisch * Glib.pm, NEWS: Merge from stable-1-10. * t/c.t: Change the flags test yet again. Make it explicit this time by using is_deeply() and \@{} so it hopefully works with any version of Test::More. 2005/09/30 kaffeetisch * GObject.xs (gperl_register_object): Automatically add each known interface an object implements to the corresponding @ISA. (gperl_new_object): If we encounter an object which has no known type in its ancestry except for G_TYPE_OBJECT, register it with a unique package name and take a look at the interfaces it implements -- if there is one we know, add it to the new package's @ISA. 2005/09/05 kaffeetisch * MANIFEST, META.yml: Remove META.yml. * Glib.pm, Makefile.PL, NEWS, README: Stable release 1.100. 2005/07/27 muppetman * CodeGen.pm: Forgot to delete the leftover gtk junk before committing. 2005/07/27 kaffeetisch * Glib.pm, META.yml, NEWS, README: Unstable release 1.093. 2005/07/26 muppetman * CodeGen.pm, Makefile.PL, MANIFEST: Take out the Gtk2-specific portions of Gtk2::CodeGen, make it extensible, and call it Glib::CodeGen. 2005/07/12 kaffeetisch * Glib.pm, META.yml, NEWS, README: Unstable release 1.092. 2005/07/05 kaffeetisch * GUtils.xs, t/1.t: Bind and test g_markup_escape_text. 2005/07/02 00:32 pcg * GMainLoop.xs (add_watch): on native win32, convert the perl fileno to a winsock fileno using win32_get_osfhandle and call g_io_channel_win32_new_socket directly. * Subclass.pm: fix my contact address while we are at it. 2005/06/28 kaffeetisch * GenPod.pm (podify_ancestors): Use one less space for the indention of ancestors to make them line up correctly. 2005/06/22 kaffeetisch * t/c.t: Use is() instead of is_deeply() to test flags values since the latter was changed to always use the string version of overloaded objects in recent versions of Test::More, whereas the former seems to work correctly. Tested with Test::More 0.45 and 0.60. 2005/06/20 kaffeetisch * xs/GLog.xs (gperl_log_handler): Set perl's context to the one gperl_handle_logs_for() was called in. This is to make sure Perl_form accesses a valid memory pool, which prevents segfaults when the log handler is called from a different thread. * GType.xs: Fix a typo in gperl_package_from_type's POD. 2005/06/06 kaffeetisch * Glib.pm, MANIFEST, META.yml, NEWS, README: Unstable release 1.091. 2005/05/30 kaffeetisch * GKeyFile.xs: Fix the g_key_file_get_keys XSUB to actually return anything, and make it omit NULLs. Fix an incorrect offset in the g_key_file_set_locale_string_list XSUB. Replace "const gchar const **" with "const gchar * const *" where appropriate. * GObject.xs (Glib::Object::set_threadsafe): Mark `threadsafe' as unused in the !GPERL_THREAD_SAFE branch. * typemap: Add a GSignalFlags typemap. The corresponding converters already exist and are exported. * t/2.t: Test Glib::Object::freeze_notify and thaw_notify. * t/7.t: Test Glib::Object::signal_stop_emission_by_name, signal_handler_block, signal_handler_unblock and signal_handler_is_connected. * t/9.t: Test Glib::main_depth, Glib::MainLoop::is_running, Glib::MainLooP::get_context, Glib::MainContext::new, Glib::MainContext::default and Glib::MainContext::pending. * t/c.t: Test the union operator of flags. * t/g.t: Test Glib::KeyFile::set_locale_string_list, get_locale_string_list, set_string_list, set_locale_string, set_comment, set_boolean, set_value, get_keys, remove_comment, remove_key, remove_group, to_data and set_list_separator. 2005/05/22 kaffeetisch * Glib.xs: Initialize filename and hostname in filename_from_uri. * t/filename.t: Add tests for the filename conversion facilities. * t/a.t: Correct existing and add new tests for Glib::Log. Test set_fatal_mask and set_always_fatal. 2005/04/27 ebassi * doctypes: fix typo for GKeyFileFlags. 2005/04/27 ebassi * Glib.xs, GError.xs, doctypes, gperl-gtypes.c, gperl-gtypes.h, gperl.h, Makefile.PL, MANIFEST, typemap, GKeyFile.xs, t/g.t: bind, document and test GKeyFile, a parser for .ini-like files. 2005/04/25 kaffeetisch * Glib.pm, META.yml, Makefile.PL, NEWS, README: Unstable release 1.090. 2005/04/19 rwmcfa1 * GenPod.pm: fixed long running auto list of enums/flags problems. enums were only getting added when there was info assocaited with them, flags could always make it through. there was also a bug which allowed enums and flags in parent properties to be listed in children. 2005/04/17 kaffeetisch * Glib.pm, META.yml, NEWS, README: Merge from stable-1-08. 2005/04/04 muppetman * GSignal.xs, t/signal_emission_hooks.t, MANIFEST: Bind, document, and test g_signal_add_emission_hook and g_signal_remove_emission_hook, with a little refactoring in GSignal.xs. 2005/03/24 kaffeetisch * GType.xs, GValue.xs, gperl.h: Add API that allows binding developers to specify conversion functions when registering fundamental types that are to be used by gperl_value_from_sv() and gperl_sv_from_value(). gperl_register_fundamental_full() is the new function that takes a GPerlValueWrapperClass struct which contains a GPerlValueWrapFunc and a GPerlValueUnwrapFunc. gperl_fundamental_wrapper_class_from_type() can be used to retrieve the GPerlValueWrapperClass that corresponds to a given GType. * GBoxed.xs, GType.xs: Document that gperl_register_boxed() and gperl_register_fundamental_full() assume that the wrapper class is statically allocated and that it will always be alive. 2005/03/07 kaffeetisch * Glib.pm, Makefile.PL, META.yml, NEWS, README: Stable release 1.080. 2005/03/06 kaffeetisch * GBoxed.xs: Fix a typo. 2005/02/28 kaffeetisch * Glib.pm, META.yml, Makefile.PL, NEWS, README: Unstable release 1.074. 2005/02/15 15:48 (-0500) rwmcfa1 * GMainLoop.xs: likely type-o on Glib::MainLoop->new causing ref count to start out at 2 and thus main loops never die, should of been unref. 2005/02/07 23:40 (-0500) muppetman * Glib.pm, NEWS, README: Unstable release 1.073 2005/02/07 23:30 (-0500) muppetman * t/9.t: Disable the async signal test on win32. 2005/02/07 23:20 (-0500) muppetman * GSignal.xs, gperl.h, Glib.exports: Bind and document g_signal_query as Glib::Object::signal_query. Add newSVGSignalQuery to marshal a GSignalQuery to perl. * GType.xs: Move guts of list_signals to newSVGSignalQuery, and call that function instead. M MANIFEST A t/signal_query.t: New test for signal_query and list_signals. 2005/02/07 23:20 (-0500) muppetman * GLog.xs: Call abort() rather than croak() on G_LOG_LEVEL_ERROR messages. croak()ing didn't do anything useful, and abort()ing allows you to stop gdb on an error and get a backtrace. 2005/02/04 22:36 (-0500) muppetman * MakeHelper.pm: (select_files_by_version) do not escape . in glob patterns; it is unnecessary on unix and win32 thinks the \ is a path separator. This one-character change fixes an intermittent win32 build problem. 2005/01/29 21:22 (-0500) muppetman * ParseXSDoc.pm: better handling for xsubs with continuation lines. 2005/01/29 13:45 (-0500) muppetman * copyright.pod: update for the new year. 2005/01/29 01:38 (-0500) muppetman * GBoxed.xs, GenPod.pm: implement support for the boxed type GStrv as a native perl anonymous array of strings 2005/01/25 23:34 (-0500) rwmcfa1 * t/c.t: remove [] around test 12. caused failures on newer Test::More's 2005/01/09 23:50 (-0400) muppetman * Glib.pm, META.yml, NEWS, README: Unstable release 1.072 2005/01/09 23:08 (-0400) muppetman * Glib.xs: minor documentation updates 2005/01/09 16:29 (-0400) muppetman * Glib.exports: add gperl_format_variable_for_output, which needs to be exported but got missed somehow for 1.060. 2005/01/08 23:45 (-0400) muppetman * GMainLoop.xs, t/9.t: Ensure that asynchronous signals, deferred by perl's safe signal handling, are delivered on time when a main loop is running. Thanks to Jan Hudec. 2005/01/04 15:15 (-0400) rwmcfa1 * t/1.t: we need to make it clear to perl that g_get_user_data_dir and friends are functions or we'll get syntax errors and test failures when no symbols with those names are found (even though they'll be skipped.) 2005/01/02 16:31 (+0100) kaffeetisch * GParamSpec.xs, TODO: Remove documentation that doesn't apply anymore. * GUtils.xs, t/1.t: Bind and test g_get_user_data_dir, g_get_user_config_dir, g_get_user_cache_dir, g_get_system_data_dirs, g_get_system_config_dirs, and g_get_language_names. 2004/11/29 21:28 (+0100) kaffeetisch * Makefile.PL: Correct the unstable warning message to say 1.06x instead of 1.04x. * Glib.pm, META.yml, NEWS, README: Unstable release 1.071. 2004/11/01 21:22 (+0100) kaffeetisch * Glib.pm, META.yml, Makefile.PL, NEWS, README: Unstable release 1.070. 2004/10/24 11:55 (-0400) rwmcfa1 * MANIFEST.SKIP: updates * perl-Glib.spec.in: new scheme that addresses x86_64 problems found by Carl Nygard 2004/10/20 19:32 (+0200) kaffeetisch * GParamSpec.xs, e.t: Add and test support for GParamSpecUnichar. 2004/10/17 12:27 (+0200) kaffeetisch * doctypes: Add a description for gunichar. 2004/10/14 15:27 (-0400) muppetman * Makefile.PL: use PREREQ_PM in both WriteMakefile calls, so META.yml gets created properly. 2004/09/27 09:35 (-0400) muppetman * README, NEWS, Glib.pm: stable release 1.061 2004/09/19 23:31 (+0200) kaffeetisch * GBoxed.xs: Use gperl_format_variable_for_output when croaking in the unwrap function. * GType.xs, Glib.xs: Fix two signedness issues. * MakeHelper.pm: Print an ellipsis after "Including ApiDoc pod" to indicate that it might take some time to comlete. 2004/09/11 15:23 (-0400) muppetman * README, NEWS, Glib.pm: stable release 1.060 * Makefile.PL: remove the "unstable" warning. 2004/08/29 14:19 (-0400) muppetman * README, NEWS, Glib.pm: unstable development release 1.055 2004/08/27 17:44 (-0400) rwmcfa1 * GenPod.pm: kaffee was seeing include failures which resulted in the carp message comming out, but it was using $_ where it should of been $pod which caused a second level of errors which were fatal. 2004/08/27 13:42 (-0400) rwmcfa1 * GenPod.pm: preprocess_pod wasn't being called on each pod section as it used to be and still should be. couldn't get to sfcvs webui to find out when it quit being, but it's been a while. 2004/08/15 17:33 (-0400) muppetman * README, NEWS, Glib.pm: unstable development release 1.054 2004/08/13 22:14 (-0400) muppetman * GenPod.pm: fix typo in doc 2004/08/06 21:10 (-0400) rwmcfa1 * GenPod.pm: get the types from signals prototypes and properties so their enum values will be listed at the bottom of the pod. (this is in addition to the xsubs and explicit stuff already in place) 2004/08/01 21:10 (-0400) muppetman * README, NEWS, Glib.pm: unstable development release 1.053 2004/08/01 17:58 (+0200) kaffeetisch * MakeHelper.pm: Move select_files_by_version and read_source_list_file from Gtk2's Makefile.PL here so that other modules can use them too. Also add Ross' cool "evenification" hack to select_files_by_version. * gperl.h, typemap: Add a char_own typemap. 2004/07/18 21:00 (-0400) muppetman * README, NEWS, Glib.pm: unstable development release 1.052 2004/07/18 21:00 (-0400) muppetman * GObject.xs: one last bug; always prefer to create the key with an underscore in its name. this preserves the semantics of the old property stuff from Glib::Object::Subclass::SET_PROPERTY(), although it means we'll always try twice on keys with no dashes. * Subclass.pm: remove the CHECK block (and the associated bugs) by changing how Subclass works. we now rely on the new default property handlers, and thus have no further need for GET_PROPERTY() and SET_PROPERTY(); by prepending Glib::Object::Subclass to the new class's @ISA, we can inherit new() normally. tested extensively in my sandbox and a couple of people reported that all was well. * t/f.t: yes, it's bad form to change the tests to fit the code, but this test was verifying old behavior that we can't produce any longer, and which was actually quite annoying in practice. verify the new semantics. 2004/07/12 20:42 (+0200) kaffeetisch * typemap: Make the OUTPUT variant of T_GPERL_GENERIC_WRAPPER do the same as the INPUT one -- that is, strip leading "const"'s and trailing asterisks from the type. 2004/06/28 00:47 (-0400) muppetman * Glib.pm, README, NEWS: unstable development release 1.051 2004/06/28 00:40 (-0400) muppetman * GType.xs: document the new property stuff. 2004/06/28 00:27 (-0400) muppetman * GValue.xs: handle undef gracefully in gperl_value_from_sv(); let the GValue default. 2004/06/28 00:17 (-0400) muppetman * GObject.xs, GType.xs, t/f.t: add new semantics for Glib::Object properties. when no GET_PROPERTY or SET_PROPERTY is defined, fall back to using the key in the wrapper hash with the same name as the property; also allow creation of properties with explicit getter and setter functions, which override [SG]ET_PROPERTY and the fallback. discussion of the ideas here is archived in the mailing list: http://mail.gnome.org/archives/gtk-perl-list/2004-June/msg00091.html 2004/06/21 22:15 (-0400) muppetman * Glib.xs: fine-tune gperl_format_variable_for_output(); don't truncate references, and disambiguate undef. 2004/06/08 21:55 (-0400) muppetman * AUTHORS, GLog.xs, GObject.xs, GParamSpec.xs, GType.xs, Glib.xs: patch from Albert Chin keeps us honest in ANSI/C89 compatibility, to allow compilation on IRIX. C++ comments are not allowed in C files (some were on dead code, so i just removed them in applying the patch); and C89 doesn't allow for non-static member initialization (the FOO_TYPE_BAR macros usually evalulate to function calls, so we have to do the param_types arrays the hard and ugly way.) 2004/06/02 13:41 (-0400) muppetman Unstable development release 1.050 * NEWS: updated. 2004/06/02 13:41 (-0400) muppetman * GParamSpec.xs: cast to hush compiler warning. 2004/06/01 11:44 (-0400) muppetman * GParamSpec.xs: remove stray debugging print 2004/06/01 11:18 (-0400) muppetman Greatly expanded GParamSpec support. * GParamSpec.xs: use attached-magic wrapper hashes and a GType registry for GParamSpecs. Previous releases used blessed scalars for Glib::ParamSpec and a list of simple hashes from Glib::Object::list_properties; but they really should've been the same object. this code puts the keys from the old simple hashes into the magical wrapper hash now used for all Glib::ParamSpecs, to retain backwards compatibility. we also add accessors for all of the interesting members of the various GParamSpec child structures. this allows you to get the extended metadata from paramspecs, such as default or minimum values, etc. Glib::ParamSpec->param is now supported, making it possible to use Glib::Object's notify signal. lots of new manpages for the various param spec types, consolidated where possible. * gperl.h, Glib.exports: add new external function, gperl_param_spec_package_from_type(). * GObject.xs: use the new and improved newSVGParamSpec() instead of creating a plain hash. * GType.xs: search through the paramspec type registry in gperl_package_from_type(). register more fundamental types on boot, with a nasty hack to correct the old mispelling of Glib::UInt (was "Glib::Uint") with some semblance of backwards compat; use the new correct name, but silently allow the old incorrect name. * Glib.pm: update docs to reflect the type registration differences. * MANIFEST, t/e.t: new test for all this new stuff 2004/05/31 21:05 (-0400) rwmcfa1 * GenPod.pm: add the type (flags|enum) back to the heading 2004/05/31 23:10 (+0200) kaffeetisch * GObject.xs (CLONE): Remove unused variable. * GType.xs: Document the interfaces keyword of register_object. 2004/05/31 15:11 (-0400) rwmcfa1 * GenPod.pm: reworked flags/enums code, added autodetection based on return and param types. so all pod files should now docuement the flags/enums used within them as returns and/or parameters. 2004/05/16 17:44 (-0400) rwmcfa1 * GObject.xs: code to allow gobject tracking which and threadsafeness. needs lots of testing, documentation, and needs a way to tell if thread support was compiled into perl. right now it's enabled (if compiled in) by calling Glib::Object->set_threadsafe. 2004/05/16 11:25 (-0400) muppetman * GObject.xs: disable stash caching. this fixes a few bizarre things that go wrong when using perl threads; different threads have separate copies of the stashes, but the caching kept only one copy, which had a tendency to be incorrect in at least one thread. to avoid an ABI break, we just look up the stash in gperl_object_stash_from_type() every time, and save a pointer on every registered object class. 2004/05/16 01:44 (-0400) muppetman * GObject.xs: add missing Glib::Object::notify(). 2004/05/11 19:35 (+0200) kaffeetisch * GClosure.xs: Fix a debug message. * GValue.xs: Adjust the apidocs for gperl_sv_from_value to match the implementation. * gperl.h * Glib.xs: Implement and export new helper function gperl_format_variable_for_output. * GObject.xs: Use the new helper in gperl_get_object_check to output a stringified version of the variable. 2004/05/04 18:11 (-0400) muppetman * t/1.t, t/2.t, t/3.t, t/4.t, t/5.t, t/6.t, t/7.t, t/8.t, t/9.t, t/a.t, t/b.t, t/c.t, t/d.t: add some commentary to explain what's going on in each test. there's a lot of duplicated testing, so we probably need to rework them at some point. 2004/04/21 12:36 (-0400) muppetman * GSignal.xs: remove invalid alias do_stuff_by_func(). 2004/04/14 19:50 (+0200) kaffetisch Merge from the stable-1-04 branch: * NEWS: Update. * typemap, GBoxed.xs: use INT2PTR to hush warnings about improper casting on cygwin. * GError.xs: Mark unused variables. * Glib.xs: Use explicit casts in the version checking part of the BOOT code. * GenPod.pm: document the __hide__, __gerror__, and __function__ modifiers for the apidoc directive. Add $MAIN_MOD to the head of the see alsos list if it's set, so that the generated pages link to the correct extension. Clean up the semantics of the copyright generation stuff, and make the docs a little clearer. * MakeHelper.pm: set $Glib::GenPod::MAIN_MOD with the module name in Glib::MakeHelper::postamble_docs_full, either from the depends object or the NAME key. * GenPod.pm * Glib.pm * MakeHelper.pm * ParseXSDoc.pm: Fix a spelling error here, adjust some grammar there. * t/8.t * GClosure.xs: don't clobber $_ when warning of unhandled exceptions. apparently the SAVE_DEFSV trick from a while back doesn't work. * Subclass.pm: beef up the docs. 2004/04/05 23:33 pcg * Glib.xs: gperl_sv_from_filename didn't check the return status of g_filename_to_utf8 properly, causing segfaults on invalid filenames. 2004/04/04 00:52 (-0500) muppetman * Glib.xs: actually do work in filename_from_unicode(). thanks to Jan Hudec for noticing this was broken. 2004/03/21 00:00 (-0500) muppetman merge from stable: * GMainLoop.xs, GObject.xs: bump version check versions * GUtils.xs, t/1.t: add Glib::GET_VERSION_INFO * GenPod.pm: sort the index * MakeHelper.pm: fix broken quoting 2004/03/17 17:09 (+0100) kaffeetisch * gperl.h (SvGObject_ornull): Use SvOK instead of SvTRUE. * gperl.h * typemap: Add typemaps for "const char_ornull *" and "char_ornull *". 2004/03/13 22:05 (-0500) muppetman * MakeHelper.pm: portability fixes; ask Config what make program we're using and generate the proper conditional syntax, lest we generate bogus makefiles. we now work with Gnu Make and NMake. 2004/03/12 16:00 (-0500) muppetman * Glib.pm, Makefile.PL, README: 1.04 will be released from the stable-1-04 branch; bump HEAD's version to 1.050. 2004/03/11 23:15 (-0500) muppetman * Glib.exports: sort the list, to make it easier to spot missing symbols. add missing symbols. * GBoxed.xs: fix dubious logic in parameter test. * Glib.pm: give propers to kaffee 2004/03/11 21:51 (-0500) muppetman * README: minor fixups. 2004/03/10 11:30 (-0500) muppetman D Changes M MANIFEST remove the grossly-out-of-date and unused Changes file. 2004/03/08 23:52 (-0500) muppetman FIXME sweep: * GMainLoop.xs, GType.xs: cleanup and commentary * GObject.xs, t/5.t: make the 'bad property' message from set() match the one from new(). clean up properly before croaking if new() encounters a bad property name. verify this behavior with tests. * GParamSpec.xs: fix ALIAS on param_spec/boxed/object to remove invalid symbol; document the fact that param_spec is unimplemented. * GValue.xs: fix a nasty bug in gperl_value_from_sv that would've resulted in a segfault when trying to read the C pointer out of an SV containing a GParamSpec; implement the other direction in gperl_sv_from_value. there's currently no way to trigger these in Glib or Gtk2, but it would be conceivable to run across GParamSpec properties in other GObject-based bindings, so we don't want to barf on them. * GenPod.pm: rework and simplify internal function podify_see_alsos() * t/9.t, t/a.t: use version guards on tests that suffer from GLib bugs that are now fixed. * TODO: updated 2004/03/07 23:54 (-0500) muppetman * GenPod.pm: don't add L<> around items that already have it in podify_see_alsos 2004/03/07 03:33 (-0500) rwmcfa1 * GenPod.pm, ParseXSDoc.pm: added support for the __gerror__ keyword on =for apidoc lines. to be used at a latter date. 2004/03/05 00:28 (-0500) muppetman * Makefile.PL: add version checks to the import attempts for our black-sheep ExtUtils modules; more recent versions actually support the version checks. * MakeHelper.pm: use almost excessive validation to detect whether ExtUtils::Depends is of sufficient vintage, and bail out if not, using the same trick as Makefile.PL to coax CPAN into updating. 2004/03/04 09:52 (-0500) muppetman * MakeHelper.pm: fix a bug in the MY::const_cccmd override which rendered makefiles broken and useless when there were no C or XS files to compile. * Makefile.PL: install the MakeHelper manpage. 2004/03/02 20:59 (-0500) rwmcfa1 * Glib.pm: alter the behavior of read only/write only tied properites. setting a read only croaks, reading a write only returns '[write-only]'. shouldn't affect anything/anyone, just make things work a little better with Dumper and stuff like that. * GObject.xs: doc changes ^ 2004/03/02 00:42 (-0500) muppetman * README, Glib.pm, NEWS: API-frozen unstable release 1.038 * GMainLoop.xs: change version guard on g_main_depth() to 2.3.5, which was released today; minor cleanup and doc. 2004/03/01 12:17 (-0500) rwmcfa1 * GMainLoop.xs: g_main_depth bound as Glib::main_depth (ver 2.4) 2004/02/27 22:12 (-0500) muppetman * GClosure.xs, GLog.xs, GMainLoop.xs, GType.xs: short descriptions for the NAME sections 2004/02/27 14:38 (-0500) rwmcfa1 * GenPod.pm: mystery solved, Exporter needed quotes around it in the use base call. as to why it died the way it was with "Unknown error" i don't yet know, looking into it. use stict is now uncommented, and this issue is closed so far as Glib is concerned. 2004/02/27 13:58 (-0500) rwmcfa1 * GenPod.pm: use warnings now used. Also turned on strict to get rid of all of it's complaints, but even after all of them are gone it dies with Unknown error, so use strict is commented out. lots and lots and lots of warnings fixed, some of which were flat out bugs. one of which was user visible, SEE ALSO's was wrong. 2004/02/27 02:00 (-0500) muppetman * Glib.pm, README, NEWS: unstable release 1.037 2004/02/26 10:16 (-0500) muppetman * t/1.t: correct the skip count. bad muppet. 2004/02/26 21:45 (-0500) muppetman * README: fix the spelling of license; update the sandbox instructions. * GUtils.xs, t/1.t: add more pod than code. enable, document, and test various utility functions (get|set_application_name, get_user_name, get_real_name, get_tmp_dir, get_home_dir). * Glib.xs: correct the semantics of the boot-time version check 2004/02/26 22:59 (+0100) kaffeetisch * GError.xs: Mark 'file' unused to hush compiler warnings. * Glib.xs: Remove debug prints. * ParseXSDoc.pm: Check if $firstline is defined before accessing it to hush some warnings. 2004/02/25 19:28 (-0500) rwmcfa1 * ParseXSDoc.pm, GenPod.pm, GBoxed.xs, GError.xs, GMainLoop.xs, GParamSpec.xs, GType.xs: =pod position= -> =for position some pod parsers don't like text after =pod. 2004/02/25 15:21 (-0500) rwmcfa1 * GObject.xs: use new positioning pod mech. use #if 0 trick to get tie_properties to act like a real method * MakeHelper.pm: extra =back removed * GBoxed.xs, GError.xs, GMainLoop.xs, GParamSpec.xs, GType.xs: use new positioning pod mech. * GenPod.pm, ParseXSDoc.pm: new positioning pod mech put in place 2004/02/23 17:05 (-0500) muppetman * GError.xs: allow '' as well as undef when an SV into a GError, as $@ is usually '' to say 'no error'. 2004/02/23 15:16 (-0500) rwmcfa1 * t/1.t: versions could be 0, which would fail before, check for defined. 2004/02/23 14:38 (-0500) muppetman * ParseXSDoc.pm: add hidden pods to the list of things to ignore when checking if a package is empty; this keeps from clobbering the pod in Glib.pm with Glib.pod, among other things. 2004/02/23 01:37 (-0500) muppetman * GClosure.xs: don't clobber $_ * GenPod.pm: if an xsub is marked as a function, generate a function's signature for it. * GUtils.xs: mark the functions as functions. * GSignal.xs: =arg -> =for arg * GError.xs, gperl.h: add the ability to register new error domains and throw Glib::Errors from Perl. New utility function, Glib::Error::matches, makes it easy to test errors. New xs utility function for parsing a perl data structure into a GError. * t/d.t: bunches of new tests for the new Glib::Error features. 2004/02/22 21:44 (-0500) rwmcfa1 * GSignal.xs: =arg -> =for arg, apidoc error/type-o fixed. * GUtils.xs, t/1.t: implemented CHECK_VERSION and friends with the same scheme that went into Gtk2 eariler today. * ParseXSDoc.pm: changed hide_hidden -> preprocess_pod. it now looks for the __function__ keyword. changed the way these keywords are recorded, they now go into xsub keys. * GenPod.pm: use the above by looking for the function key in xsubs and proceeding accordingly. 2004/02/22 15:26 (-0500) rwmcfa1 * GenPod.pm: removed warning about xsubs with no args, as they're perfectly legal, and there are now some. 2004/02/22 12:48 (-0500) rwmcfa1 * GenPod.pm: method sorting implmented with suggestions from Marc and Peter. 2004/02/20 01:18 (-0500) muppetman * Glib.pm, README, NEWS: unstable release 1.036 2004/02/19 12:50 (+0100) kaffeetisch * Glib.xs (gperl_alloc_temp): Return NULL and complain loudly if the number of bytes is not greater than 0. 2004/02/19 01:18 (-0500) muppetman * Glib.pm, GError.xs, TODO: documentation updates. 2004/02/18 01:35 (-0500) muppetman A GError.xs A gperl-gtypes.h A gperl-gtypes.c A t/d.t M MANIFEST M Makefile.PL M Glib.exports M Glib.xs M Glib.pm M gperl.h change gperl_croak_gerror() to turn GErrors into exception objects. the objects overload the stringify operator to be indistinguishable from normal exceptions, resulting in no API change for old code. gperl_croak_gerror()'s prefix argument is now useless, and has been renamed to ignore, but not removed (to retain ABI and source API compatibility). add gperl_register_error_domain(), and use it for built-ins. doing this properly requires GEnum GTypes for the error code enums, which are not provided by GLib, so we provide just the relevant ones in private files which can be recreated in the future as needed. 2004/02/18 01:31 (-0500) muppetman * ParseXSDoc.pm: quell some doc messages unless NOISYDOC is set in the environment. 2004/02/17 15:32 (-0500) muppetman * GBoxed.xs, GObject.xs, GParamSpec.xs, GSignal.xs, GType.xs, GUtils.xs, GValue.xs, Glib.pm, Glib.xs, MakeHelper.pm, Makefile.PL, Subclass.pm, gperl.h, typemap: update copyright notices; add 2004 to the stuff that has been modified this year. * GenPod.pm: add time_t to %basic_types. 2004/02/12 19:00 (-0500) muppetman * Glib.pm, Makefile.PL, README, NEWS: unstable release 1.035 2004/02/10 01:37 (-0500) muppetman Some infrastructure changes allow us to enhance the quality of generated POD. * GenPod.pm: add a way to add entries to %basic_types at runtime. * MakeHelper.pm: add postamble_docs_full(), and use it to implement postamble_docs(). the new one takes parameters by name, and does a lot more cool stuff than the old one. this allows us to make it easier to set $Glib::GenPod::COPYRIGHT, provides a way to get filenames through to Glib::GenPod::add_types(), and provides a more extensible API for future expansion. * Makefile.PL: use Glib::MakeHelper->postamble_docs_full() instead of postamble_docs(). copyright information comes from new file copyright.pod, and we use and install the new file doctypes, which adds type mappings for stuff that isn't registered with the Glib type system. A doctypes A copyright.pod M MANIFEST add copyright.pod and doctypes * README: bump version requirement for ExtUtils::Depends. 2004/02/09 08:09 (-0500) rwmcfa1 * GObject.xs: needed version guards around the interface_properties stuff b/c it's new to 2.3.x. 2004/02/08 15:16 (-0500) rwmcfa1 * GObject.xs, GenPod.pm: list_properties extended to be able to handle interfaces. since interfaces don't inherite from GObject Glib::Object::list_properties ($package) is required for it to work on an interface. GenPod was updated to call list_properties this way. 2004/02/08 00:05 (-0500) rwmcfa1 * GParamSpec.xs, t/b.t: added GParamSpec->scalar, and tested it. 2004/02/08 20:46 (-0500) muppetman * Glib.pm, README, NEWS: unstable release 1.034 * GenPod.pm: add bool and CV to %basic_types. 2004/02/07 02:22 (-0500) muppetman * GType.xs: add the ability to add GInterfaces to new GObject types with register_object. new key interfaces => \@list, where @list is a list of package names. effectively does foreach (@list) { $_->_ADD_INTERFACE ($newtype); }, where the _ADD_INTERFACE method is supposed to do the actual work of adding and initializing the interface implementation. 2004/02/05 21:10 (-0500) muppetman * GType.xs: rework _INSTALL_OVERRIDES handling one more time. rather than have a mess of inherited methods which chain up, Glib::Type::register_object looks for _INSTALL_OVERRIDES in all classes of the new type's ancestry, calling it if found. this allows proper overriding behavior and lets us add vfunc implementations without requiring changes to all client code. Glib::Type::register_object now *always* instantiates the class upon registration, to avoid problems with it maybe or maybe not existing later. we also leak the reference to avoid the class needing to be recreated, since we can't properly recreate it later, and perl doesn't let classed die in normal circumstances, anyway. * Glib.pm: add G_PARAM_READWRITE to the list of exportable constants. * Glib.xs: better message? 2004/02/05 13:38 (-0500) rwmcfa1 * GObject.xs: fixed apidoc on ... param of Glib::Object->new 2004/02/04 23:44 (-0500) muppetman * GObject.xs, GValue.xs: perl's IV is supposed to be as big as a pointer, so we can't use glib's GINT_TO_POINTER family of casts, because they'll truncate the IV on a 64-bit platform. use the INT2PTR family of macros from the Perl api. this is important for G_TYPE_POINTER GValues and g_object_[sg]et_data, for which we use IVs to represent the pointer values. * t/2.t: add some tests to ensure that we're handling int <=> pointer conversions correctly, and that we can store pointers in object data. as a side-effect, the test verifies that our unique hash wrappers work correctly, as well. 2004/02/04 19:09 (-0500) rwmcfa1 * Glib.xs: implemented linked version checking in BOOT section 2004/02/04 20:19 (+0100) kaffeetisch * gperl.h, Glib.xs: Add the new helper "object" GPerlArgv that encapsulates everything related to argv parsing and thus simplifies the various init xsubs. 2004/02/04 02:33 (-0500) muppetman * GBoxed.xs, GObject.xs, GType.xs: GType is not a guint, it's a gulong; therefore, GUINT_TO_POINTER/GPOINTER_TO_UINT are not valid for GTypes. use direct casts, instead. this fixes nasty problems on alpha. thanks to Mark Brockschmidt for finding the bug and loaning me machine time to solve it. 2004/02/04 01:21 (-0500) muppetman * GType.xs: call method _INSTALL_OVERRIDES on newly registered Glib::Object subclasses, to allow the new types an opportunity to install vfunc overrides. This method will typically be provided by the class which introduces the vfuncs, and will install implementations which marshal to inheritable perl methods. Do nothing if no such method can be found; not all classes have pure vfuncs. 2004/02/03 00:57 (-0500) muppetman * GType.xs: remove debugging print * GenPod.pm: add 'unsigned' to list of built-in mappings * t/9.t, t/a.t: add mipsel, mips, and alpha to the list of 64-bit platforms on which to skip tests which exercise glib bugs. 2004/01/30 22:36 (-0500) muppetman * Subclass.pm: pass all unknown import parameters through to Glib::Type->register_object. bump version. 2004/01/29 20:03 (-0500) rwmcfa1 * Glib.pm, README: unstable release 1.033 * NEWS: updated 1.032 isn't going public, was a test failure with no DISPLAY in Gtk2 2004/01/29 18:44 (-0500) rwmcfa1 * Glib.pm, README: unstable release 1.032 * NEWS: updated 2004/01/27 11:44 (-0500) rwmcfa1 * ParseXSDoc.pm, GenPod.pm: added a new =for type, see_also which allows for appending things to see onto the end of the apidoc autogenerated SEE ALSO sections, much desired/asked for feature. code added to ParseXSDoc to find them and GenPod to use them. 2004/01/27 10:44 (-0500) rwmcfa1 * MakeHelper.pm: provide a mechinism for over-ridding the global variables in GenPod. * GenPod.pm: doc how to go about over-ridding the global vars. 2004/01/25 03:44 (-0500) muppetman * Glib.pm, README: unstable release 1.031 * NEWS, MANIFEST.SKIP: updated 2004/01/25 01:00 (-0500) muppetman A NEWS M MANIFEST add a file to summarize changes * GObject.xs: add freeze_notify and thaw_notify. * GenPod.pm: add gshort and gushort to %basic_types, and FIXME notice on %basic_types to remind me that it needs to be extensible. remove the gchar=>integer mapping, since it conflicts with gchar=>string (the * is implied, you see) * Glib.pm: add exportable constants under a 'constants' tag. 2004/01/24 21:44 (-0500) rwmcfa1 * MakeHelper.pm: added dist-srpms target, removed doc refering to runtime_reqs as it has been replaced by the pkg-config trick * Makefile.PL: removed runtime_reqs stuff, replaced by the pkg-config trick * perl-Glib.spec.in: use pkg-config for Requires version 2004/01/22 09:44 (-0500) rwmcfa1 * MakeHelper.pm: and i thought i was done. don't know what i was thinking with the last one, laying in bed sleepless last night the problem came to me. this is another attempt at a solution. this one will work, but depends on makefile conditionals which may not be as portable as i would like. also a fix to prevent the mkdir change from a while ago from happening everytime make is done. 2004/01/21 20:56 (-0500) rwmcfa1 * MakeHelper.pm: yet another attempt at completely clearing up the issues with the -jx make option and not having the doc rebuild at every single make invocation. uses blib_done file, which depends on all of the @xs_files. hopefully this will do it, i'm about out of ideas. bascially MakeMaker sucks if you're tyring to do stuff this complicated with it. with plain old make this wouldn't be an issue at all, but with the hooks we're given this is not going to be easy. 2004/01/21 15:14 (-0500) muppetman * ParseXSDoc.pm: allow space padding on either side of the arguments in the xsub declaration. also make the error messages more digestable (by removing the __WARN__ handler, was for debug only). 2004/01/21 14:57 (-0500) rwmcfa1 * MakeHelper.pm: we need to create the directory in which index.pod will be placed under certian circumstances. this doesn't affect any of Gtk2-Perl, but some modules (with certian structures) will cause problems that creating the directory if need be will address. 2004/01/16 18:38 (-0500) rwmcfa1 * typemap: added types for gshort and gushort, patch by kaffee 2004/01/16 11:09 (-0500) rwmcfa1 * MakeHelper.pm: BLIB_MOD_EXIST -> BLIB_DONE. and set equal to something that 'seems' to ensure that blib has completed. fixes -j make build problems. 2004/01/16 00:23 (-0500) muppetman * README: unstable release 1.030 * README, Makefile.PL: add emphasis of the unstable nature of this series. 2004/01/16 00:02 (-0500) muppetman A GUtils.xs * MANIFEST, Makefile.PL, Glib.xs: add GUtils.xs, with version information functions. * ParseXSDoc.pm: don't complain about empty argument lists -- they are legal on pure functions. * AUTHORS: updated. 2004/01/15 22:08 (-0500) muppetman * Glib.xs, Glib.pm: restore the prototypes on filename_to_unicode and filename_from_unicode, to allow proper support for the function and static method calling conventions. thanks to cxreg in irc for reminding me that it would work. also add initial implementations of filename_to_uri and filename_from_uri, also callable as pure functions and class methods. as currently implemented, there are issues with utf8 handling, but i don't quite know how to resolve them. make Glib be a full Exporter, so we can add these pure functions to @EXPORT_OK and %EXPORT_TAGS. update the docs accordingly. 2004/01/15 14:31 (-0500) muppetman * GenPod.pm: name mapping for GPerlFilename_const * gperl.h, typemap: add typedef and input typemap for GPerlFilename_ornull * GType.xs, gperl_marshal.h, t/7.t, t/8.t: preserve $@ across closure invocations. * GSignal.xs: add words of warning to documentation 2004/01/14 10:59 (-0500) rwmcfa1 * GObject.xs: added pod documentation for tie_properties 2004/01/14 00:21 (-0500) muppetman * GBoxed.xs, GType.xs, GValue.xs: more spots where we should use GINT_TO_POINTER and friends * t/9.t, t/a.t: skip tests that exercise glib bugs on x86_64; we need version API in the bindings to do this correctly. 2004/01/13 22:41 (-0500) muppetman * AUTHORS, Glib.xs, GObject.xs, GType.xs, typemap: applied patch (with extra fuzz) from Jacek Konieczny to clean up warnings on 64-bit platforms. 2004/01/13 22:20 (-0500) muppetman * ParseXSDoc.pm: support continuation lines in xsubs. this borks line number handling, and is far more permissive than xsubpp, but xsubpp will be the thing that causes people's code to break, and to do the line number handling correctly would require far too much code tearup. also, honor __hide__ correctly on =for apidoc comments that supply a symbol name (by removing the end-of-line anchor from the regex). 2004/01/09 14:33 (-0500) rwmcfa1 * AUTHORS: mailing list addr correction. 2004/01/08 21:22 (-0500) rwmcfa1 * Glib.xs: bit the bullet and made filename_to_unicode and filename_from_bullet work with either :: or -> syntaxes. * Glib.pm: doc'd ^ as using the -> syntax. there was great discussion on the list about this issue (in a more general sense) bascially early on the decision/mandate was made that the -> syntax was to be used everywhere. right or wrong it's to late change now that stable stuff has hit the world. the above functions work either way, so we're safe. 2003/12/31 02:03 (-0500) muppetman * GValue.xs: paranoia -- check for sv==NULL before passing to SvOK. 2003/12/30 11:49 (-0500) rwmcfa1 * GenPod.pm, MakeHelper.pm, Subclass.pm: added version numbers 2003/12/30 10:12 (-0500) rwmcfa1 * MakeHelper.pm: moved the const_cccmd to the bottom of the file so that the first package isn't MY (caused issues with CPAN and generally wasn't a good idea.) Also converted the comment about it into a pod NOTICE so that people will be aware that it's being added. 2003/12/29 16:32 (-0500) rwmcfa1 * MakeHelper.pm: added DATE to the list of replacements, in a format that rpm is happy with * perl-Glib.spec.in: use the new DATE replacement in conjunction with VERSION to create the changlog on the fly, which is better. 2003/12/23 23:40 (-0500) muppetman * typemap: ouch, there was a typo in the T_GCHAR_ORNULL output typemap, resulting in unknown variable errors. 2003/12/23 00:52 (+0100) kaffeetisch * typemap: Add typemaps for gsize and gssize. 2003/12/18 13:54 (-0500) rwmcfa1 * MakeHelper.pm: rpms now build in HOME/rpms dir, one change to fix them all. 2003/12/16 22:00 (-0500) rwmcfa1 * GType.xs: warnings fixes, minor (non-problem) bugs 2003/12/16 13:16 (-0500) rwmcfa1 * MakeHelper.pm: the V deps have now been put under a var BLIB_MOD_EXISTS which is set to pm_to_blib now. (1 point of change if need be in the future) 2003/12/15 20:37 (-0500) rwmcfa1 * MakeHelper.pm: added pure_all as a dep on a few things. 2003/12/10 15:18 (-0500) rwmcfa1 * t/c.t: now that the register_enum|flags stuff is fixed, test it out more thoroughly. 2003/12/10 12:45 (-0500) muppetman * Subclass.pm: updated doc * GType.xs: fix memory corruption problem in register_enum and register_flags by duping and leaking the value names. there appears to be no way to clean up that memory, unfortunately. also moved those two xsubs up in the file to appear immediately after register_object in the docs, and added examples to their docs. move the existing register to register_object, since that's all it does. created a new function named register, which acts as a traffic-cop, calling the proper helper function based on the type from which you are attempting to derive. this would've been easier to do in Perl, but then getting the doc into the right place would require a rather large tearup of Glib::ParseXSDoc. * TODO: a few of these are completed, now. 2003/12/10 12:02 (-0500) rwmcfa1 * t/c.t: initial import, tests out the new register_enums|flags code 2003/12/09 13:26 (-0500) rwmcfa1 * GType.xs: another pass at getting things going. created sanitize_package_name, used it where app. 2003/12/08 22:44 (-0500) rwmcfa1 * GType.xs: implemented first pass at register_enum and register_flags 2003/12/08 11:08 (-0500) muppetman * GenPod.pm: add default translation for stdio FILE => "file handle" 2003/12/08 09:44 (-0500) rwmcfa1 * t/6.t: use strict and warnings, b/c newer Test::More do anyway, required a few minor syntax changes to work. 2003/12/04 13:07 (-0500) rwmcfa1 * MakeHelper.pm: @ARGV is now searched for disable-apidoc which, surprise, disables the generation of the api doc pods thus speeding up the build process. 2003/12/04 00:12 (-0500) muppetman * Glib.pm: credit where credit is due * Glib.pm: bump version to 1.030 to keep cvs head ahead of the stable series. 2003/12/02 23:49 (-0500) rwmcfa1 * : Merged from rel-1-02-branch * GenPod.pm: implement a sorter function that pushes GObject based pkgs to the front, instead of alpha. this is so that all classes will be instantiaed (sp?) by the time we do the interfaces. 2003/12/02 18:30 (-0500) muppetman * t/b.t: inexplicitly missing a test 2003/12/02 18:30 (-0500) muppetman * GType.xs: base_init support for perl-derived GObjects. during class initialization, invoke the method INIT_BASE in the object's package if it exists. see http://lists.gnome.org/archives/gtk-\ perl-list/2003-November/msg00194.html (and indeed the rest of that thread) for discussion. * t/6.t, MANIFEST: test the base_init stuff by ensuring multiple derivation works as expected. 2003/12/02 18:26 (-0500) muppetman * GParamSpec.xs: stray code in a switch statement prevented the successful operation of Glib::ParamSpec->object(). 2003/12/01 16:21 (-0500) rwmcfa1 * GenPod.pm: put an extra \n after each of the pods to keep pod stuff happy 2003/11/29 12:45 (-0500) muppetman * Glib.pm, README: bump version to 1.013, make release from rel-1-02-branch. 2003/11/29 12:23 (-0500) rwmcfa1 * GenPod.pm: modified copyright text as list decided. 2003/11/28 22:00 (-0500) muppetman * GType.xs: remove unused var and code. * Glib.xs: apparently this bit of doc has been b0rken for a very long time. 2003/11/28 14:47 (-0500) rwmcfa1 * ParseXSDoc.pm, GenPod.pm: moved inclusion processing into GenPod rather that ParseXSDoc, it will need to be run later than parse. * MakeHelper.pm: DOC_PL_DEPENDS is now POD_DEPENDS, related to ^ 2003/11/25 12:02 (-0500) muppetman * GType.xs: clean up some odd leaks; use proper contexts in the signal accumulator and custom class closure. 2003/11/25 11:39 (-0500) rwmcfa1 * GType.xs, devel.pod: link correction * GenPod.pm: added parents return from list ancestors. use it for podify_see_alsos, which is new. and added get_copyright * Glib.pm: removed reference to old Glib::PkgConfig * MakeHelper.pm: added new DOC_PL_DEPENDS var, should prove useful for includes * ParseXSDoc.pm: added include system =for include file, =for include !cmd 2003/11/24 23:35 (-0500) rwmcfa1 * Makefile.PL, MakeHelper.pm: clean up and resolution of issues about xsapi.pod. 2003/11/21 02:12 (-0500) muppetman * Glib.pm, README: bump version to 1.012 and release. 2003/11/21 01:00 (-0500) muppetman * GBoxed.xs: implement a generic Glib::Boxed::copy, and some doc * GBoxed.xs, GObject.xs, GType.xs, GValue.xs, typemap: replace SvTRUE() with SvOK() as a more efficient test for definedness. SvTRUE() is rather heavy, in that it evaluates to an awful lot of code, where what we generally need is just to see if the scalar is the Perl equivalent of C's NULL. * GParamSpec.xs: now that there's a gunichar typemap, implement things that were waiting on it. not sure why you'd want a unichar param in perl, but the point is to make it possible. :-) 2003/11/19 14:08 (-0500) muppetman cleanup for win32: * GType.xs: hush some warnings from msvc * MakeHelper.pm: if we're using cl, use its weird command switch to put the object files in the right place... /Fo * Glib.exports: added some missing symbols 2003/11/18 17:21 (-0500) muppetman * Glib.xs: use GPerlFilename_const in the right place to hush the compiler. also use the length returned from g_filename_(to|from)_utf8 to avoid having to call strlen() in gperl_sv_from_filename and gperl_filename_from_sv. 2003/11/18 01:09 (-0500) muppetman * GType.xs: interfaces can have signals as well; adjust logic to allow them through as well. this still misses some signals because on 2.0.x we don't have a way to list interfaces' prerequisite types to ensure that they are loaded. the beginnings of code to use g_type_interface_prerequisites() in 2.2.x is commented out, waiting for me to finish it. * ParseXSDoc: handle length() arguments in xsubs. they basically just get stripped. * GenPod.pm: 'gchar_length' means 'string'. * typemap: a corresponding OUTPUT typemap for gunichar. 2003/11/17 22:02 (+0100) kaffeetisch * typemap: Implement a gunichar INPUT typemap. 2003/11/16 20:32 (-0500) muppetman * gperl_marshal.h: add similar macros for GPerlCallback, to make sure that the callback is executed by the correct interpreter. * GClosure.xs: use the new GPerlCallback helper macros in gperl_marshal.h 2003/11/16 02:44 (-0500) muppetman * GClosure.xs, GType.xs: clean up the stack properly after call_sv to stop internal bleeding. * TODO: updated 2003/11/14 04:31 pcg * Glib.pm: rework the doc for filename conversion. horribly buggy it still was. 2003/11/13 21:32 (-0500) muppetman * Glib.pm, README: bump version to 1.011 for first 1.02 beta 2003/11/13 13:23 (-0500) muppetman * GenPod.pm: add a sensible type name mapping for GPerlFilename; will show up in docs as 'localized file name'. Fix podify_methods to take only the package name, and remove the second my $package in the same scope. Minor re-work to logic of when to skip and when to count methods; intent was to support hidden xsubs, but those are caught at the parser level now. Changed the message that gets written when all methods are defined but missing. * Glib.pm: fix some typos * Glib.xs: hide filename_(to|from)_unicode from the docgen stuff, to keep from overwriting the manpage generated for Glib.pm. these functions are already documented by hand in Glib.pm, anyway. * ParseXSDoc.pm: allow the token \b__hide__\b on the =for apidoc line to hide an xsub. * GType.xs: fix a little bug in list_values causes segfaults if you pass in type that's neither a flags nor enum type. 2003/11/12 20:45 pcg * gperl.h, typemap: Add GPerlFilename_const. * Glib.xs, Glib.pm: implement and document filename_to_unicode and filename_from_unicode. 2003/11/12 02:48 pcg * gperl.h, Glib.xs, typemap: Implement GPerlFilename type and gperl_filename_from_sv & gperl_sv_from_filename utility functions. 2003/11/11 22:25 (-0500) muppetman * GClosure.xs, gperl_marshal.h: yeah, that wasn't the right way to handle that. i forgot the update the non-PERL_IMPLICIT_CONTEXT side of the #ifdef when adding the second arg. backed out the change to GClosure.xs, fixed gperl_marshal.h. 2003/11/11 10:40 (-0500) rwmcfa1 * GClosure.xs: if PERL_IMPLICIT_CONTEXT is not defined then the call to the macro GPERL_CLOSURE_MARSHAL_INIT has the wrong number of prarameters. there's probably a better way to handle this, buf for now this will allow things to compile. 2003/11/11 00:36 (-0500) muppetman * MANIFEST, debian/*: remove the debian packaging files, since having them in the upstream dist makes it difficult for the maintainers 2003/11/10 13:12 (-0500) muppetman * gperl_marshal.h: new file * GClosure.xs, MANIFEST, Makefile.PL: use and install new file. Since client code may install custom marshallers, it is a good idea to provide some macros to tidy up the error-prone boilerplate that needs to go into each of those marshallers. gperl_marshal.h is installed to the same place as gperl.h, but not #included by default, and should be #included whereever you implement a custom marshaller. it is loaded with commentary and an example marshaller skeleton. * GSignal.xs: update commentary on gperl_signal_set_marshaller_for() to pointer binding authors to gperl_marshal.h for guidance. 2003/11/10 01:54 (-0500) muppetman * GenPod.pm: be a little smarter about enums and flags package names. 2003/11/09 22:59 (-0500) rwmcfa1 * GenPod.pm: improved the logic for placement of the no methods exist message, moved it to podify_methods. 2003/11/09 22:30 (-0500) rwmcfa1 * ParseXSDoc.pm: allow the (Object::To::Doc) construct in =for object directives. * GenPod.pm: support the new object directive allowing files to be named independantly from the objects documented in them. 2003/11/10 00:59 pcg * Glib.pm, GType.pm: implement == and eq for flags, the latter because some functions use eq as a generic comparison function. Also enable fallback for flags values, should work just fine. 2003/11/09 18:54 (-0500) muppetman writing documentation while mechagodzilla and titanosaur destroy tokyo... again. http://us.imdb.com/title/tt0073373/ * GClosure.xs, GLog.xs, GMainLoop.xs, GObject.xs, GParamSpec.xs, GSignal.xs GType.xs: added lots of apidoc pod. All the packages in GMainLoop.xs go into Glib::MainLoop, and i reordered some of the xsubs in GObject.xs but changed no code. * GenPod.pm: pod updates, cleanup; use two =over paragraphs inside xsub docs to make the argument lists indent readably in the generated manpages. * Glib.pm: big updates to the SEE ALSO section. * Makefile.PL: even yet still more cleanup * ParseXSDoc.pm: pod cleanup * TODO: updated 2003/11/09 16:29 (-0500) rwmcfa1 * ParseXSDoc.pm: added the method clean_out_empty_pods to prevent empty entries from the $data member of doc.pl. this prevents completely empty pod files from being created. * GenPod.pm: if no methods are bound to a package then print a message saying it is likely that it doesn't exist in the version the module was compiled against. the message might could stand some improvement. 2003/11/08 12:10 pcg The "more evil things?" release. * GType.xs: Allow |, & and ^ as operators on flags, too. * GType.xs: GFlags are now represented as blessed IV's, which indeed gave a _substantial_ speed improvement at an unimportant place. But it also saves memory and code, and looks nice, so I just had to do it. * GLog.xs: simplify newSVGLogLevelFlags, as excluding single values should no longer be necessary. 2003/11/08 11:30 pcg * GType.xs: In addition to the change yesterday, make sure that gperl_convert_back_flags only ever returns distinct, non-overlapping flag values. This requires an inherent ordering in the flag values, but if this isn't the case we can always sort the values first on bit-count (doh), or use a heuristic such as prefering single bit values. 2003/11/08 01:03 (-0500) muppetman * GClosure.xs: simplify, man... both dSP and the PERL_UNUSED_VAR() should've been outside the conditional. this may need to be macro-ified to prevent bugs in custom marshallers. * Glib.xs, GType.xs, gperl.h: move private function streq_enum to Glib.xs as new public function gperl_str_eq(), string compare that considers dash and underscore equivalent. add gperl_str_hash(), a hashing function that considers dash and understore equivalent. * Glib.exports: updated with new functions * GSignal.xs: use custom hash and compare functions for the signal marshallers hash. * gperl.h: add prototypes for gperl_fundamental_type_from_package() and gperl_fundamental_package_from_type(). * GObject.xs: remove unused var (which was shadowing an already-defined var in the parent scope). 2003/11/07 20:13 pcg * GType.xs: test SvPOK instead of SVt_PV, as many scalars can be valid strings. * GType.xs: apply muppet's patch to bless flags, modified to - implement overloaded operations on flags. - change the flag test from "set & mask" to "set & mask == mask", which hopefully fixes the GdkModifier problem. - since the testsuites of both glib and gtk work fine, as well as my apps, I checked it in (low-risk-patch). * Glib.pm: add overload glue + documentation. * In a second, future step, we might want to replace GFlags by bless(RV(IV)) while keeping the user-api intact. This might break some obscure parts in Gtk2, so... this is a later step that can be done without user-visible-changes. 2003/11/07 12:57 (-0500) rwmcfa1 * GenPod.pm: instead of usings methods trick, use ->can, improves things quite a bit. 2003/11/06 21:29 (-0500) rwmcfa1 * GenPod.pm: using the old methods trick i've come up with a way to only have xsubs pod for package methods that are bound. so ifdef'd out code (stuff that's not available in the compiled against version) won't be put into the pods. one more doc issue down. 2003/11/06 16:53 (-0500) muppetman * MakeHelper.pm: make the pod index have actual links. 2003/11/06 10:30 (-0500) muppetman * ParseXSDoc.pm: handle IN_OUTLIST arguments, which previously got a type of "(!!)". note: still does not handle IN_OUT or OUT args, as i don't have any of those to test. 2003/11/03 14:03 muppetman * GenPod.pm: use the actual instance arg name rather than cutting up the type name. you'd expect the arg name to be used, anyway. 2003/11/03 12:04 muppetman * GType.xs: (list_interfaces) watch out for unregistered interface classes. complain, but don't blow up. also, free the returned array of GTypes. thanks to Bjarne Steinsbø. * AUTHORS: updated contributors 2003/11/02 11:54 muppetman * GClosure.xs: the case of the missing ref; refcount bug in gperl_closure_marshal kept complex objects from finalizing properly. kudos and thanks to marc for finding and debugging this one. 2003/11/02 16:55 muppetman * ParseXSDoc.pm: match void\s* instead of just void when looking for methods with void return. use scalar(localtime) instead of the identical strftime format. 2003/11/02 16:17 muppetman * Glib.pm: undo my silly "atleast" version-check import stuff, and do something compatible with the version check supplied by Exporter. we don't use Exporter because, well, we don't export anything. 2003/11/02 02:15 muppetman * ParseXSDoc.pm: split_aliases wasn't properly deep-copying args arrays. since that's not exactly something that you'd want to do unless you are going to generate docs from the parser results, moved the splitting of aliases from parse_file() to xsdocparse() as canonicalize_xsubs(). 2003/11/01 01:15 muppetman * typemap: input (Perl-to-C) typemap for T_GPERL_GENERIC_WRAPPER now uses a more robust regex -- strip leading const\s+ and ensure that we strip the trailing \s*\* from the very end. requested by kaffee. the output typemap is unchanged. 2003/10/30 13:47 rwmcfa1 * Glib.pm: added tie_properties stuff * t/b.t: initial import, test tie_properties stuff 2003/10/30 11:29 muppetman * GenPod.pm: make sure that all signatures get the same pod directive. don't add sigils to return type names. 2003/10/30 09:30 rwmcfa1 * Glib/MakeHelper.pm: improved/safer rules for building the documentation * Glib/Makefile.PL: we have some 'special' dependancies for Glib that we need to make sure happen before xsdoc2pod can proceed 2003/10/29 02:00 muppetman * Glib.pm: add a version check to Glib's import. * GenPod.pm, MakeHelper.pm: rework package to filename handling to support packages with :: in the name. use FULLEXT (makefile var that is the full extension path under INST_LIB) and File::Spec." * ParseXSDoc.pm: don't clobber package with object; store object separately and use it when retrieving pkgdata, but not in place of the package name. this allows xsubs to be placed into a different package for doc, but not lose their actual package for the symname. 2003/10/28 23:18 muppetman * MakeHelper.pm: don't be an Exporter. take a shift-off class arg on all subs. this allows them to be overridden, and removes the requirement for each client package to import the symbols. added pod for just about everything. do_pod_files now returns the generated pod_files hash rather than fiddling with one in main::. it still uses the local @gend_pods, though. postamble_clean() takes an optional list of extra clean files. postamble_docs() takes a list of xs files instead of expecting to find @main:xs_files. * Makefile.PL: use the new semantics of the MakeHelper functions. 2003/10/28 16:47 rwmcfa1 * Glib/GClosure.xs, Glib/GLog.xs: put things in the appropriate doc object * Glib/GenPod.pm: eval the list_values call. make sure dir creation succeeds, other cleanups * Glib/MANIFEST: missing files added * Glib/Makefile.PL: updates to new system, MakeHelper. use strict and use warnings safe now * Glib/ParseXSDoc.pm: replace the warn handler with what was there before rather than deleting * Glib/MakeHelper.pm: initial import 2003/10/27 29:08 muppetman * Makefile.PL: bad quoting kept the build from working... 2003/10/27 19:29 muppetman * GenPod.pm: move =for enum parsing to the parser. have xsdoc2pod optionally write a list of the packages it has created, use 'unsigned' instead of 'integer' for unsigned data types. fix podify_signals to print nothing if there are no signals. don't call Glib::Type->package_from_cname on types with :'s in them -- they can't be C type names anyway (shuts up about half of the warnings you get doing Gtk2). watch for =arg name (__hide__), and don't display the arg having that keyword. * Makefile.PL, xsdocparse.pl(removed), ParseXSDoc.pm(new): remove the xsdocparse.pl script; the code in is Glib::ParseXSDoc now. having xsapi.pod in %pm_files creates a circular dependency; have to take it out (still in man3pods, and we'll put it into blib by hand). 2003/10/27 02:42 muppetman * Makefile.PL: manpages have the :: in the filename * GParamSpec.xs, GLog.xs, GMainLoop.xs, GSignal.xs: added some apidoc; register enums and flags as necessary; implement g_param_spec_enum and g_param_spec_flags * GenPod.pm: pod, cleanup, lots of things. watch for =for (enums|flags) in package pod and podify their values. change around how we print things to make them a little more visually distinct. 2003/10/26 21:31 rwmcfa1 * GenPod.pm: put the pod files in blib using the fully correct paths and file names * Makefile.PL: merge bug, well that and not looking closely. 2003/10/26 17:10 rwmcfa1 * GObject.xs: test out a blurb * GenPod.pm: xsdoc2pod script incorporated, will make it easier for other modules to use this stuff * Makefile.PL: go ahead and include GenPod.pm in the scheme of things. use GenPod in it's current incarnation to do the api docs 2003/10/26 11:36 muppetman * GSignal.xs: some apidoc comments to play around with * GenPod.pm: sigils don't go in %basic_types, they're added by convert_return_type as needed. count the number of properties we find that match this type, to return an empty string if this type has none of its own. added some developers' pod for the various helper functions. allow 'for' on signature and arg lines. show default argument values in call signatures. * Makefile.PL: install GenPod.pm. its manpage will be nonsense for now. * xsdoc2pod.pl: typo * xsdocparse.pl: split & duplicate aliased xsubs automagically. match up apidoc pods and xsubs. 2003/10/25 21:44 rwmcfa1 * GType.xs: can't call newSVpv if package name is not valid, shouldn't happen so croak on that error. some improved error checking to make sure that we have a valid interface and that our class is instantiatable, may need to double check. * apidoc.pl: get rid of the groups stuff since it's not used * xsdocparse.pl: get rid of the groups stuff since it's not used. * GenPod.pm: initial import added blurb retrieval * xsdoc2pod.pl: initial import 2003/10/24 17:18 muppetman * xsdocparse.pl: new file. program extracts pod and xsub signatures from XS files and dumps a big honkin' data structure to stdout. differentiates between the C section and the xsub section, and looks for a new set of pod directives, e.g. =for apidoc and =for object. this is destined to be the heart of the shiny new automatically generated api reference documentation. more on this later. * apidoc.pl, Makefile.PL: use xsdocparse.pl instead of podselect to extract pod used to build xsapi.pod. * GType.xs: new function Glib::Type->package_from_cname() turns a c type name into registered Perl package name, if found. also added some =for apidoc pod to test out xsdocparse.pl. 2003/10/23 16:04 rwmcfa1 * GType.xs: Glib::Type->list_ancestors, list_interfaces, and list_signals added. with that V commit this starts to bring together some petty powerful magic. 2003/10/23 15:51 muppetman * GType.xs: Glib::Type->list_values ($enum_or_flags_package). also takes a C type name, e.g., "GtkWidgetFlags", in case the type is registered with glib but not with the bindings. * GObject.xs: fix list_properties to allow package names instead of just objects. 2003/10/18 02:36 muppetman * Glib.pm: bump version for devel series * typemap, gperl.h: new typedef and typemaps for the much-needed gchar_ornull. * GLog.xs: use the new gchar_ornull typemap to clean things up a bit. * GType.xs: commentary 2003/10/12 13:42 rwmcfa1 * (most).xs, gperl.h: UNUSED is no more, PERL_UNUSED_VAR used where needed, relies on new ParseXS to prevent the other warnings that were its fault, we now only quite the ones that are ours 2003/10/09 22:23 muppetman * Glib.pm, META.yml, README, debian/changelog: 1.00 * GType.xs: typo in the documentation. 2003/10/03 15:54 muppetman * Glib.pm, META.yml, README, debian/changelog: 1.00rc4 2003/10/02 03:34 rwmcfa1 * Glib.xs: core dumps occur in gperl_croak_gerror when NULL is passed for err, assertion now checks for it. only binding authors would run across this one, but know it will be more ovbious what they've done wrong, speaking from expirence... 2003/10/02 03:13 muppetman * gperl.h: bad nesting of parens in a debugging macro * GClosure.xs: bug in error-handling code in gperl_callback_invoke made it a little hard to track down the fact that a callback was created with the wrong parameter type. 2003/10/01 11:20 rwmcfa1 * Glib/GBoxed.xs, Glib/GLog.xs, Glib/GObject.xs, Glib/GSignal.xs, Glib/GType.xs, Glib/gperl.h, Gtk2/xs/GtkAccelGroup.xs, Gtk2/xs/GtkIconFactory.xs, Gtk2/xs/GtkListStore.xs, Gtk2/xs/GtkObject.xs, Gtk2/xs/GtkToolbar.xs, Gtk2/xs/GtkTreeView.xs, Gtk2/xs/GtkWidget.xs: // comments -> /* 2003/09/26 04:10 muppetman * Glib.pm, META.yml, README, debian/changelog: 1.00rc3 * GClosure.xs: assert that we have a callback before doing anything to it. Clean up a bad comment char. 2003/09/21 20:19 rwmcfa1 * Makefile.PL: fixed bug in specfile generation 2003/09/21 15:03 rwmcfa1 * (lots of files): license updates/additions 2003/09/19 00:21 muppetman * Glib.pm, META.yml, README, debian/changelog, debian/control: updated for 1.00rc2 release * Makefile.PL: there was no version 0.1 of ExtUtils::PkgConfig... 2003/09/17 10:44 rwmcfa1 * Makefile.PL: ExtUtils::PkgConfig can now deal with version requirements using pkg-config's interface, make use of it. * t/6.t: removed, this tested Glib::PkgConfig 2003/09/16 23:50 rwmcfa1 * Makefile.PL, perl-*spec.in: somewhat automated versioning system implemented for depenancy modules * PkgConfig.pm: moved to new ExtUtils::PkgConfig module * MANIFEST: PkgConfig.pm removed from manifest 2003/09/16 15:00 muppetman * GClosure.xs, gperl.h: changed type of "tag" in signature of gperl_remove_exception_handler() to avoid signedness warnings. the tag's supposed to be a guint anyway. * GObject.xs, GMainLoop.xs, GParamSpec.xs, GSignal.xs, GType.xs, GValue.xs, Glib.xs: cleanup: casting to hush pedantic compiler warnings; can't have UNUSED in PREINIT:, put it in CLEANUP:; quell no-return warnings on functions that croak. 2003/09/15 22:26 rwmcfa1 * Makefile.PL: spec file dependancies improved 2003/09/15 17:43 muppetman * gperl.h, Glib.exports: add gperl_signal_set_marshaller_for and gperl_closure_new_with_marshaller * GClosure.xs: add gperl_closure_new_with_marshaller, allowing you to specify a custom marshaller to use for a GPerlClosure. you can't just call g_closure_set_marshal again, because glib asserts that it hasn't been set yet. this is used by gperl_signal_connect, as part of the changes described below. includes POD that warns you that you really don't want to use this function. gperl_closure_new now just calls this. * GSignal.xs: add thread safety to the closures list. added gperl_signal_set_marshaller_for, to allow client code to specify a special marshaller to use for all invocations of a particular named signal on a particular class; this is intended to allow workarounds for unhelpfully defined signal parameter types. * Glib.pm: bumped version to rc2, since we export new C-level APIs. 2003/09/11 23:33 muppetman * Glib.pm, MANIFEST, META.yml, README, debian/changelog: updated for 1.00rc1 release 2003/09/11 23:10 rwmcfa1 * gperl.h: added UNUSED macro * ChangeLog, GClosure.xs, GLog.xs, GMainLoop.xs, GObject.xs, GParamSpec.xs, GType.xs: make use of UNUSED macro to quite warnings about class and/or ix being unused, other slight/small warnings fixed when -Wall 2003/09/11 22:30 muppetman * Subclass.pm: documentation about creating properties, creating signals, and overriding class closures. * gperl.h: more than one file needs gperl_type_class * GType.xs: unused variable 2003/09/11 21:50 muppetman * GSignal.xs, Glib.exports, gperl.h: implement g_signal_chain_from_overridden and a wrapper for GSignalFlags; make signal_emit actually catch return values and give them back to perl; add output-only wrapper for GSignalInvocationHint. * GType.xs, t/7.t, t/8.t: make class closures optional for new signals; allow the creation of signals that have return values; allow perl to supply custom accumulators for valued signals; make overriding class closures actually work. 2003/09/11 13:27 muppetman * t/7.t: use strict and warnings in this one, too. 2003/09/11 10:35 rwmcfa1 * t/[1234568a].t: use strict and warnings, fixes to make doing so work. 2003/09/06 19:23 rwmcfa1 * Makefile.PL: dist-rpms build target added * perl-Glib.spec.in: initial import 2003/09/05 01:50 muppetman * README, debian/changelog: update for 0.97 release 2003/09/05 00:51 muppetman * Glib.pm: more pod (too much? should it be in a separate doc?) * t/a.t, Glib.exports, Glib.xs, Makefile.PL, gperl.h, MANIFEST: add support for routing g_log messages through perl 2003/09/01 19:52 muppetman * Glib.pm: don't set dl_load_flags on darwin, it generates a warning. also bump version so that cvs versions of Gtk2 which depend on T_GPERL_GENERIC_WRAPPER will force upgrades. * typemap: use a new generic typemap for all the types which follow the SvMyType/newSVMyType naming convention. 2003/08/28 23:30 muppetman * gperl.h, GClosure.xs, Glib.xs: merged changes from the exceptions branch. gtk2-perl now attempts to do reasonable handling of exceptions in callbacks. still needs pod for the perl-level stuff, but i'm not sure where to put it. * Glib.exports: new exportable symbols * GParamSpec.xs: hush uninitialized value warning (drop in the bucket) * Glib.pm, MANIFEST, README, debian/changelog: update for 0.96 release 2003/08/28 17:45 muppetman * GSignal.xs: clean up comments, bind signal_handler_is_connected 2003/08/22 01:11 muppetman * Glib.pm, README, META.yml, debian/changelog, MANIFEST: prep for 0.95 release 2003/08/19 21:11 rwmcfa1 * Makefile.PL: added realclean removal of build dir to postamble section. 2003/08/18 23:45 muppetman * t/7.t: test out signal stuff on a subclassed object. 2003/08/18 17:28 muppetman * GSignal.xs: quiet down remember_closure and forget_closure, now that i'm sure they work. 2003/08/16 20:53 muppetman * GSignal.xs: implemented wrappers for g_signal_handlers_block_by_func, unblock_by_func, and disconnect_by_func. code for the _matched versions of these functions (the generic ones) is commented out, because there is no typemap for GSignalMatchType. 2003/08/15 09:35 muppetman * debian/*, AUTHORS: patch from James Curbo adding maintainence files for debian packages. * MANIFEST, README, Glib.pm: updated for 0.94 release 2003/08/14 16:54 muppetman * apidoc.pl, Makefile.PL: use a simple perl script instead of shell commands in the makefile to create xsapi.pod; not all platforms have the shell tools, and this will let us sneak in more sophisticated stuff later. * PkgConfig.pm: portability fixes 2003/08/14 11:50 muppetman * devel.pod, Makefile.PL, Glib.pm: new manpage, Glib::devel, describes the philosphy of how the bindings are designed and how they work; an overview-style supplement to Glib::xsapi, which details the APIs themselves. 2003/08/13 23:44 muppetman * GObject.xs: fatalistic commentary * GIOChannel.xs, Glib.xs, Makefile.PL: new file GIOChannel.xs * GClosure.xs, GMainLoop.xs, GSignal.xs, gperl.h: closure correctness and simplification fixes * GValue.xs: reordering to assure that all the same types are handled in both switches; croak on unhandled types rather than just warn --- an unhandled type is a bug that we need to know about; it may require a handler registration mechanism. * TODO: updates 2003/08/13 18:15 muppetman * xsapi.pod.foot, xsapi.pod.head: new files * GBoxed.xs, GClosure.xs, GObject.xs, GSignal.xs, GType.xs, GValue.xs, Glib.xs, Makefile.PL, gperl.h: moved all the gtk-doc commentary in gperl.h into embedded pod in the various XS files; now we can extract all the pod from the XS files and convert that into an installable API reference document, Glib::xsapi. 2003/08/12 12:06 rwmcfa1 * PkgConfig.pm: can now take multiple pkg name parameters, see t/6.t for examples of usage. * t/6.t: test out PkgConfig.pm some. 2003/08/09 23:57 pcg * gperl.h: export gperl_register_fundamental. * Glib.exports: add it here, too (actually, this was an anonymous check-in by muppetman... tsk, tsk..) 2003/08/09 02:09 muppetman * GBoxed.xs, t/2.t: removed a FIXME 2003/08/01 12:41 muppetman * MANIFEST, README, Glib.pm: updated for 0.92 release 2003/07/31 19:40 muppetman * Glib.exports, Makefile.PL, gperl.h: a few windows-specific things 2003/07/30 09:21 rwmcfa1 * GBoxed.xs: bug found by matthias blasing that when getting a legal property off off a gobject that had no value assigned would croak with a NULL to boxed error. croak changed to warn and wrapped in a NOISY. returns undef from the null test 2003/07/29 14:52 rwmcfa1 * GObject.xs: #ifdef'd out the warning when returning undef from gperl_new_object, tree's can rightfully ellicit this, if you're in a state of heavy devel on wrappers you might want to re-enable it 2003/07/29 00:58 pcg * Subclass.pm: fix typoe. 2003/07/25 10:21 muppetman * Glib.pm, README: bump version to 0.91 2003/07/23 23:27 pcg * PkgConfig.pm: allow better win32 compatibility (I made a native, win32 build of Glib today). 2003/07/18 12:05 muppetman * Glib.pm, README, META.yml 2003/07/17 11:44 muppetman * GBoxed.xs, GObject.xs, GTypes.xs, Glib.xs, Makefile.PL: add the necessary locking to make the perl bindings thread-safe. thanks go to Brett Kosinski for contributing the initial patch and bugging me about it, which he needed for work on GStreamer bindings. 2003/07/10 09:50 muppetman * Glib.pm: $VERSION is actually treated as a string, write it as one to avoid bootstrap problems when using a locale that writes numbers differently. (thanks to thierry for finding that.) 2003/07/06 16:48 muppetman * GSignal.xs: add g_signal_stop_emission_by_name 2003/07/05 06:37 pcg * typemap: add gchar_own*, for functions that return allocated strings and gchar_length* for functions expecting a length() input. * gperl.h: add gchar_own and gchar_len typedefs. 2003/07/04 13:35 muppetman * Makefile.PL: patch from Thierry Vignaud fixed my copy and paste bug which leads to errors when ExtUtils::Depends isn't present. * ChangeLog: bump to 0.26 for release 2003/06/28 03:16 pcg * GType.xs: remove superfluous gperl_object_new call. * GObject.xs: important bugfix: the calls with own==FALSE in GType.xs caused premature death of the perl wrapper. The fix incurs a slight performance hit, so only do it when own==TRUE, as this should be the only case where it is ever required. * t/5.t: test for this case. 2003/06/27 17:00 muppetman * GObject.xs: get_data and set_data work only with UVs now, because it's not safe to treat them as anything else, and since we can use hash keys they aren't needed for anything else. 2003/06/27 12:00 muppetman merged realobjects-branch back onto HEAD. this was a week's worth of work, mostly by pcg with some help from me. here's a summary of changelog items from that branch: * README.api-changes: clearinghouse for API gripes, please amend * GParamSpec.xs, Glib.xs, typemap, gperl.h, Makefile.PL: support for pspecs, so we can add properties to gobjects. * Subclass.pm, t/[345].t: extra module to ease implementation of subclasses, and some tests for it * Glib.pm: pod updates * GObject.xs: big change in how perl wrappers are implemented. the new implementation will only ever create one perl wrapper (a real hash, with magic containing the gobject's address) for any gobject. The combined perl+gobject will stay alive as long as one of the partners is alive. The only real changes are in gperl_new_object and in the DESTROY method. * GType.xs: rename INSTANCE_INIT to INIT_INSTANCE and make it a function call as opposed to a method call. Also call FINALIZE_INSTANCE on object finalization time. implemented creation of properties for an object in Glib::Type::register, and implemented calling of SET_PROPERTY and GET_PROPERTY on the resultant object. other changes during the merge: * Makefile.PL: install MAN3PODS with the correct names. * PkgConfig.pm: add some documentation 2003/06/25 09:25 muppetman * GValue.xs, GClosure.xs: add a MODULE directive to appease ExtUtils::ParseXS 2003/06/20 11:29 muppetman * README, Makefile.PL: bump version number for 0.24 release 2003/06/19 00:44 pcg * Depends.pm: moved to ExtUtils-Depends module. * Makefile.PL: add ExtUtils-Depends as prerequisite, please install the ExtUtils::Depends module seperately from cvs. 2003/06/16 14:21 muppetman * GBoxed.xs, gperl.h: converted GBoxed to use vtable-based wrappers; this allows client code to install new wrapper classes that make gperl_sv_from_value and gperl_value_from_sv call the right code to convert boxed types in custom ways. GPerlBoxedPackageFunc has disappeared and the call signature for gperl_register_boxed has changed (well, the meaning of that one extra parameter -- if you already passed NULL, there's nothing to worry about). * GMainLoop.xs, typemap: added support for some GMainContext and GMainLoop methods. 2003/06/13 14:12 muppetman * GObject.xs: rename Glib::Object->_new to Glib::Object->new -- it should be that because people expect it. other cleanup. NOTE: we need to have object wrappers be able to override things like "take ownership", "wrap", "unwrap", and "destroy"... as it is, if you create a wrapper for a GtkObject from Glib::Object->new, the wrapper will be created incorrectly (gtk_object_sink will not be called). to do all of this correctly will also require wrapper caching, which i haven't made work reliably... but i'm working on it now. 2003/06/12 15:18 muppetman * GClosure.xs: protect yourself from maniacal code that passes in something to get a return value from closures/callbacks with no return value. this makes gperl_value_from_sv stop warning about bad types on the activate signal for GtkEntry, for example. 2003/06/11 09:25 muppetman * GValue.xs: undef is also false; use SvTRUE instead of SvIV when evaluating an SV as a gboolean to allow undef to pass quietly. * GType.xs: add Glib::Double 2003/06/17 18:21 muppetman * gperl.h, xs/GObject.xs: move sink functions into Glib, to avoid some problems in which GtkObject created via Glib::Object->new don't have gtk_object_sink called on them. this problem is actually more generic than just GtkObject (other libraries do similar things). 2003/06/09 13:49 muppetman * gperl.h, typemap: corrected broken handling for GObject output typemap; now uses SvGObject/newSVGObject-style macros and the _ornull/_noinc variants that Gtk2 uses. 2003/06/06 23:55 muppetman * GObject.xs, GType.xs: copy scalars that will be stored, don't just mess with the reference count, for along that way lies madness. * MANIFEST: added some key missing files (AUTHORS, LICENSE, ChangeLog) * Glib.pm: bumped version number to 0.22 for public release 2003/06/01 16:16 muppetman applied patch from Marc Lehmann (pcg at goof dot com) * GObject.xs: allow $object->get and $object->set to work on multiple properties. * Glib/GClosure.xs: don't try to PERL_SET_CONTEXT on non-threaded perls 2003/05/30 23:55 muppetman (while watching zep at the albert hall) * GType.xs: initial values, try to avoid warnings and bugs * AUTHORS, GClosure.xs, gperl.h, typemap: applied more patches from Brett Kosinski; added typemaps for gint64 and guint64, ensure that closures and callbacks are executed by the interpreters that created them. 2003/05/29 15:51 muppetman * GType.xs, gperl.h: applied patch (with liberal modifications) from Brett Kosinski (brettk at frodo dot dyn dot gno dot org) to add gperl_try_convert_flag, like the existing gperl_try_convert_enum. rearranged things to avoid copied code, and use the _try_ versions as the actual workhorses. added a little more commentary, too. 2003/05/26 04:28 muppetman * Glib.pm: bumped version for development release * GBoxed.xs: ensure that the scalar from which we try to extract a boxed pointer is actually a reference. 2003/05/22 10:30 muppetman * AUTHORS, LICENSE every other file: in every file in the project added a header pointing to the new AUTHORS and LICENSE files. changed the license clause in the docs from "same as perl" to GPL. 2003/05/18 14:00 muppetman * ChangeLog: since breaking the monolithic build into pieces, ChangeLog entries for Glib will be in here. i've included the contents of the toplevel log up to this point for history. * MANIFEST: updated for proper make dist * Glib.pm: changed version number * README: updated 2003/05/17 09:06 rwmcfa1 * Glade/*: first pass at GladeXML added * Makefile: added, see comments within * Makefile.PL: is no more * lots and lots of files: G -> Glib and other related/required changes 2003/05/16 14:55 muppetman * Gtk2/xs/GtkSpinButton.xs: removed get_value_as_float because it is deprecated (and had the wrong return type anyway). 2003/05/15 11:45 muppetman * G/GSignal.xs: hush unused parameter warning, more efficient this way, anyway * Gtk2/xs/GtkContainer.xs: implemented foreach * Gtk2/xs/GtkIconFactory.xs: minor bugfix * G/GType.xs, G/GValue.xs, G/gperl.h, G/typemap, Gnome2/xs/GnomeProgram.xs, Gtk2/xs/GtkCombo.xs, Gtk2/xs/GtkDialog.xs, Gtk2/xs/GtkFrame.xs, Gtk2/xs/GtkItemFactory.xs, Gtk2/xs/GtkStock.xs, Gtk2/xs/GtkTextBuffer.xs, Gtk2/xs/GtkToolbar.xs, Gtk2/xs/GtkTooltips.xs, Gtk2/xs/GtkTreeViewColumn.xs: use newSVGChar and SvGChar instead of newSVpv and SvPV_nolen for gchar*, to ensure valid utf8 handling. this definitely needs testing. 2003/05/06 12:56 rwmcfa1 * Gtk2/t/1.GtkWindow.t, Gtk2/t/2.GtkButton.t: prevent windows from fighting over focus and thus stall tests (happends with wmaker) * Gtk2/t/16.GtkMenu-etc.t: we don't really know how to use tearoff_state so for the time being we won't 2003/05/05 23:11 muppetman * G/G.pm, Gtk2/Gtk2.pm: pod updates 2003/05/05 16:35 muppetman * Gtk2/xs/GtkTooltips.xs: work around a (bug|feature) in the Gtk+ C library by storing a GtkTooltips reference in the GtkWidget's user data. doesn't hurt normal behavior, and prevents some hard-to-explain pitfall errors. 2003/05/03 11:17 joered * Gtk2/: Gtk2.pm, Makefile.PL, pm/Helper.pm: removed deprecated timeout/idle/input methods from Gtk2.pm; added Gtk2/pm/Helper.pm with a convenience implementation of add_watch/remove_watch 2003/05/02 18:11 muppetman * Gtk2/gtk-demo/apple-red.png, Gtk2/gtk-demo/background.jpg, Gtk2/gtk-demo/gnome-applets.png, Gtk2/gtk-demo/gnome-calendar.png, Gtk2/gtk-demo/gnome-foot.png, Gtk2/gtk-demo/gnome-gimp.png, Gtk2/gtk-demo/gnome-gmush.png, Gtk2/gtk-demo/gnome-gsame.png, Gtk2/gtk-demo/gnu-keys.png: images needed by Gtk2/gtk-demo/pixbufs.pl, directly from the gtk+-2.2.1 source distribution. * G/GType.xs, Gtk2/examples/histogramplot.pl: a bunch of code, borrowed from pygtk, to add signals to a derived class. altered the histogramplot example to use a new signal. * Gtk2/xs/GtkTooltips.xs: allow tip_private to default to NULL 2003/05/02 00:30 muppetman * Gtk2/Gtk2.pm, Gtk2/gtk2perl.h, Gtk2/examples/scribble.pl, Gtk2/gtk-demo/drawingarea.pl, Gtk2/gtk-demo/pixbufs.pl, Gtk2/xs/Gdk.xs, Gtk2/xs/GdkTypes.xs, Gtk2/xs/GtkCellRenderer.xs, Gtk2/xs/GtkWidget.xs: reverted the whole GdkRectangle mess. it's a boxed type again. this clears up several bugs to do with GdkAllocation, and in fact makes the whole shebang more efficient because we don't just create an array any time the GdkRectangle is needed, in which case it is often thrown away or only one element is used. added a ->values function, like in gtk2-perl, which returns the members in a list in the order you'd want for passing to several important gdk functions. Gtk2::Gdk::Rectangle->new is good for creating new rectangles. * Gtk2/xs/GtkTextView.xs, Gtk2/xs/GtkTreeView.xs: implemented some functions found to be missing when looking for GdkRectangle returns that needed to be marked _copy. 2003/05/01 23:17 joered * Gtk2/xs/GtkCombo.xs: added GtkCombo->entry and GtkCombo->list returning the correspondent widgets * Gtk2/xs/GtkHBox.xs, Gtk2/xs/GtkVBox.xs: default homogenous is 0 and default spacing is 5, as in gtk-perl * Gtk2/xs/GtkWidget.xs: widget flags can now be set with Widget->flag_name(1) resp. unset with Widget->flag_name(0); Widget->flag_name() still returns current state 2003/05/01 08:00 rwmcfa1 * Gtk2/xs/GtkStyle.xs: removed deprecated functions, there was a lot of them. 2003/04/31 01:00 muppetman * Gtk2/xs/GtkFrame.xs: properly allow undef in Gtk2::Frame->new (was adding an empty string instead of passing NULL) * Gtk2/xs/Gdk.xs, Gtk2/xs/GdkPixbufLoader.xs, Gtk2/xs/GdkRegion.xs, Gtk2/xs/PangoContext.xs, Gtk2/xs/PangoLayout.xs: newly implemented * Gtk2/examples/histogramplot.pl: new code to test drive drawing primitives, pango text handling and drawing, and subclassing. lots of stuff in here; was ported from a working C class library i've been writing. * G/GType.xs, G/GObject.xs, Gtk2/xs/GtkObject.xs: support for pure-perl GObject subclasses. added G::Type->register to create a new GType (basically wraps g_type_register_static), G::Object->_new, to be called from perl constructors for things inheriting GObject, and Gtk2::Object->new, which MUST be used for things inheriting GtkObject (to handle the floating ref situation properly). this allows the perl developer to create new widgets without writing C code! adding signals and properties is currently not implemented. * Gtk2/CodeGen.pm: more correct handling of undef --- previous code was allowing a variable containing undef to pass, which would cause a croak in the wrapper-reader function. * Gtk2/Gtk2.pm, Gtk2/xs/GdkTypes.xs: stopgap solution, simple lvalue subs to get members from a rectangle list * Gtk2/gtk-demo/drawingarea.pl: revert to named member method syntax for rectangles * Gtk2/gtk-demo/pixbufs.pl: actually works now. you need the images, which i don't think are in CVS yet. * Gtk2/gtk-demo/stock_browser.pl: cleanup * Gtk2/xs/GdkPixmap.xs: implemented create_from_xpm_d and colormap_create_from_xpm_d * Gtk2/xs/GdkWindow.xs: allow NULL for cursor in set_cursor * Gtk2/xs/GtkWidget.xs: implemented create_pango_layout 2003/04/29 21:55 joered * Gtk2/xs/GtkListStore.xs: bugfix: gtk_list_store_append and gtk_list_store_prepend were swapped 2003/04/29 23:44 muppetman * Gtk2/xs/GdkDrawable.xs: implemented gdk_draw_polygon, gdk_draw_points, gdk_draw_lines, gdk_draw_segments, gdk_draw_layout, and gdk_draw_layout_with_colors * G/GObject.xs: removed some very old and very broken commented-out code (wrapper instance caching). added new methods for dealing with foreign objects in perl: G::Object->new_from_pointer(VAL, NOINC) (a direct wrapper around gperl_new_object), and $object->get_pointer. 2003/04/29 18:10 muppetman * Gtk2/xs/GtkWindow.xs: icon list stuff * Gtk2/gtk-demo/images.pl, Gtk2/gtk-demo/pixbufs.pl: the last two pieces of gtk-demo (need some image files and such, though), and these two don't work correctly. * Gtk2/gtk-demo/appwindow.pl, Gtk2/gtk-demo/button_box.pl, Gtk2/gtk-demo/changedisplay.pl, Gtk2/gtk-demo/colorsel.pl, Gtk2/gtk-demo/dialog.pl, Gtk2/gtk-demo/editable_cells.pl, Gtk2/gtk-demo/item_factory.pl, Gtk2/gtk-demo/list_store.pl, Gtk2/gtk-demo/main.pl, Gtk2/gtk-demo/menus.pl, Gtk2/gtk-demo/panes.pl, Gtk2/gtk-demo/sizegroup.pl, Gtk2/gtk-demo/stock_browser.pl, Gtk2/gtk-demo/textview.pl, Gtk2/gtk-demo/tree_store.pl: gtk-demo runs! lots of cleanup in the pieces, and changed each one to us a single entry point name, defined in a package with the same name as the file; this bit of subterfuge was necessary because of the differences between C and perl, and the fact that the app is designed as a C program. NOTE: drawingarea.pl is broken, because my copy has other changes that won't work with the current state of CVS. 2003/04/29 16:16 rwmcfa1 * Gtk2/xs/GdkGC.xs: impelemted gdk_gc_set_dashes 2003/04/29 15:10 muppetman * Gtk2/xs/GtkSizeGroup.xs: implemented size groups * Depends.pm, G/Depends.pm, G/Makefile.PL, Gnome2/Makefile.PL, GnomePrint2/Makefile.PL, Gtk2/Makefile.PL, GtkSpell/Makefile.PL, G/PkgConfig.pm, Gtk2/CodeGen.pm, helpers/genstuff.pl, helpers/genboot.pl: build system hacks. moved Depends.pm under G, so that G can install it. made a module of some boilerplate to handle dealing with pkgconfig, and converted the code in helpers/genstuff.pl and helpers/genboot.pl into Gtk2/CodeGen.pm, stuff that can be called from Makefile.PLs. hacked up a the Makefile.PLs to reflect these changes. this makes it possible to use the autogen build tools outside the source tree --- the first step towards breaking up the source tree into separately distributable modules. 2003/04/29 11:14 muppetman * Gtk2/gtk-demo/sizegroup.pl: another little piece of my heart * Gtk2/xs/GtkDialog.xs: use alias to ensure that new_with_buttons exists for those who seek it. 2003/04/28 23:25 muppetman * Gtk2/xs/GtkListStore.xs, Gtk2/xs/GtkTreeStore.xs: work around bizarre stack behavior by not using a helper function. trying to read the stack in a helper function called from an xsub was resulting in the stack showing the wrong number of items. 2003/04/28 18:00 muppetman * Gtk2/gtk-demo/panes.pl: another piece of the gtk-demo pie * G/G.pm G/GObject.xs: overload the == operator, for more natural object comparisons * Gtk2/xs/GtkPaned.xs: struct member access * Gtk2/Makefile.PL Gtk2/genkeysyms.pl: create a big hash of key symbols in Gtk2::Gdk::Keysyms, a la gtk-perl * Gtk2/xs/GtkRadioButton.xs, Gtk2/xs/GtkRadioMenuItem.xs, Gtk2/xs/GtkButton.xs, Gtk2/xs/GtkCheckButton.xs, Gtk2/xs/GtkCheckMenuItem.xs, Gtk2/xs/GtkImageMenuItem.xs, Gtk2/xs/GtkMenuItem.xs, Gtk2/xs/GtkToggleButton.xs: consolidate constructors with ALIAS to avoid copying code. make sure that group isn't a valid SV pointing to undef * Gtk2/xs/GtkWidget.xs: implemented queue_draw, add_accelerator, remove_accelerator, and get_display 2003/04/27 08:52- rwmcfa1 * Gtk2/t/16.GtkMenu-etc.t: Added a first pass at the testing of GtkMenu and friends. * Gtk2/t/15.GtkHandleBox.t: Added a decently complete test of GtkHandleBox * Gtk2/t/14.GtkToolbar.t: Added a decently complete test of GtkToolbar * Gtk2/xs/GtkToolbar.xs: Fixed a bug where GtkToolbarChildType was wrongly being used as a gtype, caused all _element functions to fail * Gtk2/t/13.GtkTooltips.t: Added a decently complete test of GtkTooltips * Gtk2/xs/GtkTooltips.xs: implemented an attempt at gtk_tooltips_data_get which returns what is in the GtkTooltipsData struct as a hash. * Gtk2/t/12.GtkDialog.t: Added a decently complete test of GtkDialog * Gtk2/xs/GtkDialog.xs: added gtk_dialog_add_butttons with multiple calls to gtk_dialog_add_button. combined the vbox and action_area get functions into one aliased function. also changed a char* to a gchar * * Gtk2/maps: hand added entry for Gtk2::Progress, removed * Gtk2/xs/GtkProgressBar.xs: added a BOOT section with a isa call to tell GtkProgressBar that it's a GtkWidget dependant. 2003/04/26 09:53- rwmcfa1 * GtkSpell/Spell.pm: first pass of documentation * GtkSpell/GtkSpell.xs: gtkspell_get_from_text_view now accepts and ignores a class * Gtk2/t/10.GtkProgressBar.t, Gtk2/t/11.GtkStatusBar.t: first passes at testing the two modules * Gtk2/maps: hand added a (maybe temporary) entry for Gtk2::Progress * Gtk2/xs/GtkProgressBar.xs: removed a bunch of deprecated functions * Gtk2/xs/GtkMenuItem.xs, Gtk2/xs/GtkRadioButton.xs, Gtk2/xs/GtkRadioMenuItem.xs, Gtk2/xs/GtkToggleButton.xs: now new with string new('string') uses mnemonic instead of label. seems like a good idea. you can use new_with_label if you don't want this behavior. also impelented news with aliases for new and new_with_mnemonic (saves code space/copying). * Gtk2/xs/GtkCheckButton.xs, Gtk2/xs/GtkCheckMenuItem.xs, Gtk2/xs/GtkImageMenuItem.xs: same as ^ with the addition of: wrappers for _new_with_label were invalid they're now fixed. 2003/04/25 23:01 rwmcfa1 * GtkSpell/: Initial import of working (for me anyway) GtkSpell mappings, give them a try. 2003/04/25 18:17 muppetman * Gtk2/gtk-demo/changedisplay.pl, Gtk2/gtk-demo/drawingarea.pl, Gtk2/gtk-demo/editable_cells.pl: more demo pieces. changedisplay.pl is completely untested, because i do not have Gtk+ 2.2 on my development machine. * G/GClosure.xs: always copy SVs that are to be stored. see the perlcall manpage. this fixes some intermittent bugs that happen when reusing the same variable for various objects. * Gtk2/xs/GdkWindow.xs: implemented gdk_window_invalidate_rect * new-gtk2-perl.html, G/GBoxed.xs, helpers/genstuff.pl, G/gperl.h, G/GObject.xs: renamed gperl_register_class to gperl_register_object to be more consistent (with gperl_register_fundamental and gperl_register_boxed). also added gperl_object_set_no_warn_unreg_subclass, made gperl_get_object honor it. * Gtk2/xs/GdkGC.xs, Gtk2/xs/GtkStyle.xs: set 'no warn for unregistered subclasses on GtkStyle and GdkGC. causes the type system to stop spewing messages on stderr about unregistered types from theme engines and gdk backends. * Gtk2/gtk2perl.h, Gtk2/examples/scribble.pl, Gtk2/xs/GdkEvent.xs, Gtk2/xs/GdkTypes.xs, Gtk2/xs/GtkCellRenderer.xs: completely reworked the handling of GdkRectangle. it's now treated as a perl list instead of an opaque type; this is consistent with gtk-perl and makes life easier for manipulating the rectangles in perl. * Gtk2/xs/GtkWidget.xs: changed handling of GtkAllocation, since handling of GdkRectangle changed. invisible from the perl side. also implemented gtk_widget_get_events. * Gtk2/xs/GtkImage.xs: implemented gtk_image_new_from_pixmap, gtk_image_set_from_pixmap, and gtk_image_get_pixmap * Gtk2/xs/GtkLabel.xs: allow Label->new to default to NULL for creating empty labels. * Gtk2/xs/GtkTreeModel.xs: implemented gtk_tree_path_get_indices 2003/04/25 12:40 rwmcfa1 * Gtk2/t/1.GtkWindow.t: corrected check for gtk >= 2.2 * Gtk2/t/5.GtkListStore-etc.t: if 2.2 then try the reorder function * Gtk2/xs/GtkCurve.xs: re-did set_vector to be clearer and removed a unused param name from prototype. * Gtk2/xs/GtkFileSelection.xs: clarified the a for loop's operations in get_selections * Gtk2/xs/GtkTreeStore.xs, Gtk2/xs/GtkListStore.xs: added itital pass at _store_reorder * Gtk2/maps: added stuff new as of gtk2.2.1 * Gtk2/xs/GtkPlug.xs Gtk2/xs/GtkWindow.xs Gtk2/xs/GdkCursor.xs Gtk2/xs/GdkDrawable.xs Gtk2/xs/GtkInvisible.xs Gtk2/xs/GtkMenu.xs: uncommented stuff new to gtk 2.2 now that maps is up to date for 2.2.1 2003/04/24 18:24 muppetman * Gtk2/gtk-demo/appwindow.pl, Gtk2/gtk-demo/button_box.pl, Gtk2/gtk-demo/colorsel.pl, Gtk2/gtk-demo/dialog.pl: more pieces of the demo * Gtk2/xs/GtkToolbar.xs: implemented all the append/prepend/insert functions that were left out because they require callbacks * Gtk2/xs/GtkStock.xs: implemented gtk_stock_add * G/GSignal.xs, G/gperl.h: export gperl_signal_connect, the actual workhorse, so other XSubs can use it * Gtk2/xs/GtkColorSelection.xs: fixed get_current_color and get_previous_color * Gtk2/xs/GtkColorSelectionDialog.xs: member access * TODO: high-level things (i forgot to commit this last week) 2003/04/24 17:55 rwmcfa1 * Gtk2/t/5.GtkListStore-etc.t: fixed type-o, datam -> data that was preventing entries being made into the list * Gtk2/xs/GtkMessagedialog.xs: removed a TODO, it is probably better to just pass the message as you want it rather than use the varargs stuff anyway 2003/04/24 13:30 muppetman * Gnome2/xs/GnomeProgram.xs, Gnome2/druid.pl: implemented object properties on Gnome2::Program->init (was a FIXME) * G/GObject.xs: created alias get_property for get and set_property for set, since some objects mask the G::Object-level method with their own. in list_properties, don't die if the descr isn't set. 2003/04/24 12:55 muppetman * helpers/genstuff.pl: wrap generated code in #ifdefs to support versioning (typemaps must be generated even if the code isn't, so we generate everything but only use part of it) 2003/04/23 10:44 rwmcfa1 * Gtk2/xs/GtkHButtonBox.xs, Gtk2/xs/GtkVButtonBox.xs: get_spacing_defaults should accept and ignore class * Gtk2/gtk2perl.h: type-o newSVGdkModiferType -> newSVGdkModifierType * Gtk2/xs/GtkFontSelection.xs: type functions should not be in XS, it's all automagical * Gtk2/xs/GtkWindow.xs: a first pass at set_icon_list_function added 2003/04/23 10:37 muppetman * ChangeLog: new change log, from the cvs log on sourceforge. please keep it updated. 2003/04/22 muppetman * G/GBoxed.xs: updates to debugging output * G/GClosure.xs: don't keep the supplemental arguments array in gperl_closure_marshal --- just put mortal values on the stack and everything works out fine. simplifies the code quite a bit, and removes some subtle and nasty bugs. * G/GType.xs: GPERL_TYPE_SV, a boxed wrapper for perl scalars, mapped to the package G::Scalar. this is handy for storing hashes and other perl data structures in a TreeModel. * G/GValue.xs: special handling for GPERL_TYPE_SV. implement handling for G_TYPE_INTERFACE. * Gtk2/gtk-demo/stock_browser.pl, Gtk2/xs/GtkIconFactory.xs: stock browser demo and some supporting code * Gtk2/gtk2perl.h, Gtk2/xs/GdkTypes.xs: special handling for GdkModifierType flags... GDK_MODIFIER_MASK matches all of the flag values, and causes nasty problems when you try to convert the SV flags wrapper *back* to C. so, handle it separately, and don't allow GDK_MODIFIER_MASK to make it into perl from C. (can still go the other way, though) * Gtk2/xs/GtkItemFactory.xs: bracket callback with ENTER/SAVETMPS & FREETMPS/LEAVE * Gtk2/xs/GtkMenu.xs: implemented gtk_menu_popup * Gtk2/xs/GtkTreeModel.xs: it's possible for gtk_tree_model_iter_next to return NULL * Gtk2/xs/GtkTreeView.xs: implemented gtk_tree_view_insert_column_with_data_func * Gtk2/xs/GtkTreeViewColumn.xs: implemented gtk_tree_view_column_set_cell_data_func * Gtk2/xs/GtkWidget.xs: default params on set_size_request, and implemented render_icon 2003/04/22 rwmcfa1 * Gtk2/t/5.GtkListStore-etc.t, Gtk2/t/6.GtkLabel.t, Gtk2/t/7.GtkBoxes.t, Gtk2/t/8.GtkCombo.t: initial import * Gtk2/t/9.GtkRadioButton.t: test out a little more throughly * Gtk2/xs/GtkFileSelection.xs: first pass at gtk_file_selection_get_selections, needs to be utf8 tested/implemented maybe * Gtk2/xs/GtkRadioButton.xs: crash bug, need to make sure that svp exists * Gtk2/xs/GtkRadioMenuItem.xs: first pass at implementing this class, not tested yet 2003/04/21 muppetman * G/G.xs, G/gperl.h: added gperl_alloc_temp * G/GClosure.xs: added GPerlCallback, and made some robustness fixes for GPerlClosure. (there was bizarre stuff happening in the marshaller, wrong number of items in the supplemental arguments array.) * G/gperl.h: add GPerlCallback, with docs, and some other noise * Gtk2/gtk-demo/item_factory.pl: gtk-demo driver for GtkItemFactory * Gtk2/xs/GtkItemFactory.xs: implemented GtkItemFactory * Gtk2/xs/GtkWidget.xs: set_flags and unset_flags 2003/04/21 rwmcfa1 * Gtk2/xs/GtkRadioButton.xs: implement all of the functions now with a first pass at how to deal with GSList/group stuff. (notice: it's subject to change) 2003/04/20 rwmcfa1 * just about every file: added cvs Header: tags * Gtk2/xs/GtkWindow.xs: missing functions added; version 2.2 functions added (some commented out); decorated_window functions added, but commented out (how should we go about these?) 2003/04/18 gthyni added .cvsignore files for cleaner updates 2003/04/18 muppetman * Gnome2/druid.pl: add a button to test out Gnome2::About * Gnome2/xs/GnomeAbout.xs: patch from Chas Owens to implement the authors and documenters parameter lists, and allow defaults on parameters following authors. (authors is required by gnome_about_new) * Gtk2/xs/GtkAccelGroup.xs: implemented gtk_accelerator_parse and gtk_accelerator_name * Gtk2/xs/GtkFileSelection.xs: patch from Chas Owens giving access to member widgets * Gtk2/xs/GtkImage.xs: implemented new_from_pixbuf and set_from_pixbuf * Gtk2/xs/GtkStock.xs: implemented some stock handling stuff, enough to get the stock_browser demo working * Gtk2/xs/GtkTreeSelection.xs: implemented gtk_tree_selection_get_selected 2003/04/18 rwmcfa1 * Gtk2/xs/GtkWindow.xs: add a header tag and see if i can commit, header tags need to be added to everything before to long. 2003/04/17 muppetman massive commit of changes made by muppetman and rwmcfa1 since the last pre-sourceforge snapshot. * G/G.xs, G/gperl.h: added gperl_croak_gerror, takes care of properly freeing a GError before croaking with the message it contains * G/GObject.xs: don't allow non-RVs in gperl_get_object; added G::Object->eq * G/gperl.h: added gperl_croak_gerror, takes care of properly freeing a GError before croaking with the message it contains * Gtk2/gdk.typemap, Gtk2/gtk2perl.h: custom handling for GdkBitmap * Gtk2/examples/layout.pl: new example (ported from C by ross) * Gtk2/examples/socket.pl, Gtk2/t/0.Gtk2.t, Gtk2/t/1.GtkWindow.t, Gtk2/t/2.GtkButton.t, Gtk2/t/3.GtkGammaCurve.t: updates since snapshot * Gtk2/gtk-demo/textview.pl, Gtk2/gtk-demo/floppybuddy.gif, Gtk2/gtk-demo/gtk-logo-rgb.gif: another piece of gtk-demo, and accessories * Gtk2/xs/GdkPixbuf.xs: added lots of missing functionality * Gtk2/xs/GdkPixmap.xs: can now create GdkBitmaps. warning, GdkBitmap may be in the wrong class, there are some complaints at runtime about it (porting C code passing a GdkBitmap where a GdkPixmap was wanted, i had to re-bless in perl to achieve that). * Gtk2/xs/Gtk2.xs: added version information functions * Gtk2/xs/GtkCurve.xs: work around a C bug that the Gtk+ maintainers say won't be fixed (because the widget is to be removed in future versions) * Gtk2/xs/GtkHScale.xs, Gtk2/xs/GtkHScrollBar.xs, Gtk2/xs/GtkVScale.xs, Gtk2/xs/GtkVScrollBar.xs, Gtk2/xs/GtkScrolledWindow.xs: allow default parameters * Gtk2/xs/GtkListStore.xs: place TreeModel at the beginning of ISA so Gtk2::TreeModel::get is found before G::Object::get. remove some warn()s. * Gtk2/xs/GtkNotebook.xs: patch from Emmanuele Bassi, which was a double commit, because goran had already fixed it and i didn't notice in time * Gtk2/xs/GtkTextBuffer.xs: implemented insert_with_tags_by_name * Gtk2/xs/GtkTextIter.xs: allow NULL return from get_child_anchor * Gtk2/xs/GtkTextView.xs: oops, bad signature * Gtk2/xs/GtkTreeView.xs: implemented missing new_with_model * Gtk2/xs/GtkTreeViewColumn.xs: stack randomly had the wrong number of items. converted to a macro to avoid the use of dXSARGS, and suddenly the list_store.pl portion of gtk-demo works. dXSARGS is supposed to work anywhere; i don't understand why it didn't. * Gtk2/xs/GtkWidget.xs: implemented several _modify_* methods * Gtk2/xs/GtkWindow.xs: allow window type to default to 'toplevel' on ->new; all NULL for several other functions' parameters. * Gtk2/xs/PangoFont.xs: pango constants. 2003/04/17 gthyni imported 20030415 snapshot into CVS Glib-1.320/copyright.pod000644 001750 000024 00000000172 11664366512 016215 0ustar00bdmanningstaff000000 000000 Copyright (C) 2003-2011 by the gtk2-perl team. This software is licensed under the LGPL. See L for a full notice. Glib-1.320/devel.pod000644 001750 000024 00000035535 11701512040 015274 0ustar00bdmanningstaff000000 000000 =head1 NAME Glib::devel - Binding developer's overview of Glib's internals =head1 DESCRIPTION Do you need to know how the gtk2-perl language bindings work, or need to write your own language bindings for a Glib/Gtk2-based library? Then you've come to the right place. If you are just a perl developer wanting to write programs with Glib or Gtk2, then this is probably way over your head. This document began its life as a post to gtk-perl-list about a redesign of the fundamentals of the bindings; today it is the reference documentation for the developers of the bindings. To reduce confusion, refer to GLib, the C library, with a capital L, and Glib the perl module with a lower-case l. While the Gtk2 module is the primary client of Glib, it is not necessarily the only one; in fact, the perl bindings for the GStreamer library build directly atop Glib. Therefore, this document describes just the GLib/Glib basics. For details on how Gtk2 extends upon the concepts presented here, see L. In various places, we use the name GPerl to refer to the actual binding subsystem. In order to avoid getting very quickly out of date, this document doesn't go into great detail on APIs. gperl.h is rather heavily commented, and should be considered the canonical source of correct API information. =head1 Basic Philosophy GLib is a portability library for C programs, providing a common set of APIs and services on various platforms. Along with that you get libgobject, which provides an inheritance-based type system and other spiffy things. Glib, as a perl module, must decide which portions of GLib's facilities to map to perl and which to abstract and encapsulate. In the grand scheme, the bindings have been designed with a few basic tenets in mind: =over =item - Stick close to the C API, to allow a perl developer to use knowledge from the C API and API reference docs with the perl bindings; this is overruled in some places by the remaining tenets. =item - Be perlish. This is the most important. The user of the perl bindings should not have to worry about memory management, reference counting, freeing objects, and all that stuff, else he might as well go write in C instead. =item - Leave out deprecated functionality. =item - Don't add new functionality. The exceptions to this rule are consolidation of methods where default parameters may be used, or where the direct analog from C is not practical. =item - Be lightweight. As little indirection and bloat as possible. If possible, implement each toplevel module (e.g., Glib, Gtk2, Gnome2, GtkHTML, etc) as one .pm and one .so. =item - Be extensible. Export header files and typemaps so that other modules can easily chain off of our base. Do not require the entirely of Gtk2 for someone who needs only to build atop GObject. =back =head1 The Glib Module In keeping with the tenet of not requiring the entire car for someone who only needs a single wheel, I broke the glib/gobject library family into its own module and namespace. This has proved to be a godsend, as it has made things very easy to debug; there's a clean separation between the base of the type system and the stuff on top of it. The Glib module takes care of all the basic types handled by the GObject library --- GEnum, GFlags, GBoxed, GObject, GValue, GClosure --- as well has signal marshalling and such in GSignal. I'll discuss each of these separately. In practice, you will rarely see direct calls to the functions that convert objects in and out of perl. Most code should use the C preprocessor to provide easier-to-remember names that follow the perl API style, e.g., newSVGObject(obj) rather than gperl_new_object(type,obj) and SvGObject(sv) instead of gperl_get_gobject(type, sv). The convention used in all of gtk2-perl is described in L. =head2 Wrappers FIXME maybe this section should be rolled into the GBoxed and GObject sections? In order to use the C data structures from Perl, we need to wrap those objects up in Perl objects. In general, a Perl object is simply a blessed reference. A typical scheme for representing C objects in perl is bless a reference to a scalar holding the C pointer value; perl will destroy the reference-counted scalar when there are no more references to it, and one would normally destroy the underlying data structure at this point. However, GLib is a little more complex than your typical C library, so this easy, typical setup won't work for us. GBoxed types are opaque wrappers for C structures, providing copy and free functions, to allow the types to be used generically. For the most part we can get away with using the typical scheme described above to provide an opaque object, but in some instances an opaque object is very alien in perl. The L section explains how we get around this. GObject, on the other hand, is a type-aware, reference-counted object with lifetime semantics that differ somewhat from perl SVs. Thus we need something a bit more sophisticated than a plain old opaque wrapper; in fact, we use a blessed hash reference with the pointer to the C object tucked away in attached magic, and a pointer to the SV stored in the GObject's user data. The combined perl/C object does some nifty reference-count borrowing to ensure that object lifetime is managed correctly. If an object is created by a function that returns directly to perl, then the wrapper returned by that function should "own" the object. If no other code assumes ownership of that object (by ref'ing a GObject or copying a GBoxed), then the object should be destroyed when the perl scalar is destroyed (actually, as part of its destruction). If a function returns a preexisting object owned by someone else, then the bindings should NOT destroy the object with the perl wrapper. How we handle this for the various types is described below. =head2 GType to Package Mappings GType is the GObject library's unique type identifier; this is a runtime variable, because GLib types may be loaded dynamically. The direct analog in perl is the package name, which uniquely specifies an object's class. Since these do about the same thing, we completely replace the GType with the perl package. For various reasons, mostly to do with robustness and performance, there is a one-to-one mapping between GType classes and perl package names. These must be registered, usually as part of the module initialization process. In addition, the type system tries as hard as it can to recover when things don't go well, using the GType system to its advantage. If you return a C object of a type that is not registered with Gperl, such as MyCustomTypeFoo, gperl_new_object (see below) will warn you that it has blessed the unknown MyCustomTypeFoo into the first known package in its ancestry, Gtk2::VBox. GBoxed and GObject have distinct mapping registries to avoid cross-pollination and mistakes in the type system. See below. To assist in handling inheritance that isn't specified directly by the GType system, the function gperl_set_isa allows you to add elements to the @ISA for a package. gperl_register_object does this for you, but you may need to add additional parents, e.g., for implementing GInterfaces. (see Gtk2/xs/GtkEntry.xs for an example) You may be thinking that we could use substitution rules to map the GObject classes to perl packages. In practice, this is a bad idea, fraught with problems; the substitution rules are not easily extendable and are easily broken by extension packages which don't follow the naming conventions. =head2 GEnums and GFlags GLib provides a mechanism for creating runtime type information about enumeration and flag types. Enumerations are lists of specific values, one of which may be used at at time, whereas multiple flag values may be supplied at a time. In C flags are meant to be used with bitfields. A GType is associated with the various valid values for a given GEnum or GFlags type as strings, in both full-name and nickname forms. GPerl uses this mechanism to avoid the need to know integer values for enum and flag types at the perl level. An enum value is just a string; a bitfield of flag values is represented as a reference to an array of strings. These strings are the GLib-provided nicknames. For the convenience of a perl developer, the bindings treat '-' and '_' as equivalent when looking up the corresponding integer values during conversion. A GEnum or GFlags type mapping should be registered with void gperl_register_fundamental (GType gtype, const char * package); so that their package names can be used where a GType is required (for example, as GObject property types or GtkTreeModel column types). The basic functions for converting between C and perl values are /* croak if val is not part of type, otherwise return * corresponding value. this is the general case. */ gint gperl_convert_enum (GType type, SV * val); /* return a scalar which is the nickname of the enum value * val, or croak if val is not a member of the enum. */ SV * gperl_convert_back_enum (GType type, gint val); /* collapse a list of strings to an integer with all the * correct bits set, croak if anything is invalid. */ gint gperl_convert_flags (GType type, SV * val); /* convert a bitfield to a list of strings, or croak. */ SV * gperl_convert_back_flags (GType type, gint val); Other utility functions allow for finer-grained control, such as the ability to pass unknown values, which can be necessary in special cases. In general, each of these functions raises an exception when something goes wrong. To be helpful, they croak with a message listing the valid values when they encounter invalid input. =head2 GBoxed GBoxed provides a way to register functions that create, copy, and destroy opaque structures. For our purposes, we'll allow any perl package to inherit from Glib::Boxed and implement accessors for the struct members, but Glib::Boxed will handle the object and wrapper lifetime issues. There are two functions for creating boxed wrappers: SV * gperl_new_boxed (gpointer boxed, GType gtype, gboolean own); SV * gperl_new_boxed_copy (gpointer boxed, GType gtype); If own is TRUE, the wrapper returned by gperl_new_boxed will take boxed with it when it dies. In the case of a copy, own is implied, so there's a separate function which doesn't need the own option. To get a boxed pointer out of a scalar wrapper, you just call gperl_get_boxed_check --- this will croak if the sv is undef or not blessed into the specified package. When you register a boxed type you get the option of supplying a table of function pointers describing how the boxed object should be wrapped, unwrapped, and destroyed. This allows you to decide in the wrapping function what subclass of the boxed type's class the wrapper should actually take (a trick used by Gtk2::Gdk::Event), or represent a boxed type as a native perl type (such as using array references for Gnome2::Canvas::Point objects). All of this happens automagically, behind the scenes, and most types assume the default wrapper class. See the commentary in gperl.h for more information. =head2 GObject The GObject knows its own type. Thus, we need only one parameter to create a GObject wrapper. In reality, we ask for two: SV * gperl_new_object (GObject * object, gboolean own); The wrapper SV will be blessed into the package corresponding to the gtype returned by G_OBJECT_TYPE (object), that is, the bottommost type in the inheritance chain. If that bottommost type is not known, the function walks back up the tree until it finds one that's known, blesses the reference into that package, and spits out a warning on stderr. To hush the warning, you need merely call In general, this process will claim a reference on the GObject (with g_object_ref()), so that the C object stays alive so long as there is a perl wrapper for it. If own is set to TRUE, the perl wrapper will claim ownership of the C object by removing that reference; in theory, for a new GObject, fresh from a constructor, this leaves the object with a single reference owned by the perl object. The next question out of your mouth should be, "But what about GObject derivatives that require sinking or other strange methods to claim ownership?" For the answer, see the GtkObject section's description of sink functions. void gperl_register_object (GType gtype, const char * package); This magical function also sets up the @ISA for the package to point to the package corresponding to g_type_parent (gtype). [Since this requires the parent package to be registered, there is a simple deferral mechanism, which means your @ISA might not be set until the next call to gperl_register_object.] There are two ways to get an object out of an SV (though I think only one is really needed): GObject * gperl_get_object (SV * sv); GObject * gperl_get_object_check (SV * sv, GType gtype); The second one is like the first, but croaks if the object is not derived from gtype. You can get and set object data and object parameters just like you'd expect. =head2 GSignal All of this GObject stuff wouldn't be very useful if you couldn't connect signals and closures. I got most of my handling code from gtk2-perl and pygtk, and it's pretty straightforward. The data member is optional, and must be a scalar. To connect perl subroutines to GSignals I use GClosures, which require the handling of GValues. =head2 GPerlClosure Use a GPerlClosure wherever you could use a GClosure and things should work out great. I =head2 GPerlCallback Function pointers are required in many places throughout gtk+, usually for a callback to be used as a "foreach" function or for some other purpose. Unfortunately, a majority of these spots aren't designed to work with GClosures (usually by lacking a way to destroy data associated with the callback when it is no longer needed). For this purpose, the GPerlCallback wraps up the gruntwork of using perl's call_sv to use a callback function directly. =head1 SEE ALSO perl(1), perlxs(1), perlguts(1), perlapi(1), perlxstut(1), L(3pm), L(3pm) L(3pm), L(3pm), L(3pm) =head1 AUTHOR muppet Escott at asofyet.orgE =head1 COPYRIGHT Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. =cut Glib-1.320/doctypes000644 001750 000024 00000001422 11664366512 015255 0ustar00bdmanningstaff000000 000000 # Use this file to add to the documentation generation system a set of # C type name to Perl type description mappings for types which are not # registered with the GLib type system. This allows the documentation # system to produce useful type names or descriptions in documentation. # The C type name should have no spaces; namely, do NOT include # "const" and/or "*". Also, "_ornull" is handled for you ("or undef" gets # appended to the description). The description may have spaces. # # C name description # ------------ ---------------- GMainContext Glib::MainContext thingamabob GMainLoop Glib::MainLoop GParamSpec Glib::ParamSpec GParamFlags Glib::ParamFlags gunichar character GKeyFile Glib::KeyFile GKeyFileFlags Glib::KeyFileFlags GBookmarkFile Glib::BookmarkFile Glib-1.320/GBookmarkFile.xs000644 001750 000024 00000047414 11706211701 016525 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2006,2012 by the gtk2-perl team (see the file AUTHORS for * the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * */ #include "gperl.h" SV * newSVGBookmarkFile (GBookmarkFile * bookmark_file) { HV * bookmark = newHV (); SV * sv; HV * stash; /* tie the key_file to our hash using some magic */ _gperl_attach_mg ((SV *) bookmark, bookmark_file); /* wrap it, bless it, ship it. */ sv = newRV_noinc ((SV *) bookmark); stash = gv_stashpv ("Glib::BookmarkFile", TRUE); sv_bless (sv, stash); return sv; } GBookmarkFile * SvGBookmarkFile (SV * sv) { MAGIC * mg; if (!gperl_sv_is_ref (sv) || !(mg = _gperl_find_mg (SvRV (sv)))) return NULL; return (GBookmarkFile *) mg->mg_ptr; } MODULE = Glib::BookmarkFile PACKAGE = Glib::BookmarkFile PREFIX = g_bookmark_file_ =for object Glib::BookmarkFile Parser for bookmark files =cut =for position SYNOPSIS =head1 SYNOPSIS use Glib; $date .= $_ while (); $b = Glib::BookmarkFile->new; $b->load_from_data($data); $uri = 'file:///some/path/to/a/file.txt'; if ($b->has_item($uri)) { $title = $b->get_title($uri); $desc = $b->get_description($uri); print "Bookmark for `$uri' ($title):\n"; print " $desc\n"; } 0; __DATA__ Test File Some test file =for position DESCRIPTION =head1 DESCRIPTION B lets you parse, edit or create files containing lists of bookmarks to resources pointed to by URIs, with some meta-data bound to them, following the Desktop Bookmark Specification. The recent files support inside GTK+ uses this type of files to store the list of recently used files. The syntax of bookmark files is described in detail in the Desktop Bookmarks Specification, here is a quick summary: bookmark files use a subclass of the XML Bookmark Exchange Language (XBEL) document format, defining meta-data such as the MIME type of the resource pointed by a bookmark, the list of applications that have registered the same URI and the visibility of the bookmark. =cut void DESTROY (GBookmarkFile *bookmark_file) CODE: g_bookmark_file_free (bookmark_file); GBookmarkFile * g_bookmark_file_new (class) C_ARGS: /* void */ # unneeded # void g_bookmark_file_free (GBookmarkFile *bookmark); =for apidoc __gerror__ Parses a bookmark file. =cut void g_bookmark_file_load_from_file (bookmark_file, file) GBookmarkFile *bookmark_file GPerlFilename_const file PREINIT: GError *err = NULL; CODE: g_bookmark_file_load_from_file (bookmark_file, file, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ Parses a string containing a bookmark file structure. =cut void g_bookmark_file_load_from_data (bookmark_file, buf) GBookmarkFile *bookmark_file SV *buf PREINIT: STRLEN length; GError *err = NULL; const gchar *data = (const gchar *) SvPV (buf, length); CODE: g_bookmark_file_load_from_data (bookmark_file, data, length, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ =signature ($full_path) = $bookmark_file->load_from_data_dirs ($file) Parses a bookmark file, searching for it inside the data directories. If a file is found, it returns the full path. =cut void g_bookmark_file_load_from_data_dirs (bookmark_file, file) GBookmarkFile *bookmark_file GPerlFilename_const file PREINIT: GError *err = NULL; gchar *full_path; PPCODE: g_bookmark_file_load_from_data_dirs (bookmark_file, file, &full_path, &err); if (err) gperl_croak_gerror (NULL, err); if (full_path) { XPUSHs (sv_2mortal (newSVGChar (full_path))); g_free (full_path); } =for apidoc __gerror__ Returns the bookmark file as a string. =cut gchar_own * g_bookmark_file_to_data (bookmark_file) GBookmarkFile *bookmark_file PREINIT: GError *err = NULL; gsize len; CODE: RETVAL = g_bookmark_file_to_data (bookmark_file, &len, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc __gerror__ Saves the contents of a bookmark file into a file. The write operation is guaranteed to be atomical by writing the contents of the bookmark file to a temporary file and then moving the file to the target file. =cut void g_bookmark_file_to_file (bookmark_file, file) GBookmarkFile *bookmark_file GPerlFilename_const file PREINIT: GError *err = NULL; CODE: g_bookmark_file_to_file (bookmark_file, file, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc Looks whether the bookmark file has a bookmark for $uri. =cut gboolean g_bookmark_file_has_item (GBookmarkFile *bookmark_file, const gchar *uri) =for apidoc __gerror__ Removes the bookmark for $uri from the bookmark file. =cut void g_bookmark_file_remove_item (GBookmarkFile *bookmark_file, const gchar *uri) PREINIT: GError *err = NULL; CODE: g_bookmark_file_remove_item (bookmark_file, uri, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ Changes the URI of a bookmark item from $old_uri to $new_uri. Any existing bookmark for $new_uri will be overwritten. If $new_uri is undef, then the bookmark is removed. =cut void g_bookmark_file_move_item (bookmark_file, old_uri, new_uri) GBookmarkFile *bookmark_file const gchar *old_uri const gchar_ornull *new_uri PREINIT: GError *err = NULL; CODE: g_bookmark_file_move_item (bookmark_file, old_uri, new_uri, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc Gets the number of bookmarks inside the bookmark file. =cut gint g_bookmark_file_get_size (GBookmarkFile *bookmark_file) =for apidoc =signature list = $bookmark_file->get_uris Returns the URI of all the bookmarks in the bookmark file. =cut void g_bookmark_file_get_uris (bookmark_file) GBookmarkFile *bookmark_file PREINIT: gchar **uris; gsize len, i; PPCODE: uris = g_bookmark_file_get_uris (bookmark_file, &len); if (len != 0) { for (i = 0; i < len; i++) { if (uris[i]) XPUSHs (sv_2mortal (newSVGChar (uris[i]))); } } g_strfreev (uris); =for apidoc Sets the title of the bookmark for $uri. If no bookmark for $uri is found one is created. =cut void g_bookmark_file_set_title (GBookmarkFile *bookmark_file, const gchar *uri, const gchar *title) =for apidoc __gerror__ =signature $bookmark_file->get_title ($uri, $title) Gets the title of the bookmark for $uri. =cut gchar_own * g_bookmark_file_get_title (bookmark_file, uri) GBookmarkFile *bookmark_file const gchar *uri PREINIT: GError *err = NULL; CODE: RETVAL = g_bookmark_file_get_title (bookmark_file, uri, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc Sets the description of the bookmark for $uri. If no bookmark for $uri is found one is created. =cut void g_bookmark_file_set_description (GBookmarkFile *bookmark_file, const gchar *uri, const gchar *description) =for apidoc __gerror__ =signature $bookmark_file->get_description ($uri) Gets the description of the bookmark for $uri. =cut gchar_own * g_bookmark_file_get_description (bookmark_file, uri) GBookmarkFile *bookmark_file const gchar *uri PREINIT: GError *err = NULL; CODE: RETVAL = g_bookmark_file_get_description (bookmark_file, uri, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc Sets the MIME type of the bookmark for $uri. If no bookmark for $uri is found one is created. =cut void g_bookmark_file_set_mime_type (GBookmarkFile *bookmark_file, const gchar *uri, const gchar *mime_type) =for apidoc __gerror__ Gets the MIME type of the bookmark for $uri. =cut gchar_own * g_bookmark_file_get_mime_type (bookmark_file, uri) GBookmarkFile *bookmark_file const gchar *uri PREINIT: GError *err = NULL; CODE: RETVAL = g_bookmark_file_get_mime_type (bookmark_file, uri, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc =for arg ... one or more group names Sets a list of group names for the item with URI $uri. Each previously set group name list is removed. If no bookmark for $uri is found one is created. =cut void g_bookmark_file_set_groups (GBookmarkFile *bookmark_file, const gchar *uri, ...) PREINIT: gchar **groups; gsize groups_len; int i; CODE: groups_len = (gsize) (items - 2); groups = g_new0 (gchar *, groups_len + 1); for (i = 2; i < items; i++) groups[i - 2] = SvPV_nolen (ST (i)); g_bookmark_file_set_groups (bookmark_file, uri, (const gchar **) groups, groups_len); g_free (groups); =for apidoc Adds $group to the list of groups to which the bookmark for $uri belongs to. If no bookmark for $uri is found one is created. =cut void g_bookmark_file_add_group (GBookmarkFile *bookmark_file, const gchar *uri, const gchar *group) =for apidoc __gerror__ Checks whether $group appears in the list of groups to which the bookmark for $uri belongs to. =cut gboolean g_bookmark_file_has_group (bookmark_file, uri, group) GBookmarkFile *bookmark_file const gchar *uri const gchar *group PREINIT: GError *err = NULL; CODE: RETVAL = g_bookmark_file_has_group (bookmark_file, uri, group, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc __gerror__ Retrieves the list of group names of the bookmark for $uri. =cut void g_bookmark_file_get_groups (GBookmarkFile *bookmark_file, const gchar *uri) PREINIT: GError *err = NULL; gchar **groups; gsize len, i; PPCODE: groups = g_bookmark_file_get_groups (bookmark_file, uri, &len, &err); if (err) gperl_croak_gerror (NULL, err); if (len != 0) { for (i = 0; i < len; i++) { if (groups[i]) XPUSHs (sv_2mortal (newSVGChar (groups[i]))); } } g_strfreev (groups); =for apidoc __gerror__ Removes $group from the list of groups to which the bookmark for $uri belongs to. =cut void g_bookmark_file_remove_group (bookmark_file, uri, group) GBookmarkFile *bookmark_file const gchar *uri const gchar *group PREINIT: GError *err = NULL; CODE: g_bookmark_file_remove_group (bookmark_file, uri, group, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc Adds the application with $name and $exec to the list of applications that have registered a bookmark for $uri into $bookmark_file. Every bookmark inside a C must have at least an application registered. Each application must provide a name, a command line useful for launching the bookmark, the number of times the bookmark has been registered by the application and the last time the application registered this bookmark. If $name is undef, the name of the application will be the same returned by Glib::get_application_name(); if $exec is undef, the command line will be a composition of the program name as returned by Glib::get_prgname() and the "%u" modifier, which will be expanded to the bookmark's URI. This function will automatically take care of updating the registrations count and timestamping in case an application with the same $name had already registered a bookmark for $uri inside the bookmark file. If no bookmark for $uri is found one is created. =cut void g_bookmark_file_add_application (bookmark_file, uri, name, exec) GBookmarkFile *bookmark_file const gchar *uri const gchar_ornull *name const gchar_ornull *exec =for apidoc __gerror__ Checks whether the bookmark for $uri inside $bookmark_file has been registered by application $name. =cut gboolean g_bookmark_file_has_application (bookmark_file, uri, name) GBookmarkFile *bookmark_file const gchar *uri const gchar *name PREINIT: GError *err = NULL; CODE: RETVAL = g_bookmark_file_has_application (bookmark_file, uri, name, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc __gerror__ Removes application registered with $name from the list of applications that have registered a bookmark for $uri inside $bookmark_file. =cut void g_bookmark_file_remove_application (bookmark_file, uri, name) GBookmarkFile *bookmark_file const gchar *uri const gchar *name PREINIT: GError *err = NULL; CODE: g_bookmark_file_remove_application (bookmark_file, uri, name, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ =signature list = $bookmark_file->get_applications ($uri) Retrieves the names of the applications that have registered the bookmark for $uri. =cut void g_bookmark_file_get_applications (bookmark_file, uri) GBookmarkFile *bookmark_file const gchar *uri PREINIT: gchar **apps; gsize len, i; GError *err = NULL; PPCODE: apps = g_bookmark_file_get_applications (bookmark_file, uri, &len, &err); if (err) gperl_croak_gerror (NULL, err); if (len != 0) { for (i = 0; i < len; i++) { if (apps[i]) XPUSHs (sv_2mortal (newSVGChar (apps[i]))); } } g_strfreev (apps); =for apidoc __gerror__ Sets the meta-data of application $name inside the list of applications that have registered a bookmark for $uri inside $bookmark_file. You should rarely use this method; use Glib::BookmarkFile::add_application() and Glib::BookmarkFile::remove_application() instead. $name can be any UTF-8 encoded string used to identify an application. $exec can have one of these two modifiers: "%f", which will be expanded as the local file name retrieved from the bookmark's URI; "%u", which will be expanded as the bookmark's URI. The expansion is done automatically when retrieving the stored command line using the Glib::BookmarkFile::get_app_info() method. $count is the number of times the application has registered the bookmark; if it is < 0, the current registration count will be increased by one, if it is 0, the application with $name will be removed from the list of registered applications. $stamp is the Unix time of the last registration, as returned by time(); if it is -1, the current time will be used. If you try to remove an application by setting its registration count to zero, and no bookmark for $uri is found, %FALSE is returned and an exception is fired. =cut void g_bookmark_file_set_app_info (bookmark_file, uri, name, exec, count, stamp) GBookmarkFile *bookmark_file const gchar *uri const gchar *name const gchar *exec gint count time_t stamp PREINIT: GError *err = NULL; CODE: g_bookmark_file_set_app_info (bookmark_file, uri, name, exec, count, stamp, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ =signature ($exec, $count, $stamp) = $bookmark_file->get_app_info ($uri, $name) Gets the registration information of $name for the bookmark for $uri. See Glib::BookmarkFile::set_app_info() for more information about the returned data. =cut void g_bookmark_file_get_app_info (bookmark_file, uri, name) GBookmarkFile *bookmark_file const gchar *uri const gchar *name PREINIT: gchar *exec; guint count; time_t stamp; GError *err = NULL; PPCODE: g_bookmark_file_get_app_info (bookmark_file, uri, name, &exec, &count, &stamp, &err); if (err) gperl_croak_gerror (NULL, err); EXTEND (SP, 3); PUSHs (sv_2mortal (newSVGChar (exec))); PUSHs (sv_2mortal (newSViv (count))); PUSHs (sv_2mortal (newSViv (stamp))); g_free (exec); =for apidoc =cut void g_bookmark_file_set_is_private (GBookmarkFile *bookmark_file, const gchar *uri, gboolean is_private) =for apidoc __gerror__ =cut gboolean g_bookmark_file_get_is_private (GBookmarkFile *bookmark_file, const gchar *uri) PREINIT: GError *err = NULL; CODE: RETVAL = g_bookmark_file_get_is_private (bookmark_file, uri, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc Sets the icon for the bookmark for $uri. If $href is undef, unsets the currently set icon. =cut void g_bookmark_file_set_icon (bookmark_file, uri, href, mime_type) GBookmarkFile *bookmark_file const gchar *uri const gchar_ornull *href const gchar_ornull *mime_type =for apidoc __gerror__ =signature ($href, $mime_type) = $bookmark_file->get_icon ($uri) Gets the icon of the bookmark for $uri. =cut void g_bookmark_file_get_icon (GBookmarkFile *bookmark_file, const gchar *uri) PREINIT: gchar *href, *mime_type; GError *err = NULL; PPCODE: g_bookmark_file_get_icon (bookmark_file, uri, &href, &mime_type, &err); if (err) gperl_croak_gerror (NULL, err); EXTEND (SP, 2); PUSHs (sv_2mortal (newSVGChar (href))); PUSHs (sv_2mortal (newSVGChar (mime_type))); g_free (href); g_free (mime_type); =for apidoc Glib::BookmarkFile::get_added =for apidoc __gerror__ Gets the time the bookmark for $uri was added to $bookmark_file. =cut =for apidoc Glib::BookmarkFile::get_modified =for apidoc __gerror__ Gets the time the bookmark for $uri was last modified. =cut =for apidoc Glib::BookmarkFile::get_visited =for apidoc __gerror__ Gets the time the bookmark for $uri was last visited. =cut time_t g_bookmark_file_get_added (bookmark_file, uri) GBookmarkFile *bookmark_file const gchar *uri ALIAS: Glib::BookmarkFile::get_modified = 1 Glib::BookmarkFile::get_visited = 2 PREINIT: GError *err = NULL; CODE: switch (ix) { case 0: RETVAL = g_bookmark_file_get_added (bookmark_file, uri, &err); break; case 1: RETVAL = g_bookmark_file_get_modified (bookmark_file, uri, &err); break; case 2: RETVAL = g_bookmark_file_get_visited (bookmark_file, uri, &err); break; default: RETVAL = 0; g_assert_not_reached (); break; } if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc Glib::BookmarkFile::set_added Sets the time the bookmark for $uri was added. If no bookmark for $uri is found one is created. =cut =for apidoc Glib::BookmarkFile::set_modified Sets the time the bookmark for $uri was last modified. If no bookmark for $uri is found one is created. =cut =for apidoc Glib::BookmarkFile::set_visited Sets the time the bookmark for $uri was last visited. If no bookmark for $uri is found one is created. =cut void g_bookmark_file_set_added (bookmark_file, uri, value) GBookmarkFile *bookmark_file const gchar *uri time_t value ALIAS: Glib::BookmarkFile::set_modified = 1 Glib::BookmarkFile::set_visited = 2 CODE: switch (ix) { case 0: g_bookmark_file_set_added (bookmark_file, uri, value); break; case 1: g_bookmark_file_set_modified (bookmark_file, uri, value); break; case 2: g_bookmark_file_set_visited (bookmark_file, uri, value); break; default: g_assert_not_reached (); break; } Glib-1.320/GBoxed.xs000644 001750 000024 00000060555 12636024471 015233 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2005, 2009-2013 by the gtk2-perl team (see the file * AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ =head2 GBoxed =over =item GPerlBoxedWrapperClass Specifies the vtable of functions to be used for bringing boxed types in and out of perl. The structure is defined like this: typedef struct _GPerlBoxedWrapperClass GPerlBoxedWrapperClass; struct _GPerlBoxedWrapperClass { GPerlBoxedWrapFunc wrap; GPerlBoxedUnwrapFunc unwrap; GPerlBoxedDestroyFunc destroy; }; The members are function pointers, each of which serves a specific purpose: =over =item GPerlBoxedWrapFunc turn a boxed pointer into an SV. gtype is the type of the boxed pointer, and package is the package to which that gtype is registered (the lookup has already been done for you at this point). if own is true, the wrapper is responsible for freeing the object; if it is false, some other code owns the object and you must NOT free it. typedef SV* (*GPerlBoxedWrapFunc) (GType gtype, const char * package, gpointer boxed, gboolean own); =item GPerlBoxedUnwrapFunc turn an SV into a boxed pointer. like GPerlBoxedWrapFunc, gtype and package are the registered type pair, already looked up for you (in the process of finding the proper wrapper class). sv is the sv to unwrap. typedef gpointer (*GPerlBoxedUnwrapFunc) (GType gtype, const char * package, SV * sv); =item GPerlBoxedDestroyFunc this will be called by Glib::Boxed::DESTROY, when the wrapper is destroyed. it is a hook that allows you to destroy an object owned by the wrapper; note, however, that you will have had to keep track yourself of whether the object was to be freed. typedef void (*GPerlBoxedDestroyFunc) (SV * sv); =back =cut /* there's still one list open! */ #include "gperl.h" /* #define NOISY */ /* !PRIVATE! BoxedInfo similar to ClassInfo in GObject.xs, BoxedInfo stores information about a boxed type's mapping from C to perl. we keep two hashes of these structures, one indexed by GType, the other by perl package name, for quick and easy lookup. the fundamental job of this mapping is to tell us what perl package corresponds to a particular GType. the next most important thing is the wrapper_class --- this tells the bindings what set of functions to use to convert this boxed type in and out of perl. a default implementation is supplied; see the BoxedWrapper and default_* stuff. */ static GHashTable * info_by_gtype = NULL; static GHashTable * info_by_package = NULL; /* and thread-safety for the above: */ G_LOCK_DEFINE_STATIC (info_by_gtype); G_LOCK_DEFINE_STATIC (info_by_package); typedef struct _BoxedInfo BoxedInfo; typedef struct _BoxedWrapper BoxedWrapper; struct _BoxedInfo { GType gtype; char * package; GPerlBoxedWrapperClass * wrapper_class; }; static BoxedInfo * boxed_info_new (GType gtype, const char * package, GPerlBoxedWrapperClass * wrapper_class) { BoxedInfo * boxed_info; boxed_info = g_new0 (BoxedInfo, 1); boxed_info->gtype = gtype; boxed_info->package = package ? g_strdup (package) : NULL; boxed_info->wrapper_class = wrapper_class; return boxed_info; } static BoxedInfo * boxed_info_copy (BoxedInfo * boxed_info) { BoxedInfo * new_boxed_info; new_boxed_info = g_new0 (BoxedInfo, 1); memcpy (new_boxed_info, boxed_info, sizeof (BoxedInfo)); new_boxed_info->package = g_strdup (boxed_info->package); return new_boxed_info; } static void boxed_info_destroy (BoxedInfo * boxed_info) { if (boxed_info) { boxed_info->gtype = 0; if (boxed_info->package) g_free (boxed_info->package); boxed_info->package = NULL; boxed_info->wrapper_class = NULL; g_free (boxed_info); } } =item void gperl_register_boxed (GType gtype, const char * package, GPerlBoxedWrapperClass * wrapper_class) Register a mapping between the GBoxed derivative I and I. The specified, I will be used to wrap and unwrap objects of this type; you may pass NULL to use the default wrapper (the same one returned by gperl_default_boxed_wrapper_class()). In normal usage, the standard opaque wrapper supplied by the library is sufficient and correct. In some cases, however, you want a boxed type to map directly to a native perl type; for example, some struct may be more appropriately represented as a hash in perl. Since the most necessary place for this conversion to happen is in gperl_value_from_sv() and gperl_sv_from_value(), the only reliable and robust way to implement this is a hook into gperl_get_boxed_check() and gperl_new_boxed(); that is exactly the purpose of I. See C. I does not copy the contents of I -- it assumes that I is statically allocated and that it will be valid for the whole lifetime of the program. =cut void gperl_register_boxed (GType gtype, const char * package, GPerlBoxedWrapperClass * wrapper_class) { BoxedInfo * boxed_info; G_LOCK (info_by_gtype); G_LOCK (info_by_package); if (!info_by_gtype) { info_by_gtype = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify) boxed_info_destroy); info_by_package = g_hash_table_new_full (g_str_hash, g_str_equal, NULL, NULL); } boxed_info = boxed_info_new (gtype, package, wrapper_class); /* We need to insert into info_by_package first because there might * otherwise be trouble if we overwrite an entry: inserting into * info_by_gtype frees the boxed_info of the overwritten entry, so that * boxed_info->package is no longer valid at this point. * * Note also it's g_hash_table_replace() for info_by_package, * because the old key string in the old boxed_info will be freed * when info_by_gtype updates the value there. */ g_hash_table_replace (info_by_package, boxed_info->package, boxed_info); g_hash_table_insert (info_by_gtype, (gpointer) gtype, boxed_info); /* GBoxed types are plain structures, so it would be really * surprising to find a boxed type that actually inherits another * boxed type. we'll do that at the perl level, for example with * GdkEvent, but at the C level it's not safe. such things should * be objects. * so, we don't have to worry about the complicated semantics of * type registration like gperl_register_object, and life is simple * and beautiful. */ if (package && gtype != G_TYPE_BOXED) gperl_set_isa (package, "Glib::Boxed"); #ifdef NOISY warn ("gperl_register_boxed (%d(%s), %s, %p)\n", gtype, g_type_name (gtype), package, wrapper_class); #endif G_UNLOCK (info_by_gtype); G_UNLOCK (info_by_package); } =item void gperl_register_boxed_alias (GType gtype, const char * package) Makes I an alias for I. This means that the package name specified by I will be mapped to I by I, but I won't map I to I. This is useful if you want to change the canonical package name of a type while preserving backwards compatibility with code which uses I to specify I. In order for this to make sense, another package name should be registered for I with I. =cut void gperl_register_boxed_alias (GType gtype, const char * package) { BoxedInfo * boxed_info; G_LOCK (info_by_gtype); boxed_info = (BoxedInfo *) g_hash_table_lookup (info_by_gtype, (gpointer) gtype); G_UNLOCK (info_by_gtype); if (!boxed_info) { croak ("cannot register alias %s for the unregistered type %s", package, g_type_name (gtype)); } G_LOCK (info_by_package); /* associate package with the same boxed_info. boxed_info is still owned by info_by_gtype. info_by_package doesn't have a free-function installed, so that's ok. */ g_hash_table_insert (info_by_package, (char *) package, boxed_info); G_UNLOCK (info_by_package); } =item void gperl_register_boxed_synonym (GType registered_gtype, GType synonym_gtype) Registers I as a synonym for I. All boxed objects of type I will then be treated as if they were of type I, and I will return the package associated with I. I must have been registered with I already. =cut void gperl_register_boxed_synonym (GType registered_gtype, GType synonym_gtype) { BoxedInfo * registered_boxed_info, * synonym_boxed_info; G_LOCK (info_by_gtype); registered_boxed_info = (BoxedInfo *) g_hash_table_lookup (info_by_gtype, (gpointer) registered_gtype); if (!registered_boxed_info) { croak ("cannot make %s synonymous to the unregistered type %s", g_type_name (synonym_gtype), g_type_name (registered_gtype)); } synonym_boxed_info = boxed_info_copy (registered_boxed_info); g_hash_table_insert (info_by_gtype, (gpointer) synonym_gtype, synonym_boxed_info); G_UNLOCK (info_by_gtype); } =item GType gperl_boxed_type_from_package (const char * package) Look up the GType associated with package I. Returns 0 if I is not registered. =cut GType gperl_boxed_type_from_package (const char * package) { BoxedInfo * boxed_info; G_LOCK (info_by_package); boxed_info = (BoxedInfo*) g_hash_table_lookup (info_by_package, package); G_UNLOCK (info_by_package); if (!boxed_info) return 0; return boxed_info->gtype; } =item const char * gperl_boxed_package_from_type (GType type) Look up the package associated with GBoxed derivative I. Returns NULL if I is not registered. =cut const char * gperl_boxed_package_from_type (GType type) { BoxedInfo * boxed_info; G_LOCK (info_by_gtype); boxed_info = (BoxedInfo*) g_hash_table_lookup (info_by_gtype, (gpointer) type); G_UNLOCK (info_by_gtype); if (!boxed_info) return NULL; return boxed_info->package; } /************************************************************/ /* BoxedWrapper In order to make life simple, we supply a default GPerlBoxedWrapperClass, which wraps boxed type objects into an opaque data structure. GBoxed types don't know what their own type is, nor do they give you a way to store metadata. thus, we actually wrap a BoxedWrapper struct into the perl wrapper, and store the boxed object and some metadata in the BoxedWrapper. */ /* inspired by pygtk */ struct _BoxedWrapper { gpointer boxed; GType gtype; gboolean free_on_destroy; }; static BoxedWrapper * boxed_wrapper_new (gpointer boxed, GType gtype, gboolean free_on_destroy) { BoxedWrapper * boxed_wrapper; boxed_wrapper = g_new (BoxedWrapper, 1); boxed_wrapper->boxed = boxed; boxed_wrapper->gtype = gtype; boxed_wrapper->free_on_destroy = free_on_destroy; return boxed_wrapper; } static void boxed_wrapper_destroy (BoxedWrapper * boxed_wrapper) { if (boxed_wrapper) { if (boxed_wrapper->free_on_destroy) g_boxed_free (boxed_wrapper->gtype, boxed_wrapper->boxed); g_free (boxed_wrapper); } else { warn ("boxed_wrapper_destroy called on NULL pointer"); } } static SV * default_boxed_wrap (GType gtype, const char * package, gpointer boxed, gboolean own) { SV * sv; BoxedWrapper * boxed_wrapper; boxed_wrapper = boxed_wrapper_new (boxed, gtype, own); sv = newSV (0); sv_setref_pv (sv, package, boxed_wrapper); #ifdef NOISY warn ("default_boxed_wrap 0x%p for %s 0x%p", boxed_wrapper, package, boxed); #endif return sv; } static gpointer default_boxed_unwrap (GType gtype, const char * package, SV * sv) { BoxedWrapper * boxed_wrapper; PERL_UNUSED_VAR (gtype); if (!gperl_sv_is_ref (sv)) croak ("expected a blessed reference"); if (!sv_derived_from (sv, package)) croak ("%s is not of type %s", gperl_format_variable_for_output (sv), package); boxed_wrapper = INT2PTR (BoxedWrapper*, SvIV (SvRV (sv))); if (!boxed_wrapper) croak ("internal nastiness: boxed wrapper contains NULL pointer"); return boxed_wrapper->boxed; } static void default_boxed_destroy (SV * sv) { #ifdef NOISY { BoxedWrapper * wrapper = (BoxedWrapper*) SvIV (SvRV (sv)); warn ("default_boxed_destroy wrapper 0x%p --- %s 0x%p\n", wrapper, g_type_name (wrapper ? wrapper->gtype : 0), wrapper ? wrapper->boxed : NULL); } #endif boxed_wrapper_destroy (INT2PTR (BoxedWrapper*, SvIV (SvRV (sv)))); } static GPerlBoxedWrapperClass _default_wrapper_class = { default_boxed_wrap, default_boxed_unwrap, default_boxed_destroy }; =item GPerlBoxedWrapperClass * gperl_default_boxed_wrapper_class (void) get a pointer to the default wrapper class; handy if you want to use the normal wrapper, with minor modifications. note that you can just pass NULL to gperl_register_boxed(), so you really only need this in fringe cases. =cut GPerlBoxedWrapperClass * gperl_default_boxed_wrapper_class (void) { return &_default_wrapper_class; } /***************************************************************************/ =item SV * gperl_new_boxed (gpointer boxed, GType gtype, gboolean own) Export a GBoxed derivative to perl, according to whatever GPerlBoxedWrapperClass is registered for I. In the default implementation, this means wrapping an opaque perl object around the pointer to a small wrapper structure which stores some metadata, such as whether the boxed structure should be destroyed when the wrapper is destroyed (controlled by I; if the wrapper owns the object, the wrapper is in charge of destroying it's data). This function might end up calling other Perl code, so if you use it in XS code for a generic GType, make sure the stack pointer is set up correctly before the call, and restore it after the call. =cut SV * gperl_new_boxed (gpointer boxed, GType gtype, gboolean own) { BoxedInfo * boxed_info; GPerlBoxedWrapFunc wrap; if (!boxed) { #ifdef NOISY warn ("NULL pointer made it into gperl_new_boxed"); #endif return &PL_sv_undef; } G_LOCK (info_by_gtype); boxed_info = (BoxedInfo*) g_hash_table_lookup (info_by_gtype, (gpointer) gtype); G_UNLOCK (info_by_gtype); if (!boxed_info) croak ("GType %s (%d) is not registered with gperl", g_type_name (gtype), gtype); wrap = boxed_info->wrapper_class ? boxed_info->wrapper_class->wrap : _default_wrapper_class.wrap; if (!wrap) croak ("no function to wrap boxed objects of type %s / %s", g_type_name (gtype), boxed_info->package); return (*wrap) (gtype, boxed_info->package, boxed, own); } =item SV * gperl_new_boxed_copy (gpointer boxed, GType gtype) Create a new copy of I and return an owner wrapper for it. I may not be NULL. See C. =cut SV * gperl_new_boxed_copy (gpointer boxed, GType gtype) { return boxed ? gperl_new_boxed (g_boxed_copy (gtype, boxed), gtype, TRUE) : &PL_sv_undef; } =item gpointer gperl_get_boxed_check (SV * sv, GType gtype) Extract the boxed pointer from a wrapper; croaks if the wrapper I is not blessed into a derivative of the expected I. Does not allow undef. =cut gpointer gperl_get_boxed_check (SV * sv, GType gtype) { BoxedInfo * boxed_info; GPerlBoxedUnwrapFunc unwrap; if (!gperl_sv_is_defined (sv)) croak ("variable not allowed to be undef where %s is wanted", g_type_name (gtype)); G_LOCK (info_by_gtype); boxed_info = g_hash_table_lookup (info_by_gtype, (gpointer) gtype); G_UNLOCK (info_by_gtype); if (!boxed_info) croak ("internal problem: GType %s (%d) has not been registered with GPerl", g_type_name (gtype), gtype); unwrap = boxed_info->wrapper_class ? boxed_info->wrapper_class->unwrap : _default_wrapper_class.unwrap; if (!unwrap) croak ("no function to unwrap boxed objects of type %s / %s", g_type_name (gtype), boxed_info->package); return (*unwrap) (gtype, boxed_info->package, sv); } =back =cut static BoxedInfo * lookup_known_package_recursive (const char * package) { BoxedInfo * boxed_info = g_hash_table_lookup (info_by_package, package); if (!boxed_info) { int i; char * isa_name = form ("%s::ISA", package); AV * isa = get_av (isa_name, FALSE); if (!isa) return NULL; for (i = 0 ; i <= av_len (isa); i++) { SV ** sv = av_fetch (isa, i, FALSE); char * p = sv ? SvPV_nolen (*sv) : NULL; if (p) { boxed_info = lookup_known_package_recursive (p); if (boxed_info) break; } } } return boxed_info; } #if GLIB_CHECK_VERSION (2, 4, 0) static SV* strv_wrap (GType gtype, const char * package, gpointer boxed, gboolean own) { AV * av; int i; gchar ** strv; PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); if (!boxed) return &PL_sv_undef; strv = (gchar**) boxed; av = newAV (); for (i = 0 ; strv[i] != NULL ; i++) av_push (av, newSVGChar (strv[i])); if (own) g_strfreev (strv); return newRV_noinc ((SV*)av); } static gpointer strv_unwrap (GType gtype, const char * package, SV * sv) { gchar ** strv = NULL; PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); /* pass undef */ if (!gperl_sv_is_defined (sv)) return NULL; if (gperl_sv_is_ref (sv)) { AV * av; int n; /* only allow a reference to an array */ if (!gperl_sv_is_array_ref (sv)) croak ("expecting a reference to an array of strings for Glib::Strv"); av = (AV*) SvRV (sv); n = av_len (av) + 1; if (n > 0) { int i; strv = gperl_alloc_temp ((n + 1) * sizeof (gchar *)); for (i = 0 ; i < n ; i++) strv[i] = SvGChar (*av_fetch (av, i, FALSE)); strv[n] = NULL; } } else { /* stringify anything else, assuming it's a one-element list */ strv = gperl_alloc_temp (2 * sizeof (gchar*)); strv[0] = SvGChar (sv); strv[1] = NULL; } return strv; } static GPerlBoxedWrapperClass strv_wrapper_class = { strv_wrap, strv_unwrap, NULL }; #endif static SV* gstring_wrap (GType gtype, const char * package, gpointer boxed, gboolean own) { SV * sv; GString *gstr; PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); if (!boxed) return &PL_sv_undef; gstr = (GString*) boxed; sv = newSVpv (gstr->str, gstr->len); if (own) g_string_free (gstr, TRUE); return sv; } static gpointer gstring_unwrap (GType gtype, const char * package, SV * sv) { GString *gstr = NULL; PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); /* pass undef */ if (!gperl_sv_is_defined (sv)) return NULL; gstr = gperl_alloc_temp (sizeof (GString)); gstr->str = SvPV (sv, gstr->len); gstr->allocated_len = gstr->len; return gstr; } static GPerlBoxedWrapperClass gstring_wrapper_class = { gstring_wrap, gstring_unwrap, NULL }; #if GLIB_CHECK_VERSION (2, 26, 0) static SV* gerror_wrap (GType gtype, const char * package, gpointer boxed, gboolean own) { SV *sv; GError *error; PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); if (!boxed) return &PL_sv_undef; error = (GError*) boxed; sv = gperl_sv_from_gerror (error); if (own) g_error_free (error); return sv; } static gpointer gerror_unwrap (GType gtype, const char * package, SV * sv) { GError *error = NULL; PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); gperl_gerror_from_sv (sv, &error); return error; } static GPerlBoxedWrapperClass gerror_wrapper_class = { gerror_wrap, gerror_unwrap, NULL }; #endif MODULE = Glib::Boxed PACKAGE = Glib::Boxed BOOT: gperl_register_boxed (G_TYPE_BOXED, "Glib::Boxed", NULL); gperl_register_boxed (G_TYPE_STRING, "Glib::String", NULL); gperl_set_isa ("Glib::String", "Glib::Boxed"); gperl_register_boxed (G_TYPE_GSTRING, "Glib::GString", &gstring_wrapper_class); #if GLIB_CHECK_VERSION (2, 4, 0) gperl_register_boxed (G_TYPE_STRV, "Glib::Strv", &strv_wrapper_class); #endif #if GLIB_CHECK_VERSION (2, 26, 0) gperl_register_boxed (G_TYPE_ERROR, "Glib::Error", &gerror_wrapper_class); #endif #if GLIB_CHECK_VERSION (2, 32, 0) gperl_register_boxed (G_TYPE_BYTES, "Glib::Bytes", NULL); #endif =for object Glib::Boxed Generic wrappers for C structures =cut =for position DESCRIPTION =head1 DESCRIPTION Glib::Boxed is a generic wrapper mechanism for arbitrary C structures. For the most part you don't care about this as a Perl developer, but it is important to know that all Glib::Boxed descendents can be copied with the C method. =cut =for apidoc =for signature copy_of_boxed = $boxed->copy Create and return a new copy of I<$boxed>. =cut SV * copy (SV * sv) PREINIT: BoxedInfo * boxed_info; GPerlBoxedWrapperClass * class; gpointer boxed; const char * package; CODE: /* the sticky part is that we have to decipher from the SV what gtype * we actually have; but the SV may have been blessed into some * other type. however, if we got here, then Glib::Boxed is in the * @ISA somewhere, so we should be able to walk the inheritance * tree until we find a valid GType. */ package = sv_reftype (SvRV (sv), TRUE); G_LOCK (info_by_package); boxed_info = lookup_known_package_recursive (package); G_UNLOCK (info_by_package); if (!boxed_info) croak ("can't find boxed class registration info for %s\n", package); class = boxed_info->wrapper_class ? boxed_info->wrapper_class : &_default_wrapper_class; if (!class->wrap) croak ("no function to wrap boxed objects of type %s / %s", g_type_name (boxed_info->gtype), boxed_info->package); if (!class->unwrap) croak ("no function to unwrap boxed objects of type %s / %s", g_type_name (boxed_info->gtype), boxed_info->package); boxed = class->unwrap (boxed_info->gtype, boxed_info->package, sv); /* No PUTBACK/SPAGAIN needed here. */ RETVAL = class->wrap (boxed_info->gtype, boxed_info->package, g_boxed_copy (boxed_info->gtype, boxed), TRUE); OUTPUT: RETVAL void DESTROY (sv) SV * sv PREINIT: BoxedInfo * boxed_info; const char * class; GPerlBoxedDestroyFunc destroy; CODE: if (!gperl_sv_is_ref (sv) || !SvRV (sv)) croak ("DESTROY called on a bad value"); /* we need to find the wrapper class associated with whatever type * the wrapper is blessed into. */ class = sv_reftype (SvRV (sv), TRUE); G_LOCK (info_by_package); boxed_info = g_hash_table_lookup (info_by_package, class); G_UNLOCK (info_by_package); #ifdef NOISY warn ("Glib::Boxed::DESTROY (%s) for %s -> %s", SvPV_nolen (sv), class, boxed_info ? g_type_name (boxed_info->gtype) : NULL); #endif destroy = boxed_info ? (boxed_info->wrapper_class ? boxed_info->wrapper_class->destroy : _default_wrapper_class.destroy) : NULL; if (destroy) (*destroy) (sv); MODULE = Glib::Boxed PACKAGE = Glib::Bytes PREFIX = g_bytes_ =for DESCRIPTION =head1 DESCRIPTION In addition to the low-level API documented below, L also provides stringification overloading so that you can treat any C object as a normal Perl string. =cut GBytes_own * g_bytes_new (class, SV *data) PREINIT: const char *real_data; STRLEN len; CODE: real_data = SvPVbyte (data, len); RETVAL = g_bytes_new (real_data, len); OUTPUT: RETVAL SV * g_bytes_get_data (GBytes *bytes) PREINIT: gconstpointer data; gsize size; CODE: data = g_bytes_get_data (bytes, &size); RETVAL = newSVpv (data, size); OUTPUT: RETVAL gsize g_bytes_get_size (GBytes *bytes); guint g_bytes_hash (GBytes *bytes); gboolean g_bytes_equal (GBytes *bytes1, GBytes *bytes2); gint g_bytes_compare (GBytes *bytes1, GBytes *bytes2); Glib-1.320/GClosure.xs000644 001750 000024 00000057677 12435270240 015613 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2009, 2012-2013 by the gtk2-perl team (see the file * AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ =head2 GClosure / GPerlClosure GPerlClosure is a wrapper around the gobject library's GClosure with special handling for marshalling perl subroutines as callbacks. This is specially tuned for use with GSignal and stuff like io watch, timeout, and idle handlers. For generic callback functions, which need parameters but do not get registered with the type system, this is sometimes overkill. See GPerlCallback, below. =over =cut #include "gperl.h" #include #include "gperl_marshal.h" #include "gperl-private.h" static void gperl_closure_invalidate (gpointer data, GClosure * closure) { GPerlClosure * pc = (GPerlClosure *)closure; PERL_UNUSED_VAR (data); #ifdef NOISY warn ("Invalidating closure for %s\n", SvPV_nolen (pc->callback)); #endif if (pc->callback) { SvREFCNT_dec (pc->callback); pc->callback = NULL; } if (pc->data) { SvREFCNT_dec (pc->data); pc->data = NULL; } } #ifdef PERL_IMPLICIT_CONTEXT # define INVOKED_FROM_FOREIGN_THREAD (!PERL_GET_CONTEXT) #else # define INVOKED_FROM_FOREIGN_THREAD \ (_gperl_get_main_tid () != g_thread_self ()) #endif static void _closure_hand_to_main (GClosure * closure, GValue * return_value, guint n_param_values, const GValue * param_values, gpointer invocation_hint, gpointer marshal_data); static void gperl_closure_marshal (GClosure * closure, GValue * return_value, guint n_param_values, const GValue * param_values, gpointer invocation_hint, gpointer marshal_data) { gboolean want_return_value; int flags; guint i; dGPERL_CLOSURE_MARSHAL_ARGS; /* If the current thread doesn't have a Perl context associated with * it, then we have no choice but to hand over everything to the main * thread and let it handle marshalling. * * We cannot simply use the main thread's Perl context here because the * Perl interpreter is not thread-safe. For the same reason, we cannot * use perl_clone to create a new Perl interpreter from the main one. */ if (INVOKED_FROM_FOREIGN_THREAD) { #ifdef NOISY g_printerr ("*** GPerl asked to invoke callback from a foreign thread; " "handing it over to the main loop\n"); #endif _closure_hand_to_main (closure, return_value, n_param_values, param_values, invocation_hint, marshal_data); return; } GPERL_CLOSURE_MARSHAL_INIT (closure, marshal_data); PERL_UNUSED_VAR (invocation_hint); ENTER; SAVETMPS; PUSHMARK (SP); if (n_param_values == 0) { data = SvREFCNT_inc (pc->data); } else { GPERL_CLOSURE_MARSHAL_PUSH_INSTANCE (param_values); /* the rest of the params should be quite straightforward. */ for (i = 1; i < n_param_values; i++) { SV * arg = SAVED_STACK_SV ( gperl_sv_from_value ((GValue*) param_values + i)); /* make these mortal as they go onto the stack */ XPUSHs (sv_2mortal (arg)); } } GPERL_CLOSURE_MARSHAL_PUSH_DATA; PUTBACK; want_return_value = return_value && G_VALUE_TYPE (return_value); flags = want_return_value ? G_SCALAR : G_VOID|G_DISCARD; SPAGAIN; GPERL_CLOSURE_MARSHAL_CALL (flags); PERL_UNUSED_VAR (count); if (want_return_value) { gperl_value_from_sv (return_value, POPs); PUTBACK; /* vitally important */ } /* * clean up */ FREETMPS; LEAVE; } typedef struct { GClosure * closure; GValue * return_value; guint n_param_values; const GValue * param_values; gpointer invocation_hint; gpointer marshal_data; GCond * done_cond; GMutex * done_mutex; } MarshallerArgs; static gboolean _closure_remarshal (gpointer data) { MarshallerArgs *args = data; g_mutex_lock (args->done_mutex); gperl_closure_marshal (args->closure, args->return_value, args->n_param_values, args->param_values, args->invocation_hint, args->marshal_data); g_cond_signal (args->done_cond); g_mutex_unlock (args->done_mutex); return FALSE; } static void _closure_hand_to_main (GClosure * closure, GValue * return_value, guint n_param_values, const GValue * param_values, gpointer invocation_hint, gpointer marshal_data) { MarshallerArgs args; args.closure = closure; args.return_value = return_value; args.n_param_values = n_param_values; args.param_values = param_values; args.invocation_hint = invocation_hint; args.marshal_data = marshal_data; /* We need to wait for the other thread to finish marshalling to avoid * gperl_closure_marshal returning prematurely. */ #if GLIB_CHECK_VERSION (2, 32, 0) /* FIXME: we should put these on the stack, but it gets real ugly real fast */ args.done_cond = g_slice_new (GCond); g_cond_init (args.done_cond); args.done_mutex = g_slice_new (GMutex); g_mutex_init (args.done_mutex); #else args.done_cond = g_cond_new (); args.done_mutex = g_mutex_new (); #endif /* 2.32 */ g_mutex_lock (args.done_mutex); /* FIXME: Should we use a higher priority? */ g_idle_add (_closure_remarshal, &args); g_cond_wait (args.done_cond, args.done_mutex); g_mutex_unlock (args.done_mutex); #if GLIB_CHECK_VERSION (2, 32, 0) g_cond_clear (args.done_cond); g_slice_free (GCond, args.done_cond); g_mutex_clear (args.done_mutex); g_slice_free (GMutex, args.done_mutex); #else g_cond_free (args.done_cond); g_mutex_free (args.done_mutex); #endif /* 2.32 */ } =item GClosure * gperl_closure_new (SV * callback, SV * data, gboolean swap) Create and return a new GPerlClosure. I and I will be copied for storage; I must not be NULL. If I is TRUE, I will be swapped with the instance during invocation (this is used to implement g_signal_connect_swapped()). If compiled under a thread-enabled perl, the closure will be created and marshaled in such a way as to ensure that the same interpreter which created the closure will be used to invoke it. =cut GClosure * gperl_closure_new (SV * callback, SV * data, gboolean swap) { return gperl_closure_new_with_marshaller (callback, data, swap, NULL); } =item GClosure * gperl_closure_new_with_marshaller (SV * callback, SV * data, gboolean swap, GClosureMarshal marshaller) Like C, but uses a caller-supplied marshaller. This is provided for use in those sticky circumstances when you just can't do it any other way; in general, you want to use the default marshaller, which you get if you provide NULL for I. If you use you own marshaller, you need to take care of everything yourself, including swapping the instance and data if C is true, calling C if ERRSV is true after invoking the perl sub, and ensuring that you properly use the C parameter as the perl interpreter when PERL_IMPLICIT_CONTEXT is defined. See the implementation of the default marshaller, C, in Glib/GClosure.xs for inspiration. =cut GClosure * gperl_closure_new_with_marshaller (SV * callback, SV * data, gboolean swap, GClosureMarshal marshaller) { GPerlClosure *closure; g_return_val_if_fail (callback != NULL, NULL); if (marshaller == NULL) marshaller = gperl_closure_marshal; closure = (GPerlClosure*) g_closure_new_simple (sizeof (GPerlClosure), NULL); g_closure_add_invalidate_notifier ((GClosure*) closure, NULL, gperl_closure_invalidate); #ifndef PERL_IMPLICIT_CONTEXT g_closure_set_marshal ((GClosure*) closure, marshaller); #else /* make sure the closure gets executed by the same interpreter that's * creating it now; gperl_closure_marshal will interpret the * marshal_data as the proper aTHX. */ g_closure_set_meta_marshal ((GClosure*) closure, aTHX, marshaller); #endif /* * we have to take full copies of these SVs, rather than just * SvREFCNT_inc'ing them, to avoid some bizarre things that can * happen in special cases. see the notes in perlcall section * 'Using call_sv' for more info */ closure->callback = (callback && callback != &PL_sv_undef) ? newSVsv (callback) : NULL; closure->data = (data && data != &PL_sv_undef) ? newSVsv (data) : NULL; closure->swap = swap; return (GClosure*)closure; } =back =head2 GPerlCallback generic callback functions usually get invoked directly, and are not passed parameter lists as GValues. we could very easily wrap up such generic callbacks with something that converts the parameters to GValues and then channels everything through GClosure, but this has two problems: 1) the above implementation of GClosure is tuned to marshalling signal handlers, which always have an instance object, and 2) it's more work than is strictly necessary. additionally, generic callbacks aren't always kind to the GClosure paradigm. so, here's GPerlCallback, which is designed specifically to run generic callback functions. it reads parameters off the C stack and converts them into parameters on the perl stack. (it uses the GValue to/from SV mechanism to do so, but doesn't allocate any temps on the heap.) the callback object itself stores the parameter type list. unfortunately, since the data element is always last, but the number of arguments is not known until we have the callback object, we can't pass gperl_callback_invoke directly to functions requiring a callback; you'll have to write a proxy callback which calls gperl_callback_invoke. =over =item GPerlCallback * gperl_callback_new (SV * func, SV * data, gint n_params, GType param_types[], GType return_type) Create and return a new GPerlCallback; use gperl_callback_destroy when you are finished with it. I: perl subroutine to call. this SV will be copied, so don't worry about reference counts. must B be #NULL. I: scalar to pass to I in addition to all other arguments. the SV will be copied, so don't worry about reference counts. may be #NULL. I: the number of elements in I. I: the #GType of each argument that should be passed from the invocation to I. may be #NULL if I is zero, otherwise it must be I elements long or nasty things will happen. this array will be copied; see gperl_callback_invoke() for how it is used. I: the #GType of the return value, or 0 if the function has void return. =cut GPerlCallback * gperl_callback_new (SV * func, SV * data, gint n_params, GType param_types[], GType return_type) { GPerlCallback * callback; callback = g_new0 (GPerlCallback, 1); /* copy the scalars, so we still have them when the time comes to * be invoked. see the perlcall manpage for more information. */ callback->func = newSVsv (func); if (data) callback->data = newSVsv (data); callback->n_params = n_params; if (callback->n_params) { if (!param_types) croak ("n_params is %d but param_types is NULL in gperl_callback_new", n_params); callback->param_types = g_new (GType, n_params); memcpy (callback->param_types, param_types, n_params * sizeof (GType)); } callback->return_type = return_type; #ifdef PERL_IMPLICIT_CONTEXT callback->priv = aTHX; #endif return callback; } =item void gperl_callback_destroy (GPerlCallback * callback) Dispose of I. =cut void gperl_callback_destroy (GPerlCallback * callback) { #ifdef NOISY warn ("gperl_callback_destroy 0x%p", callback); #endif if (callback) { if (callback->func) { SvREFCNT_dec (callback->func); callback->func = NULL; } if (callback->data) { SvREFCNT_dec (callback->data); callback->data = NULL; } if (callback->param_types) { g_free (callback->param_types); callback->n_params = 0; callback->param_types = NULL; } g_free (callback); } } =item void gperl_callback_invoke (GPerlCallback * callback, GValue * return_value, ...) Marshall the variadic parameters according to I's param_types, and then invoke I's subroutine in scalar context, or void context if the return type is G_TYPE_VOID. If I is not NULL, then value returned (if any) will be copied into I. A typical callback handler would look like this: static gint real_c_callback (Foo * f, Bar * b, int a, gpointer data) { GPerlCallback * callback = (GPerlCallback*)data; GValue return_value = {0,}; gint retval; g_value_init (&return_value, callback->return_type); gperl_callback_invoke (callback, &return_value, f, b, a); retval = g_value_get_int (&return_value); g_value_unset (&return_value); return retval; } =cut void gperl_callback_invoke (GPerlCallback * callback, GValue * return_value, ...) { va_list var_args; dGPERL_CALLBACK_MARSHAL_SP; g_return_if_fail (callback != NULL); GPERL_CALLBACK_MARSHAL_INIT (callback); ENTER; SAVETMPS; PUSHMARK (SP); va_start (var_args, return_value); /* put args on the stack */ if (callback->n_params > 0) { int i; GValue v = {0, }; /* Crib note: must g_value_unset() even when asking for * G_VALUE_NOCOPY_CONTENTS. A GObject is always * g_object_ref()ed for storage in a GValue, even under * G_VALUE_NOCOPY_CONTENTS (see code in * g_value_object_collect_value()). Always reffing in * G_VALUE_COLLECT is in fact the recommended behaviour for * all ref-counted types (see the GTypeValueTable docs, * apparently to ensure objects remain alive for the * duration of a g_signal_emit_valist()). */ for (i = 0 ; i < callback->n_params ; i++) { gchar * error = NULL; SV * sv; g_value_init (&v, callback->param_types[i]); G_VALUE_COLLECT (&v, var_args, G_VALUE_NOCOPY_CONTENTS, &error); if (error) { SV * errstr; /* this should only happen if you've * created the callback incorrectly */ /* we modified the stack -- we need to make * sure perl sees that! */ PUTBACK; errstr = newSVpvf ("error while collecting" " varargs parameters: %s\n" "is your GPerlCallback " "created properly? " " bailing out", error); g_free (error); /* this won't return */ croak ("%s", SvPV_nolen (errstr)); } sv = SAVED_STACK_SV (gperl_sv_from_value (&v)); g_value_unset (&v); if (!sv) { /* this should be very rare, too. */ PUTBACK; croak ("failed to convert GValue to SV"); } XPUSHs (sv_2mortal (sv)); } } /* Usual REFCNT_inc and 2mortal here for putting something on the * stack. It's possible callback->func will disconnect itself, in * which case gperl_callback_destroy() will REFCNT_dec the data. * That's fine, it leaves the mortal ref on the stack as the only * one remaining, and the next FREETMPS will decrement and destroy * in the usual way. * * Being a plain push here means callback->func can modify its * $_[-1] to modify the stored userdata. Slightly scary, but it's a * cute way to get a free bit of per-connection data you can play * with as a state variable or whatnot. And not making a copy saves * a couple of bytes of memory :-). */ { SV *data = callback->data; if (data) { XPUSHs (sv_2mortal (SvREFCNT_inc (data))); } } va_end (var_args); PUTBACK; /* invoke the callback */ if (return_value && G_VALUE_TYPE (return_value)) { if (1 != call_sv (callback->func, G_SCALAR)) croak ("callback returned more than one value in " "scalar context --- something really bad " "is happening"); SPAGAIN; gperl_value_from_sv (return_value, POPs); PUTBACK; /* we modified the stack pointer */ } else { call_sv (callback->func, G_DISCARD); } /* clean up */ FREETMPS; LEAVE; } #if 0 static const char * dump_callback (GPerlCallback * c) { SV * sv = newSVpvf ("{%d, [", c->n_params); int i; for (i = 0 ; i < c->n_params ; i++) sv_catpvf (sv, "%s%s", g_type_name (c->param_types[i]), (i+1) == c->n_params ? "" : ", "); sv_catpvf (sv, "], %s, %s[%d], %s[%d], 0x%p}", g_type_name (c->return_type), SvPV_nolen (c->func), SvREFCNT (c->func), SvPV_nolen (c->data), SvREFCNT (c->data), c->priv); sv_2mortal (sv); return SvPV_nolen (sv); } #endif =back =head2 Exception Handling Like Event, Tk, and most other callback-using, event-based perl modules, Glib traps exceptions that happen in callbacks. To enable your code to do something about these exceptions, Glib stores a list of exception handlers which will be called on the trapped exceptions. This is completely distinct from the $SIG{__DIE__} mechanism provided by Perl itself, for various reasons (not the least of which is that the Perl docs and source code say that $SIG{__DIE__} is intended for running as the program is about to exit, and other behaviors may be removed in the future (apparently a source of much debate on p5p)). =over =cut typedef struct { gulong tag; GClosure * closure; } ExceptionHandler; static GSList * exception_handlers = NULL; G_LOCK_DEFINE_STATIC (exception_handlers); /* this is modified only behind the exception_handlers lock. */ static gboolean in_exception_handler = FALSE; =item int gperl_install_exception_handler (GClosure * closure) Install a GClosure to be executed when gperl_closure_invoke() traps an exception. The closure should return boolean (TRUE if the handler should remain installed) and expect to receive a perl scalar. This scalar will be a private copy of ERRSV ($@) which the handler can mangle to its heart's content. The return value is an integer id tag that may be passed to gperl_removed_exception_handler(). =cut int gperl_install_exception_handler (GClosure * closure) { static int tag = 0; ExceptionHandler * h; h = g_new0 (ExceptionHandler, 1); G_LOCK (exception_handlers); h->tag = ++tag; h->closure = g_closure_ref (closure); g_closure_sink (closure); exception_handlers = g_slist_append (exception_handlers, h); G_UNLOCK (exception_handlers); return h->tag; } void exception_handler_free (ExceptionHandler * h) { g_closure_unref (h->closure); g_free (h); } static void remove_exception_handler_unlocked (guint tag) { GSList * i; for (i = exception_handlers ; i != NULL ; i = i->next) { ExceptionHandler * h = (ExceptionHandler*) i->data; if (h->tag == tag) { exception_handler_free (h); exception_handlers = g_slist_delete_link (exception_handlers, i); break; } } } =item void gperl_remove_exception_handler (guint tag) Remove the exception handler identified by I, as returned by gperl_install_exception_handler(). If I cannot be found, this does nothing. WARNING: this function locks a global data structure, so do NOT call it recursively. also, calling this from within an exception handler will result in a deadlock situation. if you want to remove your handler just have it return FALSE. =cut void gperl_remove_exception_handler (guint tag) { G_LOCK (exception_handlers); remove_exception_handler_unlocked (tag); G_UNLOCK (exception_handlers); } static void warn_of_ignored_exception (const char * message) { /* there's a bit of extra nastiness here to strip the trailing * newline from the contents of ERRSV for printing. */ /* * don't clobber $_. for some reason, SAVE_DEFSV doesn't work here. * so we do it by hand. */ SV * saved_defsv = newSVsv (DEFSV); ENTER; SAVETMPS; sv_setsv (DEFSV, ERRSV); eval_pv ("s/^/*** /mg", FALSE); eval_pv ("s/\n$//s", FALSE); warn ("*** %s:\n" "%s\n" "*** ignoring", message, SvPV_nolen (DEFSV)); FREETMPS; LEAVE; sv_setsv (DEFSV, saved_defsv); SvREFCNT_dec (saved_defsv); } =item void gperl_run_exception_handlers (void) Invoke whatever exception handlers are installed. You will need this if you have written a custom marshaler. Uses the value of the global ERRSV. =cut void gperl_run_exception_handlers (void) { GSList * i, * this; int n_run = 0; /* to avoid problems with handlers that fiddle with the value of * the global $@, we'll pass a copy of $@ to all the handlers * on the stack. this way we know they all get the same one, and * they can do whatever they want to it without actually affecting * anyone else. */ SV * errsv = newSVsv (ERRSV); if (in_exception_handler) { warn_of_ignored_exception ("died in an exception handler"); return; } G_LOCK (exception_handlers); ++in_exception_handler; /* call any registered handlers */ for (i = exception_handlers ; i != NULL ; /* in loop */) { ExceptionHandler * h = (ExceptionHandler *) i->data; GValue param_values = {0, }; GValue return_value = {0, }; g_value_init (¶m_values, GPERL_TYPE_SV); g_value_init (&return_value, G_TYPE_BOOLEAN); /* this will duplicate errsv each time, so that all * callbacks get the same value. */ g_value_set_boxed (¶m_values, errsv); g_closure_invoke (h->closure, &return_value, 1, ¶m_values, NULL); this = i; i = i->next; g_assert (i != this); if (!g_value_get_boolean (&return_value)) { #ifdef NOISY warn ("handler %d returned FALSE, removing\n", h->tag); #endif exception_handler_free (h); exception_handlers = g_slist_delete_link (exception_handlers, this); } g_value_unset (¶m_values); g_value_unset (&return_value); ++n_run; } --in_exception_handler; G_UNLOCK (exception_handlers); if (n_run == 0) warn_of_ignored_exception ("unhandled exception in callback"); /* and clear the error */ sv_setsv (ERRSV, &PL_sv_undef); SvREFCNT_dec (errsv); } =back =cut MODULE = Glib::Closure PACKAGE = Glib PREFIX = gperl_ =for object Glib::Signal Object customization and general purpose notification =cut =for apidoc =for arg func (subroutine) Install a subroutine to be executed when a signal emission traps an exception (a croak or die). I<$func> should return boolean (true if the handler should remain installed) and expect to receive a single scalar. This scalar will be a private copy of $@ which the handler can mangle to its heart's content. Returns an identifier that may be used with C. See C in L. =cut int gperl_install_exception_handler (class, SV * func, SV * data=NULL) C_ARGS: gperl_closure_new (func, data, 0) =for apidoc Remove the exception handler identified by I<$tag>, as returned by C. If I<$tag> cannot be found, this does nothing. WARNING: Do not call this function from within an exception handler. If you want to remove your handler during its execution just have it return false. See C in L. =cut void gperl_remove_exception_handler (class, guint tag) C_ARGS: tag ## ## end on the native package ## MODULE = Glib::Closure PACKAGE = Glib::Closure PREFIX = g_closure_ Glib-1.320/GError.xs000644 001750 000024 00000045131 12636024471 015254 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2004-2009 by the gtk2-perl team (see the file AUTHORS for the full * list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ #include "gperl.h" #include "gperl-gtypes.h" =head2 GError Exception Objects GError is a facility for propagating run-time error / exception information around in C, which is a language without native support for exceptions. GError uses a simple error code, usually defined as an enum. Since the enums will overlap, GError includes the GQuark corresponding to a particular error "domain" to tell you which error codes will be used. There's also a string containing a specific error message. The strings are arbitrary, and may be translated, but the domains and codes are definite. Perl has native support for exceptions, using C as "try", C or C as "throw", and C<< if ($@) >> as "catch". C<$@> may, in fact, be any scalar, including blessed objects. So, GPerl maps GLib's GError to Perl exceptions. Since, as we described above, error messages are not guaranteed to be unique everywhere, we need to support the use of the error domains and codes. The obvious choice here is to use exception objects; however, to support blessed exception objects, we must perform a little bit of black magic in the bindings. There is no built-in association between an error domain quark and the GType of the corresponding error code enumeration, so the bindings supply both of these when specifying the name of the package into which to bless exceptions of this domain. All GError-based exceptions derive from Glib::Error, of course, and this base class provides all of the functionality, including stringification. All you'll really ever need to do is register error domains with C, and throw errors with C. =over =cut typedef struct { GQuark domain; GType error_enum; char * package; } ErrorInfo; static ErrorInfo * error_info_new (GQuark domain, GType error_enum, const char * package) { ErrorInfo * info = g_new (ErrorInfo, 1); info->domain = domain; info->error_enum = error_enum; info->package = package ? g_strdup (package) : NULL; return info; } static void error_info_free (ErrorInfo * info) { if (info) { info->domain = 0; info->error_enum = 0; if (info->package) g_free (info->package); info->package = NULL; g_free (info); } } static GHashTable * errors_by_domain = NULL; =item void gperl_register_error_domain (GQuark domain, GType error_enum, const char * package) Tell the bindings to bless GErrors with error->domain == I into I, and use I to find the nicknames for the error codes. This will call C on I to add "Glib::Error" to I's @ISA. I may not be 0, and I may not be NULL; what would be the point? I may be 0, in which case you'll get no fancy stringified error values. =cut void gperl_register_error_domain (GQuark domain, GType error_enum, const char * package) { g_return_if_fail (domain != 0); /* pointless without this */ g_return_if_fail (package != NULL); /* or this */ if (!errors_by_domain) errors_by_domain = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify) error_info_free); g_hash_table_insert (errors_by_domain, GUINT_TO_POINTER (domain), error_info_new (domain, error_enum, package)); gperl_set_isa (package, "Glib::Error"); } struct FindData { const char * package; ErrorInfo * info; }; static void find_package (gpointer key, ErrorInfo * info, struct FindData * find_data) { PERL_UNUSED_VAR (key); if (g_str_equal (find_data->package, info->package)) find_data->info = info; } static ErrorInfo * error_info_from_package (const char * package) { struct FindData find_data; find_data.package = package; find_data.info = NULL; g_hash_table_foreach (errors_by_domain, (GHFunc) find_package, &find_data); return find_data.info; } static ErrorInfo * error_info_from_domain (GQuark domain) { return (ErrorInfo*) g_hash_table_lookup (errors_by_domain, GUINT_TO_POINTER (domain)); } =item SV * gperl_sv_from_gerror (GError * error) You should rarely, if ever, need to call this function. This is what turns a GError into a Perl object. =cut SV * gperl_sv_from_gerror (GError * error) { HV * hv; ErrorInfo * info; char * package; if (!error) return newSVsv (&PL_sv_undef); info = error_info_from_domain (error->domain); hv = newHV (); gperl_hv_take_sv_s (hv, "domain", newSVGChar (g_quark_to_string (error->domain))); gperl_hv_take_sv_s (hv, "code", newSViv (error->code)); if (info) gperl_hv_take_sv_s (hv, "value", gperl_convert_back_enum (info->error_enum, error->code)); gperl_hv_take_sv_s (hv, "message", newSVGChar (error->message)); /* WARNING: using evil undocumented voodoo. mess() is the function * that die(), warn(), and croak() use to format messages, and it's * what knows how to find the code location. don't want to do that * ourselves, since that's blacker magic, so we'll call this and * hope the perl API doesn't change. */ gperl_hv_take_sv_s (hv, "location", newSVsv (mess ("%s", ""))); package = info ? info->package : "Glib::Error"; return sv_bless (newRV_noinc ((SV*) hv), gv_stashpv (package, TRUE)); } =item gperl_gerror_from_sv (SV * sv, GError ** error) You should rarely need this function. This parses a perl data structure into a GError. If I is undef (or the empty string), sets *I to NULL, otherwise, allocates a new GError with C and writes through I; the caller is responsible for calling C. (gperl_croak_gerror() does this, for example.) =cut void gperl_gerror_from_sv (SV * sv, GError ** error) { ErrorInfo * info = NULL; const char * package; GError scratch; HV * hv; SV ** svp; /* pass back NULL if the sv is false. we need to allow for the * empty string because $@ is often '' rather than undef; as a * side effect, 0 is also allowed. we just won't advertise that. * the logic here is a bit ugly to avoid running the overloaded * stringification operator via SvTRUE(). */ if (!gperl_sv_is_defined (sv) || /* not defined */ (!SvROK (sv) && !SvTRUE (sv))) /* not a ref, but still false */ { *error = NULL; return; } /* * now we must parse a hash. */ if (!gperl_sv_is_hash_ref (sv)) croak ("expecting undef or a hash reference for a GError"); /* * error domain. prefer the type into which the object is blessed, * fall back to the 'domain' key. */ package = sv_reftype (SvRV (sv), TRUE); hv = (HV*) SvRV (sv); if (package) info = error_info_from_package (package); if (!info) { const char * domain; GQuark qdomain; svp = hv_fetch (hv, "domain", 6, FALSE); if (!svp || !gperl_sv_is_defined (*svp)) g_error ("key 'domain' not found in plain hash for GError"); domain = SvPV_nolen (*svp); qdomain = g_quark_try_string (domain); if (!qdomain) g_error ("%s is not a valid quark, did you remember to register an error domain?", domain); info = error_info_from_domain (qdomain); } if (!info) croak ("%s is neither a Glib::Error derivative nor a valid GError domain", SvPV_nolen (sv)); scratch.domain = info->domain; /* * error code. prefer the 'value' key, fall back to 'code'. */ svp = hv_fetch (hv, "value", 5, FALSE); if (svp && gperl_sv_is_defined (*svp)) scratch.code = gperl_convert_enum (info->error_enum, *svp); else { svp = hv_fetch (hv, "code", 4, FALSE); if (!svp || !gperl_sv_is_defined (*svp)) croak ("error hash contains neither a 'value' nor 'code' key; no error valid error code found"); scratch.code = SvIV (*svp); } /* * the message is the easy part. */ svp = hv_fetch (hv, "message", 7, FALSE); if (!svp || !gperl_sv_is_defined (*svp)) croak ("error has contains no error message"); scratch.message = SvGChar (*svp); *error = g_error_new_literal (scratch.domain, scratch.code, scratch.message); } =item void gperl_croak_gerror (const char * ignored, GError * err) Croak with an exception based on I. I may not be NULL. I exists for backward compatibility, and is, well, ignored. This function calls croak(), which does not return. Since croak() does not return, this function handles the magic behind not leaking the memory associated with the #GError. To use this you'd do something like PREINIT: GError * error = NULL; CODE: if (!funtion_that_can_fail (something, &error)) gperl_croak_gerror (NULL, error); It's just that simple! =cut void gperl_croak_gerror (const char * ignored, GError * err) { PERL_UNUSED_VAR (ignored); /* this really could only happen if there's a problem with XS bindings * so we'll use a assertion to catch it, rather than handle null */ g_return_if_fail (err != NULL); sv_setsv (ERRSV, gperl_sv_from_gerror (err)); /* croak() does not return; free this now to avoid leaking it. */ g_error_free (err); croak (Nullch); } =back =cut MODULE = Glib::Error PACKAGE = Glib::Error BOOT: /* i can't quite decide whether i'm happy about registering all * of these here. in theory, it's possible to get any of these, * so we should define them for later use; in practice, we may * never see a few of them. */ #if GLIB_CHECK_VERSION (2, 12, 0) /* gbookmarkfile.h */ gperl_register_error_domain (G_BOOKMARK_FILE_ERROR, GPERL_TYPE_BOOKMARK_FILE_ERROR, "Glib::BookmarkFile::Error"); #endif /* GLIB_CHECK_VERSION (2, 12, 0) */ /* gconvert.h */ gperl_register_error_domain (G_CONVERT_ERROR, GPERL_TYPE_CONVERT_ERROR, "Glib::Convert::Error"); /* gfileutils.h */ gperl_register_error_domain (G_FILE_ERROR, GPERL_TYPE_FILE_ERROR, "Glib::File::Error"); #if GLIB_CHECK_VERSION (2, 6, 0) /* gkeyfile.h */ gperl_register_error_domain (G_KEY_FILE_ERROR, GPERL_TYPE_KEY_FILE_ERROR, "Glib::KeyFile::Error"); #endif /* GLIB_CHECK_VERSION (2, 6, 0) */ /* giochannel.h */ gperl_register_error_domain (G_IO_CHANNEL_ERROR, GPERL_TYPE_IO_CHANNEL_ERROR, "Glib::IOChannel::Error"); /* gmarkup.h */ gperl_register_error_domain (G_MARKUP_ERROR, GPERL_TYPE_MARKUP_ERROR, "Glib::Markup::Error"); /* gshell.h */ gperl_register_error_domain (G_SHELL_ERROR, GPERL_TYPE_SHELL_ERROR, "Glib::Shell::Error"); /* gspawn.h */ gperl_register_error_domain (G_SPAWN_ERROR, GPERL_TYPE_SPAWN_ERROR, "Glib::Spawn::Error"); /* gthread.h */ gperl_register_error_domain (G_THREAD_ERROR, GPERL_TYPE_THREAD_ERROR, "Glib::Thread::Error"); #if GLIB_CHECK_VERSION (2, 28, 0) /* gvariant.h */ gperl_register_error_domain (G_VARIANT_PARSE_ERROR, GPERL_TYPE_VARIANT_PARSE_ERROR, "Glib::Variant::ParseError"); #endif PERL_UNUSED_VAR (file); =for object Glib::Error Exception Objects based on GError =cut =for position SYNOPSIS =head1 SYNOPSIS eval { my $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file ($filename); $image->set_from_pixbuf ($pixbuf); }; if ($@) { print "$@\n"; if (Glib::Error::matches ($@, 'Gtk2::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 $@; } } =cut =for position DESCRIPTION =head1 DESCRIPTION Gtk2-Perl translates GLib's GError runtime errors into Perl exceptions, by creating exception objects based on Glib::Error. Glib::Error overloads the stringification operator, so a Glib::Error object will act like a string if used with print() or warn(), so most code using $@ will not even know the difference. The point of having exception objects, however, is that the error messages in GErrors are often localized with NLS translation. Thus, it's not good for your code to attempt to handle errors by string matching on the the error message. Glib::Error provides a way to get to the deterministic error code. You will typically deal with objects that inherit from Glib::Error, such as Glib::Convert::Error, Glib::File::Error, Gtk2::Gdk::Pixbuf::Error, etc; these classes are provided by the libraries that define the error domains. However, it is possible to get a base Glib::Error when the bindings encounter an unknown or unbound error domain. The interface used here degrades nicely in such a situation, but in general you should submit a bug report to the binding maintainer if you get such an exception. =cut ## ## evil trick here -- define xsubs that xsdocparse can see, but which ## xsubpp will not compile, so we get documentation on them. ## #if 0 =for apidoc The source line and file closest to the emission of the exception, in the same format that you'd get from croak() or die(). If there's non-ascii characters in the filename Perl leaves them as raw bytes, so you may have to put the string through Glib::filename_display_name for a wide-char form. =cut char * location (SV * error) =for apidoc The error message. This may be localized, as it is intended to be shown to a user. =cut char * message (SV * error) =for apidoc The error domain. You normally do not need this, as the object will be blessed into a corresponding class. =cut char * domain (SV * error) =for apidoc The enumeration value nickname of the integer value in C<< $error->code >>, according to this error domain. This will not be available if the error object is a base Glib::Error, because the bindings will have no idea how to get to the correct nickname. =cut char * value (SV * error) =forapidoc This is the numeric error code. Normally, you'll want to use C instead, for readability. =cut int code (SV * error) #endif =for apidoc Glib::Error::throw =for signature scalar = Glib::Error::throw ($class, $code, $message) =for signature scalar = $class->throw ($code, $message) =for arg code (GEnum) an enumeration value, depends on I<$class> Throw an exception with a Glib::Error exception object. Equivalent to C<< croak (Glib::Error::new ($class, $code, $message)); >>. =cut =for apidoc =for signature scalar = Glib::Error::new ($class, $code, $message) =for signature scalar = $class->new ($code, $message) =for arg code (GEnum) an enumeration value, depends on I<$class> Create a new exception object of type I<$class>, where I<$class> is associated with a GError domain. I<$code> should be a value from the enumeration type associated with this error domain. I<$message> can be anything you like, but should explain what happened from the point of view of a user. =cut SV * new (const char * class, SV * code, const gchar * message) ALIAS: Glib::Error::throw = 1 PREINIT: ErrorInfo * info = NULL; CODE: info = error_info_from_package (class); if (!info) { GQuark d; if (0 != (d = g_quark_try_string (class))) info = error_info_from_domain (d); } if (info) { /* this is rather wasteful, as it converts one way and * then back, but that effectively launders everything * for us. */ GError error; error.domain = info->domain; error.code = gperl_convert_enum (info->error_enum, code); error.message = (gchar*)message; RETVAL = gperl_sv_from_gerror (&error); } else { warn ("%s is neither a Glib::Error derivative nor a valid GError domain", class); RETVAL = newSVGChar (message); } if (ix == 1) { /* go ahead and throw it. */ SvSetSV (ERRSV, RETVAL); croak (Nullch); } OUTPUT: RETVAL =for apidoc __function__ =for arg package class name to register as a Glib::Error. =for arg enum_package class name of the enum type to use for this domain's error codes. Register a new error domain. Glib::Error will be added @I::ISA for you. I must be a valid Glib::Enum type, either from a C library or registered with C<< Glib::Type::register_enum >>. After registering an error domain, you can create or throw exceptions of this type. =cut void register (char * package, char * enum_package) PREINIT: GQuark qdomain; GType enum_type; CODE: enum_type = gperl_fundamental_type_from_package (enum_package); if (!enum_type) croak ("%s is not registered as a Glib enum", enum_package); ENTER; SAVESPTR (DEFSV); sv_setpv (DEFSV, package); eval_pv ("$_ = lc $_; s/::/-/g;", G_VOID); qdomain = g_quark_from_string (SvPV_nolen (DEFSV)); LEAVE; gperl_register_error_domain (qdomain, enum_type, package); =for apidoc Returns true if the exception in I<$error> matches the given I<$domain> and I<$code>. I<$domain> may be a class name or domain quark (that is, the real string used in C). I<$code> may be an integer value or an enum nickname; the enum type depends on the value of I<$domain>. =cut gboolean matches (SV * error, const char * domain, SV * code) PREINIT: GError * real_error; ErrorInfo * info; int real_code; CODE: gperl_gerror_from_sv (error, &real_error); info = error_info_from_package (domain); if (!info) { GQuark q = g_quark_try_string (domain); if (!q) croak ("%s is not a valid error domain", domain); info = error_info_from_domain (q); } if (!info) croak ("%s is not a registered error domain", domain); real_code = looks_like_number (code) ? SvIV (code) : gperl_convert_enum (info->error_enum, code); RETVAL = g_error_matches (real_error, info->domain, real_code); if (real_error) g_error_free (real_error); OUTPUT: RETVAL Glib-1.320/GIOChannel.xs000644 001750 000024 00000020767 11701512040 015755 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full * list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ #include "gperl.h" /* GIOChannel is GLib's way to creating a portable and unified for IO over files, sockets, pipes, and whatever else acts like an FD on unix. but perl's filehandles already do this. so we'll just replace the GLib concept of GIOChannel with perl file handles or at least filenos. thus, pretty much nothing from this header is bound to perl, except for a one-way boxed wrapper to convert GIOChannels into file descriptors for gperl_closure_marshal. */ static SV* gperl_io_channel_wrap (GType gtype, const char * package, GIOChannel * channel, gboolean own) { PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); PERL_UNUSED_VAR (own); return newSViv (g_io_channel_unix_get_fd (channel)); } static gpointer gperl_io_channel_unwrap (GType gtype, const char * package, SV * sv) { PERL_UNUSED_VAR (gtype); PERL_UNUSED_VAR (package); PERL_UNUSED_VAR (sv); croak ("can't unwrap GIOChannels -- how'd you get one in perl?!?\n" " you appear to have found a bug in gtk2-perl-xs. congratulations.\n" " please report this bug to gtk-perl-list@gnome.org\n" " croaking "); return NULL; } static GPerlBoxedWrapperClass io_channel_wrapper_class = { (GPerlBoxedWrapFunc) gperl_io_channel_wrap, gperl_io_channel_unwrap, NULL }; MODULE = Glib::IO::Channel PACKAGE = Glib::IO::Channel PREFIX = g_io_channel_ BOOT: gperl_register_boxed (G_TYPE_IO_CHANNEL, "Glib::IO::Channel", &io_channel_wrapper_class); ##void g_io_channel_init (GIOChannel *channel); ##void g_io_channel_ref (GIOChannel *channel); ##void g_io_channel_unref (GIOChannel *channel); ## ###ifndef G_DISABLE_DEPRECATED ##GIOError g_io_channel_read (GIOChannel *channel, gchar *buf, gsize count, gsize *bytes_read); ##GIOError g_io_channel_write (GIOChannel *channel, const gchar *buf, gsize count, gsize *bytes_written); ##GIOError g_io_channel_seek (GIOChannel *channel, gint64 offset, GSeekType type); ##void g_io_channel_close (GIOChannel *channel); ###endif /* G_DISABLE_DEPRECATED */ ## ##GIOStatus g_io_channel_shutdown (GIOChannel *channel, ## gboolean flush, ## GError **err); #### #### g_io_add_watch is bound in GMainLoop.xs as Glib::IO->add_watch #### ##guint g_io_add_watch_full (GIOChannel *channel, ## gint priority, ## GIOCondition condition, ## GIOFunc func, ## gpointer user_data, ## GDestroyNotify notify); ##GSource * g_io_create_watch (GIOChannel *channel, ## GIOCondition condition); ##guint g_io_add_watch (GIOChannel *channel, ## GIOCondition condition, ## GIOFunc func, ## gpointer user_data); ##/* character encoding conversion involved functions. ## */ ## ##void g_io_channel_set_buffer_size (GIOChannel *channel, ## gsize size); ##gsize g_io_channel_get_buffer_size (GIOChannel *channel); ##GIOCondition g_io_channel_get_buffer_condition (GIOChannel *channel); ##GIOStatus g_io_channel_set_flags (GIOChannel *channel, ## GIOFlags flags, ## GError **error); ##GIOFlags g_io_channel_get_flags (GIOChannel *channel); ##void g_io_channel_set_line_term (GIOChannel *channel, ## const gchar *line_term, ## gint length); ##G_CONST_RETURN gchar* g_io_channel_get_line_term (GIOChannel *channel, ## gint *length); ##void g_io_channel_set_buffered (GIOChannel *channel, ## gboolean buffered); ##gboolean g_io_channel_get_buffered (GIOChannel *channel); ##GIOStatus g_io_channel_set_encoding (GIOChannel *channel, ## const gchar *encoding, ## GError **error); ##G_CONST_RETURN gchar* g_io_channel_get_encoding (GIOChannel *channel); ##void g_io_channel_set_close_on_unref (GIOChannel *channel, ## gboolean do_close); ##gboolean g_io_channel_get_close_on_unref (GIOChannel *channel); ## ## ##GIOStatus g_io_channel_flush (GIOChannel *channel, ## GError **error); ##GIOStatus g_io_channel_read_line (GIOChannel *channel, ## gchar **str_return, ## gsize *length, ## gsize *terminator_pos, ## GError **error); ##GIOStatus g_io_channel_read_line_string (GIOChannel *channel, ## GString *buffer, ## gsize *terminator_pos, ## GError **error); ##GIOStatus g_io_channel_read_to_end (GIOChannel *channel, ## gchar **str_return, ## gsize *length, ## GError **error); ##GIOStatus g_io_channel_read_chars (GIOChannel *channel, ## gchar *buf, ## gsize count, ## gsize *bytes_read, ## GError **error); ##GIOStatus g_io_channel_read_unichar (GIOChannel *channel, ## gunichar *thechar, ## GError **error); ##GIOStatus g_io_channel_write_chars (GIOChannel *channel, ## const gchar *buf, ## gssize count, ## gsize *bytes_written, ## GError **error); ##GIOStatus g_io_channel_write_unichar (GIOChannel *channel, ## gunichar thechar, ## GError **error); ##GIOStatus g_io_channel_seek_position (GIOChannel *channel, ## gint64 offset, ## GSeekType type, ## GError **error); ##GIOChannel* g_io_channel_new_file (const gchar *filename, ## const gchar *mode, ## GError **error); ## ##/* Error handling */ ## ##GQuark g_io_channel_error_quark (void); ##GIOChannelError g_io_channel_error_from_errno (gint en); ## ##GIOChannel* g_io_channel_unix_new (int fd); ##gint g_io_channel_unix_get_fd (GIOChannel *channel); ## ##/* Hook for GClosure / GSource integration. Don't touch */ ##GLIB_VAR GSourceFuncs g_io_watch_funcs; ## ###ifdef G_OS_WIN32 ## ##/* You can use this "pseudo file descriptor" in a GPollFD to add ## * polling for Windows messages. GTK applications should not do that. ## */ ## ###define G_WIN32_MSG_HANDLE 19981206 ## ##/* Use this to get a GPollFD from a GIOChannel, so that you can call ## * g_io_channel_win32_poll(). After calling this you should only use ## * g_io_channel_read() to read from the GIOChannel, i.e. never read() ## * from the underlying file descriptor. For SOCKETs, it is possible to call ## * recv(). ## */ ##void g_io_channel_win32_make_pollfd (GIOChannel *channel, ## GIOCondition condition, ## GPollFD *fd); ## ##/* This can be used to wait a until at least one of the channels is readable. ## * On Unix you would do a select() on the file descriptors of the channels. ## */ ##gint g_io_channel_win32_poll (GPollFD *fds, ## gint n_fds, ## gint timeout_); ## ##/* Create an IO channel for Windows messages for window handle hwnd. */ ##GIOChannel *g_io_channel_win32_new_messages (guint hwnd); ## ##GIOChannel* g_io_channel_win32_new_fd (gint fd); ## ##gint g_io_channel_win32_get_fd (GIOChannel *channel); ## ##/* Create an IO channel for a winsock socket. The parameter should be ## * a SOCKET. Contrary to IO channels for file descriptors (on *Win32), ## * you can use normal recv() or recvfrom() on sockets even if GLib ## * is polling them. ## */ ##GIOChannel *g_io_channel_win32_new_socket (gint socket); ## ###endif ## Glib-1.320/GKeyFile.xs000644 001750 000024 00000052322 12251766676 015530 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2005,2013 by the gtk2-perl team (see the file AUTHORS for * the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * */ #include "gperl.h" #include "gperl-gtypes.h" SV * newSVGKeyFileFlags (GKeyFileFlags flags) { return gperl_convert_back_flags (GPERL_TYPE_KEY_FILE_FLAGS, flags); } GKeyFileFlags SvGKeyFileFlags (SV * sv) { return gperl_convert_flags (GPERL_TYPE_KEY_FILE_FLAGS, sv); } SV * newSVGKeyFile (GKeyFile * key_file) { HV * key = newHV (); SV * sv; HV * stash; /* tie the key_file to our hash using some magic */ _gperl_attach_mg ((SV*) key, key_file); /* wrap it, bless it, ship it. */ sv = newRV_noinc ((SV*) key); stash = gv_stashpv ("Glib::KeyFile", TRUE); sv_bless (sv, stash); return sv; } GKeyFile * SvGKeyFile (SV * sv) { MAGIC * mg; if (!gperl_sv_is_ref (sv) || !(mg = _gperl_find_mg (SvRV (sv)))) return NULL; return (GKeyFile *) mg->mg_ptr; } MODULE = Glib::KeyFile PACKAGE = Glib::KeyFile PREFIX = g_key_file_ =for object Glib::KeyFile Parser for .ini-like files =cut =for position SYNOPSIS =head1 SYNOPSIS use Glib; $data .= $_ while (); $f = Glib::KeyFile->new; $f->load_from_data($data); if ($f->has_group('Main') && $f->has_key('Main', 'someotherkey')) { $val = $f->get_integer('Main', 'someotherkey'); print $val . "\n"; } 0; __DATA__ # a comment [MainSection] somekey=somevalue someotherkey=42 someboolkey=true listkey=1;1;2;3;5;8;13;21 localekey=Good Morning localekey[it]=Buon giorno localekey[es]=Buenas dias localekey[fr]=Bonjour =for position DESCRIPTION =head1 DESCRIPTION B lets you parse, edit or create files containing groups of key-value pairs, which we call key files for lack of a better name. Several freedesktop.org specifications use key files now, e.g the Desktop Entry Specification and the Icon Theme Specification. The syntax of key files is described in detail in the Desktop Entry Specification, here is a quick summary: Key files consists of groups of key-value pairs, interspersed with comments. =cut BOOT: gperl_register_fundamental (GPERL_TYPE_KEY_FILE_FLAGS, "Glib::KeyFileFlags"); void DESTROY (GKeyFile * key_file) CODE: g_key_file_free (key_file); GKeyFile* g_key_file_new (class) C_ARGS: /* void */ # unneded #void g_key_file_free (GKeyFile *key_file); =for apidoc Sets the list separator character. =cut void g_key_file_set_list_separator (key_file, separator) GKeyFile * key_file gchar separator =for enum Glib::KeyFileFlags =cut =for apidoc __gerror__ Parses a key file. =cut gboolean g_key_file_load_from_file (key_file, file, flags) GKeyFile * key_file const gchar * file GKeyFileFlags flags PREINIT: GError *err = NULL; CODE: RETVAL = g_key_file_load_from_file (key_file, file, flags, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc __gerror__ Parses a string containing a key file structure. =cut gboolean g_key_file_load_from_data (key_file, buf, flags) GKeyFile * key_file SV * buf GKeyFileFlags flags PREINIT: STRLEN length; GError *err = NULL; const gchar *data = (const gchar *) SvPV (buf, length); CODE: RETVAL = g_key_file_load_from_data (key_file, data, length, flags, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL #if GLIB_CHECK_VERSION (2, 14, 0) =for apidoc __gerror__ =signature boolean = $key_file->load_from_dirs ($file, $flags, @search_dirs) =signature (boolean, scalar) = $key_file->load_from_dirs ($file, $flags, @search_dirs) Parses a key file, searching for it inside the specified directories. In scalar context, it returns a boolean value (true on success, false otherwise); in array context, it returns a boolean value and the full path of the file. =cut void g_key_file_load_from_dirs (key_file, file, flags, ...) GKeyFile *key_file const gchar *file GKeyFileFlags flags PREINIT: int n_dirs, i; gchar **search_dirs; gchar *full_path = NULL; GError *error = NULL; gboolean retval; PPCODE: n_dirs = items - 3; search_dirs = g_new0 (gchar*, n_dirs + 1); for (i = 0; i < n_dirs; i++) { search_dirs[i] = SvGChar (ST (3 + i)); } search_dirs[n_dirs] = NULL; retval = g_key_file_load_from_dirs ( key_file, file, (const gchar **) search_dirs, &full_path, flags, &error); if (error) gperl_croak_gerror (NULL, error); PUSHs (sv_2mortal (newSVuv (retval))); if (GIMME_V == G_ARRAY && full_path) XPUSHs (sv_2mortal (newSVGChar (full_path))); if (full_path) g_free (full_path); g_free (search_dirs); #endif =for apidoc __gerror__ =signature boolean = $key_file->load_from_data_dirs ($file, $flags) =signature (boolean, scalar) = $key_file->load_from_data_dirs ($file, $flags) Parses a key file, searching for it inside the data directories. In scalar context, it returns a boolean value (true on success, false otherwise); in array context, it returns a boolean value and the full path of the file. =cut void g_key_file_load_from_data_dirs (key_file, file, flags) GKeyFile * key_file const gchar * file GKeyFileFlags flags PREINIT: GError *err = NULL; gchar *full_path = NULL; gboolean retval; PPCODE: retval = g_key_file_load_from_data_dirs (key_file, file, GIMME_V == G_ARRAY ? &full_path : NULL, flags, &err); if (err) gperl_croak_gerror (NULL, err); PUSHs (sv_2mortal (newSViv (retval))); if (GIMME_V == G_ARRAY && full_path) XPUSHs (sv_2mortal (newSVGChar (full_path))); if (full_path) g_free (full_path); =for apidoc __gerror__ Returns the key file as a string. =cut gchar_own * g_key_file_to_data (key_file) GKeyFile * key_file PREINIT: GError *err = NULL; gsize len; CODE: RETVAL = g_key_file_to_data (key_file, &len, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc Returns the first group inside a key file. =cut gchar_own * g_key_file_get_start_group (key_file) GKeyFile * key_file =for apidoc =signature list = $key_file->get_groups Returns the list of groups inside the key_file. =cut void g_key_file_get_groups (key_file) GKeyFile * key_file PREINIT: gchar **groups; gsize len, i; PPCODE: groups = g_key_file_get_groups (key_file, &len); if (len != 0) { EXTEND(SP, len); for (i = 0; i < len; i++) PUSHs (sv_2mortal (newSVGChar (groups[i]))); } g_strfreev (groups); /* otherwise, we leak */ =for apidoc __gerror__ =signature list = $key_file->get_keys ($group_name) Returns the list of keys inside a group of the key file. =cut void g_key_file_get_keys (key_file, group_name) GKeyFile * key_file const gchar * group_name PREINIT: GError *err = NULL; gchar **keys; gsize len, i; PPCODE: keys = g_key_file_get_keys (key_file, group_name, &len, &err); if (err) gperl_croak_gerror (NULL, err); if (len != 0) { for (i = 0; i < len; i++) if (keys[i]) XPUSHs (sv_2mortal (newSVGChar (keys[i]))); } g_strfreev (keys); /* otherwise, we leak */ =for apidoc Checks whether $group_name is present in $key_file. =cut gboolean g_key_file_has_group (key_file, group_name) GKeyFile * key_file const gchar * group_name =for apidoc __gerror__ Checks whether $group_name has $key in it. =cut gboolean g_key_file_has_key (key_file, group_name, key) GKeyFile * key_file const gchar * group_name const gchar * key PREINIT: GError *err = NULL; CODE: RETVAL = g_key_file_has_key (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc __gerror__ Retrieves the literal value of $key inside $group_name. =cut gchar_own * g_key_file_get_value (key_file, group_name, key) GKeyFile * key_file const gchar * group_name const gchar * key PREINIT: GError *err = NULL; CODE: RETVAL = g_key_file_get_value (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc Sets the literal value of $key inside $group_name. If $key cannot be found, it is created. If $group_name cannot be found, it is created. =cut void g_key_file_set_value (key_file, group_name, key, value) GKeyFile * key_file const gchar * group_name const gchar * key const gchar * value =for apidoc Glib::KeyFile::set_boolean =arg value (gboolean) Sets a boolean value to $key inside $group_name. If $key is not found, it is created. =cut =for apidoc Glib::KeyFile::set_integer =arg value (gint) Sets an integer value to $key inside $group_name. If $key is not found, it is created. =cut =for apidoc Glib::KeyFile::set_string =arg value (gchar*) Sets a string value to $key inside $group_name. The string will be escaped if it contains special characters. If $key is not found, it is created. =cut void g_key_file_set_boolean (key_file, group_name, key, value) GKeyFile * key_file const gchar * group_name const gchar * key SV * value ALIAS: Glib::KeyFile::set_integer = 1 Glib::KeyFile::set_string = 2 CODE: switch (ix) { case 0: g_key_file_set_boolean (key_file, group_name, key, SvTRUE (value)); break; case 1: g_key_file_set_integer (key_file, group_name, key, SvIV (value)); break; case 2: g_key_file_set_string (key_file, group_name, key, SvGChar (value)); break; } #if GLIB_CHECK_VERSION (2, 12, 0) =for apidoc Sets a double value to $key inside $group_name. If $key is not found, it is created. =cut void g_key_file_set_double (GKeyFile *key_file, const gchar *group_name, const gchar *key, gdouble value); #endif =for apidoc Glib::KeyFile::get_boolean __gerror__ =signature boolean = $key_file->get_boolean ($group_name, $key) Retrieves a boolean value from $key inside $group_name. =cut =for apidoc Glib::KeyFile::get_integer __gerror__ =signature integer = $key_file->get_integer ($group_name, $key) Retrieves an integer value from $key inside $group_name. =cut =for apidoc Glib::KeyFile::get_string __gerror__ =signature string = $key_file->get_string ($group_name, $key) Retrieves a string value from $key inside $group_name. =cut SV * g_key_file_get_boolean (key_file, group_name, key) GKeyFile * key_file const gchar * group_name const gchar * key ALIAS: Glib::KeyFile::get_integer = 1 Glib::KeyFile::get_string = 2 PREINIT: GError *err = NULL; CODE: switch (ix) { case 0: { gboolean retval; retval = g_key_file_get_boolean (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); RETVAL = boolSV (retval); break; } case 1: { gint retval; retval = g_key_file_get_integer (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); RETVAL = newSViv (retval); break; } case 2: { gchar *retval; retval = g_key_file_get_string (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); RETVAL = newSVGChar (retval); g_free (retval); /* leaks otherwise */ break; } default: RETVAL = NULL; g_assert_not_reached (); } OUTPUT: RETVAL #if GLIB_CHECK_VERSION (2, 12, 0) =for apidoc __gerror__ Retrieves a double value from $key inside $group_name. =cut gdouble g_key_file_get_double (key_file, group_name, key) GKeyFile * key_file const gchar * group_name const gchar * key PREINIT: GError *err = NULL; CODE: RETVAL = g_key_file_get_double (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL #endif =for apidoc __gerror__ Returns the value associated with $key under $group_name translated in the given $locale if available. If $locale is undef then the current locale is assumed. =cut gchar_own * g_key_file_get_locale_string (key_file, group_name, key, locale=NULL) GKeyFile * key_file const gchar * group_name const gchar * key const gchar_ornull * locale PREINIT: GError *err = NULL; CODE: RETVAL = g_key_file_get_locale_string (key_file, group_name, key, locale, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL void g_key_file_set_locale_string (key_file, group_name, key, locale, string) GKeyFile * key_file const gchar * group_name const gchar * key const gchar * locale const gchar * string =for apidoc __gerror__ =cut void g_key_file_get_locale_string_list (key_file, group_name, key, locale); GKeyFile * key_file const gchar * group_name const gchar * key const gchar * locale PREINIT: gchar **retlist; GError *err = NULL; gsize retlen, i; PPCODE: retlist = g_key_file_get_locale_string_list (key_file, group_name, key, locale, &retlen, &err); if (err) gperl_croak_gerror (NULL, err); for (i = 0; i < retlen; i++) XPUSHs (sv_2mortal (newSVGChar (retlist[i]))); g_strfreev (retlist); =for apidoc Associates a list of string values for $key and $locale under $group_name. If the translation for $key cannot be found then it is created. =cut void g_key_file_set_locale_string_list (key_file, group_name, key, locale, ...) GKeyFile * key_file const gchar * group_name const gchar * key const gchar * locale PREINIT: gchar **list; gsize list_len; int i; CODE: list_len = (gsize) (items - 3); list = g_new0 (gchar *, list_len); for (i = 4; i < items; i++) list[i - 4] = SvPV_nolen (ST (i)); g_key_file_set_locale_string_list (key_file, group_name, key, locale, (const gchar * const *) list, list_len); g_free (list); =for apidoc Glib::KeyFile::get_string_list __gerror__ =signature list = $key_file->get_string_list ($group_name, $key) Retrieves a list of strings from $key inside $group_name. =cut =for apidoc Glib::KeyFile::get_integer_list __gerror__ =signature list = $key_file->get_integer_list ($group_name, $key) Retrieves a list of integers from $key inside $group_name. =cut =for apidoc Glib::KeyFile::get_boolean_list __gerror__ =signature list = $key_file->get_boolean_list ($group_name, $key) Retrieves a list of booleans from $key inside $group_name. =cut void g_key_file_get_string_list (key_file, group_name, key) GKeyFile * key_file const gchar * group_name const gchar * key ALIAS: Glib::KeyFile::get_boolean_list = 1 Glib::KeyFile::get_integer_list = 2 PREINIT: GError *err = NULL; gsize retlen, i; PPCODE: switch (ix) { #define CROAK_ON_GERROR(error) if (error) gperl_croak_gerror (NULL, error) case 0: { gchar **retlist; retlist = g_key_file_get_string_list (key_file, group_name, key, &retlen, &err); CROAK_ON_GERROR (err); EXTEND (sp, retlen); for (i = 0; i < retlen; i++) PUSHs (sv_2mortal (newSVGChar (retlist[i]))); g_strfreev (retlist); break; } case 1: { gboolean *retlist; retlist = g_key_file_get_boolean_list (key_file, group_name, key, &retlen, &err); CROAK_ON_GERROR (err); EXTEND (sp, retlen); for (i = 0; i < retlen; i++) PUSHs (sv_2mortal (boolSV (retlist[i]))); g_free (retlist); break; } case 2: { gint *retlist; retlist = g_key_file_get_integer_list (key_file, group_name, key, &retlen, &err); CROAK_ON_GERROR (err); EXTEND (sp, retlen); for (i = 0; i < retlen; i++) PUSHs (sv_2mortal (newSViv (retlist[i]))); g_free (retlist); } } #if GLIB_CHECK_VERSION (2, 12, 0) =for apidoc __gerror__ =signature list = $key_file->get_double_list ($group_name, $key) Retrieves a list of doubles from $key inside $group_name. =cut void g_key_file_get_double_list (key_file, group_name, key) GKeyFile * key_file const gchar * group_name const gchar * key PREINIT: GError *err = NULL; gsize retlen, i; gdouble *retlist; PPCODE: retlist = g_key_file_get_double_list (key_file, group_name, key, &retlen, &err); if (err) gperl_croak_gerror (NULL, err); EXTEND (sp, retlen); for (i = 0; i < retlen; i++) PUSHs (sv_2mortal (newSVnv (retlist[i]))); g_free (retlist); #endif =for apidoc Glib::KeyFile::set_string_list =for arg ... list of strings Sets a list of strings in $key inside $group_name. The strings will be escaped if contain special characters. If $key cannot be found then it is created. If $group_name cannot be found then it is created. =cut =for apidoc Glib::KeyFile::set_boolean_list =for arg ... list of booleans Sets a list of booleans in $key inside $group_name. If $key cannot be found then it is created. If $group_name cannot be found then it is created. =cut =for apidoc Glib::KeyFile::set_integer_list =for arg ... list of integers Sets a list of doubles in $key inside $group_name. If $key cannot be found then it is created. If $group_name cannot be found then it is created. =cut void g_key_file_set_string_list (key_file, group_name, key, ...) GKeyFile * key_file const gchar * group_name const gchar * key ALIAS: Glib::KeyFile::set_boolean_list = 1 Glib::KeyFile::set_integer_list = 2 PREINIT: gsize list_len; int i; CODE: switch (ix) { case 0: { gchar **list; list_len = (gsize) (items - 3); list = g_new0 (gchar *, list_len); for (i = 3; i < items; i++) list[i - 3] = SvPV_nolen (ST (i)); g_key_file_set_string_list (key_file, group_name, key, (const gchar * const *) list, list_len); g_free (list); break; } case 1: { gboolean *list; list_len = (gsize) (items - 3); list = g_new0 (gboolean, list_len); for (i = 3; i < items; i++) list[i - 3] = SvTRUE (ST (i)); g_key_file_set_boolean_list (key_file, group_name, key, list, list_len); g_free (list); break; } case 2: { gint *list; list_len = (gsize) (items - 3); list = g_new0 (gint, list_len); for (i = 3; i < items; i++) list[i - 3] = SvIV (ST (i)); g_key_file_set_integer_list (key_file, group_name, key, list, list_len); g_free (list); break; } } #if GLIB_CHECK_VERSION (2, 12, 0) =for apidoc =for arg ... list of doubles Sets a list of doubles in $key inside $group_name. If $key cannot be found then it is created. If $group_name cannot be found then it is created. =cut void g_key_file_set_double_list (key_file, group_name, key, ...) GKeyFile * key_file const gchar * group_name const gchar * key PREINIT: gsize list_len; int i; gdouble *list; CODE: list_len = (gsize) (items - 3); list = g_new0 (gdouble, list_len); for (i = 3; i < items; i++) list[i - 3] = SvNV (ST (i)); g_key_file_set_double_list (key_file, group_name, key, list, list_len); g_free (list); #endif =for apidoc __gerror__ Places a comment above $key from $group_name. If $key is undef then $comment will be written above $group_name. If both $key and $group_name are undef, then $comment will be written above the first group in the file. =cut void g_key_file_set_comment (key_file, group_name, key, comment) GKeyFile * key_file const gchar_ornull * group_name const gchar_ornull * key const gchar * comment PREINIT: GError *err = NULL; CODE: g_key_file_set_comment (key_file, group_name, key, comment, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ Retreives a comment above $key from $group_name. If $key is undef then $comment will be read from above $group_name. If both $key and $group_name are undef, then $comment will be read from above the first group in the file. =cut gchar_own * g_key_file_get_comment (key_file, group_name=NULL, key=NULL) GKeyFile * key_file const gchar_ornull * group_name const gchar_ornull * key PREINIT: GError *err = NULL; CODE: RETVAL = g_key_file_get_comment (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); OUTPUT: RETVAL =for apidoc __gerror__ Removes a comment from a group in a key file. If $key is undef, the comment will be removed from above $group_name. If both $key and $group_name are undef, the comment will be removed from the top of the key file. =cut void g_key_file_remove_comment (key_file, group_name=NULL, key=NULL) GKeyFile * key_file const gchar_ornull * group_name const gchar_ornull * key PREINIT: GError *err = NULL; CODE: g_key_file_remove_comment (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ Removes a key from $group_name. =cut void g_key_file_remove_key (key_file, group_name, key) GKeyFile * key_file const gchar * group_name const gchar * key PREINIT: GError *err = NULL; CODE: g_key_file_remove_key (key_file, group_name, key, &err); if (err) gperl_croak_gerror (NULL, err); =for apidoc __gerror__ Removes a group from a key file. =cut void g_key_file_remove_group (key_file, group_name) GKeyFile * key_file const gchar * group_name PREINIT: GError *err = NULL; CODE: g_key_file_remove_group (key_file, group_name, &err); if (err) gperl_croak_gerror (NULL, err); Glib-1.320/Glib.exports000644 001750 000024 00000005665 12636024471 016013 0ustar00bdmanningstaff000000 000000 # Copyright (C) 2003-2005 by the gtk2-perl team (see the file AUTHORS for # the full list) # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # # $Id$ # @exports = qw( SvGChar SvGKeyFile SvGParamFlags SvGParamSpec SvGSignalFlags SvGInt64 SvGUInt64 SvGVariant SvGVariantType _gperl_attach_mg _gperl_call_XS _gperl_find_mg _gperl_remove_mg gperl_alloc_temp gperl_argv_free gperl_argv_new gperl_argv_update gperl_boxed_package_from_type gperl_boxed_type_from_package gperl_callback_destroy gperl_callback_invoke gperl_callback_new gperl_closure_new gperl_closure_new_with_marshaller gperl_convert_back_enum gperl_convert_back_enum_pass_unknown gperl_convert_back_flags gperl_convert_enum gperl_convert_flag_one gperl_convert_flags gperl_croak_gerror gperl_default_boxed_wrapper_class gperl_filename_from_sv gperl_format_variable_for_output gperl_fundamental_package_from_type gperl_fundamental_type_from_package gperl_gerror_from_sv gperl_get_boxed_check gperl_get_object gperl_get_object_check gperl_handle_logs_for gperl_hv_take_sv gperl_install_exception_handler gperl_new_boxed gperl_new_boxed_copy gperl_new_object gperl_object_check_type gperl_object_package_from_type gperl_object_set_no_warn_unreg_subclass gperl_object_stash_from_type gperl_object_type_from_package gperl_option_context_get_type gperl_option_group_get_type gperl_package_from_type gperl_param_spec_package_from_type gperl_param_spec_type_from_package gperl_prepend_isa gperl_register_boxed gperl_register_boxed_alias gperl_register_boxed_synonym gperl_register_error_domain gperl_register_fundamental gperl_register_fundamental_alias gperl_register_object gperl_register_object_alias gperl_register_param_spec gperl_register_sink_func gperl_remove_exception_handler gperl_run_exception_handlers gperl_set_isa gperl_signal_connect gperl_signal_set_marshaller_for gperl_str_eq gperl_str_hash gperl_sv_copy gperl_sv_is_defined gperl_sv_free gperl_sv_from_filename gperl_sv_from_gerror gperl_sv_from_value gperl_sv_get_type gperl_try_convert_enum gperl_try_convert_flag gperl_type_class gperl_type_from_package gperl_value_from_sv newSVGChar newSVGParamFlags newSVGParamSpec newSVGSignalFlags newSVGSignalInvocationHint newSVGSignalQuery newSVGInt64 newSVGUInt64 newSVGVariant newSVGVariant_noinc newSVGVariantType newSVGVariantType_own ); 1; Glib-1.320/Glib.xs000644 001750 000024 00000040070 12636024471 014726 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2005, 2012-2013 by the gtk2-perl team (see the file * AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ #include "gperl.h" =head2 Miscellaneous Various useful utilities defined in Glib.xs. =over =item GPERL_CALL_BOOT(name) call the boot code of a module by symbol rather than by name. in a perl extension which uses several xs files but only one pm, you need to bootstrap the other xs files in order to get their functions exported to perl. if the file has MODULE = Foo::Bar, the boot symbol would be boot_Foo__Bar. =item void _gperl_call_XS (pTHX_ void (*subaddr) (pTHX_ CV *), CV * cv, SV ** mark); never use this function directly. see C. for the curious, this calls a perl sub by function pointer rather than by name; call_sv requires that the xsub already be registered, but we need this to call a function which will register xsubs. this is an evil hack and should not be used outside of the GPERL_CALL_BOOT macro. it's implemented as a function to avoid code size bloat, and exported so that extension modules can pull the same trick. =cut void _gperl_call_XS (pTHX_ void (*subaddr) (pTHX_ CV *), CV * cv, SV ** mark) { dSP; PUSHMARK (mark); (*subaddr) (aTHX_ cv); PUTBACK; /* forget return values */ } =item gpointer gperl_alloc_temp (int nbytes) Allocate and return a pointer to an I-long, zero-initialized, temporary buffer that will be reaped at the next garbage collection sweep. This is handy for allocating things that need to be alloc'ed before a croak (since croak doesn't return and give you the chance to free them). The trick is that the memory is allocated in a mortal perl scalar. See the perl online manual for notes on using this technique. Do B under any circumstances attempt to call g_free(), free(), or any other deallocator on this pointer, or you will crash the interpreter. =cut /* * taken from pgtk_alloc_temp in Gtk-Perl-0.7008/Gtk/MiscTypes.c */ gpointer gperl_alloc_temp (int nbytes) { dTHR; SV * s; g_return_val_if_fail (nbytes > 0, NULL); s = sv_2mortal (NEWSV (0, nbytes)); memset (SvPVX (s), 0, nbytes); return SvPVX (s); } =item gchar *gperl_filename_from_sv (SV *sv) Return a localized version of the filename in the sv, using g_filename_from_utf8 (and consequently this function might croak). The memory is allocated using gperl_alloc_temp. =cut gchar * gperl_filename_from_sv (SV *sv) { dTHR; GError *error = NULL; gchar *lname = NULL; gsize output_length = 0; STRLEN input_length = 0; gchar *filename = SvPVutf8 (sv, input_length); lname = g_filename_from_utf8 (filename, input_length, 0, &output_length, &error); if (!lname) gperl_croak_gerror (NULL, error); filename = gperl_alloc_temp (output_length + 1); memcpy (filename, lname, output_length); g_free (lname); return filename; } =item SV *gperl_sv_from_filename (const gchar *filename) Convert the filename into an utf8 string as used by gtk/glib and perl. =cut SV * gperl_sv_from_filename (const gchar *filename) { GError *error = NULL; SV *sv; gsize len; gchar *str = g_filename_to_utf8 (filename, -1, NULL, &len, &error); if (!str) gperl_croak_gerror (NULL, error); sv = newSVpv (str, len); g_free (str); SvUTF8_on (sv); return sv; } =item gboolean gperl_str_eq (const char * a, const char * b); Compare a pair of ascii strings, considering '-' and '_' to be equivalent. Used for things like enum value nicknames and signal names. =cut gboolean gperl_str_eq (const char * a, const char * b) { while (*a && *b) { if (*a == *b || ((*a == '-' || *a == '_') && (*b == '-' || *b == '_'))) { a++; b++; } else return FALSE; } return *a == *b; } =item guint gperl_str_hash (gconstpointer key) Like g_str_hash(), but considers '-' and '_' to be equivalent. =cut guint gperl_str_hash (gconstpointer key) { const char *p = key; guint h = *p; if (h) for (p += 1; *p != '\0'; p++) h = (h << 5) - h + (*p == '-' ? '_' : *p); return h; } /* --- GPerlArgv ----------------------------------------------------------- */ typedef struct { /* Shadow copies of the pointers to the copies of the strings in argv. * Used to free the copied strings reliably even if they are removed * from argv. */ char **shadows; /* Hash table (pointer (not string) -> utf8 flag) so we can completely * restore PVs from the strings. We cannot simply use an array of * utf8 flags because strings might be removed from argv, in which * case we wouldn't know which entry in the utf8 flag array * corresponds to which string. */ GHashTable *utf8_flags; } GPerlArgvPriv; =item GPerlArgv * gperl_argv_new () Creates a new Perl argv object whose members can then be passed to functions that request argc and argv style arguments. If the called function(s) modified argv, you can call L to update Perl's @ARGV in the same way. Remember to call L when you're done. =cut GPerlArgv* gperl_argv_new () { AV * ARGV; SV * ARGV0; int len, i; GPerlArgv *pargv; GPerlArgvPriv *priv; pargv = g_new (GPerlArgv, 1); /* * heavily borrowed from gtk-perl. * * given the way perl handles the refcounts on SVs and the strings * to which they point, i'm not certain that the g_strdup'ing of * the string values is entirely necessary; however, this compiles * and runs and doesn't appear either to leak or segfault, so i'll * leave it. */ ARGV = get_av ("ARGV", FALSE); ARGV0 = get_sv ("0", FALSE); /* * construct the argv argument... we'll have to prepend @ARGV with $0 * to make it look real. an important wrinkle: client code may strip * arguments it processes without freeing them (argv is statically * allocated in conventional usage). thus, we need to keep a shadow * copy of argv so we can keep from leaking the stripped strings. */ len = av_len (ARGV) + 1; pargv->argc = len + 1; pargv->argv = g_new0 (char*, pargv->argc); priv = g_new (GPerlArgvPriv, 1); priv->shadows = g_new0 (char*, pargv->argc); priv->utf8_flags = g_hash_table_new (NULL, NULL); pargv->priv = priv; pargv->argv[0] = SvPV_nolen (ARGV0); for (i = 0 ; i < len ; i++) { SV ** svp = av_fetch (ARGV, i, 0); if (svp && gperl_sv_is_defined (*svp)) { const char *arg = SvPV_nolen (*svp); gboolean utf8_flag = !!SvUTF8 (*svp); priv->shadows[i] = pargv->argv[i+1] = g_strdup (arg); g_hash_table_insert (priv->utf8_flags, pargv->argv[i+1], GINT_TO_POINTER (utf8_flag)); } } return pargv; } =item void gperl_argv_update (GPerlArgv *pargv) Updates @ARGV to resemble the stored argv array. =cut void gperl_argv_update (GPerlArgv *pargv) { GPerlArgvPriv *priv = pargv->priv; AV * ARGV; int i; ARGV = get_av ("ARGV", FALSE); /* clear and refill @ARGV with whatever gtk_init didn't steal. */ av_clear (ARGV); for (i = 1 ; i < pargv->argc ; i++) { SV *sv; const char *arg = pargv->argv[i]; gboolean utf8_flag = !!g_hash_table_lookup (priv->utf8_flags, arg); sv = newSVpv (arg, 0); if (utf8_flag) SvUTF8_on (sv); av_push (ARGV, sv); } } =item void gperl_argv_free (GPerlArgv *pargv) Frees any resources associated with I. =cut void gperl_argv_free (GPerlArgv *pargv) { GPerlArgvPriv *priv = pargv->priv; g_strfreev (priv->shadows); g_hash_table_destroy (priv->utf8_flags); g_free (pargv->priv); g_free (pargv->argv); g_free (pargv); } /* ------------------------------------------------------------------------- */ =item char * gperl_format_variable_for_output (SV * sv) Formats the variable stored in I for output in error messages. Like SvPV_nolen(), but ellipsizes real strings (i.e., not stringified references) at 20 chars to trim things down for error messages. =cut char * gperl_format_variable_for_output (SV * sv) { if (sv) { /* disambiguate undef */ if (!gperl_sv_is_defined (sv)) return SvPV_nolen (sv_2mortal (newSVpv ("undef", 5))); /* don't truncate references... */ if (SvROK (sv)) return SvPV_nolen (sv); /* and quote everything else to disambiguate empty strings * and the like. */ return form (sv_len (sv) > 20 ? "`%.20s...'" : "`%s'", SvPV_nolen (sv)); } return NULL; } =item gboolean gperl_sv_is_defined (SV *sv) Checks the SV I for definedness just like Perl's I would do. Most importantly, it correctly handles "magical" SVs, unlike bare I. It's also NULL-safe. =cut gboolean gperl_sv_is_defined (SV *sv) { /* This is adapted from PP(pp_defined) in perl's pp.c */ if (!sv || !SvANY(sv)) return FALSE; switch (SvTYPE(sv)) { case SVt_PVAV: if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) return TRUE; break; case SVt_PVHV: if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) return TRUE; break; case SVt_PVCV: if (CvROOT(sv) || CvXSUB(sv)) return TRUE; break; default: if (SvGMAGICAL(sv)) mg_get(sv); if (SvOK(sv)) return TRUE; } return FALSE; } =item void gperl_hv_take_sv (HV *hv, const char *key, size_t key_length, SV *sv) Tries to store I in I. Decreases I's reference count if something goes wrong. =cut void gperl_hv_take_sv (HV *hv, const char *key, size_t key_length, SV *sv) { if (!hv_store (hv, key, key_length, sv, 0)) { sv_free (sv); } } =back =cut /* * Thread-safety stuff. */ static PerlInterpreter *gperl_master_interp = NULL; G_LOCK_DEFINE_STATIC (gperl_master_interp); void _gperl_set_master_interp (PerlInterpreter *interp) { G_LOCK (gperl_master_interp); gperl_master_interp = interp; G_UNLOCK (gperl_master_interp); } PerlInterpreter * _gperl_get_master_interp (void) { return gperl_master_interp; } #ifndef PERL_IMPLICIT_CONTEXT /* If perl doesn't use thread-local storage, then we store the main thread's ID * at BOOT time so that GClosure.xs can later find out whether we've been * called from a foreign thread. */ static GThread *gperl_main_tid = NULL; static void _gperl_fetch_main_tid (void) { gperl_main_tid = g_thread_self (); } GThread * _gperl_get_main_tid (void) { return gperl_main_tid; } #endif MODULE = Glib PACKAGE = Glib PREFIX = g_ BOOT: #if !GLIB_CHECK_VERSION (2, 32, 0) && defined(G_THREADS_ENABLED) && !defined(GPERL_DISABLE_THREADSAFE) /* g_thread_init() is a deprecated no-op */ /*warn ("calling g_thread_init (NULL)");*/ if (!g_thread_supported ()) g_thread_init (NULL); #endif #if !GLIB_CHECK_VERSION (2, 36, 0) /* g_type_init() is a deprecated no-op */ g_type_init (); #endif _gperl_set_master_interp (PERL_GET_INTERP); #ifndef PERL_IMPLICIT_CONTEXT _gperl_fetch_main_tid (); #endif /* boot all in one go. other modules may not want to do it this * way, if they prefer instead to perform demand loading. */ GPERL_CALL_BOOT (boot_Glib__Utils); GPERL_CALL_BOOT (boot_Glib__Error); GPERL_CALL_BOOT (boot_Glib__Log); GPERL_CALL_BOOT (boot_Glib__Type); GPERL_CALL_BOOT (boot_Glib__Boxed); GPERL_CALL_BOOT (boot_Glib__Object); GPERL_CALL_BOOT (boot_Glib__Signal); GPERL_CALL_BOOT (boot_Glib__Closure); GPERL_CALL_BOOT (boot_Glib__MainLoop); GPERL_CALL_BOOT (boot_Glib__ParamSpec); GPERL_CALL_BOOT (boot_Glib__IO__Channel); #if GLIB_CHECK_VERSION (2, 6, 0) GPERL_CALL_BOOT (boot_Glib__KeyFile); GPERL_CALL_BOOT (boot_Glib__Option); #endif /* GLIB_CHECK_VERSION (2, 6, 0) */ #if GLIB_CHECK_VERSION (2, 12, 0) GPERL_CALL_BOOT (boot_Glib__BookmarkFile); #endif /* GLIB_CHECK_VERSION (2, 12, 0) */ #if GLIB_CHECK_VERSION (2, 24, 0) GPERL_CALL_BOOT (boot_Glib__Variant); #endif /* GLIB_CHECK_VERSION (2, 24, 0) */ /* make sure that we're running/linked against a version at least as * new as we built against, otherwise bad things will happen. */ if ((((int)glib_major_version) < GLIB_MAJOR_VERSION) || (glib_major_version == GLIB_MAJOR_VERSION && ((int)glib_minor_version) < GLIB_MINOR_VERSION) || (glib_major_version == GLIB_MAJOR_VERSION && glib_minor_version == GLIB_MINOR_VERSION && ((int)glib_micro_version) < GLIB_MICRO_VERSION)) warn ("*** This build of Glib was compiled with glib %d.%d.%d," " but is currently running with %d.%d.%d, which is too" " old. We'll continue, but expect problems!\n", GLIB_MAJOR_VERSION, GLIB_MINOR_VERSION, GLIB_MICRO_VERSION, glib_major_version, glib_minor_version, glib_micro_version); ## ## NOTE: in order to avoid overwriting the docs for the main Glib.pm, ## all xsubs in this section must be either assigned to other ## packages or marked as hidden. ## =for apidoc __hide__ =cut const char * filename_from_unicode (class_or_filename, filename=NULL) GPerlFilename_const class_or_filename GPerlFilename_const filename PROTOTYPE: $ CODE: RETVAL = items < 2 ? class_or_filename : filename; OUTPUT: RETVAL =for apidoc __hide__ =cut GPerlFilename_const filename_to_unicode (const char * class_or_filename, const char *filename=NULL) PROTOTYPE: $ CODE: RETVAL = items < 2 ? class_or_filename : filename; OUTPUT: RETVAL =for apidoc __hide__ =cut void filename_from_uri (...) PROTOTYPE: $ PREINIT: gchar * filename = NULL; const char * uri; char * hostname = NULL; GError * error = NULL; PPCODE: /* support multiple call syntaxes. */ uri = items < 2 ? SvPVutf8_nolen (ST (0)) : SvPVutf8_nolen (ST (1)); filename = g_filename_from_uri (uri, GIMME_V == G_ARRAY ? &hostname : NULL, &error); if (!filename) gperl_croak_gerror (NULL, error); PUSHs (sv_2mortal (newSVpv (filename, 0))); if (GIMME_V == G_ARRAY && hostname) { /* The g_filename_from_uri() docs say hostname is utf8, * hence newSVGChar, though as of glib circa 2.16 * hostname_validate() only actually allows ascii * alphanumerics, so utf8 doesn't actually come out. */ XPUSHs (sv_2mortal (newSVGChar (hostname))); } g_free (filename); if (hostname) g_free (hostname); =for apidoc __hide__ =cut gchar_own * filename_to_uri (...) PROTOTYPE: $$ PREINIT: char * filename = NULL; char * hostname = NULL; GError * error = NULL; CODE: /* The g_filename_to_uri() docs say hostname is utf8, hence SvGChar, * though as of glib circa 2.16 hostname_validate() only actually * allows ascii alphanumerics, so you can't in fact pass in utf8. */ if (items == 2) { filename = SvPV_nolen (ST (0)); hostname = gperl_sv_is_defined (ST (1)) ? SvGChar (ST (1)) : NULL; } else if (items == 3) { filename = SvPV_nolen (ST (1)); hostname = gperl_sv_is_defined (ST (2)) ? SvGChar (ST (2)) : NULL; } else { croak ("Usage: Glib::filename_to_uri (filename, hostname)\n" " -or- Glib->filename_to_uri (filename, hostname)\n" " wrong number of arguments"); } RETVAL = g_filename_to_uri (filename, hostname, &error); if (!RETVAL) gperl_croak_gerror (NULL, error); OUTPUT: RETVAL ## XXX i'd prefer to have local fallbacks so that we don't need this version hack. ## unfortunately, these functions are nontrivial. #if GLIB_CHECK_VERSION(2, 6, 0) ### note the use of raw const char* here. # from gconvert.h. Pod is in Glib.pm. =for apidoc __hide__ =cut gchar_own * g_filename_display_name (const char * filename); # from gconvert.h. Pod is in Glib.pm. =for apidoc __hide__ =cut gchar_own * g_filename_display_basename (const char * filename); #endif Glib-1.320/GLog.xs000644 001750 000024 00000030562 12251766676 014723 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2005, 2009, 2012-2013 by the gtk2-perl team (see the * file AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ #include "gperl.h" #include "gperl-gtypes.h" #include "gperl-private.h" /* for GPERL_SET_CONTEXT */ =head2 GLog GLib has a message logging mechanism which it uses for the g_return_if_fail() assertion macros, etc.; it's really versatile and allows you to set various levels to be fatal and whatnot. Libraries use these for various types of message reporting. These functions let you reroute those messages from Perl. By default, the warning, critical, and message levels go through perl's warn(), and fatal ones go through croak(). [i'm not sure that these get to croak() before GLib abort()s on them...] =over =cut #if 0 /* Log level shift offset for user defined * log levels (0-7 are used by GLib). */ #define G_LOG_LEVEL_USER_SHIFT (8) /* GLib log levels that are considered fatal by default */ #define G_LOG_FATAL_MASK (G_LOG_FLAG_RECURSION | G_LOG_LEVEL_ERROR) #endif SV * newSVGLogLevelFlags (GLogLevelFlags flags) { return gperl_convert_back_flags (GPERL_TYPE_LOG_LEVEL_FLAGS, flags); } GLogLevelFlags SvGLogLevelFlags (SV * sv) { return gperl_convert_flags (GPERL_TYPE_LOG_LEVEL_FLAGS, sv); } /* for GLogFunc style, to be invoked by gperl_log_func() below */ static GPerlCallback * gperl_log_callback_new (SV *log_func, SV *user_data) { GType param_types[3]; param_types[0] = G_TYPE_STRING; param_types[1] = GPERL_TYPE_LOG_LEVEL_FLAGS; param_types[2] = G_TYPE_STRING; return gperl_callback_new (log_func, user_data, 3, param_types, G_TYPE_NONE); } static void gperl_log_func (const gchar *log_domain, GLogLevelFlags log_level, const gchar *message, gpointer user_data) { gperl_callback_invoke ((GPerlCallback *) user_data, NULL, log_domain, log_level, message); } #if GLIB_CHECK_VERSION (2, 6, 0) /* the GPerlCallback currently installed through g_log_set_default_handler(), or NULL if no such */ static GPerlCallback *gperl_log_default_handler_callback = NULL; G_LOCK_DEFINE_STATIC (gperl_log_default_handler_callback); #endif void gperl_log_handler (const gchar *log_domain, GLogLevelFlags log_level, const gchar *message, gpointer user_data) { char * desc; gboolean in_recursion = (log_level & G_LOG_FLAG_RECURSION) != 0; gboolean is_fatal = (log_level & G_LOG_FLAG_FATAL) != 0; PERL_UNUSED_VAR (user_data); log_level &= G_LOG_LEVEL_MASK; if (!message) message = "(NULL) message"; switch (log_level) { case G_LOG_LEVEL_CRITICAL: desc = "CRITICAL"; break; case G_LOG_LEVEL_ERROR: desc = "ERROR"; break; case G_LOG_LEVEL_WARNING: desc = "WARNING"; break; case G_LOG_LEVEL_MESSAGE: desc = "Message"; break; default: desc = "LOG"; } GPERL_SET_CONTEXT; warn ("%s%s%s %s**: %s", (log_domain ? log_domain : ""), (log_domain ? "-" : ""), desc, (in_recursion ? "(recursed) " : ""), message); /* the standard log handler calls abort() for G_LOG_LEVEL_ERROR * messages. this is handy for being able to stop gdb on the * error and get a backtrace. we originally mapped the error * level stuff to croak(), but this broke the ability to find * these errors in gdb, and didn't stop the script as expected * in the perl debugger. so, let's preserve the GLib semantics. */ if (is_fatal) /* XXX would be nice to get a perl backtrace here, but * XXX Carp::cluck() doesn't print anything useful here. */ abort (); } #define ALL_LOGS (G_LOG_LEVEL_MASK | G_LOG_FLAG_FATAL | G_LOG_FLAG_RECURSION) =item gint gperl_handle_logs_for (const gchar * log_domain) Route all g_logs for I through gperl's log handling. You'll have to register domains in each binding submodule, because there's no way we can know about them down here. And, technically, this traps all the predefined log levels, not any of the ones you (or your library) may define for yourself. =cut gint gperl_handle_logs_for (const gchar * log_domain) { return g_log_set_handler (log_domain, ALL_LOGS, gperl_log_handler, NULL); } =back =cut MODULE = Glib::Log PACKAGE = Glib::Log PREFIX = g_log_ =for object Glib::Log A flexible logging mechanism =cut BOOT: gperl_handle_logs_for (NULL); /* gperl_handle_logs_for ("main"); */ gperl_handle_logs_for ("GLib"); gperl_handle_logs_for ("GLib-GObject"); gperl_register_fundamental (GPERL_TYPE_LOG_LEVEL_FLAGS, "Glib::LogLevelFlags"); =for flags Glib::LogLevelFlags =cut ## ## Logging mechanism ## ##guint g_log_set_handler (const gchar *log_domain, GLogLevelFlags log_levels, GLogFunc log_func, gpointer user_data); =for apidoc =for arg log_domain name of the domain to handle with this callback. =arg log_levels (GLogLevelFlags) log levels to handle with this callback =arg log_func (subroutine) handler function $log_func will be called as &$log_func ($log_domain, $log_levels, $message, $user_data); where $log_domain is the name requested and $log_levels is a Glib::LogLevelFlags of level and flags being reported. =cut guint g_log_set_handler (class, gchar_ornull * log_domain, SV * log_levels, SV * log_func, SV * user_data=NULL) PREINIT: GPerlCallback * callback; CODE: callback = gperl_log_callback_new (log_func, user_data); RETVAL = g_log_set_handler (log_domain, SvGLogLevelFlags (log_levels), gperl_log_func, callback); /* we have no choice but to leak the callback. */ /* FIXME what about keeping a hash by the ID, and freeing it on * Glib::Log->remove_handler ($id)? */ /*pcg: would probably take more memory in typical programs... */ OUTPUT: RETVAL ##void g_log_remove_handler (const gchar *log_domain, guint handler_id); =for apidoc =for arg handler_id as returned by C =cut void g_log_remove_handler (class, gchar_ornull *log_domain, guint handler_id); C_ARGS: log_domain, handler_id =for apidoc __function__ =for signature Glib::Log::default_handler ($log_domain, $log_level, $message, ...) =for arg ... possible "userdata" argument ignored The arguments are the same as taken by the function for set_handler or set_default_handler. =cut void g_log_default_handler (const gchar *log_domain, SV *log_level, const gchar *message, ...); CODE: g_log_default_handler (log_domain, SvGLogLevelFlags(log_level), message, NULL); #if GLIB_CHECK_VERSION (2, 6, 0) ##GLogFunc g_log_set_default_handler (GLogFunc log_func, gpointer user_data); =for apidoc =for signature prev_log_func = Glib::Log->set_default_handler ($log_func, $user_data) =arg log_func (subroutine) handler function or undef Install log_func as the default log handler. log_func is called for anything which doesn't otherwise have a handler (either Glib::Log->set_handler, or the L gperl_handle_logs_for), &$log_func ($log_domain, $log_levels, $message, $user_data) where $log_domain is a string, and $log_levels is a Glib::LogLevelFlags of level and flags being reported. If log_func is \&Glib::Log::default_handler or undef then Glib's default handler is set. The return value from C is the previous handler. This is \&Glib::Log::default_handler for Glib's default, otherwise a Perl function previously installed. If the handler is some other non-Perl function then currently the return is undef, but perhaps that will change to some wrapped thing, except that without associated userdata there's very little which could be done with it (it couldn't be reinstalled later without its userdata). =cut SV * g_log_set_default_handler (class, SV * log_func, SV * user_data=NULL) PREINIT: GLogFunc new_func = &g_log_default_handler; GLogFunc old_func; GPerlCallback *new_callback = NULL; GPerlCallback *old_callback; CODE: if (gperl_sv_is_defined (log_func)) { /* check for log_func == \&Glib::Log::default_handler and * turn that into g_log_default_handler() directly, rather * than making a callback into perl and out again. This is * mainly an optimization, but if something weird has * happened then the direct C function will be much more * likely to work. */ HV *st; GV *gv; CV *cv = sv_2cv(log_func, &st, &gv, 0); if (cv && CvXSUB(cv) == XS_Glib__Log_default_handler) { /* new_func already initialized to * g_log_default_handler above */ } else { new_func = gperl_log_func; new_callback = gperl_log_callback_new (log_func, user_data); } } G_LOCK (gperl_log_default_handler_callback); old_func = g_log_set_default_handler (new_func, new_callback); old_callback = gperl_log_default_handler_callback; gperl_log_default_handler_callback = new_callback; G_UNLOCK (gperl_log_default_handler_callback); RETVAL = &PL_sv_undef; if (old_func == g_log_default_handler) { CV *cv = get_cv ("Glib::Log::default_handler", 0); assert (cv); RETVAL = newRV_inc ((SV*) cv); SvREFCNT_inc (RETVAL); } else if (old_func == gperl_log_func) { RETVAL = old_callback->func; SvREFCNT_inc (RETVAL); } if (old_callback) { gperl_callback_destroy (old_callback); } OUTPUT: RETVAL #endif # this is a little ugly, because i didn't want to export a typemap for # GLogLevelFlags. MODULE = Glib::Log PACKAGE = Glib PREFIX = g_ =for object Glib::Log =cut void g_log (class, gchar_ornull * log_domain, SV * log_level, const gchar *message) CODE: g_log (log_domain, SvGLogLevelFlags (log_level), "%s", message); MODULE = Glib::Log PACKAGE = Glib::Log PREFIX = g_log_ SV * g_log_set_fatal_mask (class, const gchar *log_domain, SV * fatal_mask); CODE: RETVAL = newSVGLogLevelFlags (g_log_set_fatal_mask (log_domain, SvGLogLevelFlags (fatal_mask))); OUTPUT: RETVAL SV * g_log_set_always_fatal (class, SV * fatal_mask); CODE: RETVAL = newSVGLogLevelFlags (g_log_set_always_fatal (SvGLogLevelFlags (fatal_mask))); OUTPUT: RETVAL ## ## there are, indeed, some incidences in which it would be handy to have ## perl hooks into the g_log mechanism ## ##ifndef G_LOG_DOMAIN ##define G_LOG_DOMAIN ((gchar*) 0) ##endif /* G_LOG_DOMAIN */ MODULE = Glib::Log PACKAGE = Glib =for object Glib::Log =cut ### ### these are of dubious value, but i imagine that they could be useful... ### ##define g_error(...) g_log (G_LOG_DOMAIN, G_LOG_LEVEL_ERROR, __VA_ARGS__) ##define g_message(...) g_log (G_LOG_DOMAIN, G_LOG_LEVEL_MESSAGE, __VA_ARGS__) ##define g_critical(...) g_log (G_LOG_DOMAIN, G_LOG_LEVEL_CRITICAL, __VA_ARGS__) ##define g_warning(...) g_log (G_LOG_DOMAIN, G_LOG_LEVEL_WARNING, __VA_ARGS__) void error (class, gchar_ornull * domain, const gchar * message) ALIAS: error = 0 message = 1 critical = 2 warning = 3 PREINIT: GLogLevelFlags flags = G_LOG_LEVEL_MESSAGE; CODE: switch (ix) { case 0: flags = G_LOG_LEVEL_ERROR; break; case 1: flags = G_LOG_LEVEL_MESSAGE; break; case 2: flags = G_LOG_LEVEL_CRITICAL; break; case 3: flags = G_LOG_LEVEL_WARNING; break; } g_log (domain, flags, "%s", message); ## ## these are not needed -- perl's print() and warn() do the job. ## ## typedef void (*GPrintFunc) (const gchar *string); ## void g_print (const gchar *format, ...) G_GNUC_PRINTF (1, 2); ## GPrintFunc g_set_print_handler (GPrintFunc func); ## void g_printerr (const gchar *format, ...) G_GNUC_PRINTF (1, 2); ## GPrintFunc g_set_printerr_handler (GPrintFunc func); ## ## ## the assertion and return macros aren't really useful at all in perl; ## there are native perl replacements for them on CPAN. ## ##define g_assert(expr) ##define g_assert_not_reached() ##define g_return_if_fail(expr) ##define g_return_val_if_fail(expr,val) ##define g_return_if_reached() ##define g_return_val_if_reached(val) Glib-1.320/GMainLoop.xs000644 001750 000024 00000046130 12636024471 015701 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2005 by the gtk2-perl team (see the file AUTHORS for * the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ #include "gperl.h" /* stuff from gmain.h, the main loop and friends */ /* GMainLoop is in libglib; GClosure is in libgobject. the mainloop can't refer to GClosure for dependency reasons, but the code is designed to be used with GClosure anyway. that's what we'll do here. specifically, GSourceDummyMarshal is just a placeholder for GClosureMarshal. since we have GClosure implemented in GClosure.xs, we'll use it to handle the callbacks here. in the more general sense, this file offers the GLib-level interface to the main loop stuff wrapped by the Gtk2 module. at the current point, i can't think of any reason to expose the lower-level main loop stuff here, because how many apps are going to be using the event loop without Gtk? then again, it's quite conceivable that you'd want to do that, so it's not precluded (just not done). if you want to implement the main loop stuff here, you'll need to create typemaps for these types: GMainContext <- Opaque GMainLoop <- Opaque and you'll need to typemap these if you want to create custom sources from perl: GSource GSourceCallbackFuncs GSourceFuncs as far as i can tell, each of these is a ref-counted object, but none are GObject or GBoxed descendents (as they are part of glib, not gobject!). for anyone who needs to implement this stuff, i've left the majority of gmain.h in here, commented out. */ /* * Since 5.7.3, perl uses "safe" signal handling by default. * (As gtk2-perl requires at least 5.8.0, this is relevant to us.) * To protect the interpreter from having signal handlers run during * important and otherwise uninterruptible operations, when something * is installed in %SIG, perl installs a sigaction handler that simply * sets a flag saying that a signal is pending; then, at "strategic" * points in later operation, it checks that flag. This is done using * the PERL_ASYNC_CHECK() macro after each op. * * This is important, because while a glib main loop is running, it generally * sleeps in a poll(), and control does not normally return to perl. That * causes pending signals to pile up, and looks to the user as though the * signals are being ignored. * * To solve this, the bindings will always install an event source which * watches PL_sig_pending, and calls the PERL_ASYNC_CHECK() macro whenever * we see it go true. Since an async signal will wake up a poll(), this * will always run at just the right time, so no delays or other performance * penalties result. * * Thanks to Jan Hudec for the implementation idea: * http://mail.gnome.org/archives/gtk-perl-list/2004-December/msg00034.html */ static gboolean async_watcher_prepare (GSource * source, gint * timeout) { PERL_UNUSED_VAR (source); /* wait as long as you like. we rely on the fact that the * poll will be awoken by the receipt of an async signal. */ *timeout = -1; return FALSE; } static gboolean async_watcher_check (GSource * source) { PERL_UNUSED_VAR (source); return PL_sig_pending; } static gboolean async_watcher_dispatch (GSource * source, GSourceFunc callback, gpointer user_data) { PERL_UNUSED_VAR (source); PERL_UNUSED_VAR (callback); PERL_UNUSED_VAR (user_data); /* this checks PL_sig_pending again, but that's probably not * a bad thing -- it's conceivable that since the check, some * other handler has triggered a perl callback, which would've * cause perl to dispatch the signal handlers, and if we didn't * recheck here we'd redispatch. */ PERL_ASYNC_CHECK (); return TRUE; } static void async_watcher_install (void) { static GSourceFuncs async_watcher_funcs = { async_watcher_prepare, async_watcher_check, async_watcher_dispatch, NULL, NULL, NULL }; /* FIXME: we never unref the watcher. */ GSource * async_watcher = g_source_new (&async_watcher_funcs, sizeof (GSource)); g_source_attach (async_watcher, NULL); } #if GLIB_CHECK_VERSION (2, 4, 0) static void gperl_child_watch_callback (GPid pid, gint status, gpointer cb) { gperl_callback_invoke ((GPerlCallback*)cb, NULL, (int) pid, status); } #endif /* 2.4 */ MODULE = Glib::MainLoop PACKAGE = Glib PREFIX = g_ BOOT: async_watcher_install (); =for object Glib::MainLoop =cut #if GLIB_CHECK_VERSION(2,4,0) =for apidoc __function__ Find the current main loop recursion level. This is handy in fringe situations, but those are very rare; see the C API reference for a more in-depth discussion. =cut int g_main_depth () #endif MODULE = Glib::MainLoop PACKAGE = Glib::MainContext PREFIX = g_main_context_ =for object Glib::MainLoop An event source manager =cut =for position DESCRIPTION =head1 DESCRIPTION Event-driven programs need some sort of loop which watches for events and launches the appropriate actions. Glib::MainLoop provides this functionality. Mainloops have context, provided by the MainContext object. For the most part you can use the default context (see C), but if you want to create a subcontext for a nested loop which doesn't have the same event sources, etc, you can. Event sources, attached to main contexts, watch for events to happen, and launch appropriate actions. Glib provides a few ready-made event sources, the Glib::Timeout, Glib::Idle, and io watch (C<< Glib::IO->add_watch >>). Under the hood, Gtk+ adds event sources for GdkEvents to dispatch events to your widgets. In fact, Gtk2 provides an abstraction of Glib::MainLoop (See C<< Gtk2->main >> and friends), so you may rarely have cause to use Glib::MainLoop directly. Note: As of version 1.080, the Glib module uses a custom event source to ensure that perl's safe signal handling and the glib polling event loop play nicely together. It is no longer necessary to install a timeout to ensure that async signals get handled in a timely manner. =head1 CONSTANTS C and C are designed for use as the return values from timeout, idle and I/O watch source functions. They return true to keep running or false to remove themselves. These constants can help you get that the right way around. Glib::SOURCE_CONTINUE # true Glib::SOURCE_REMOVE # false =cut ##################### ### GMainContext: ### ##################### GMainContext * g_main_context_new (class) C_ARGS: /*void*/ CLEANUP: g_main_context_unref (RETVAL); /* release the typemap's ref, so the wrapper owns the object */ void DESTROY (maincontext) GMainContext * maincontext CODE: g_main_context_unref (maincontext); ## these are automatic, now ##void g_main_context_ref (GMainContext *context); ##void g_main_context_unref (GMainContext *context); GMainContext * g_main_context_default (class) C_ARGS: /*void*/ gboolean g_main_context_iteration (GMainContext *context, gboolean may_block); gboolean g_main_context_pending (GMainContext *context); ##/* For implementation of legacy interfaces */ ##GSource *g_main_context_find_source_by_id (GMainContext *context, ## guint source_id); ##GSource *g_main_context_find_source_by_user_data (GMainContext *context, ## gpointer user_data); ##GSource *g_main_context_find_source_by_funcs_user_data (GMainContext *context, ## GSourceFuncs *funcs, ## gpointer user_data); ##/* Low level functions for implementing custom main loops. */ ##void g_main_context_wakeup (GMainContext *context); ##gboolean g_main_context_acquire (GMainContext *context); ##void g_main_context_release (GMainContext *context); ##gboolean g_main_context_wait (GMainContext *context, ## GCond *cond, ## GMutex *mutex); ## ##gboolean g_main_context_prepare (GMainContext *context, ## gint *priority); ##gint g_main_context_query (GMainContext *context, ## gint max_priority, ## gint *timeout_, ## GPollFD *fds, ## gint n_fds); ##gint g_main_context_check (GMainContext *context, ## gint max_priority, ## GPollFD *fds, ## gint n_fds); ##void g_main_context_dispatch (GMainContext *context); ## ##void g_main_context_set_poll_func (GMainContext *context, ## GPollFunc func); ##GPollFunc g_main_context_get_poll_func (GMainContext *context); ## ##/* Low level functions for use by source implementations */ ##void g_main_context_add_poll (GMainContext *context, ## GPollFD *fd, ## gint priority); ##void g_main_context_remove_poll (GMainContext *context, ## GPollFD *fd); #if GLIB_CHECK_VERSION (2, 12, 0) gboolean g_main_context_is_owner (GMainContext *context); #endif MODULE = Glib::MainLoop PACKAGE = Glib::MainLoop PREFIX = g_main_loop_ ################## ### GMainLoop: ### ################## ## the OUTPUT typemap for GMainLoop* takes a ref on the object, and the ## DESTROY method for the wrapper releases it. g_main_loop_new returns ## a new object that is to be owned by the wrapper, so it releases the ## typemap's reference in the CLEANUP section. ##GMainLoop *g_main_loop_new (GMainContext *context, gboolean is_running); GMainLoop * g_main_loop_new (class, context=NULL, is_running=FALSE) GMainContext *context gboolean is_running C_ARGS: context, is_running CLEANUP: g_main_loop_unref (RETVAL); void DESTROY (mainloop) GMainLoop * mainloop CODE: g_main_loop_unref (mainloop); void g_main_loop_run (GMainLoop *loop); void g_main_loop_quit (GMainLoop *loop); ## see above, these are taken care of for you ##GMainLoop *g_main_loop_ref (GMainLoop *loop); ##void g_main_loop_unref (GMainLoop *loop); gboolean g_main_loop_is_running (GMainLoop * loop); GMainContext * g_main_loop_get_context (GMainLoop * loop); ### NOTE: stuff behind G_DISABLE_DEPRECATED shall not be bound. ### i've left their declarations here as a reminder that we didn't ### forget them, they're just not supposed to be included. ### ##/* ============== Compat main loop stuff ================== */ ## ###ifndef G_DISABLE_DEPRECATED ## ##/* Legacy names for GMainLoop functions */ ###define g_main_new(is_running) g_main_loop_new (NULL, is_running); ###define g_main_run(loop) g_main_loop_run(loop) ###define g_main_quit(loop) g_main_loop_quit(loop) ###define g_main_destroy(loop) g_main_loop_unref(loop) ###define g_main_is_running(loop) g_main_loop_is_running(loop) ## ##/* Functions to manipulate the default main loop */ ## ###define g_main_iteration(may_block) g_main_context_iteration (NULL, may_block) ###define g_main_pending() g_main_context_pending (NULL) ## ###define g_main_set_poll_func(func) g_main_context_set_poll_func (NULL, func) ## ###endif /* G_DISABLE_DEPRECATED */ MODULE = Glib::MainLoop PACKAGE = Glib::Source PREFIX = g_source_ =for object Glib::MainLoop =cut ################ ### GSource: ### ################ ##GSource *g_source_new (GSourceFuncs *source_funcs, ## guint struct_size); ##GSource *g_source_ref (GSource *source); ##void g_source_unref (GSource *source); ##guint g_source_attach (GSource *source, ## GMainContext *context); ##void g_source_destroy (GSource *source); ##void g_source_set_priority (GSource *source, ## gint priority); ##gint g_source_get_priority (GSource *source); ##void g_source_set_can_recurse (GSource *source, ## gboolean can_recurse); ##gboolean g_source_get_can_recurse (GSource *source); ##guint g_source_get_id (GSource *source); ## ##GMainContext *g_source_get_context (GSource *source); ## ##void g_source_set_callback (GSource *source, ## GSourceFunc func, ## gpointer data, ## GDestroyNotify notify); ##void g_source_add_poll (GSource *source, ## GPollFD *fd); ##void g_source_remove_poll (GSource *source, ## GPollFD *fd); ## ##void g_source_get_current_time (GSource *source, ## GTimeVal *timeval); ## ##/* Specific source types */ ##GSource *g_idle_source_new (void); ##GSource *g_timeout_source_new (guint interval); ##/* Miscellaneous functions ## */ ##void g_get_current_time (GTimeVal *result); =for apidoc Remove an event source. I<$tag> is the number returned by things like C<< Glib::Timeout->add >>, C<< Glib::Idle->add >>, and C<< Glib::IO->add_watch >>. =cut gboolean g_source_remove (class, tag) guint tag C_ARGS: tag ##gboolean g_source_remove_by_user_data (gpointer user_data); ##gboolean g_source_remove_by_funcs_user_data (GSourceFuncs *funcs, ## gpointer user_data); MODULE = Glib::MainLoop PACKAGE = Glib::Timeout PREFIX = g_timeout_ =for object Glib::MainLoop =cut ########################## ### Idles and timeouts ### ########################## =for apidoc =for arg interval number of milliseconds =for arg callback (subroutine) Run I<$callback> every I<$interval> milliseconds until I<$callback> returns false. Returns a source id which may be used with C<< Glib::Source->remove >>. Note that a mainloop must be active for the timeout to execute. =cut guint g_timeout_add (class, interval, callback, data=NULL, priority=G_PRIORITY_DEFAULT) guint interval SV * callback SV * data gint priority PREINIT: GClosure * closure; GSource * source; CODE: closure = gperl_closure_new (callback, data, FALSE); source = g_timeout_source_new (interval); if (priority != G_PRIORITY_DEFAULT) g_source_set_priority (source, priority); g_source_set_closure (source, closure); RETVAL = g_source_attach (source, NULL); g_source_unref (source); OUTPUT: RETVAL #if GLIB_CHECK_VERSION (2, 14, 0) guint g_timeout_add_seconds (class, guint interval, SV * callback, SV * data=NULL, gint priority=G_PRIORITY_DEFAULT) PREINIT: GClosure * closure; GSource * source; CODE: closure = gperl_closure_new (callback, data, FALSE); source = g_timeout_source_new_seconds (interval); if (priority != G_PRIORITY_DEFAULT) g_source_set_priority (source, priority); g_source_set_closure (source, closure); RETVAL = g_source_attach (source, NULL); g_source_unref (source); OUTPUT: RETVAL #endif MODULE = Glib::MainLoop PACKAGE = Glib::Idle PREFIX = g_idle_ =for object Glib::MainLoop =cut =for apidoc =for arg callback (subroutine) Run I<$callback> when the mainloop is idle. If I<$callback> returns false, it will uninstall itself, otherwise, it will run again at the next idle iteration. Returns a source id which may be used with C<< Glib::Source->remove >>. =cut guint g_idle_add (class, callback, data=NULL, priority=G_PRIORITY_DEFAULT_IDLE) SV * callback SV * data gint priority PREINIT: GClosure * closure; GSource * source; CODE: closure = gperl_closure_new (callback, data, FALSE); source = g_idle_source_new (); g_source_set_priority (source, priority); g_source_set_closure (source, closure); RETVAL = g_source_attach (source, NULL); g_source_unref (source); OUTPUT: RETVAL ### FIXME i'm not sure about how to search for the data if we set SVs there. ##gboolean g_idle_remove_by_data (gpointer data); MODULE = Glib::MainLoop PACKAGE = Glib::IO PREFIX = g_io_ =for object Glib::MainLoop =cut BOOT: gperl_register_fundamental (G_TYPE_IO_CONDITION, "Glib::IOCondition"); =for enum Glib::IOCondition =cut =for apidoc =for arg fd (integer) file descriptor, e.g. fileno($filehandle) =for arg callback (subroutine) Run I<$callback> when there is an event on I<$fd> that matches I<$condition>. The watch uninstalls itself if I<$callback> returns false. Returns a source id that may be used with C<< Glib::Source->remove >>. Glib's IO channels serve the same basic purpose as Perl's file handles, so for the most part you don't see GIOChannels in Perl. The IO watch integrates IO operations with the main loop, which Perl file handles don't do. For various reasons, this function requires raw file descriptors, not full file handles. See C in L. =cut guint g_io_add_watch (class, fd, condition, callback, data=NULL, priority=G_PRIORITY_DEFAULT) int fd GIOCondition condition SV * callback SV * data gint priority PREINIT: GClosure * closure; GSource * source; GIOChannel * channel; CODE: #ifdef USE_SOCKETS_AS_HANDLES /* native win32 doesn't have fd's, so first convert perls fd into a winsock fd */ channel = g_io_channel_win32_new_socket ((HANDLE)win32_get_osfhandle (fd)); #else channel = g_io_channel_unix_new (fd); #endif /* USE_SOCKETS_AS_HANDLES */ source = g_io_create_watch (channel, condition); if (priority != G_PRIORITY_DEFAULT) g_source_set_priority (source, priority); closure = gperl_closure_new (callback, data, FALSE); g_source_set_closure (source, closure); RETVAL = g_source_attach (source, NULL); g_source_unref (source); g_io_channel_unref (channel); OUTPUT: RETVAL MODULE = Glib::MainLoop PACKAGE = Glib::Child PREFIX = g_child_ =for object Glib::MainLoop =cut #if GLIB_CHECK_VERSION (2, 4, 0) =for apidoc =for arg pid (integer) child process ID =for arg callback (subroutine) Add a source to the default main context which will call &$callback ($pid, $waitstatus, $data) when child process $pid terminates. The return value is a source id which can be used with C<< Glib::Source->remove >>. When the callback is made the source is removed automatically. In a non-threaded program Glib implements this source by installing a SIGCHLD handler. Don't change $SIG{CHLD} in Perl or the callback will never run. =cut guint g_child_watch_add (class, int pid, SV *callback, SV *data=NULL, gint priority=G_PRIORITY_DEFAULT) PREINIT: GPerlCallback* cb; GType param_types[2]; CODE: /* As of Glib 2.16.4 there's no "callback_closure" func in g_child_watch_funcs, and none added there by g_source_set_closure (unlike idle, timeout and io above), so go GPerlCallback style. */ param_types[0] = G_TYPE_INT; param_types[1] = G_TYPE_INT; cb = gperl_callback_new (callback, data, 2, param_types, 0); RETVAL = g_child_watch_add_full (priority, (GPid) pid, gperl_child_watch_callback, cb, (GDestroyNotify) gperl_callback_destroy); OUTPUT: RETVAL #endif /* 2.4 */ Glib-1.320/GObject.xs000644 001750 000024 00000151556 12636024471 015402 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2006, 2010, 2012-2013 by the gtk2-perl team (see the * file AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ /* * the POD directives in here will be stripped by xsubpp before compilation, * and are intended to be extracted by podselect when creating xs api * reference documentation. pod must NOT appear within C comments, because * it gets replaced by a comment that says "embedded pod stripped". */ =head2 GObject To deal with the intricate interaction of the different reference-counting semantics of Perl objects versus GObjects, the bindings create a combined PerlObject+GObject, with the GObject's pointer in magic attached to the Perl object, and the Perl object's pointer in the GObject's user data. Thus it's not really a "wrapper", but we refer to it as one, because "combined Perl object + GObject" is a cumbersome and confusing mouthful. GObjects are represented as blessed hash references. The GObject user data mechanism is not typesafe, and thus is used only for unsigned integer values; the Perl-level hash is available for any type of user data. The combined nature of the wrapper means that data stored in the hash will stick around as long as the object is alive. Since the C pointer is stored in attached magic, the C pointer is not available to the Perl developer via the hash object, so there's no need to worry about breaking it from perl. Propers go to Marc Lehmann for dreaming most of this up. =over =cut #include "gperl.h" #include "gperl-private.h" /* for GPERL_SET_CONTEXT and * _gperl_sv_from_value_internal */ typedef struct _ClassInfo ClassInfo; typedef struct _SinkFunc SinkFunc; struct _ClassInfo { GType gtype; char * package; gboolean initialized; }; struct _SinkFunc { GType gtype; GPerlObjectSinkFunc func; }; static GHashTable * types_by_type = NULL; static GHashTable * types_by_package = NULL; /* store outside of the class info maps any options we expect to be sparse; * this will save us a fair amount of space. */ static GHashTable * nowarn_by_type = NULL; static GArray * sink_funcs = NULL; static GQuark wrapper_quark; /* this quark stores the object's wrapper sv */ /* what should be done here */ #define GPERL_THREAD_SAFE !GPERL_DISABLE_THREADSAFE #if GPERL_THREAD_SAFE /* keep a list of all gobjects */ static gboolean perl_gobject_tracking = FALSE; static GHashTable * perl_gobjects = NULL; G_LOCK_DEFINE_STATIC (perl_gobjects); #endif /* thread safety locks for the modifiables above */ G_LOCK_DEFINE_STATIC (types_by_type); G_LOCK_DEFINE_STATIC (types_by_package); G_LOCK_DEFINE_STATIC (nowarn_by_type); G_LOCK_DEFINE_STATIC (sink_funcs); static MGVTBL gperl_mg_vtbl; /* * Attach a C to the given C. It can be retrieved later using * C<_gperl_find_mg> and removed again using C<_gperl_remove_mg>. */ void _gperl_attach_mg (SV * sv, void * ptr) { sv_magicext (sv, NULL, PERL_MAGIC_ext, &gperl_mg_vtbl, (const char *)ptr, 0); } /* * Retrieve the magic used to attach a pointer to the given C using * C<_gperl_attach_mg>. The C member of the returned struct will contain * the actual pointer attached to the scalar. */ MAGIC * _gperl_find_mg (SV * sv) { MAGIC *mg; if (SvTYPE (sv) < SVt_PVMG) return NULL; for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &gperl_mg_vtbl) { assert (mg->mg_ptr); return mg; } } return NULL; } /* copied from ppport.h, needed for older perls (< 5.8.8?) */ #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif /* * Remove the association between a pointer attached to C using * C<_gperl_attach_mg> and the C. */ void _gperl_remove_mg (SV * sv) { MAGIC *mg, *prevmagic = NULL, *moremagic = NULL; if (SvTYPE (sv) < SVt_PVMG || !SvMAGIC (sv)) return; for (mg = SvMAGIC (sv); mg; prevmagic = mg, mg = moremagic) { moremagic = mg->mg_moremagic; if (mg->mg_type == PERL_MAGIC_ext && mg->mg_virtual == &gperl_mg_vtbl) break; } if (prevmagic) { prevmagic->mg_moremagic = moremagic; } else { SvMAGIC_set (sv, moremagic); } mg->mg_moremagic = NULL; Safefree (mg); } static ClassInfo * class_info_new (GType gtype, const char * package) { ClassInfo * class_info; class_info = g_new0 (ClassInfo, 1); class_info->gtype = gtype; class_info->package = g_strdup (package); class_info->initialized = FALSE; return class_info; } static void class_info_destroy (ClassInfo * class_info) { if (class_info) { g_free (class_info->package); g_free (class_info); } } static void class_info_finish_loading (ClassInfo * class_info) { char * child_isa_full; AV * isa; AV * new_isa; int i, items; #ifdef NOISY static int depth = 0; char leader[50] = ""; depth++; for (i = 0 ; i < depth ; i++) leader[i] = ' '; leader[i] = '\0'; warn ("%s%s(0x%p) -> %s\n", leader, __FUNCTION__, class_info, class_info->package); #endif child_isa_full = g_strconcat (class_info->package, "::ISA", NULL); isa = get_av (child_isa_full, FALSE); /* supposed to exist already */ if (!isa) croak ("internal inconsistency -- finishing lazy loading, " "but %s::ISA does not exist", class_info->package); g_free (child_isa_full); /* * Rather than just blowing away the old @ISA and replacing it with * one of our own, we need to replace the _LazyLoader marker with * the proper new info. This is because some classes may need to * have interfaces appear in @ISA *before* the parent class, in order * to resolve name clashes -- think of Gtk2::TreeModel::get versus * Glib::Object::get, for example. * * Thus, this will be a little roundabout. */ new_isa = newAV (); items = av_len (isa) + 1; for (i = 0 ; i < items ; i++) { /* We're shifting the entries off of the @ISA array here * because just accessing them and later calling av_clear * seems to break the caching magic associated with @ISA when * running under perl 5.10.0. */ SV * sv = av_shift (isa); if (!sv) continue; if (strEQ (SvPV_nolen (sv), "Glib::Object::_LazyLoader")) { /* omit _LazyLoader, fill with proper info */ GType parent_type; GType *interfaces; guint n_interfaces; const char * package; int i; parent_type = g_type_parent (class_info->gtype); if (!parent_type) /* we just found GObject or GInterface. * this is legal. */ continue; if (parent_type == G_TYPE_INTERFACE) /* not interested in setting this up. */ continue; /* possibly recurse, loading all the way down to * GObject if necessary */ package = gperl_object_package_from_type (parent_type); if (!package) { warn ("WHOA! parent %s of %s is not an object" " or interface!", g_type_name (parent_type), g_type_name (class_info->gtype)); continue; } av_push (new_isa, newSVpv (package, 0)); /* add in any interfaces we can find. */ interfaces = g_type_interfaces (class_info->gtype, &n_interfaces); for (i = 0 ; interfaces[i] != 0 ; i++) { package = gperl_object_package_from_type (interfaces[i]); if (package) av_push (new_isa, newSVpv (package, 0)); else warn ("interface type %s(%"G_GSIZE_FORMAT") is not" " registered", g_type_name (interfaces[i]), interfaces[i]); } if (interfaces) g_free (interfaces); /* this scalar is not needed anymore */ sv_free (sv); } else { /* ownership of sv is transferred to new_isa */ av_push (new_isa, sv); } } /* copy back to the now empty isa */ items = av_len (new_isa) + 1; for (i = 0 ; i < items ; i++) { SV ** svp = av_fetch (new_isa, i, FALSE); if (svp && *svp) av_push (isa, SvREFCNT_inc (*svp)); else warn ("bad pointer inside av\n"); } av_clear (new_isa); av_undef (new_isa); class_info->initialized = TRUE; #ifdef NOISY warn ("%sdone\n", leader); depth--; #endif } static ClassInfo * find_registered_type_in_ancestry (const char *package) { char *isa_name; AV *isa; isa_name = g_strconcat (package, "::ISA", NULL); isa = get_av (isa_name, FALSE); /* supposed to exist already */ g_free (isa_name); if (isa) { int i, n_items = av_len (isa) + 1; for (i = 0; i < n_items; i++) { ClassInfo *class_info; SV **entry; entry = av_fetch (isa, i, 0); if (!entry || !gperl_sv_is_defined (*entry)) continue; G_LOCK (types_by_package); class_info = (ClassInfo*) g_hash_table_lookup (types_by_package, SvPV_nolen (*entry)); G_UNLOCK (types_by_package); if (!class_info) { /* If this package is not registered, maybe one * of its ancestors is? So try to recurse into * this package's @ISA. */ class_info = find_registered_type_in_ancestry ( SvPV_nolen (*entry)); } if (class_info) { return class_info; } } } return NULL; } =item void gperl_register_object (GType gtype, const char * package) tell the GPerl type subsystem what Perl package corresponds with a given GObject by GType. automagically sets up @I::ISA for you. note that @ISA will not be created for gtype until gtype's parent has been registered. if you are experiencing strange problems with a class' @ISA not being set up, change the order in which you register them. =cut void gperl_register_object (GType gtype, const char * package) { ClassInfo * class_info; G_LOCK (types_by_type); G_LOCK (types_by_package); if (!types_by_type) { /* we put the same data pointer into each hash table, so we * must only associate the destructor with one of them. * also, for the string-keyed hashes, the keys will be * destroyed by the ClassInfo destructor, so we don't need * a key_destroy_func. */ types_by_type = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify) class_info_destroy); types_by_package = g_hash_table_new_full (g_str_hash, g_str_equal, NULL, NULL); } class_info = class_info_new (gtype, package); /* We need to insert into types_by_package first because there might * otherwise be trouble if we overwrite an entry: inserting into * types_by_type frees the class_info of the overwritten entry, so * that class_info->package is no longer valid at this point. * * Note also it's g_hash_table_replace() for types_by_package, * because the old key string in the old class_info will be freed * when types_by_type updates the value there. */ g_hash_table_replace (types_by_package, class_info->package, class_info); g_hash_table_insert (types_by_type, (gpointer) class_info->gtype, class_info); /* warn ("registered type %s to package %s\n", g_type_name (class_info->gtype), class_info->package); */ /* defer the actual ISA setup to Glib::Object::_LazyLoader */ gperl_set_isa (package, "Glib::Object::_LazyLoader"); G_UNLOCK (types_by_type); G_UNLOCK (types_by_package); if (G_TYPE_IS_INTERFACE (gtype)) /* * Force GInterfaces to finish loading now. In some cases, * we won't cause a call to gperl_object_package_from_type() * on the interface type to happen from perl code before * somebody tries to do a lookup on an object type that * implements that interface, which causes _LazyLoader to * get upset. Since GInterfaces are not deep-derivable, an * alternative is simply to avoid setting up lazy loading * for GInterfaces, but that can cause problems if the * GInterface type is not registered. * * NOTE: class_info_finish_loading() may call other * functions that grab locks, so we need to be * unlocked. */ class_info_finish_loading (class_info); } =item void gperl_register_object_alias (GType gtype, const char * package) Makes I an alias for I. This means that the package name specified by I will be mapped to I by I, but I won't map I to I. This is useful if you want to change the canonical package name of a type while preserving backwards compatibility with code which uses I to specify I. In order for this to make sense, another package name should be registered for I with I. =cut void gperl_register_object_alias (GType gtype, const char * package) { ClassInfo *class_info; G_LOCK (types_by_type); class_info = (ClassInfo *) g_hash_table_lookup (types_by_type, (gpointer) gtype); G_UNLOCK (types_by_type); if (!class_info) { croak ("cannot register alias %s for the unregistered type %s", package, g_type_name (gtype)); } G_LOCK (types_by_package); /* associate package with the same class_info. class_info is still owned by types_by_type. types_by_package doesn't have a free-function installed, so that's ok. */ g_hash_table_insert (types_by_package, (char *) package, class_info); G_UNLOCK (types_by_package); } =item void gperl_register_sink_func (GType gtype, GPerlObjectSinkFunc func) Tell gperl_new_object() to use I to claim ownership of objects derived from I. gperl_new_object() always refs a GObject when wrapping it for the first time. To have the Perl wrapper claim ownership of a GObject as part of gperl_new_object(), you unref the object after ref'ing it. however, different GObject subclasses have different ways to claim ownership; for example, GtkObject simply requires you to call gtk_object_sink(). To make this concept generic, this function allows you to register a function to be called when then wrapper should claim ownership of the object. The I registered for a given I will be called on any object for which C<< g_type_isa (G_TYPE_OBJECT (object), type) >> succeeds. If no sinkfunc is found for an object, g_object_unref() will be used. Even though GObjects don't need sink funcs, we need to have them in Glib as a hook for upstream objects. If we create a GtkObject (or any other type of object which uses a different way to claim ownership) via Glib::Object->new, any upstream wrappers, such as gtk2perl_new_object(), will B be called. Having a sink func facility down here enables us always to do the right thing. =cut /* * this stuff is directly inspired by pygtk. i didn't actually copy * and paste the code, but it sure looks like i did, down to the names. * hey, they were the obvious names! * * for the record, i think this is a rather dodgy way to do sink funcs * --- it presumes that you'll find the right one first; i prepend new * registrees in the hopes that this will work out, but nothing guarantees * that this will work. to do it right, the wrappers need to have * some form of inherited vtable or something... but i've had enough * problems just getting the object caching working, so i can't really * mess with that right now. */ void gperl_register_sink_func (GType gtype, GPerlObjectSinkFunc func) { SinkFunc sf; G_LOCK (sink_funcs); if (!sink_funcs) sink_funcs = g_array_new (FALSE, FALSE, sizeof (SinkFunc)); sf.gtype = gtype; sf.func = func; g_array_prepend_val (sink_funcs, sf); G_UNLOCK (sink_funcs); } /* * helper for gperl_new_object; do whatever you have to do to this * object to ensure that the calling code now owns the object. assumes * the object has already been ref'd once. to do this, we look up the * proper sink func; if none has been registered for this type, then * just call g_object_unref. */ static void gperl_object_take_ownership (GObject * object) { G_LOCK (sink_funcs); if (sink_funcs) { guint i; for (i = 0 ; i < sink_funcs->len ; i++) if (g_type_is_a (G_OBJECT_TYPE (object), g_array_index (sink_funcs, SinkFunc, i).gtype)) { g_array_index (sink_funcs, SinkFunc, i).func (object); G_UNLOCK (sink_funcs); return; } } G_UNLOCK (sink_funcs); g_object_unref (object); } #if GLIB_CHECK_VERSION (2, 10, 0) static void sink_initially_unowned (GObject *object) { /* FIXME: This is not correct when the object is not floating. The * sink function is supposed to effectively remove a reference, but * when the object is not floating, ref_sink+unref == ref+unref == nop. * Luckily, there do not seem to be functions of GInitiallyUnowned * descendants out there that transfer ownership of a non-floating * reference to the caller. If we ever encounter one, this needs to be * revisited. * * One peculiar corner case is Glib::Object::Introspection's handling * of GtkWindow and its descendants. G:O:I marks all constructors of * GInitiallyUnowned descendants as transferring ownership (to override * special-casing done by gobject-introspection). This is thus * inadvertedly also applied to GtkWindow and its descendants even * though their constructors do not transfer ownership (because gtk+ * keeps an internal reference to each window). But due to this * incorrect code below, the ownership transfer is effectively ignored, * resulting in correct behavior. */ g_object_ref_sink (object); g_object_unref (object); } #endif =item void gperl_object_set_no_warn_unreg_subclass (GType gtype, gboolean nowarn) In versions 1.00 through 1.10x of Glib, the bindings required all types to be registered ahead of time. Upon encountering an unknown type, the bindings would emit a warning to the effect of "unknown type 'Foo'; representing as first known parent type 'Bar'". However, for some types, such as GtkStyle or GdkGC, the actual object returned is an instance of a child type of a private implementation (e.g., a theme engine ("BlueCurveStyle") or gdk backend ("GdkGCX11")); we neither can nor should have registered names for these types. Therefore, it is possible to tell the bindings not to warn about these unregistered subclasses, and simply represent them as the parent type. With 1.12x, the bindings will automatically register unknown classes into the namespace Glib::Object::_Unregistered to avoid possible breakage resulting from unknown ancestors of known children. To preserve the old registered-as-unregistered behavior, the value installed by this function is used to prevent the _Unregistered mapping for such private backend classes. Note: this assumes I has already been registered with gperl_register_object(). =cut void gperl_object_set_no_warn_unreg_subclass (GType gtype, gboolean nowarn) { G_LOCK (nowarn_by_type); if (!nowarn_by_type) { if (!nowarn) return; nowarn_by_type = g_hash_table_new (g_direct_hash, g_direct_equal); } g_hash_table_insert (nowarn_by_type, (gpointer) gtype, GINT_TO_POINTER (nowarn)); G_UNLOCK (nowarn_by_type); } static gboolean gperl_object_get_no_warn_unreg_subclass (GType gtype) { gboolean result; G_LOCK (nowarn_by_type); if (!nowarn_by_type) result = FALSE; else result = GPOINTER_TO_INT (g_hash_table_lookup (nowarn_by_type, (gpointer) gtype)); G_UNLOCK (nowarn_by_type); return result; } =item const char * gperl_object_package_from_type (GType gtype) Get the package corresponding to I. If I is not a GObject or GInterface, returns NULL. If I is not registered to a package name, a new name of the form C will be created, used to register the class, and then returned. =cut const char * gperl_object_package_from_type (GType gtype) { ClassInfo * class_info; if (!g_type_is_a (gtype, G_TYPE_OBJECT) && !g_type_is_a (gtype, G_TYPE_INTERFACE)) return NULL; if (!types_by_type) croak ("internal problem: gperl_object_package_from_type " "called before any classes were registered"); G_LOCK (types_by_type); class_info = (ClassInfo *) g_hash_table_lookup (types_by_type, (gpointer) gtype); G_UNLOCK (types_by_type); if (!class_info) { /* * Walk up the ancestry to see if we're the child of a type * whose children are private. In the old days, we called * this "no-warn", to suppress warnings about unregistered * types (e.g. Styles, GCs, etc). Now we'll use it to * map "private" GTypes to known parent classes. */ GType parent = gtype; while (0 != (parent = g_type_parent (parent))) { if (gperl_object_get_no_warn_unreg_subclass (parent)) { /* Use this class's ClassInfo instead. */ class_info = (ClassInfo *) g_hash_table_lookup (types_by_type, (gpointer) parent); break; } } } if (!class_info) { gchar * package; package = g_strconcat ("Glib::Object::_Unregistered::", g_type_name (gtype), NULL); /* XXX find a way to do this without locking twice */ gperl_register_object (gtype, package); g_free (package); G_LOCK (types_by_type); class_info = (ClassInfo*) g_hash_table_lookup (types_by_type, (gpointer) gtype); G_UNLOCK (types_by_type); } g_assert (class_info); if (!class_info->initialized) { /* do a proper @ISA setup for this guy. */ class_info_finish_loading (class_info); } return class_info->package; } =item HV * gperl_object_stash_from_type (GType gtype) Get the stash corresponding to I; returns NULL if I is not registered. The stash is useful for Cing. =cut HV * gperl_object_stash_from_type (GType gtype) { const char * package = gperl_object_package_from_type (gtype); if (package) return gv_stashpv (package, TRUE); else return NULL; } =item GType gperl_object_type_from_package (const char * package) Inverse of gperl_object_package_from_type(), returns 0 if I is not registered. =cut GType gperl_object_type_from_package (const char * package) { if (types_by_package) { ClassInfo * class_info; G_LOCK (types_by_package); class_info = (ClassInfo *) g_hash_table_lookup (types_by_package, package); G_UNLOCK (types_by_package); if (class_info) { /* class_info_finish_loading calls us, so even if * !class_info->initialized, we should not call it to * avoid recursion. */ return class_info->gtype; } else { return 0; } } else croak ("internal problem: gperl_object_type_from_package " "called before any classes were registered"); return 0; /* not reached */ } /* * Manipulate a pointer to indicate that an SV is undead. * Relies on SV pointers being word-aligned. */ #define IS_UNDEAD(x) (PTR2UV(x) & 1) #define MAKE_UNDEAD(x) INT2PTR(void*, PTR2UV(x) | 1) #define REVIVE_UNDEAD(x) INT2PTR(void*, PTR2UV(x) & ~1) /* * this function is called whenever the gobject gets destroyed. this only * happens if the perl object is no longer referenced anywhere else, so * put it to final rest here. */ static void gobject_destroy_wrapper (SV *obj) { GPERL_SET_CONTEXT; /* As of perl 5.16, this function needs to run even during global * destruction (i.e. when PL_in_clean_objs is true) since we might * otherwise end up with undead HVs hanging on to garbage. Prior to * 5.16, this did not matter, but recent versions of perl will find * these HVs and call DESTROY on them. */ #ifdef NOISY warn ("gobject_destroy_wrapper (%p)[%d]\n", obj, SvREFCNT ((SV*)REVIVE_UNDEAD(obj))); #endif obj = REVIVE_UNDEAD(obj); _gperl_remove_mg (obj); /* we might want to optimize away the call to DESTROY here for non-perl classes. */ SvREFCNT_dec (obj); } static void update_wrapper (GObject *object, gpointer obj) { /* printf("update_wrapper [%p] (%p)\n", object, obj); */ g_object_steal_qdata (object, wrapper_quark); g_object_set_qdata_full (object, wrapper_quark, obj, (GDestroyNotify)gobject_destroy_wrapper); } =item SV * gperl_new_object (GObject * object, gboolean own) Use this function to get the perl part of a GObject. If I has never been seen by perl before, a new, empty perl object will be created and added to a private key under I's qdata. If I already has a perl part, a new reference to it will be created. The gobject + perl object together form a combined object that is properly refcounted, i.e. both parts will stay alive as long as at least one of them is alive, and only when both perl object and gobject are no longer referenced will both be freed. The perl object will be blessed into the package corresponding to the GType returned by calling G_OBJECT_TYPE() on I; if that class has not been registered via gperl_register_object(), this function will emit a warning to that effect (with warn()), and attempt to bless it into the first known class in the object's ancestry. Since Glib::Object is already registered, you'll get a Glib::Object if you are lazy, and thus this function can fail only if I isn't descended from GObject, in which case it croaks. (In reality, if you pass a non-GObject to this function, you'll be lucky if you don't get a segfault, as there's not really a way to trap that.) In practice these warnings can be unavoidable, so you can use gperl_object_set_no_warn_unreg_subclass() to quell them on a class-by-class basis. However, when perl code is calling a GObject constructor (any function which returns a new GObject), call gperl_new_object() with I set to %TRUE; this will cause the first matching sink function to be called on the GObject to claim ownership of that object, so that it will be destroyed when the perl object goes out of scope. The default sink func is g_object_unref(); other types should supply the proper function; e.g., GtkObject should use gtk_object_sink() here. Returns the blessed perl object, or #&PL_sv_undef if object was #NULL. =cut SV * gperl_new_object (GObject * object, gboolean own) { SV *obj; SV *sv; /* take the easy way out if we can */ if (!object) { #ifdef NOISY warn ("gperl_new_object (NULL) => undef\n"); #endif return &PL_sv_undef; } if (!G_IS_OBJECT (object)) croak ("object %p is not really a GObject", object); /* fetch existing wrapper_data */ obj = (SV *)g_object_get_qdata (object, wrapper_quark); if (!obj) { /* create the perl object */ GType gtype = G_OBJECT_TYPE (object); HV *stash = gperl_object_stash_from_type (gtype); /* We should only get NULL for the stash here if gtype is * neither a GObject nor GInterface. We filtered out all * non-GObject types a few lines back. */ g_assert (stash != NULL); /* * Create the "object", a hash. * * This does not need to be a HV, the only problem is finding * out what to use, and HV is certainly the way to go for any * built-in objects. */ /* this increases the combined object's refcount. */ obj = (SV *)newHV (); /* attach magic */ _gperl_attach_mg (obj, object); /* The SV has a ref to the C object. If we are to own this * object, then any other references will be taken care of * below in take_ownership */ g_object_ref (object); /* create the wrapper to return, the _noinc decreases the * combined refcount by one. */ sv = newRV_noinc (obj); /* bless into the package */ sv_bless (sv, stash); /* attach it to the gobject */ update_wrapper (object, obj); /* printf("creating new wrapper for [%p] (%p)\n", object, obj); */ /* the noinc is so that the SV (initially) exists only as long * as the perl code needs it. When the DESTROY gets called, we * check and see if the SV is the only referer to the C object, * and if so remove both. Otherwise, the SV will become * "undead," to be either revived or destroyed with the C * object */ #ifdef NOISY warn ("gperl_new_object%d %s(%p)[%d] => %s (%p) (NEW)\n", own, G_OBJECT_TYPE_NAME (object), object, object->ref_count, gperl_object_package_from_type (G_OBJECT_TYPE (object)), SvRV (sv)); #endif } else { /* create the wrapper to return, increases the combined * refcount by one. */ /* if the SV is undead, revive it */ if (IS_UNDEAD(obj)) { g_object_ref (object); obj = REVIVE_UNDEAD(obj); update_wrapper (object, obj); sv = newRV_noinc (obj); /* printf("reviving undead wrapper for [%p] (%p)\n", object, obj); */ } else { /* printf("reusing previous wrapper for %p\n", obj); */ sv = newRV_inc (obj); } } #ifdef NOISY warn ("gperl_new_object%d %s(%p)[%d] => %s (%p)[%d] (PRE-OWN)\n", own, G_OBJECT_TYPE_NAME (object), object, object->ref_count, gperl_object_package_from_type (G_OBJECT_TYPE (object)), SvRV (sv), SvREFCNT (SvRV (sv))); #endif if (own) gperl_object_take_ownership (object); #if GPERL_THREAD_SAFE if(perl_gobject_tracking) { G_LOCK (perl_gobjects); /*g_printerr ("adding object: 0x%p - %d\n", object, object->ref_count);*/ if (!perl_gobjects) perl_gobjects = g_hash_table_new (g_direct_hash, g_direct_equal); g_hash_table_insert (perl_gobjects, (gpointer)object, (gpointer)1); G_UNLOCK (perl_gobjects); } #endif return sv; } =item GObject * gperl_get_object (SV * sv) retrieve the GObject pointer from a Perl object. Returns NULL if I is not linked to a GObject. Note, this one is not safe -- in general you want to use gperl_get_object_check(). =cut GObject * gperl_get_object (SV * sv) { MAGIC *mg; if (!gperl_sv_is_ref (sv) || !(mg = _gperl_find_mg (SvRV (sv)))) return NULL; return (GObject *) mg->mg_ptr; } =item GObject * gperl_get_object_check (SV * sv, GType gtype); croaks if I is undef or is not blessed into the package corresponding to I. use this for bringing parameters into xsubs from perl. Returns the same as gperl_get_object() (provided it doesn't croak first). =cut GObject * gperl_get_object_check (SV * sv, GType gtype) { MAGIC *mg; const char * package; package = gperl_object_package_from_type (gtype); if (!package) croak ("INTERNAL: GType %s (%d) is not registered with GPerl!", g_type_name (gtype), gtype); if (!gperl_sv_is_ref (sv) || !sv_derived_from (sv, package)) croak ("%s is not of type %s", gperl_format_variable_for_output (sv), package); if (!(mg = _gperl_find_mg (SvRV (sv)))) croak ("%s is not a proper Glib::Object " "(it doesn't contain the right magic)", gperl_format_variable_for_output (sv)); return (GObject *) mg->mg_ptr; } =item SV * gperl_object_check_type (SV * sv, GType gtype) Essentially the same as gperl_get_object_check(). This croaks if the types aren't compatible. =cut SV * gperl_object_check_type (SV * sv, GType gtype) { gperl_get_object_check (sv, gtype); return sv; } /* helper for g_object_[gs]et_parameter */ static void init_property_value (GObject * object, const char * name, GValue * value) { GParamSpec * pspec; pspec = g_object_class_find_property (G_OBJECT_GET_CLASS (object), name); if (!pspec) { const char * classname = gperl_object_package_from_type (G_OBJECT_TYPE (object)); if (!classname) classname = G_OBJECT_TYPE_NAME (object); croak ("type %s does not support property '%s'", classname, name); } g_value_init (value, G_PARAM_SPEC_VALUE_TYPE (pspec)); } =item typedef GObject GObject_noinc =item typedef GObject GObject_ornull =item newSVGObject(obj) =item newSVGObject_noinc(obj) =item SvGObject(sv) =item SvGObject_ornull(sv) =back =cut /* * $sv = $object->{name} * * if the key doesn't exist with name, convert - to _ and try again. * that is, support both "funny-name" and "funny_name". * * if create is true, autovivify the key (and always return a value). * if create is false, returns NULL is there is no such key. */ SV * _gperl_fetch_wrapper_key (GObject * object, const char * name, gboolean create) { SV ** svp; SV * svname; HV * wrapper_hash; wrapper_hash = g_object_get_qdata (object, wrapper_quark); /* we don't care whether the wrapper is alive or undead. forcibly * remove the undead bit, or the pointer will be unusable. */ wrapper_hash = REVIVE_UNDEAD (wrapper_hash); svname = newSVpv (name, strlen (name)); svp = hv_fetch (wrapper_hash, SvPV_nolen (svname), SvCUR (svname), FALSE); /* never create on the first try; prefer * prefer to create the second version. */ if (!svp) { /* the key doesn't exist with that name. do s/-/_/g and * try again. */ register char * c; for (c = SvPV_nolen (svname); c <= SvEND (svname) ; c++) if (*c == '-') *c = '_'; svp = hv_fetch (wrapper_hash, SvPV_nolen (svname), SvCUR (svname), create); } SvREFCNT_dec (svname); return (svp ? *svp : NULL); } #if GPERL_THREAD_SAFE static void _inc_ref_and_count (GObject * key, gint value, gpointer user_data) { PERL_UNUSED_VAR (user_data); g_object_ref (key); value += 1; g_hash_table_replace (perl_gobjects, key, GINT_TO_POINTER (value)); } #endif MODULE = Glib::Object PACKAGE = Glib::Object PREFIX = g_object_ #if GPERL_THREAD_SAFE =for apidoc __hide__ Users shouldn't know this exists. This is part of the machinery to support object tracking in a threaded environment. When perl spawns a new interpreter thread, it invokes CLONE on all packages -- NOT on objects. This is our only hook into that process. =cut void CLONE (gchar * class) CODE: /* !perl_gobjects can happen when no object has been created yet. */ if (perl_gobject_tracking && perl_gobjects && strcmp (class, "Glib::Object") == 0) { G_LOCK (perl_gobjects); /*g_printerr ("we're in clone: %s\n", class);*/ g_hash_table_foreach (perl_gobjects, (GHFunc)_inc_ref_and_count, NULL); G_UNLOCK (perl_gobjects); } #endif =for apidoc set_threadsafe Enables/disables threadsafe gobject tracking. Returns whether or not tracking will be successful and thus whether using perl ithreads will be possible. =cut gboolean set_threadsafe (class, gboolean threadsafe) CODE: #if GPERL_THREAD_SAFE RETVAL = perl_gobject_tracking = threadsafe; #else PERL_UNUSED_VAR (threadsafe); RETVAL = FALSE; #endif OUTPUT: RETVAL =for object Glib::Object Bindings for GObject =cut =for position DESCRIPTION =head1 DESCRIPTION GObject is the base object class provided by the gobject library. It provides object properties with a notification system, and emittable signals. Glib::Object is the corresponding Perl object class. Glib::Objects are represented by blessed hash references, with a magical connection to the underlying C object. =head2 get and set Some subclasses of C override C and C with methods more useful to the subclass, for example C getting and setting row contents. This is usually done when the subclass has no object properties. Any object properties it or a further subclass does have can always be accessed with C and C (together with C and C to enquire about them). Generic code for any object subclass can use the names C and C to be sure of getting the object properties as such. =cut BOOT: gperl_register_object (G_TYPE_INTERFACE, "Glib::Interface"); gperl_register_object (G_TYPE_OBJECT, "Glib::Object"); #if GLIB_CHECK_VERSION (2, 10, 0) gperl_register_object (G_TYPE_INITIALLY_UNOWNED, "Glib::InitiallyUnowned"); gperl_register_sink_func (G_TYPE_INITIALLY_UNOWNED, sink_initially_unowned); #endif wrapper_quark = g_quark_from_static_string ("Perl-wrapper-object"); void DESTROY (SV *sv) PREINIT: GObject *object; gboolean was_undead; CODE: object = gperl_get_object (sv); if (!object) /* Happens on GObject destruction. */ return; #ifdef NOISY warn ("DESTROY< (%p)[%d] => %s (%p)[%d]\n", object, object->ref_count, gperl_object_package_from_type (G_OBJECT_TYPE (object)), sv, SvREFCNT (SvRV(sv))); #endif was_undead = IS_UNDEAD (g_object_get_qdata (object, wrapper_quark)); /* gobject object still exists, so take back the refcount we lend it. */ /* this operation does NOT change the refcount of the combined object. */ if (PL_in_clean_objs) { /* be careful during global destruction. basically, * don't bother, since refcounting is no longer meaningful. */ _gperl_remove_mg (SvRV (sv)); g_object_steal_qdata (object, wrapper_quark); } else { SvREFCNT_inc (SvRV (sv)); if (object->ref_count > 1) { /* become undead */ SV *obj = SvRV(sv); update_wrapper (object, MAKE_UNDEAD(obj)); /* printf("zombies! [%p] (%p)\n", object, obj);*/ } } #if GPERL_THREAD_SAFE if(perl_gobject_tracking) { gint count; G_LOCK (perl_gobjects); count = GPOINTER_TO_INT (g_hash_table_lookup (perl_gobjects, object)); count--; if (count > 0) { /*g_printerr ("decing: %p - %d\n", object, count);*/ g_hash_table_replace (perl_gobjects, object, GINT_TO_POINTER (count)); } else { /*g_printerr ("removing: %p\n", object);*/ g_hash_table_remove (perl_gobjects, object); } G_UNLOCK (perl_gobjects); } #endif /* As of perl 5.16, even HVs that are not referenced by any SV will get * their DESTROY called during global destruction. Such HVs can occur * when the GObject outlives the HV, as for GtkWindow or GdkScreen. * Here in DESTROY such an HV will be in the "undead" state and will * not own a reference to the GObject anymore. Thus we need to avoid * calling unref in this case. See * for the * perl change. */ if (!was_undead) { g_object_unref (object); } #ifdef NOISY warn ("DESTROY> (%p) done\n", object); /* warn ("DESTROY> (%p)[%d] => %s (%p)[%d]", object, object->ref_count, gperl_object_package_from_type (G_OBJECT_TYPE (object)), sv, SvREFCNT (SvRV(sv))); */ #endif =for apidoc =for signature object = $class->new (...) =for arg ... key/value pairs, property values to set on creation Instantiate a Glib::Object of type I<$class>. Any key/value pairs in I<...> are used to set properties on the new object; see C. This is designed to be inherited by Perl-derived subclasses (see L), but you can actually use it to create any GObject-derived type. =cut SV * g_object_new (class, ...) const char *class PREINIT: int n_params = 0; GParameter * params = NULL; GType object_type; GObject * object; GObjectClass *oclass = NULL; CODE: #define FIRST_ARG 1 object_type = gperl_object_type_from_package (class); if (!object_type) croak ("%s is not registered with gperl as an object type", class); if (G_TYPE_IS_ABSTRACT (object_type)) croak ("cannot create instance of abstract (non-instantiatable)" " type `%s'", g_type_name (object_type)); if (0 != ((items - 1) % 2)) croak ("new method expects name => value pairs " "(odd number of arguments detected)"); if (items > FIRST_ARG) { int i; if (NULL == (oclass = g_type_class_ref (object_type))) croak ("could not get a reference to type class"); n_params = (items - FIRST_ARG) / 2; params = g_new0 (GParameter, n_params); for (i = 0 ; i < n_params ; i++) { const char * key = SvPV_nolen (ST (FIRST_ARG+i*2+0)); GParamSpec * pspec; pspec = g_object_class_find_property (oclass, key); if (!pspec) { /* clean up... */ int j; for (j = 0 ; j < i ; j++) g_value_unset (¶ms[j].value); g_free (params); /* and bail out. */ croak ("type %s does not support property '%s'", class, key); } g_value_init (¶ms[i].value, G_PARAM_SPEC_VALUE_TYPE (pspec)); /* note: this croaks if there is a problem. this is * usually the right thing to do, because if it * doesn't know how to convert the value, then there's * something seriously wrong; however, it means that * if there is a problem, all non-trivial values we've * converted will be leaked. */ gperl_value_from_sv (¶ms[i].value, ST (FIRST_ARG+i*2+1)); params[i].name = key; /* will be valid until this * xsub is finished */ } } #undef FIRST_ARG object = g_object_newv (object_type, n_params, params); /* this wrapper *must* own this object! * because we've been through initialization, the perl object * will already exist at this point --- but this still causes * gperl_object_take_ownership to be called. */ RETVAL = gperl_new_object (object, TRUE); if (n_params) { int i; for (i = 0 ; i < n_params ; i++) g_value_unset (¶ms[i].value); g_free (params); } if (oclass) g_type_class_unref (oclass); OUTPUT: RETVAL =for apidoc Glib::Object::get =for arg ... (list) list of property names Alias for C (see L above). =cut =for apidoc Glib::Object::get_property =for arg ... (__hide__) Fetch and return the values for the object properties named in I<...>. =cut void g_object_get (object, ...) GObject * object ALIAS: Glib::Object::get = 0 Glib::Object::get_property = 1 PREINIT: GValue value = {0,}; int i; CODE: /* Use CODE: instead of PPCODE: so we can handle the stack ourselves in * order to avoid that xsubs called by g_object_get_property or * _gperl_sv_from_value_internal overwrite what we put on the stack. */ PERL_UNUSED_VAR (ix); for (i = 1; i < items; i++) { char *name = SvPV_nolen (ST (i)); init_property_value (object, name, &value); g_object_get_property (object, name, &value); ST (i - 1) = sv_2mortal ( _gperl_sv_from_value_internal (&value, TRUE)); g_value_unset (&value); } XSRETURN (items - 1); =for apidoc Glib::Object::set =for signature $object->set (key => $value, ...) =for arg ... key/value pairs Alias for C (see L above). =cut =for apidoc Glib::Object::set_property =for signature $object->set_property (key => $value, ...) =for arg ... (__hide__) Set object properties. =cut void g_object_set (object, ...) GObject * object ALIAS: Glib::Object::set = 0 Glib::Object::set_property = 1 PREINIT: GValue value = {0,}; int i; CODE: PERL_UNUSED_VAR (ix); if (0 != ((items - 1) % 2)) croak ("set method expects name => value pairs " "(odd number of arguments detected)"); for (i = 1; i < items; i += 2) { char *name = SvPV_nolen (ST (i)); SV *newval = ST (i + 1); init_property_value (object, name, &value); gperl_value_from_sv (&value, newval); g_object_set_property (object, name, &value); g_value_unset (&value); } =for apidoc Emits a "notify" signal for the property I<$property> on I<$object>. =cut void g_object_notify (GObject * object, const gchar * property_name) =for apidoc Stops emission of "notify" signals on I<$object>. The signals are queued until C is called on I<$object>. =cut void g_object_freeze_notify (GObject * object) =for apidoc Reverts the effect of a previous call to C. This causes all queued "notify" signals on I<$object> to be emitted. =cut void g_object_thaw_notify (GObject * object) =for apidoc Glib::Object::list_properties =for signature list = $object_or_class_name->list_properties =for arg ... (__hide__) List all the object properties for I<$object_or_class_name>; returns them as a list of hashes, containing these keys: =over =item name The name of the property =item type The type of the property =item owner_type The type that owns the property =item descr The description of the property =item flags The Glib::ParamFlags of the property =back =cut =for apidoc Glib::Object::find_property =for signature pspec or undef = $object_or_class_name->find_property ($name) =for arg name (string) =for arg ... (__hide__) Find the definition of object property I<$name> for I<$object_or_class_name>. Return C if no such property. For the returned data see L. =cut void g_object_find_property (object_or_class_name, ...) SV * object_or_class_name ALIAS: Glib::Object::list_properties = 1 PREINIT: GType type = G_TYPE_INVALID; gchar *name = NULL; PPCODE: if (gperl_sv_is_ref (object_or_class_name)) { GObject * object = SvGObject (object_or_class_name); if (!object) croak ("wha? NULL object in list_properties"); type = G_OBJECT_TYPE (object); } else { type = gperl_object_type_from_package (SvPV_nolen (object_or_class_name)); if (!type) croak ("package %s is not registered with GPerl", SvPV_nolen (object_or_class_name)); } if (ix == 0 && items == 2) { name = SvGChar (ST (1)); #ifdef NOISY warn ("Glib::Object::find_property ('%s', '%s')\n", g_type_name (type), name); #endif } else if (ix == 0 && items != 2) croak ("Usage: Glib::Object::find_property (class, name)"); else if (ix == 1 && items != 1) croak ("Usage: Glib::Object::list_properties (class)"); if (G_TYPE_IS_OBJECT (type)) { /* classes registered by perl are kept alive by the bindings. * those coming straight from C are not. if we had an actual * object, the class will be alive, but if we just had a * package, the class may not exist yet. thus, we'll have to * do an honest ref here, rather than a peek. */ GObjectClass *object_class = g_type_class_ref (type); if (ix == 0) { GParamSpec *pspec; pspec = g_object_class_find_property (object_class, name); if (pspec) XPUSHs (sv_2mortal (newSVGParamSpec (pspec))); else XPUSHs (newSVsv (&PL_sv_undef)); } else if (ix == 1) { GParamSpec **props; guint n_props, i; props = g_object_class_list_properties (object_class, &n_props); #ifdef NOISY warn ("list_properties: %d properties\n", n_props); #endif if (n_props) { EXTEND (SP, n_props); for (i = 0; i < n_props; i++) PUSHs (sv_2mortal (newSVGParamSpec (props[i]))); } g_free (props); /* must free even when n_props==0 */ } g_type_class_unref (object_class); } #if GLIB_CHECK_VERSION(2,4,0) else if (G_TYPE_IS_INTERFACE (type)) { gpointer iface = g_type_default_interface_ref (type); if (ix == 0) { GParamSpec *pspec; pspec = g_object_interface_find_property (iface, name); if (pspec) XPUSHs (sv_2mortal (newSVGParamSpec (pspec))); else XPUSHs (newSVsv (&PL_sv_undef)); } else if (ix == 1) { GParamSpec **props; guint n_props, i; props = g_object_interface_list_properties (iface, &n_props); #ifdef NOISY warn ("list_properties: %d properties\n", n_props); #endif if (n_props) { EXTEND (SP, n_props); for (i = 0; i < n_props; i++) PUSHs (sv_2mortal (newSVGParamSpec (props[i]))); } g_free (props); /* must free even when n_props==0 */ } g_type_default_interface_unref (iface); } #endif else { XSRETURN_EMPTY; } =for apidoc GObject provides an arbitrary data mechanism that assigns unsigned integers to key names. Functionality overlaps with the hash used as the Perl object instance, so we strongly recommend you use hash keys for your data storage. The GObject data values cannot store type information, so they are not safe to use for anything but integer values, and you really should use this method only if you know what you are doing. =cut void g_object_set_data (object, key, data) GObject * object gchar * key SV * data CODE: if (SvROK (data) || !SvIOK (data)) croak ("set_data only sets unsigned integers, use" " a key in the object hash for anything else"); g_object_set_data (object, key, INT2PTR (gpointer, SvUV (data))); =for apidoc Fetch the integer stored under the object data key I<$key>. These values do not have types; type conversions must be done manually. See C. =cut UV g_object_get_data (object, key) GObject * object gchar * key CODE: RETVAL = PTR2UV (g_object_get_data (object, key)); OUTPUT: RETVAL ### ### rudimentary support for foreign objects. ### =for apidoc Glib::Object::new_from_pointer =for arg pointer (unsigned) a C pointer value as an integer. =for arg noinc (boolean) if true, do not increase the GObject's reference count when creating the Perl wrapper. this typically means that when the Perl wrapper will own the object. in general you don't want to do that, so the default is false. Create a Perl Glib::Object reference for the C object pointed to by I<$pointer>. You should need this I rarely; it's intended to support foreign objects. NOTE: the cast from arbitrary integer to GObject may result in a core dump without warning, because the type-checking macro G_OBJECT() attempts to dereference the pointer to find a GTypeClass structure, and there is no portable way to validate the pointer. =cut SV * new_from_pointer (class, pointer, noinc=FALSE) gpointer pointer gboolean noinc CODE: RETVAL = gperl_new_object (G_OBJECT (pointer), noinc); OUTPUT: RETVAL =for apidoc Complement of C. =cut gpointer get_pointer (object) GObject * object CODE: RETVAL = object; OUTPUT: RETVAL #if 0 =for apidoc =for arg all if FALSE (or omitted) tie only properties for this object's class, if TRUE tie the properties of this and all parent classes. A special method available to Glib::Object derivatives, it uses perl's tie facilities to associate hash keys with the properties of the object. For example: $button->tie_properties; # equivilent to $button->set (label => 'Hello World'); $button->{label} = 'Hello World'; print "the label is: ".$button->{label}."\n"; Attempts to write to read-only properties will croak, reading a write-only property will return '[write-only]'. Care must be taken when using tie_properties with objects of types created with Glib::Object::Subclass as there may be clashes with existing hash keys that could cause infinite loops. The solution is to use custom property get/set functions to alter the storage locations of the properties. =cut void tie_properties (GObject * object, gboolean all=FALSE) #endif MODULE = Glib::Object PACKAGE = Glib::Object::_LazyLoader =for apidoc __hide__ =cut void _load (const char * package) PREINIT: ClassInfo * class_info; CODE: #ifdef NOISY warn ("_load (%s)\n", package); #endif G_LOCK (types_by_package); class_info = (ClassInfo*) g_hash_table_lookup (types_by_package, package); G_UNLOCK (types_by_package); /* This can happen when we get called on a package that is not * registered with the type system but is instead manually set up to * inherit from a package that is registered with the type system. For * example: * * Glib::Object::_LazyLoader * +----Gtk2::Gdk::Pixmap * +----Gtk2::Gdk::Bitmap * * When someone tries to call a method on Gtk2::Gdk::Bitmap before * Gtk2::Gdk::Pixmap has been set up, we get in here and class_info == * NULL. * * So we walk the package's @ISA and look for a package that is * registered. This is supposed to succeed -- how did we get in here * at all if there is no registered package in the ancestry? */ if (!class_info) class_info = find_registered_type_in_ancestry (package); if (!class_info) croak ("asked to lazy-load %s, but that package is not " "registered and has no registered packages in its " "ancestry", package); class_info_finish_loading (class_info); Glib-1.320/GOption.xs000644 001750 000024 00000053020 12251766676 015444 0ustar00bdmanningstaff000000 000000 /* * Copyright (c) 2005-2009, 2013 by the gtk2-perl team (see the file AUTHORS) * * Licensed under the LGPL, see LICENSE file for more information. * * $Id$ */ #include "gperl.h" #include "gperl-gtypes.h" /* ------------------------------------------------------------------------- */ /* This hash table is used to store option groups that have been handed to * GOptionContext. */ static GHashTable *transferred_groups = NULL; static GOptionGroup * gperl_option_group_transfer (GOptionGroup *group) { if (!transferred_groups) transferred_groups = g_hash_table_new (g_direct_hash, g_direct_equal); g_hash_table_insert (transferred_groups, group, group); return group; } /* ------------------------------------------------------------------------- */ /* Define custom types for GOptionContext, GOptionGroup, GOptionFlags, and * GOptionArg since glib doesn't provide them. */ static gpointer no_copy_for_you (gpointer boxed) { croak ("copying Glib::OptionContext and Glib::OptionGroup isn't supported"); return boxed; } /* glib assumes ownership of option groups it gets, and there's no copy * function. So we need a custom free function here that checks if the group * was transferred to glib already before freeing it. */ static void gperl_option_group_free (GOptionGroup *group) { if (!g_hash_table_lookup (transferred_groups, group)) g_option_group_free (group); } GType gperl_option_context_get_type (void) { static GType t = 0; if (!t) t = g_boxed_type_register_static ("GOptionContext", (GBoxedCopyFunc) no_copy_for_you, (GBoxedFreeFunc) g_option_context_free); return t; } GType gperl_option_group_get_type (void) { static GType t = 0; if (!t) t = g_boxed_type_register_static ("GOptionGroup", (GBoxedCopyFunc) no_copy_for_you, (GBoxedFreeFunc) gperl_option_group_free); return t; } /* ------------------------------------------------------------------------- */ #if 0 static SV * newSVGOptionFlags (GOptionFlags flags) { return gperl_convert_back_flags (GPERL_TYPE_OPTION_FLAGS, flags); } #endif static GOptionFlags SvGOptionFlags (SV *sv) { return gperl_convert_flags (GPERL_TYPE_OPTION_FLAGS, sv); } /* ------------------------------------------------------------------------- */ #if 0 static SV * newSVGOptionArg (GOptionArg arg) { return gperl_convert_back_enum (GPERL_TYPE_OPTION_ARG, arg); } #endif static GOptionArg SvGOptionArg (SV *sv) { return gperl_convert_enum (GPERL_TYPE_OPTION_ARG, sv); } /* ------------------------------------------------------------------------- */ typedef struct { GOptionArg arg; gpointer arg_data; } GPerlArgInfo; static GPerlArgInfo * gperl_arg_info_new (GOptionArg arg, gpointer arg_data) { GPerlArgInfo *info = g_new0 (GPerlArgInfo, 1); info->arg = arg; info->arg_data = arg_data; return info; } static void gperl_arg_info_destroy (GPerlArgInfo *info) { g_free (info->arg_data); /* NULL-safe */ g_free (info); } typedef struct { GHashTable *scalar_to_info; GSList *allocated_strings; } GPerlArgInfoTable; static GPerlArgInfoTable * gperl_arg_info_table_new (void) { GPerlArgInfoTable *table = g_new0 (GPerlArgInfoTable, 1); table->scalar_to_info = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify) gperl_arg_info_destroy); table->allocated_strings = NULL; return table; } static void gperl_arg_info_table_destroy (GPerlArgInfoTable *table) { g_hash_table_destroy (table->scalar_to_info); /* These are NULL-safe. */ g_slist_foreach (table->allocated_strings, (GFunc) g_free, NULL); g_slist_free (table->allocated_strings); g_free (table); } /* ------------------------------------------------------------------------- */ #define INSTALL_POINTER(type) \ { \ type *pointer = g_new0 (type, 1); \ g_hash_table_insert (scalar_to_info, \ ref, \ gperl_arg_info_new (entry->arg, pointer)); \ entry->arg_data = pointer; \ } static void handle_arg_data (GOptionEntry *entry, SV *ref, GHashTable *scalar_to_info) { if (!gperl_sv_is_ref (ref)) croak ("encountered non-reference variable for the arg_value " "field"); switch (entry->arg) { case G_OPTION_ARG_NONE: INSTALL_POINTER (gboolean); break; case G_OPTION_ARG_STRING: case G_OPTION_ARG_FILENAME: INSTALL_POINTER (gchar *); break; case G_OPTION_ARG_INT: INSTALL_POINTER (gint); break; case G_OPTION_ARG_CALLBACK: croak ("unhandled arg type G_OPTION_ARG_CALLBACK encountered"); break; case G_OPTION_ARG_STRING_ARRAY: case G_OPTION_ARG_FILENAME_ARRAY: INSTALL_POINTER (gchar **); break; #if GLIB_CHECK_VERSION (2, 12, 0) case G_OPTION_ARG_DOUBLE: INSTALL_POINTER (gdouble); break; case G_OPTION_ARG_INT64: INSTALL_POINTER (gint64); break; #endif } } static gchar * copy_string (gchar *src, GPerlArgInfoTable *table) { gchar *result; if (!src) return NULL; result = g_strdup (src); table->allocated_strings = g_slist_prepend (table->allocated_strings, result); return result; } static GOptionEntry * sv_to_option_entry (SV *sv, GPerlArgInfoTable *table) { SV *long_name = NULL, *short_name = NULL, *flags = NULL, *description = NULL, *arg_description = NULL, *arg_type = NULL, *arg_value = NULL; GOptionEntry *entry; if (!gperl_sv_is_hash_ref (sv) && !gperl_sv_is_array_ref (sv)) croak ("an option entry must be either a hash or an array " "reference"); if (gperl_sv_is_hash_ref (sv)) { HV *hv = (HV *) SvRV (sv); SV **value; value = hv_fetch (hv, "long_name", 9, 0); if (value) long_name = *value; value = hv_fetch (hv, "short_name", 10, 0); if (value) short_name = *value; value = hv_fetch (hv, "flags", 5, 0); if (value) flags = *value; value = hv_fetch (hv, "description", 11, 0); if (value) description = *value; value = hv_fetch (hv, "arg_description", 15, 0); if (value) arg_description = *value; value = hv_fetch (hv, "arg_type", 8, 0); if (value) arg_type = *value; value = hv_fetch (hv, "arg_value", 9, 0); if (value) arg_value = *value; } else { AV *av = (AV *) SvRV (sv); SV **value; if (4 != av_len (av) + 1) croak ("an option entry array reference must contain " "four values: long_name, short_name, arg_type, " "and arg_value"); value = av_fetch (av, 0, 0); if (value) long_name = *value; value = av_fetch (av, 1, 0); if (value) short_name = *value; value = av_fetch (av, 2, 0); if (value) arg_type = *value; value = av_fetch (av, 3, 0); if (value) arg_value = *value; } if (!gperl_sv_is_defined (long_name) || !gperl_sv_is_defined (arg_type) || !gperl_sv_is_defined (arg_value)) croak ("in an option entry, the fields long_name, arg_type, and " "arg_value must be specified"); entry = gperl_alloc_temp (sizeof (GOptionEntry)); entry->long_name = copy_string (SvGChar (long_name), table); entry->arg = SvGOptionArg (arg_type); entry->arg_data = NULL; handle_arg_data (entry, arg_value, table->scalar_to_info); entry->short_name = gperl_sv_is_defined (short_name) ? (SvGChar (short_name))[0] : 0; entry->flags = gperl_sv_is_defined (flags) ? SvGOptionFlags (flags) : 0; entry->description = gperl_sv_is_defined (description) ? copy_string (SvGChar (description), table) : NULL; entry->arg_description = gperl_sv_is_defined (arg_description) ? copy_string (SvGChar (arg_description), table) : NULL; return entry; } static GOptionEntry * sv_to_option_entries (SV *sv, GPerlArgInfoTable *table) { GOptionEntry *entries; AV *av; int length, i; SV **value; if (!gperl_sv_is_array_ref (sv)) croak ("option entries must be an array reference containing hash references"); av = (AV *) SvRV (sv); length = av_len (av) + 1; /* Allocating length + 1 entries here because the list is supposed to * be NULL-terminated. */ entries = gperl_alloc_temp (sizeof (GOptionEntry) * (length + 1)); for (i = 0; i < length; i++) { value = av_fetch (av, i, 0); if (value && gperl_sv_is_defined (*value)) entries[i] = *(sv_to_option_entry (*value, table)); } return entries; } /* ------------------------------------------------------------------------- */ static gchar ** strings_from_sv (SV *sv) { AV *av; gint n_strings, i; gchar **result; if (!gperl_sv_is_array_ref (sv)) return NULL; av = (AV *) SvRV (sv); n_strings = av_len (av) + 1; if (n_strings <= 0) return NULL; /* NULL-terminated */ result = gperl_alloc_temp (sizeof (gchar *) * (n_strings + 1)); for (i = 0; i < n_strings; i++) { SV **string_sv = av_fetch (av, i, 0); result[i] = string_sv ? SvGChar (*string_sv) : NULL; } return result; } static gchar ** filenames_from_sv (SV *sv) { AV *av; gint n_filenames, i; gchar **result; if (!gperl_sv_is_array_ref (sv)) return NULL; av = (AV *) SvRV (sv); n_filenames = av_len (av) + 1; if (n_filenames <= 0) return NULL; /* NULL-terminated */ result = gperl_alloc_temp (sizeof (gchar *) * (n_filenames + 1)); for (i = 0; i < n_filenames; i++) { SV **string_sv = av_fetch (av, i, 0); result[i] = string_sv ? SvPV_nolen (*string_sv) : NULL; } return result; } #define INITIALIZE_POINTER(type, converter) \ { \ SV *sv = SvRV (ref); \ if (gperl_sv_is_defined (sv)) \ *((type *) info->arg_data) = converter (sv); \ } static void initialize_scalar (gpointer key, gpointer value, gpointer data) { SV *ref = key; GPerlArgInfo *info = value; PERL_UNUSED_VAR (data); switch (info->arg) { case G_OPTION_ARG_NONE: INITIALIZE_POINTER (gboolean, sv_2bool); break; case G_OPTION_ARG_STRING: INITIALIZE_POINTER (gchar *, SvGChar); break; case G_OPTION_ARG_INT: INITIALIZE_POINTER (gint, SvIV); break; case G_OPTION_ARG_CALLBACK: croak ("unhandled arg type G_OPTION_ARG_CALLBACK encountered"); break; case G_OPTION_ARG_FILENAME: /* FIXME: Is this the correct converter? */ INITIALIZE_POINTER (gchar *, SvPV_nolen); break; case G_OPTION_ARG_STRING_ARRAY: INITIALIZE_POINTER (gchar **, strings_from_sv); break; case G_OPTION_ARG_FILENAME_ARRAY: INITIALIZE_POINTER (gchar **, filenames_from_sv); break; #if GLIB_CHECK_VERSION (2, 12, 0) case G_OPTION_ARG_DOUBLE: INITIALIZE_POINTER (gdouble, SvNV); break; case G_OPTION_ARG_INT64: INITIALIZE_POINTER (gint64, SvGInt64); break; #endif } } static gboolean initialize_scalars (GOptionContext *context, GOptionGroup *group, gpointer data, GError **error) { GPerlArgInfoTable *table = data; PERL_UNUSED_VAR (context); PERL_UNUSED_VAR (group); PERL_UNUSED_VAR (error); g_hash_table_foreach (table->scalar_to_info, initialize_scalar, NULL); return TRUE; } /* ------------------------------------------------------------------------- */ static SV * sv_from_strings (gchar **strings) { AV *av; gint i; if (!strings) return &PL_sv_undef; av = newAV (); for (i = 0; strings[i] != NULL; i++) { av_push (av, newSVGChar (strings[i])); } return newRV_noinc ((SV *) av); } static SV * sv_from_filenames (gchar **filenames) { AV *av; gint i; if (!filenames) return &PL_sv_undef; av = newAV (); for (i = 0; filenames[i] != NULL; i++) { /* FIXME: Is this the correct converter? */ av_push (av, newSVpv (filenames[i], 0)); } return newRV_noinc ((SV *) av); } #define READ_POINTER(type) (*((type *) info->arg_data)) static void fill_in_scalar (gpointer key, gpointer value, gpointer data) { SV *ref = key; GPerlArgInfo *info = value; SV *sv = SvRV (ref); PERL_UNUSED_VAR (data); switch (info->arg) { case G_OPTION_ARG_NONE: sv_setsv (sv, boolSV (READ_POINTER (gboolean))); break; case G_OPTION_ARG_STRING: sv_setpv (sv, READ_POINTER (gchar *)); SvUTF8_on (sv); break; case G_OPTION_ARG_INT: sv_setiv (sv, READ_POINTER (gint)); break; case G_OPTION_ARG_CALLBACK: croak ("unhandled arg type G_OPTION_ARG_CALLBACK encountered"); break; case G_OPTION_ARG_FILENAME: /* FIXME: Is this the correct converter? */ sv_setpv (sv, READ_POINTER (gchar *)); break; case G_OPTION_ARG_STRING_ARRAY: sv_setsv (sv, sv_from_strings (READ_POINTER (gchar **))); break; case G_OPTION_ARG_FILENAME_ARRAY: sv_setsv (sv, sv_from_filenames (READ_POINTER (gchar **))); break; #if GLIB_CHECK_VERSION (2, 12, 0) case G_OPTION_ARG_DOUBLE: sv_setnv (sv, READ_POINTER (gdouble)); break; case G_OPTION_ARG_INT64: sv_setsv (sv, newSVGInt64 (READ_POINTER (gint64))); break; #endif } } static gboolean fill_in_scalars (GOptionContext *context, GOptionGroup *group, gpointer data, GError **error) { GPerlArgInfoTable *table = data; PERL_UNUSED_VAR (context); PERL_UNUSED_VAR (group); PERL_UNUSED_VAR (error); g_hash_table_foreach (table->scalar_to_info, fill_in_scalar, NULL); return TRUE; } /* ------------------------------------------------------------------------- */ static GPerlCallback * gperl_translate_func_create (SV *func, SV *data) { GType param_types [1]; param_types[0] = G_TYPE_STRING; return gperl_callback_new (func, data, G_N_ELEMENTS (param_types), param_types, G_TYPE_STRING); } static const gchar * gperl_translate_func (const gchar *str, gpointer data) { GPerlCallback *callback = (GPerlCallback *) data; GValue value = {0,}; const gchar *retval; /* FIXME: This leaks but I've no idea how to make sure the string * survives. */ g_value_init (&value, callback->return_type); gperl_callback_invoke (callback, &value, str); retval = g_value_dup_string (&value); g_value_unset (&value); return retval; } /* ------------------------------------------------------------------------- */ MODULE = Glib::Option PACKAGE = Glib::OptionContext PREFIX = g_option_context_ BOOT: gperl_register_boxed (GPERL_TYPE_OPTION_CONTEXT, "Glib::OptionContext", NULL); gperl_register_boxed (GPERL_TYPE_OPTION_GROUP, "Glib::OptionGroup", NULL); gperl_register_fundamental (GPERL_TYPE_OPTION_ARG, "Glib::OptionArg"); gperl_register_fundamental (GPERL_TYPE_OPTION_FLAGS, "Glib::OptionFlags"); =for position SYNOPSIS =head1 SYNOPSIS my ($verbose, $source, $filenames) = ('', undef, []); my $entries = [ { long_name => 'verbose', short_name => 'v', arg_type => 'none', arg_value => \$verbose, description => 'be verbose' }, { long_name => 'source', short_name => 's', arg_type => 'string', arg_value => \$source, description => 'set the source', arg_description => 'source' }, [ 'filenames', 'f', 'filename-array', \$filenames ], ]; my $context = Glib::OptionContext->new ('- urgsify your life'); $context->add_main_entries ($entries, 'C'); $context->parse (); # $verbose, $source, and $filenames are now updated according to the # command line options given =cut ## GOptionContext * g_option_context_new (const gchar *parameter_string); GOptionContext_own * g_option_context_new (class, parameter_string); const gchar *parameter_string C_ARGS: parameter_string void g_option_context_set_help_enabled (GOptionContext *context, gboolean help_enabled); gboolean g_option_context_get_help_enabled (GOptionContext *context); void g_option_context_set_ignore_unknown_options (GOptionContext *context, gboolean ignore_unknown); gboolean g_option_context_get_ignore_unknown_options (GOptionContext *context); # void g_option_context_add_main_entries (GOptionContext *context, const GOptionEntry *entries, const gchar *translation_domain); =for signature =arg entries reference to an array of option entries =cut void g_option_context_add_main_entries (GOptionContext *context, SV *entries, const gchar *translation_domain) PREINIT: GPerlArgInfoTable *table; GOptionGroup *group; GOptionEntry *real_entries; CODE: table = gperl_arg_info_table_new (); group = g_option_group_new (NULL, NULL, NULL, table, (GDestroyNotify) gperl_arg_info_table_destroy); g_option_group_set_parse_hooks (group, initialize_scalars, fill_in_scalars); real_entries = sv_to_option_entries (entries, table); if (real_entries) g_option_group_add_entries (group, real_entries); g_option_group_set_translation_domain (group, translation_domain); /* context assumes ownership of group */ g_option_context_set_main_group (context, group); ## gboolean g_option_context_parse (GOptionContext *context, gint *argc, gchar ***argv, GError **error); =for apidoc __gerror__ This method works directly on I<@ARGV>. =cut gboolean g_option_context_parse (context) GOptionContext *context PREINIT: GPerlArgv *pargv; GError *error = NULL; CODE: pargv = gperl_argv_new (); RETVAL = g_option_context_parse (context, &pargv->argc, &pargv->argv, &error); if (error) { gperl_argv_free (pargv); gperl_croak_gerror (NULL, error); } gperl_argv_update (pargv); gperl_argv_free (pargv); OUTPUT: RETVAL # Groups that belong to a context will be destroyed when that context goes # away, so we need to mark the group to ensure it doesn't get freed by our # boxed wrappers. ## void g_option_context_add_group (GOptionContext *context, GOptionGroup *group); void g_option_context_add_group (context, group) GOptionContext *context GOptionGroup *group C_ARGS: context, gperl_option_group_transfer (group) ## void g_option_context_set_main_group (GOptionContext *context, GOptionGroup *group); void g_option_context_set_main_group (context, group); GOptionContext *context GOptionGroup *group C_ARGS: context, gperl_option_group_transfer (group) GOptionGroup * g_option_context_get_main_group (GOptionContext *context); # --------------------------------------------------------------------------- # MODULE = Glib::Option PACKAGE = Glib::OptionGroup PREFIX = g_option_group_ =for enum Glib::OptionFlags =cut =for enum Glib::OptionArg =cut ## GOptionGroup * g_option_group_new (const gchar *name, const gchar *description, const gchar *help_description, gpointer user_data, GDestroyNotify destroy); ## void g_option_group_add_entries (GOptionGroup *group, const GOptionEntry *entries); ## void g_option_group_set_parse_hooks (GOptionGroup *group, GOptionParseFunc pre_parse_func, GOptionParseFunc post_parse_func); ## void g_option_group_set_error_hook (GOptionGroup *group, GOptionErrorFunc error_func); =for apidoc =for signature optiongroup = Glib::OptionGroup->new (key => value, ...) =for arg ... (__hide__) Creates a new option group from the given key-value pairs. The valid keys are name, description, help_description, and entries. The first three specify strings while the last one, entries, specifies an array reference of option entries. Example: my $group = Glib::OptionGroup->new ( name => 'urgs', description => 'Urgs Urgs Urgs', help_description => 'Help with Urgs', entries => \@entries); An option entry is a hash reference like this: { long_name => 'verbose', short_name => 'v', flags => [qw/reverse hidden in-main/], arg_type => 'none', arg_value => \$verbose, description => 'verbose desc.', arg_description => 'verbose arg desc.' } Of those keys only long_name, arg_type, and arg_value are required. So this is a valid option entry too: { long_name => 'package-names', arg_type => 'string-array', arg_value => \$package_names } For convenience, option entries can also be specified as array references containing long_name, short_name, arg_type, and arg_value: [ 'filenames', 'f', 'filename-array', \$filenames ] If you don't want an option to have a short name, specify undef for it: [ 'filenames', undef, 'filename-array', \$filenames ] =cut GOptionGroup_own * g_option_group_new (class, ...) PREINIT: int i; gchar *name = NULL; gchar *description = NULL; gchar *help_description = NULL; SV *entries = NULL; GPerlArgInfoTable *table; GOptionEntry *real_entries = NULL; CODE: if ((items - 1) % 2 != 0) croak ("even number of arguments expected: key => value, ..."); for (i = 1; i < items; i += 2) { char *key = SvPV_nolen (ST (i)); SV *value = ST (i + 1); if (strEQ (key, "name")) name = SvGChar (value); else if (strEQ (key, "description")) description = SvGChar (value); else if (strEQ (key, "help_description")) help_description = SvGChar (value); else if (strEQ (key, "entries")) entries = value; else warn ("unknown key `%s´ encountered; ignoring", key); } table = gperl_arg_info_table_new (); if (entries) real_entries = sv_to_option_entries (entries, table); RETVAL = g_option_group_new (name, description, help_description, table, (GDestroyNotify) gperl_arg_info_table_destroy); g_option_group_set_parse_hooks (RETVAL, initialize_scalars, fill_in_scalars); if (real_entries) g_option_group_add_entries (RETVAL, real_entries); OUTPUT: RETVAL ## void g_option_group_set_translate_func (GOptionGroup *group, GTranslateFunc func, gpointer data, GDestroyNotify destroy_notify); void g_option_group_set_translate_func (group, func, data=NULL); GOptionGroup *group SV *func SV *data PREINIT: GPerlCallback *callback; CODE: callback = gperl_translate_func_create (func, data); g_option_group_set_translate_func (group, gperl_translate_func, callback, (GDestroyNotify) gperl_callback_destroy); void g_option_group_set_translation_domain (GOptionGroup *group, const gchar *domain); Glib-1.320/GParamSpec.xs000644 001750 000024 00000105555 12251766676 016062 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2004, 2010 by the gtk2-perl team (see the file AUTHORS for * the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ #include "gperl.h" #include "gperl-gtypes.h" #include "gperl-private.h" /* for _gperl_sv_from_value_internal() */ SV * newSVGParamFlags (GParamFlags flags) { return gperl_convert_back_flags (GPERL_TYPE_PARAM_FLAGS, flags); } GParamFlags SvGParamFlags (SV * sv) { return gperl_convert_flags (GPERL_TYPE_PARAM_FLAGS, sv); } static GHashTable * param_package_by_type = NULL; void gperl_register_param_spec (GType gtype, const char * package) { if (!param_package_by_type) { param_package_by_type = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, g_free); g_hash_table_insert (param_package_by_type, (gpointer) G_TYPE_PARAM, g_strdup ("Glib::ParamSpec")); } g_hash_table_insert (param_package_by_type, (gpointer) gtype, g_strdup (package)); gperl_set_isa (package, "Glib::ParamSpec"); } const char * gperl_param_spec_package_from_type (GType gtype) { g_return_val_if_fail (param_package_by_type != NULL, NULL); return (const char*) g_hash_table_lookup (param_package_by_type, (gpointer) gtype); } /* * reverse lookup for paramspec types will be really rare, so we'll save * some storage space by sacrificing traversal time. */ struct FindData { const char * package; GType found_type; }; #if GLIB_CHECK_VERSION (2, 4, 0) static gboolean find_func (gpointer key, gpointer value, gpointer user_data) { struct FindData * fd = user_data; if (g_str_equal ((const char *) value, fd->package)) { fd->found_type = (GType) key; return TRUE; } else return FALSE; } #else static void find_func (gpointer key, gpointer value, gpointer user_data) { struct FindData * fd = user_data; if (g_str_equal ((const char *) value, fd->package)) fd->found_type = (GType) key; } #endif GType gperl_param_spec_type_from_package (const char * package) { struct FindData fd; fd.package = package; fd.found_type = 0; g_return_val_if_fail (param_package_by_type != NULL, 0); #if GLIB_CHECK_VERSION (2, 4, 0) g_hash_table_find (param_package_by_type, find_func, (gpointer) &fd); #else g_hash_table_foreach (param_package_by_type, find_func, (gpointer) &fd); #endif return fd.found_type; } SV * newSVGParamSpec (GParamSpec * pspec) { const gchar * pv; HV * property; SV * sv; HV * stash; const char * package; if (!pspec) return &PL_sv_undef; g_param_spec_ref (pspec); g_param_spec_sink (pspec); property = newHV (); _gperl_attach_mg ((SV*)property, pspec); /* for hysterical raisins (backward compatibility with the old * versions which did not use the same C-to-Perl mapping for the * paramspec list returned from Glib::Object::list_properties()) * we store a few select keys in the hash directly. */ gperl_hv_take_sv_s (property, "name", newSVpv (g_param_spec_get_name (pspec), 0)); /* map type names to package names, if possible */ pv = gperl_package_from_type (pspec->value_type); if (!pv) pv = g_type_name (pspec->value_type); gperl_hv_take_sv_s (property, "type", newSVpv (pv, 0)); pv = gperl_package_from_type (pspec->owner_type); if (!pv) pv = g_type_name (pspec->owner_type); if (pv) gperl_hv_take_sv_s (property, "owner_type", newSVpv (pv, 0)); pv = g_param_spec_get_blurb (pspec); if (pv) gperl_hv_take_sv_s (property, "descr", newSVpv (pv, 0)); gperl_hv_take_sv_s (property, "flags", newSVGParamFlags (pspec->flags)); /* wrap it, bless it, ship it. */ sv = newRV_noinc ((SV*)property); package = gperl_param_spec_package_from_type (G_PARAM_SPEC_TYPE (pspec)); if (!package) { package = "Glib::ParamSpec"; warn ("unhandled paramspec type %s, falling back to %s", G_PARAM_SPEC_TYPE_NAME (pspec), package); } stash = gv_stashpv (package, TRUE); sv_bless (sv, stash); return sv; } GParamSpec * SvGParamSpec (SV * sv) { MAGIC * mg; if (!gperl_sv_is_ref (sv) || !(mg = _gperl_find_mg (SvRV (sv)))) return NULL; return (GParamSpec*) mg->mg_ptr; } MODULE = Glib::ParamSpec PACKAGE = Glib::ParamSpec PREFIX = g_param_spec_ void DESTROY (GParamSpec * pspec) CODE: g_param_spec_unref (pspec); =for position DESCRIPTION =head1 DESCRIPTION Glib::ParamSpec encapsulates the metadata required to specify parameters. You will see these most often when creating new Glib::Object types; see C<< Glib::Type->register >> and L. Parameter specifications allow you to provide limits for validation as well as nicknames and blurbs to document the parameters. Blurbs show up in reference documentation such as this page or the gtk+ C API reference; i'm not really sure where the nicknames get used. The Perl bindings for the most part ignore the difference between dashes and underscores in the paramspec names, which typically find use as the actual keys for object parameters. It's worth noting that Glib offers various sizes of integer and floating point values, while Perl really only deals with full integers and double precision floating point values. The size distinction is important for the underlying C libraries. =cut BOOT: gperl_register_fundamental (GPERL_TYPE_PARAM_FLAGS, "Glib::ParamFlags"); gperl_register_param_spec (G_TYPE_PARAM_CHAR, "Glib::Param::Char"); gperl_register_param_spec (G_TYPE_PARAM_UCHAR, "Glib::Param::UChar"); gperl_register_param_spec (G_TYPE_PARAM_UNICHAR, "Glib::Param::Unichar"); gperl_register_param_spec (G_TYPE_PARAM_BOOLEAN, "Glib::Param::Boolean"); gperl_register_param_spec (G_TYPE_PARAM_INT, "Glib::Param::Int"); gperl_register_param_spec (G_TYPE_PARAM_UINT, "Glib::Param::UInt"); gperl_register_param_spec (G_TYPE_PARAM_LONG, "Glib::Param::Long"); gperl_register_param_spec (G_TYPE_PARAM_ULONG, "Glib::Param::ULong"); gperl_register_param_spec (G_TYPE_PARAM_INT64, "Glib::Param::Int64"); gperl_register_param_spec (G_TYPE_PARAM_UINT64, "Glib::Param::UInt64"); gperl_register_param_spec (G_TYPE_PARAM_ENUM, "Glib::Param::Enum"); gperl_register_param_spec (G_TYPE_PARAM_FLAGS, "Glib::Param::Flags"); gperl_register_param_spec (G_TYPE_PARAM_FLOAT, "Glib::Param::Float"); gperl_register_param_spec (G_TYPE_PARAM_DOUBLE, "Glib::Param::Double"); gperl_register_param_spec (G_TYPE_PARAM_STRING, "Glib::Param::String"); gperl_register_param_spec (G_TYPE_PARAM_PARAM, "Glib::Param::Param"); gperl_register_param_spec (G_TYPE_PARAM_BOXED, "Glib::Param::Boxed"); gperl_register_param_spec (G_TYPE_PARAM_POINTER, "Glib::Param::Pointer"); gperl_register_param_spec (G_TYPE_PARAM_VALUE_ARRAY, "Glib::Param::ValueArray"); gperl_register_param_spec (G_TYPE_PARAM_OBJECT, "Glib::Param::Object"); #if GLIB_CHECK_VERSION(2,4,0) gperl_register_param_spec (G_TYPE_PARAM_OVERRIDE, "Glib::Param::Override"); #endif #if GLIB_CHECK_VERSION(2,10,0) gperl_register_param_spec (G_TYPE_PARAM_GTYPE, "Glib::Param::GType"); #endif =for enum Glib::ParamFlags =cut ## stuff from gparam.h =for apidoc =signature string = $paramspec->get_name Dashes in the name are converted to underscores. =cut SV * g_param_spec_get_name (GParamSpec * pspec) CODE: char *c; RETVAL = newSVpv (g_param_spec_get_name (pspec), 0); for (c = SvPV_nolen (RETVAL); c <= SvEND (RETVAL); c++) if (*c == '-') *c = '_'; OUTPUT: RETVAL const gchar* g_param_spec_get_nick (GParamSpec * pspec) const gchar* g_param_spec_get_blurb (GParamSpec * pspec) ## stuff from gparamspecs.h ### ### glib's param specs offer lots of different sizes of integers and floating ### point values, but perl only supports UV (uint), IV (int), and NV (double). ### so, we can save quite a bit of code space by just aliasing all these ### together (and letting the compiler take care of casting the values to ### the right sizes). ### ## GParamSpec* g_param_spec_char (const gchar *name, const gchar *nick, const gchar *blurb, gint8 minimum, gint8 maximum, gint8 default_value, GParamFlags flags) ## GParamSpec* g_param_spec_int (const gchar *name, const gchar *nick, const gchar *blurb, gint minimum, gint maximum, gint default_value, GParamFlags flags) ## GParamSpec* g_param_spec_long (const gchar *name, const gchar *nick, const gchar *blurb, glong minimum, glong maximum, glong default_value, GParamFlags flags) GParamSpec* IV (class, name, nick, blurb, minimum, maximum, default_value, flags) const gchar *name const gchar *nick const gchar *blurb IV minimum IV maximum IV default_value GParamFlags flags ALIAS: IV = 0 char = 1 int = 2 long = 3 CODE: RETVAL = NULL; switch (ix) { case 1: RETVAL = g_param_spec_char (name, nick, blurb, (char)minimum, (char)maximum, (char)default_value, flags); break; case 2: RETVAL = g_param_spec_int (name, nick, blurb, minimum, maximum, default_value, flags); break; case 0: case 3: RETVAL = g_param_spec_long (name, nick, blurb, minimum, maximum, default_value, flags); break; } OUTPUT: RETVAL ## GParamSpec* g_param_spec_int64 (const gchar *name, const gchar *nick, const gchar *blurb, gint64 minimum, gint64 maximum, gint64 default_value, GParamFlags flags) GParamSpec* g_param_spec_int64 (class, name, nick, blurb, minimum, maximum, default_value, flags) const gchar *name const gchar *nick const gchar *blurb gint64 minimum gint64 maximum gint64 default_value GParamFlags flags C_ARGS: name, nick, blurb, minimum, maximum, default_value, flags ## GParamSpec* g_param_spec_uchar (const gchar *name, const gchar *nick, const gchar *blurb, guint8 minimum, guint8 maximum, guint8 default_value, GParamFlags flags) ## GParamSpec* g_param_spec_uint (const gchar *name, const gchar *nick, const gchar *blurb, guint minimum, guint maximum, guint default_value, GParamFlags flags) ## GParamSpec* g_param_spec_ulong (const gchar *name, const gchar *nick, const gchar *blurb, gulong minimum, gulong maximum, gulong default_value, GParamFlags flags) GParamSpec* UV (class, name, nick, blurb, minimum, maximum, default_value, flags) const gchar *name const gchar *nick const gchar *blurb UV minimum UV maximum UV default_value GParamFlags flags ALIAS: UV = 0 uchar = 1 uint = 2 ulong = 3 CODE: RETVAL = NULL; switch (ix) { case 1: RETVAL = g_param_spec_uchar (name, nick, blurb, (guchar)minimum, (guchar)maximum, (guchar)default_value, flags); break; case 2: RETVAL = g_param_spec_uint (name, nick, blurb, minimum, maximum, default_value, flags); break; case 0: case 3: RETVAL = g_param_spec_ulong (name, nick, blurb, minimum, maximum, default_value, flags); break; } OUTPUT: RETVAL ## GParamSpec* g_param_spec_uint64 (const gchar *name, const gchar *nick, const gchar *blurb, guint64 minimum, guint64 maximum, guint64 default_value, GParamFlags flags) GParamSpec* g_param_spec_uint64 (class, name, nick, blurb, minimum, maximum, default_value, flags) const gchar *name const gchar *nick const gchar *blurb guint64 minimum guint64 maximum guint64 default_value GParamFlags flags C_ARGS: name, nick, blurb, minimum, maximum, default_value, flags ## GParamSpec* g_param_spec_boolean (const gchar *name, const gchar *nick, const gchar *blurb, gboolean default_value, GParamFlags flags) GParamSpec* g_param_spec_boolean (class, name, nick, blurb, default_value, flags) const gchar *name const gchar *nick const gchar *blurb gboolean default_value GParamFlags flags C_ARGS: name, nick, blurb, default_value, flags ### GParamSpec* g_param_spec_unichar (const gchar *name, const gchar *nick, const gchar *blurb, gunichar default_value, GParamFlags flags) GParamSpec* g_param_spec_unichar (class, const gchar *name, const gchar *nick, const gchar *blurb, gunichar default_value, GParamFlags flags) C_ARGS: name, nick, blurb, default_value, flags ### GParamSpec* g_param_spec_enum (const gchar *name, const gchar *nick, const gchar *blurb, GType enum_type, gint default_value, GParamFlags flags) GParamSpec* g_param_spec_enum (class, const gchar *name, const gchar *nick, const gchar *blurb, const char * enum_type, SV * default_value, GParamFlags flags) PREINIT: GType gtype; CODE: gtype = gperl_fundamental_type_from_package (enum_type); if (!gtype) croak ("package %s is not registered as an enum type", enum_type); RETVAL = g_param_spec_enum (name, nick, blurb, gtype, gperl_convert_enum (gtype, default_value), flags); OUTPUT: RETVAL ### GParamSpec* g_param_spec_flags (const gchar *name, const gchar *nick, const gchar *blurb, GType flags_type, guint default_value, GParamFlags flags) GParamSpec* g_param_spec_flags (class, const gchar *name, const gchar *nick, const gchar *blurb, const char * flags_type, SV * default_value, GParamFlags flags) PREINIT: GType gtype; CODE: gtype = gperl_fundamental_type_from_package (flags_type); if (!gtype) croak ("package %s is not registered as an flags type", flags_type); RETVAL = g_param_spec_flags (name, nick, blurb, gtype, gperl_convert_flags (gtype, default_value), flags); OUTPUT: RETVAL ## GParamSpec* g_param_spec_float (const gchar *name, const gchar *nick, const gchar *blurb, gfloat minimum, gfloat maximum, gfloat default_value, GParamFlags flags) ## GParamSpec* g_param_spec_double (const gchar *name, const gchar *nick, const gchar *blurb, gdouble minimum, gdouble maximum, gdouble default_value, GParamFlags flags) GParamSpec* g_param_spec_double (class, name, nick, blurb, minimum, maximum, default_value, flags) const gchar *name const gchar *nick const gchar *blurb double minimum double maximum double default_value GParamFlags flags ALIAS: float = 1 CODE: if (ix == 1) RETVAL = g_param_spec_float (name, nick, blurb, (float)minimum, (float)maximum, (float)default_value, flags); else RETVAL = g_param_spec_double (name, nick, blurb, minimum, maximum, default_value, flags); OUTPUT: RETVAL ## GParamSpec* g_param_spec_string (const gchar *name, const gchar *nick, const gchar *blurb, const gchar *default_value, GParamFlags flags) ## ## "default_value" can be NULL. Not actually described in the docs as ## of 2.18, but used that way in lots of the builtin classes ## GParamSpec* g_param_spec_string (class, name, nick, blurb, default_value, flags) const gchar *name const gchar *nick const gchar *blurb const gchar_ornull *default_value GParamFlags flags C_ARGS: name, nick, blurb, default_value, flags ### GParamSpec* g_param_spec_param (const gchar *name, const gchar *nick, const gchar *blurb, GType param_type, GParamFlags flags) ## GParamSpec* g_param_spec_boxed (const gchar *name, const gchar *nick, const gchar *blurb, GType boxed_type, GParamFlags flags) ## GParamSpec* g_param_spec_object (const gchar *name, const gchar *nick, const gchar *blurb, GType object_type, GParamFlags flags) =for apidoc object =for arg package name of the class, derived from Glib::Object, of the objects this property will hold. =cut =for apidoc boxed =for arg package name of the class, derived from Glib::Boxed, of the objects this property will hold. =cut =for apidoc =for arg package name of the class, derived from Glib::ParamSpec, of the objects this property will hold. =cut GParamSpec* param_spec (class, name, nick, blurb, package, flags) const gchar *name const gchar *nick const gchar *blurb const char * package GParamFlags flags ALIAS: boxed = 1 object = 2 PREINIT: GType type = 0; CODE: RETVAL = NULL; switch (ix) { case 0: type = gperl_param_spec_type_from_package (package); break; case 1: type = gperl_boxed_type_from_package (package); break; case 2: type = gperl_object_type_from_package (package); break; } if (!type) croak ("type %s is not registered with Glib-Perl", package); switch (ix) { case 0: RETVAL = g_param_spec_param (name, nick, blurb, type, flags); break; case 1: RETVAL = g_param_spec_boxed (name, nick, blurb, type, flags); break; case 2: RETVAL = g_param_spec_object (name, nick, blurb, type, flags); break; } OUTPUT: RETVAL =for apidoc ParamSpec to be used for any generic perl scalar, including references to complex objects. Currently C cannot set object properties of this type (there's no hooks for property value parsing, as of Gtk 2.20), so prefer the builtin types if buildable support for an object matters. A C of C can give an array of strings. A signal handler callback can do most of what a coderef might. =cut GParamSpec* scalar (class, name, nick, blurb, flags) const gchar *name const gchar *nick const gchar *blurb GParamFlags flags CODE: RETVAL = g_param_spec_boxed (name, nick, blurb, GPERL_TYPE_SV, flags); OUTPUT: RETVAL ### plain pointers are dangerous, and i don't even know how you'd create ### them from perl since there are no pointers in perl (references are SVs) ## GParamSpec* g_param_spec_pointer (const gchar *name, const gchar *nick, const gchar *blurb, GParamFlags flags) #### we don't have full pspec support, and probably don't really need #### value arrays. ### GParamSpec* g_param_spec_value_array (const gchar *name, const gchar *nick, const gchar *blurb, GParamSpec *element_spec, GParamFlags flags) #if GLIB_CHECK_VERSION(2, 4, 0) GParamSpec* g_param_spec_override (class, name, overridden) const gchar *name GParamSpec *overridden C_ARGS: name, overridden GParamSpec_ornull * g_param_spec_get_redirect_target (pspec) GParamSpec *pspec #endif #if GLIB_CHECK_VERSION(2, 10, 0) =for apidoc =for arg is_a_type The name of a class whose subtypes are allowed as values of the property. Use C to allow any type. =cut GParamSpec* g_param_spec_gtype (class, name, nick, blurb, is_a_type, flags) const gchar *name const gchar *nick const gchar *blurb const gchar_ornull *is_a_type GParamFlags flags C_ARGS: name, nick, blurb, is_a_type ? gperl_type_from_package (is_a_type) : G_TYPE_NONE, flags #endif #### #### accessors #### #### the various paramspec structures have important members in them, but #### the API does not provide accessors for them. (i presume to reduce #### bloat and performance penalties.) thus, we have to provide our own #### accessors in order to be able to find important things like default #### and limit values, etc. #### #### an important choice is whether to use the simple and popular #### dual-purpose accessor/mutator combo used widely in the Gtk2 module, #### or to use get_foo/set_foo pairs. well, that decision is pretty much #### made for us, by the fact that the simple form for pspec.flags would #### conflict directly with the GParamFlags constructor. so, we use the #### get_foo form throughout. set_foo functions are currently not #### implemented. #### #### and finally, there's the sticky issue of documentation generation. #### i've aliased a many of the repetitive accessors together, and this #### results in some problems with the docgen tools, since the aliases #### are actually in different packages. to cut down on confusion and #### the overall number of manpages generated, i've hidden all but the #### "master" alias from the docs, e.g., for the integer types, only #### Int is documented, and a note explains that the others are the same. #### suggestions for a better scheme are quite welcome. #### # name -> get_name() GParamFlags get_flags (GParamSpec * pspec) CODE: RETVAL = pspec->flags; OUTPUT: RETVAL const char * get_value_type (GParamSpec * pspec) ALIAS: get_owner_type = 1 PREINIT: GType type; CODE: switch (ix) { case 0: type = pspec->value_type; break; case 1: type = pspec->owner_type; break; default: g_assert_not_reached (); type = 0; } RETVAL = gperl_package_from_type (type); if (!RETVAL) RETVAL = g_type_name (type); OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::ParamSpec PREFIX = g_param_ =for apidoc (This is the C level C function.) Note that on a C the return is a single-char string. This is the same as the constructor C<< Glib::ParamSpec->unichar >>, but it's not the same as C C<< get_property >> / C<< set_property >>, so an C conversion is needed if passing the default value to a unichar C. =cut SV * get_default_value (GParamSpec * pspec) PREINIT: GValue v = { 0, }; GType type; CODE: /* crib note: G_PARAM_SPEC_VALUE_TYPE() is suitable for GParamSpecOverride and gives the target's value type */ type = G_PARAM_SPEC_VALUE_TYPE (pspec); g_value_init (&v, type); g_param_value_set_default (pspec, &v); if (type == G_TYPE_BOOLEAN) { /* For historical compatibility with what Perl-Gtk2 has done in the past, return boolSV() style '' or 1 for a G_TYPE_BOOLEAN, the same as gboolean typemap output, not the newSViv() style 0 or 1 which the generic gperl_sv_from_value() would give on G_TYPE_BOOLEAN. The two falses, '' vs 0, are of course the same in any boolean context or arithmetic, but maybe someone has done a string compare or something, so keep ''. This applies to Glib::Param::Boolean and in the interests of consistency also to a Glib::Param::Override targetting a boolean, and also to any hypothetical other ParamSpec which had value type G_TYPE_BOOLEAN, either a sub-type of GParamSpecBoolean or just a completely separate one with G_TYPE_BOOLEAN. */ RETVAL = boolSV (g_value_get_boolean (&v)); } else if (type == G_TYPE_UINT) { /* For historical compatibility with what Perl-Gtk2 has done in the past, return a single-char string for GParamSpecUnichar. The GValue for a GParamSpecUnichar is only a G_TYPE_UINT and gperl_sv_from_value() would give an integer. This applies to Glib::Param::Unichar and in the interests of consistency is applied also to a Glib::Param::Override targetting a unichar, and also to any sub-type of GParamUnichar. As noted in the POD above this is a bit unfortunate, since it means $obj->set_property() can't be simply called with $obj->find_property->get_default_value(). Watch this space for some sort of variation on get_default_value() which can go straight to set_property(), or to values_cmp() against a get_property(), etc. */ GParamSpec *ptarget; #if GLIB_CHECK_VERSION(2, 4, 0) ptarget = g_param_spec_get_redirect_target(pspec); if (! ptarget) { ptarget = pspec; } #else ptarget = pspec; #endif if (g_type_is_a (G_PARAM_SPEC_TYPE(ptarget), G_TYPE_PARAM_UNICHAR)) { { gchar temp[6]; gint length = g_unichar_to_utf8 (g_value_get_uint(&v), temp); RETVAL = newSVpv (temp, length); SvUTF8_on (RETVAL); } } else { /* a plain uint, not a unichar */ goto plain_gvalue; } } else { plain_gvalue: /* No PUTBACK/SPAGAIN needed here. */ RETVAL = gperl_sv_from_value (&v); } g_value_unset (&v); OUTPUT: RETVAL =for apidoc =signature bool = $paramspec->value_validate ($value) =signature (bool, newval) = $paramspec->value_validate ($value) In scalar context return true if $value must be modified to be valid for $paramspec, or false if it's valid already. In array context return also a new value which is $value made valid. $value must be the right type for $paramspec (with usual stringizing, numizing, etc). C checks the further restrictions such as minimum and maximum for a numeric type or allowed characters in a string. The "made valid" return is then for instance clamped to the min/max, or offending chars replaced by a substitutor. =cut void g_param_value_validate (GParamSpec * pspec, SV *value) PREINIT: GValue v = { 0, }; GType type; int modify, retcount=1; CODE: type = G_PARAM_SPEC_VALUE_TYPE (pspec); g_value_init (&v, type); gperl_value_from_sv (&v, value); modify = g_param_value_validate (pspec, &v); ST(0) = sv_2mortal (boolSV (modify)); if (GIMME_V == G_ARRAY) { /* If unmodified then can leave ST(1) "value" alone. If modified then expect that g_param_value_validate() will have made a new block of memory owned by the GValue and which will be freed at the g_value_unset(). For that reason ask _gperl_sv_from_value_internal() to "copy_boxed" to grab before it's freed. If g_param_value_validate() says modified but doesn't in fact modify but just leaves the GValue pointing into the input ST(1) "value" then we might prefer not to copy (but instead leave ST(1) as the return). Believe that shouldn't happen, ie. a value_validate vfunc shouldn't modify the input but rather if modifying something then it will put in new memory. Or alternately if it doesn't modify anything then it shouldn't say modified. (The Glib ref manual circa 2.27 doesn't have much guidance on this.) */ retcount = 2; if (modify) /* No PUTBACK/SPAGAIN needed here. */ ST(1) = sv_2mortal (_gperl_sv_from_value_internal(&v,TRUE)); } g_value_unset (&v); XSRETURN(retcount); =for Compares I with I according to I, and returns -1, 0 or +1, if value1 is found to be less than, equal to or greater than value2, respectively. =cut int g_param_values_cmp (GParamSpec * pspec, SV *value1, SV *value2) PREINIT: GValue v1 = { 0, }; GValue v2 = { 0, }; GType type; CODE: type = G_PARAM_SPEC_VALUE_TYPE (pspec); g_value_init (&v1, type); g_value_init (&v2, type); gperl_value_from_sv (&v1, value1); gperl_value_from_sv (&v2, value2); RETVAL = g_param_values_cmp (pspec, &v1, &v2); g_value_unset (&v1); g_value_unset (&v2); OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::Char ## actually for all signed integer types =for object Glib::Param::Int - Paramspecs for integer types =for position post_hierarchy Glib::ParamSpec +----Glib::Param::Char Glib::ParamSpec +----Glib::Param::Long =cut =head1 DESCRIPTION This page documents the extra accessors available for all of the integer type paramspecs: Char, Int, and Long. Perl really only supports full-size integers, so all of these methods return IVs; the distinction of integer size is important to the underlying C library and also determines the data value range. =cut =for see_also Glib::ParamSpec =cut =for apidoc Glib::Param::Char::get_minimum __hide__ =cut =for apidoc Glib::Param::Long::get_minimum __hide__ =cut IV get_minimum (GParamSpec * pspec) ALIAS: Glib::Param::Int::get_minimum = 1 Glib::Param::Long::get_minimum = 2 CODE: switch (ix) { case 0: RETVAL = G_PARAM_SPEC_CHAR (pspec)->minimum; break; case 1: RETVAL = G_PARAM_SPEC_INT (pspec)->minimum; break; case 2: RETVAL = G_PARAM_SPEC_LONG (pspec)->minimum; break; default: g_assert_not_reached (); RETVAL = 0; } OUTPUT: RETVAL =for apidoc Glib::Param::Char::get_maximum __hide__ =cut =for apidoc Glib::Param::Long::get_maximum __hide__ =cut IV get_maximum (GParamSpec * pspec) ALIAS: Glib::Param::Int::get_maximum = 1 Glib::Param::Long::get_maximum = 2 CODE: switch (ix) { case 0: RETVAL = G_PARAM_SPEC_CHAR (pspec)->maximum; break; case 1: RETVAL = G_PARAM_SPEC_INT (pspec)->maximum; break; case 2: RETVAL = G_PARAM_SPEC_LONG (pspec)->maximum; break; default: g_assert_not_reached (); RETVAL = 0; } OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::UChar ## similarly, all unsigned integer types =for object Glib::Param::UInt =for position post_hierarchy Glib::ParamSpec +----Glib::Param::UChar Glib::ParamSpec +----Glib::Param::ULong =cut =head1 DESCRIPTION This page documents the extra accessors available for all of the unsigned integer type paramspecs: UChar, UInt, and ULong. Perl really only supports full-size integers, so all of these methods return UVs; the distinction of integer size is important to the underlying C library and also determines the data value range. =cut =for see_also Glib::ParamSpec =cut =for apidoc Glib::Param::UChar::get_minimum __hide__ =cut =for apidoc Glib::Param::ULong::get_minimum __hide__ =cut UV get_minimum (GParamSpec * pspec) ALIAS: Glib::Param::UInt::get_minimum = 1 Glib::Param::ULong::get_minimum = 2 CODE: switch (ix) { case 0: RETVAL = G_PARAM_SPEC_UCHAR (pspec)->minimum; break; case 1: RETVAL = G_PARAM_SPEC_UINT (pspec)->minimum; break; case 2: RETVAL = G_PARAM_SPEC_ULONG (pspec)->minimum; break; default: g_assert_not_reached (); RETVAL = 0; } OUTPUT: RETVAL =for apidoc Glib::Param::UChar::get_maximum __hide__ =cut =for apidoc Glib::Param::ULong::get_maximum __hide__ =cut UV get_maximum (GParamSpec * pspec) ALIAS: Glib::Param::UInt::get_maximum = 1 Glib::Param::ULong::get_maximum = 2 CODE: switch (ix) { case 0: RETVAL = G_PARAM_SPEC_UCHAR (pspec)->maximum; break; case 1: RETVAL = G_PARAM_SPEC_UINT (pspec)->maximum; break; case 2: RETVAL = G_PARAM_SPEC_ULONG (pspec)->maximum; break; default: g_assert_not_reached (); RETVAL = 0; } OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::Int64 =for object Glib::Param::Int64 =head1 DESCRIPTION This page documents the extra accessors available for the signed 64 bit integer type paramspecs. On 32 bit machines and even on some 64 bit machines, perl really only supports 32 bit integers, so all of these methods convert the values to and from Perl strings if necessary. =cut gint64 get_minimum (GParamSpec * pspec) CODE: RETVAL = G_PARAM_SPEC_INT64 (pspec)->minimum; OUTPUT: RETVAL gint64 get_maximum (GParamSpec * pspec) CODE: RETVAL = G_PARAM_SPEC_INT64 (pspec)->maximum; OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::UInt64 =for object Glib::Param::UInt64 =head1 DESCRIPTION This page documents the extra accessors available for the unsigned 64 bit integer type paramspecs. On 32 bit machines and even on some 64 bit machines, perl really only supports 32 bit integers, so all of these methods convert the values to and from Perl strings if necessary. =cut guint64 get_minimum (GParamSpec * pspec) CODE: RETVAL = G_PARAM_SPEC_UINT64 (pspec)->minimum; OUTPUT: RETVAL guint64 get_maximum (GParamSpec * pspec) CODE: RETVAL = G_PARAM_SPEC_UINT64 (pspec)->maximum; OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::Float ## and again for the floating-point types =for object Glib::Param::Double =for position post_hierarchy Glib::ParamSpec +----Glib::Param::Float =cut =head1 DESCRIPTION This page documents the extra accessors available for both of the floating-point type paramspecs: Float and Double. Perl really only supports doubles, so all of these methods return NVs (that is, the C type "double"); the distinction of size is important to the underlying C library and also determines the data value range. =cut =for see_also Glib::ParamSpec =cut =for apidoc Glib::Param::Float::get_minimum __hide__ =cut double get_minimum (GParamSpec * pspec) ALIAS: Glib::Param::Double::get_minimum = 1 CODE: switch (ix) { case 0: RETVAL = G_PARAM_SPEC_FLOAT (pspec)->minimum; break; case 1: RETVAL = G_PARAM_SPEC_DOUBLE (pspec)->minimum; break; default: g_assert_not_reached (); RETVAL = 0.0; } OUTPUT: RETVAL =for apidoc Glib::Param::Float::get_maximum __hide__ =cut double get_maximum (GParamSpec * pspec) ALIAS: Glib::Param::Double::get_maximum = 1 CODE: switch (ix) { case 0: RETVAL = G_PARAM_SPEC_FLOAT (pspec)->maximum; break; case 1: RETVAL = G_PARAM_SPEC_DOUBLE (pspec)->maximum; break; default: g_assert_not_reached (); RETVAL = 0.0; } OUTPUT: RETVAL =for apidoc Glib::Param::Float::get_epsilon __hide__ =cut double get_epsilon (GParamSpec * pspec) ALIAS: Glib::Param::Double::get_epsilon = 1 CODE: switch (ix) { case 0: RETVAL = G_PARAM_SPEC_FLOAT (pspec)->epsilon; break; case 1: RETVAL = G_PARAM_SPEC_DOUBLE (pspec)->epsilon; break; default: g_assert_not_reached (); RETVAL = 0.0; } OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::Enum =for see_also Glib::ParamSpec =cut const char * get_enum_class (GParamSpec * pspec_enum) CODE: RETVAL = gperl_fundamental_package_from_type (G_ENUM_CLASS_TYPE (G_PARAM_SPEC_ENUM (pspec_enum)->enum_class)); OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::Flags =for see_also Glib::ParamSpec =cut const char * get_flags_class (GParamSpec * pspec_flags) CODE: RETVAL = gperl_fundamental_package_from_type (G_FLAGS_CLASS_TYPE (G_PARAM_SPEC_FLAGS (pspec_flags)->flags_class)); OUTPUT: RETVAL MODULE = Glib::ParamSpec PACKAGE = Glib::Param::GType #if GLIB_CHECK_VERSION(2, 10, 0) =for section DESCRIPTION =head1 DESCRIPTION This object describes a parameter which holds the name of a class known to the GLib type system. The name of the class is considered to be the common ancestor for valid values. To create a param that allows any type name, specify C for the package name. Beware, however, that although we say "any type name", this actually refers to any type registered with Glib; normal Perl packages will not work. =cut =for apidoc If C, then any class is allowed. =cut const gchar_ornull * get_is_a_type (GParamSpec * pspec_gtype) CODE: GParamSpecGType * p = G_PARAM_SPEC_GTYPE (pspec_gtype); RETVAL = p->is_a_type == G_TYPE_NONE ? NULL : gperl_package_from_type (p->is_a_type); OUTPUT: RETVAL #endif # These don't have their MODULE section since they have no or no interesting # members: ## Glib::Param::Boolean ## Glib::Param::String ## Glib::Param::Unichar ## Glib::Param::Param ## Glib::Param::Boxed ## Glib::Param::Pointer ## Glib::Param::Object ## Glib::Param::Override Glib-1.320/gperl-gtypes.c000644 001750 000024 00000051607 12636024471 016273 0ustar00bdmanningstaff000000 000000 /* * this was initially generated by glib-mkenums, but i stripped out all the * non-Error definitions, as we won't use them. */ #include "gperl.h" /* -------------------------------------------------------------------------- * --- Enums/Flags: --------------------------------------------------------- * -------------------------------------------------------------------------- */ GType gperl_connect_flags_get_type (void) { static GType etype = 0; if ( etype == 0 ) { static const GFlagsValue values[] = { { G_CONNECT_AFTER, "G_CONNECT_AFTER", "after" }, { G_CONNECT_SWAPPED, "G_CONNECT_SWAPPED", "swapped" }, { 0, NULL, NULL } }; etype = g_flags_register_static ("GConnectFlags", values); } return etype; } /* -------------------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 6, 0) GType gperl_key_file_flags_get_type () { static GType type = 0; if (! type) { static const GFlagsValue values[] = { { G_KEY_FILE_NONE, "G_KEY_FILE_NONE", "none" }, { G_KEY_FILE_KEEP_COMMENTS, "G_KEY_FILE_KEEP_COMMENTS", "keep-comments" }, { G_KEY_FILE_KEEP_TRANSLATIONS, "G_KEY_FILE_KEEP_TRANSLATIONS", "keep-translations" }, { 0, NULL, NULL } }; type = g_flags_register_static ("GKeyFileFlags", values); } return type; } #endif /* -------------------------------------------------------------------------- */ GType gperl_log_level_flags_get_type (void) { static GType etype = 0; if ( etype == 0 ) { static const GFlagsValue values[] = { { G_LOG_FLAG_RECURSION, "G_LOG_FLAG_RECURSION", "recursion" }, { G_LOG_FLAG_FATAL, "G_LOG_FLAG_FATAL", "fatal" }, { G_LOG_LEVEL_ERROR, "G_LOG_LEVEL_ERROR", "error" }, { G_LOG_LEVEL_CRITICAL, "G_LOG_LEVEL_CRITICAL", "critical" }, { G_LOG_LEVEL_WARNING, "G_LOG_LEVEL_WARNING", "warning" }, { G_LOG_LEVEL_MESSAGE, "G_LOG_LEVEL_MESSAGE", "message" }, { G_LOG_LEVEL_INFO, "G_LOG_LEVEL_INFO", "info" }, { G_LOG_LEVEL_DEBUG, "G_LOG_LEVEL_DEBUG", "debug" }, { G_LOG_FATAL_MASK, "G_LOG_FATAL_MASK", "fatal-mask" }, { 0, NULL, NULL } }; etype = g_flags_register_static ("GLogLevelFlags", values); } return etype; } /* -------------------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 6, 0) GType gperl_option_arg_get_type (void) { static GType t = 0; if (t == 0) { static const GEnumValue values[] = { {G_OPTION_ARG_NONE, "G_OPTION_ARG_NONE", "none"}, {G_OPTION_ARG_STRING, "G_OPTION_ARG_STRING", "string"}, {G_OPTION_ARG_INT, "G_OPTION_ARG_INT", "int"}, {G_OPTION_ARG_CALLBACK, "G_OPTION_ARG_CALLBACK", "callback"}, {G_OPTION_ARG_FILENAME, "G_OPTION_ARG_FILENAME", "filename"}, {G_OPTION_ARG_STRING_ARRAY, "G_OPTION_ARG_STRING_ARRAY", "string-array"}, {G_OPTION_ARG_FILENAME_ARRAY, "G_OPTION_ARG_FILENAME_ARRAY", "filename-array"}, #if GLIB_CHECK_VERSION (2, 12, 0) {G_OPTION_ARG_DOUBLE, "G_OPTION_ARG_DOUBLE", "double"}, {G_OPTION_ARG_INT64, "G_OPTION_ARG_INT64", "int64"}, #endif {0, NULL, NULL} }; t = g_enum_register_static ("GOptionArg", values); } return t; } #endif /* -------------------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 6, 0) GType gperl_option_flags_get_type (void) { static GType t = 0; if (t == 0) { static const GFlagsValue values[] = { {G_OPTION_FLAG_HIDDEN, "G_OPTION_FLAG_HIDDEN", "hidden"}, {G_OPTION_FLAG_IN_MAIN, "G_OPTION_FLAG_IN_MAIN", "in-main"}, {G_OPTION_FLAG_REVERSE, "G_OPTION_FLAG_REVERSE", "reverse"}, #if GLIB_CHECK_VERSION (2, 8, 0) {G_OPTION_FLAG_NO_ARG, "G_OPTION_FLAG_NO_ARG", "no-arg"}, {G_OPTION_FLAG_FILENAME, "G_OPTION_FLAG_FILENAME", "filename"}, {G_OPTION_FLAG_OPTIONAL_ARG, "G_OPTION_FLAG_OPTIONAL_ARG", "optional-arg"}, {G_OPTION_FLAG_NOALIAS, "G_OPTION_FLAG_NOALIAS", "noalias"}, #endif {0, NULL, NULL} }; t = g_flags_register_static ("GOptionFlags", values); } return t; } #endif /* -------------------------------------------------------------------------- */ /* the obvious GParamFlags is taken by GParamSpecFlags. */ GType gperl_param_flags_get_type (void) { static GType etype = 0; if (etype == 0) { static const GFlagsValue values[] = { {G_PARAM_READABLE, "G_PARAM_READABLE", "readable"}, {G_PARAM_WRITABLE, "G_PARAM_WRITABLE", "writable"}, {G_PARAM_CONSTRUCT, "G_PARAM_CONSTRUCT", "construct"}, {G_PARAM_CONSTRUCT_ONLY, "G_PARAM_CONSTRUCT_ONLY", "construct-only"}, {G_PARAM_LAX_VALIDATION, "G_PARAM_LAX_VALIDATION", "lax-validation"}, {G_PARAM_PRIVATE, "G_PARAM_PRIVATE", "private"}, {0, NULL, NULL} }; etype = g_flags_register_static ("GPerlParamFlags", values); } return etype; } /* -------------------------------------------------------------------------- */ GType gperl_signal_flags_get_type (void) { static GType etype = 0; if ( etype == 0 ) { static const GFlagsValue values[] = { { G_SIGNAL_RUN_FIRST, "G_SIGNAL_RUN_FIRST", "run-first" }, { G_SIGNAL_RUN_LAST, "G_SIGNAL_RUN_LAST", "run-last" }, { G_SIGNAL_RUN_CLEANUP, "G_SIGNAL_RUN_CLEANUP", "run-cleanup" }, { G_SIGNAL_NO_RECURSE, "G_SIGNAL_NO_RECURSE", "no-recurse" }, { G_SIGNAL_DETAILED, "G_SIGNAL_DETAILED", "detailed" }, { G_SIGNAL_ACTION, "G_SIGNAL_ACTION", "action" }, { G_SIGNAL_NO_HOOKS, "G_SIGNAL_NO_HOOKS", "no-hooks" }, { 0, NULL, NULL } }; etype = g_flags_register_static ("GSignalFlags", values); } return etype; } /* -------------------------------------------------------------------------- */ GType gperl_spawn_flags_get_type (void) { static GType etype = 0; if (G_UNLIKELY(etype == 0)) { static const GFlagsValue values[] = { #if GLIB_CHECK_VERSION (2, 38, 0) { G_SPAWN_DEFAULT, "G_SPAWN_DEFAULT", "default" }, #endif { G_SPAWN_LEAVE_DESCRIPTORS_OPEN, "G_SPAWN_LEAVE_DESCRIPTORS_OPEN", "leave-descriptors-open" }, { G_SPAWN_DO_NOT_REAP_CHILD, "G_SPAWN_DO_NOT_REAP_CHILD", "do-not-reap-child" }, { G_SPAWN_SEARCH_PATH, "G_SPAWN_SEARCH_PATH", "search-path" }, { G_SPAWN_STDOUT_TO_DEV_NULL, "G_SPAWN_STDOUT_TO_DEV_NULL", "stdout-to-dev-null" }, { G_SPAWN_STDERR_TO_DEV_NULL, "G_SPAWN_STDERR_TO_DEV_NULL", "stderr-to-dev-null" }, { G_SPAWN_CHILD_INHERITS_STDIN, "G_SPAWN_CHILD_INHERITS_STDIN", "child-inherits-stdin" }, { G_SPAWN_FILE_AND_ARGV_ZERO, "G_SPAWN_FILE_AND_ARGV_ZERO", "file-and-argv-zero" }, #if GLIB_CHECK_VERSION (2, 34, 0) { G_SPAWN_SEARCH_PATH_FROM_ENVP, "G_SPAWN_SEARCH_PATH_FROM_ENVP", "search-path-from-envp" }, #endif { 0, NULL, NULL } }; etype = g_flags_register_static (g_intern_static_string ("GSpawnFlags"), values); } return etype; } /* -------------------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 14, 0) GType gperl_user_directory_get_type (void) { static GType etype = 0; if (etype == 0) { static const GEnumValue values[] = { { G_USER_DIRECTORY_DESKTOP, "G_USER_DIRECTORY_DESKTOP", "desktop" }, { G_USER_DIRECTORY_DOCUMENTS, "G_USER_DIRECTORY_DOCUMENTS", "documents" }, { G_USER_DIRECTORY_DOWNLOAD, "G_USER_DIRECTORY_DOWNLOAD", "download" }, { G_USER_DIRECTORY_MUSIC, "G_USER_DIRECTORY_MUSIC", "music" }, { G_USER_DIRECTORY_PICTURES, "G_USER_DIRECTORY_PICTURES", "pictures" }, { G_USER_DIRECTORY_PUBLIC_SHARE, "G_USER_DIRECTORY_PUBLIC_SHARE", "public-share" }, { G_USER_DIRECTORY_TEMPLATES, "G_USER_DIRECTORY_TEMPLATES", "templates" }, { G_USER_DIRECTORY_VIDEOS, "G_USER_DIRECTORY_VIDEOS", "videos" }, { 0, NULL, NULL } }; etype = g_enum_register_static ("GUserDirectory", values); } return etype; } #endif /* -------------------------------------------------------------------------- * --- Error values: -------------------------------------------------------- * -------------------------------------------------------------------------- */ static const GEnumValue _gperl_convert_error_values[] = { { G_CONVERT_ERROR_NO_CONVERSION, "G_CONVERT_ERROR_NO_CONVERSION", "no-conversion" }, { G_CONVERT_ERROR_ILLEGAL_SEQUENCE, "G_CONVERT_ERROR_ILLEGAL_SEQUENCE", "illegal-sequence" }, { G_CONVERT_ERROR_FAILED, "G_CONVERT_ERROR_FAILED", "failed" }, { G_CONVERT_ERROR_PARTIAL_INPUT, "G_CONVERT_ERROR_PARTIAL_INPUT", "partial-input" }, { G_CONVERT_ERROR_BAD_URI, "G_CONVERT_ERROR_BAD_URI", "bad-uri" }, { G_CONVERT_ERROR_NOT_ABSOLUTE_PATH, "G_CONVERT_ERROR_NOT_ABSOLUTE_PATH", "not-absolute-path" }, { 0, NULL, NULL } }; GType gperl_convert_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GConvertError", _gperl_convert_error_values); return type; } /* -------------------------------------------------------------------------- */ static const GEnumValue _gperl_file_error_values[] = { { G_FILE_ERROR_EXIST, "G_FILE_ERROR_EXIST", "exist" }, { G_FILE_ERROR_ISDIR, "G_FILE_ERROR_ISDIR", "isdir" }, { G_FILE_ERROR_ACCES, "G_FILE_ERROR_ACCES", "acces" }, { G_FILE_ERROR_NAMETOOLONG, "G_FILE_ERROR_NAMETOOLONG", "nametoolong" }, { G_FILE_ERROR_NOENT, "G_FILE_ERROR_NOENT", "noent" }, { G_FILE_ERROR_NOTDIR, "G_FILE_ERROR_NOTDIR", "notdir" }, { G_FILE_ERROR_NXIO, "G_FILE_ERROR_NXIO", "nxio" }, { G_FILE_ERROR_NODEV, "G_FILE_ERROR_NODEV", "nodev" }, { G_FILE_ERROR_ROFS, "G_FILE_ERROR_ROFS", "rofs" }, { G_FILE_ERROR_TXTBSY, "G_FILE_ERROR_TXTBSY", "txtbsy" }, { G_FILE_ERROR_FAULT, "G_FILE_ERROR_FAULT", "fault" }, { G_FILE_ERROR_LOOP, "G_FILE_ERROR_LOOP", "loop" }, { G_FILE_ERROR_NOSPC, "G_FILE_ERROR_NOSPC", "nospc" }, { G_FILE_ERROR_NOMEM, "G_FILE_ERROR_NOMEM", "nomem" }, { G_FILE_ERROR_MFILE, "G_FILE_ERROR_MFILE", "mfile" }, { G_FILE_ERROR_NFILE, "G_FILE_ERROR_NFILE", "nfile" }, { G_FILE_ERROR_BADF, "G_FILE_ERROR_BADF", "badf" }, { G_FILE_ERROR_INVAL, "G_FILE_ERROR_INVAL", "inval" }, { G_FILE_ERROR_PIPE, "G_FILE_ERROR_PIPE", "pipe" }, { G_FILE_ERROR_AGAIN, "G_FILE_ERROR_AGAIN", "again" }, { G_FILE_ERROR_INTR, "G_FILE_ERROR_INTR", "intr" }, { G_FILE_ERROR_IO, "G_FILE_ERROR_IO", "io" }, { G_FILE_ERROR_PERM, "G_FILE_ERROR_PERM", "perm" }, { G_FILE_ERROR_FAILED, "G_FILE_ERROR_FAILED", "failed" }, { 0, NULL, NULL } }; GType gperl_file_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GFileError", _gperl_file_error_values); return type; } #define GPERL_TYPE_FILE_ERROR gperl_file_error_get_type() GType gperl_file_error_get_type (void); /* -------------------------------------------------------------------------- */ static const GEnumValue _gperl_io_error_values[] = { { G_IO_ERROR_NONE, "G_IO_ERROR_NONE", "none" }, { G_IO_ERROR_AGAIN, "G_IO_ERROR_AGAIN", "again" }, { G_IO_ERROR_INVAL, "G_IO_ERROR_INVAL", "inval" }, { G_IO_ERROR_UNKNOWN, "G_IO_ERROR_UNKNOWN", "unknown" }, { 0, NULL, NULL } }; GType gperl_io_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GIOError", _gperl_io_error_values); return type; } #define GPERL_TYPE_IO_ERROR gperl_io_error_get_type() GType gperl_io_error_get_type (void); /* -------------------------------------------------------------------------- */ static const GEnumValue _gperl_io_channel_error_values[] = { { G_IO_CHANNEL_ERROR_FBIG, "G_IO_CHANNEL_ERROR_FBIG", "fbig" }, { G_IO_CHANNEL_ERROR_INVAL, "G_IO_CHANNEL_ERROR_INVAL", "inval" }, { G_IO_CHANNEL_ERROR_IO, "G_IO_CHANNEL_ERROR_IO", "io" }, { G_IO_CHANNEL_ERROR_ISDIR, "G_IO_CHANNEL_ERROR_ISDIR", "isdir" }, { G_IO_CHANNEL_ERROR_NOSPC, "G_IO_CHANNEL_ERROR_NOSPC", "nospc" }, { G_IO_CHANNEL_ERROR_NXIO, "G_IO_CHANNEL_ERROR_NXIO", "nxio" }, { G_IO_CHANNEL_ERROR_OVERFLOW, "G_IO_CHANNEL_ERROR_OVERFLOW", "overflow" }, { G_IO_CHANNEL_ERROR_PIPE, "G_IO_CHANNEL_ERROR_PIPE", "pipe" }, { G_IO_CHANNEL_ERROR_FAILED, "G_IO_CHANNEL_ERROR_FAILED", "failed" }, { 0, NULL, NULL } }; GType gperl_io_channel_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GIOChannelError", _gperl_io_channel_error_values); return type; } #define GPERL_TYPE_IO_CHANNEL_ERROR gperl_io_channel_error_get_type() GType gperl_io_channel_error_get_type (void); /* -------------------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 6, 0) static const GEnumValue _gperl_key_file_error_values[] = { { G_KEY_FILE_ERROR_UNKNOWN_ENCODING, "G_KEY_FILE_ERROR_UNKNOWN_ENCODING", "unknwon-encoding" }, { G_KEY_FILE_ERROR_PARSE, "G_KEY_FILE_ERROR_PARSE", "parse" }, { G_KEY_FILE_ERROR_NOT_FOUND, "G_KEY_FILE_ERROR_NOT_FOUND", "not-found" }, { G_KEY_FILE_ERROR_KEY_NOT_FOUND, "G_KEY_FILE_ERROR_KEY_NOT_FOUND", "key-not-found" }, { G_KEY_FILE_ERROR_GROUP_NOT_FOUND, "G_KEY_FILE_ERROR_GROUP_NOT_FOUND", "group-not-found" }, { G_KEY_FILE_ERROR_INVALID_VALUE, "G_KEY_FILE_ERROR_INVALID_VALUE", "invalid-value" }, { 0, NULL, NULL } }; GType gperl_key_file_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GKeyFileError", _gperl_key_file_error_values); return type; } #define GPERL_TYPE_KEY_FILE_ERROR gperl_key_file_error_get_type() GType gperl_key_file_error_get_type (void); #endif /* GLIB_CHECK_VERSION (2, 6, 0) */ /* -------------------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 12, 0) static const GEnumValue _gperl_bookmark_file_error_values[] = { { G_BOOKMARK_FILE_ERROR_INVALID_URI, "G_BOOKMARK_FILE_ERROR_INVALID_URI", "invalid-uri" }, { G_BOOKMARK_FILE_ERROR_INVALID_VALUE, "G_BOOKMARK_FILE_ERROR_INVALID_VALUE", "invalid-value" }, { G_BOOKMARK_FILE_ERROR_APP_NOT_REGISTERED, "G_BOOKMARK_FILE_ERROR_APP_NOT_REGISTERED", "not-registered" }, { G_BOOKMARK_FILE_ERROR_URI_NOT_FOUND, "G_BOOKMARK_FILE_ERROR_URI_NOT_FOUND", "uri-not-found" }, { G_BOOKMARK_FILE_ERROR_READ, "G_BOOKMARK_FILE_ERROR_URI_NOT_FOUND", "read" }, { G_BOOKMARK_FILE_ERROR_UNKNOWN_ENCODING, "G_BOOKMARK_FILE_ERROR_UNKNOWN_ENCODING", "unknown-encoding" }, { G_BOOKMARK_FILE_ERROR_WRITE, "G_BOOKMARK_FILE_ERROR_WRITE", "write" }, { G_BOOKMARK_FILE_ERROR_FILE_NOT_FOUND, "G_BOOKMARK_FILE_ERROR_FILE_NOT_FOUND", "not-found" }, { 0, NULL, NULL }, }; GType gperl_bookmark_file_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GBookmarkFileError", _gperl_bookmark_file_error_values); return type; } #define GPERL_TYPE_BOOKMARK_FILE_ERROR gperl_bookmark_file_error_get_type() GType gperl_bookmark_file_error_get_type (void); #endif /* GLIB_CHECK_VERSION (2, 12, 0) */ /* -------------------------------------------------------------------------- */ static const GEnumValue _gperl_markup_error_values[] = { { G_MARKUP_ERROR_BAD_UTF8, "G_MARKUP_ERROR_BAD_UTF8", "bad-utf8" }, { G_MARKUP_ERROR_EMPTY, "G_MARKUP_ERROR_EMPTY", "empty" }, { G_MARKUP_ERROR_PARSE, "G_MARKUP_ERROR_PARSE", "parse" }, { G_MARKUP_ERROR_UNKNOWN_ELEMENT, "G_MARKUP_ERROR_UNKNOWN_ELEMENT", "unknown-element" }, { G_MARKUP_ERROR_UNKNOWN_ATTRIBUTE, "G_MARKUP_ERROR_UNKNOWN_ATTRIBUTE", "unknown-attribute" }, { G_MARKUP_ERROR_INVALID_CONTENT, "G_MARKUP_ERROR_INVALID_CONTENT", "invalid-content" }, { 0, NULL, NULL } }; GType gperl_markup_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GMarkupError", _gperl_markup_error_values); return type; } #define GPERL_TYPE_MARKUP_ERROR gperl_markup_error_get_type() GType gperl_markup_error_get_type (void); /* -------------------------------------------------------------------------- */ static const GEnumValue _gperl_shell_error_values[] = { { G_SHELL_ERROR_BAD_QUOTING, "G_SHELL_ERROR_BAD_QUOTING", "bad-quoting" }, { G_SHELL_ERROR_EMPTY_STRING, "G_SHELL_ERROR_EMPTY_STRING", "empty-string" }, { G_SHELL_ERROR_FAILED, "G_SHELL_ERROR_FAILED", "failed" }, { 0, NULL, NULL } }; GType gperl_shell_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GShellError", _gperl_shell_error_values); return type; } #define GPERL_TYPE_SHELL_ERROR gperl_shell_error_get_type() GType gperl_shell_error_get_type (void); /* -------------------------------------------------------------------------- */ static const GEnumValue _gperl_spawn_error_values[] = { { G_SPAWN_ERROR_FORK, "G_SPAWN_ERROR_FORK", "fork" }, { G_SPAWN_ERROR_READ, "G_SPAWN_ERROR_READ", "read" }, { G_SPAWN_ERROR_CHDIR, "G_SPAWN_ERROR_CHDIR", "chdir" }, { G_SPAWN_ERROR_ACCES, "G_SPAWN_ERROR_ACCES", "acces" }, { G_SPAWN_ERROR_PERM, "G_SPAWN_ERROR_PERM", "perm" }, { G_SPAWN_ERROR_2BIG, "G_SPAWN_ERROR_2BIG", "2big" }, { G_SPAWN_ERROR_NOEXEC, "G_SPAWN_ERROR_NOEXEC", "noexec" }, { G_SPAWN_ERROR_NAMETOOLONG, "G_SPAWN_ERROR_NAMETOOLONG", "nametoolong" }, { G_SPAWN_ERROR_NOENT, "G_SPAWN_ERROR_NOENT", "noent" }, { G_SPAWN_ERROR_NOMEM, "G_SPAWN_ERROR_NOMEM", "nomem" }, { G_SPAWN_ERROR_NOTDIR, "G_SPAWN_ERROR_NOTDIR", "notdir" }, { G_SPAWN_ERROR_LOOP, "G_SPAWN_ERROR_LOOP", "loop" }, { G_SPAWN_ERROR_TXTBUSY, "G_SPAWN_ERROR_TXTBUSY", "txtbusy" }, { G_SPAWN_ERROR_IO, "G_SPAWN_ERROR_IO", "io" }, { G_SPAWN_ERROR_NFILE, "G_SPAWN_ERROR_NFILE", "nfile" }, { G_SPAWN_ERROR_MFILE, "G_SPAWN_ERROR_MFILE", "mfile" }, { G_SPAWN_ERROR_INVAL, "G_SPAWN_ERROR_INVAL", "inval" }, { G_SPAWN_ERROR_ISDIR, "G_SPAWN_ERROR_ISDIR", "isdir" }, { G_SPAWN_ERROR_LIBBAD, "G_SPAWN_ERROR_LIBBAD", "libbad" }, { G_SPAWN_ERROR_FAILED, "G_SPAWN_ERROR_FAILED", "failed" }, { 0, NULL, NULL } }; GType gperl_spawn_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GSpawnError", _gperl_spawn_error_values); return type; } #define GPERL_TYPE_SPAWN_ERROR gperl_spawn_error_get_type() GType gperl_spawn_error_get_type (void); /* -------------------------------------------------------------------------- */ static const GEnumValue _gperl_thread_error_values[] = { { G_THREAD_ERROR_AGAIN, "G_THREAD_ERROR_AGAIN", "again" }, { 0, NULL, NULL } }; GType gperl_thread_error_get_type (void) { static GType type = 0; if (!type) type = g_enum_register_static ("GThreadError", _gperl_thread_error_values); return type; } #define GPERL_TYPE_THREAD_ERROR gperl_thread_error_get_type() GType gperl_thread_error_get_type (void); /* -------------------------------------------------------------------------- */ /* The enum in its current form was added later than GVariant itself. */ #if GLIB_CHECK_VERSION (2, 28, 0) GType gperl_variant_parse_error_get_type (void) { static GType type = 0; if (!type) { static const GEnumValue values[] = { { G_VARIANT_PARSE_ERROR_FAILED, "G_VARIANT_PARSE_ERROR_FAILED", "failed" }, { G_VARIANT_PARSE_ERROR_BASIC_TYPE_EXPECTED, "G_VARIANT_PARSE_ERROR_BASIC_TYPE_EXPECTED", "basic-type-expected" }, { G_VARIANT_PARSE_ERROR_CANNOT_INFER_TYPE, "G_VARIANT_PARSE_ERROR_CANNOT_INFER_TYPE", "cannot-infer-type" }, { G_VARIANT_PARSE_ERROR_DEFINITE_TYPE_EXPECTED, "G_VARIANT_PARSE_ERROR_DEFINITE_TYPE_EXPECTED", "definite-type-expected" }, { G_VARIANT_PARSE_ERROR_INPUT_NOT_AT_END, "G_VARIANT_PARSE_ERROR_INPUT_NOT_AT_END", "input-not-at-end" }, { G_VARIANT_PARSE_ERROR_INVALID_CHARACTER, "G_VARIANT_PARSE_ERROR_INVALID_CHARACTER", "invalid-character" }, { G_VARIANT_PARSE_ERROR_INVALID_FORMAT_STRING, "G_VARIANT_PARSE_ERROR_INVALID_FORMAT_STRING", "invalid-format-string" }, { G_VARIANT_PARSE_ERROR_INVALID_OBJECT_PATH, "G_VARIANT_PARSE_ERROR_INVALID_OBJECT_PATH", "invalid-object-path" }, { G_VARIANT_PARSE_ERROR_INVALID_SIGNATURE, "G_VARIANT_PARSE_ERROR_INVALID_SIGNATURE", "invalid-signature" }, { G_VARIANT_PARSE_ERROR_INVALID_TYPE_STRING, "G_VARIANT_PARSE_ERROR_INVALID_TYPE_STRING", "invalid-type-string" }, { G_VARIANT_PARSE_ERROR_NO_COMMON_TYPE, "G_VARIANT_PARSE_ERROR_NO_COMMON_TYPE", "no-common-type" }, { G_VARIANT_PARSE_ERROR_NUMBER_OUT_OF_RANGE, "G_VARIANT_PARSE_ERROR_NUMBER_OUT_OF_RANGE", "number-out-of-range" }, { G_VARIANT_PARSE_ERROR_NUMBER_TOO_BIG, "G_VARIANT_PARSE_ERROR_NUMBER_TOO_BIG", "number-too-big" }, { G_VARIANT_PARSE_ERROR_TYPE_ERROR, "G_VARIANT_PARSE_ERROR_TYPE_ERROR", "type-error" }, { G_VARIANT_PARSE_ERROR_UNEXPECTED_TOKEN, "G_VARIANT_PARSE_ERROR_UNEXPECTED_TOKEN", "unexpected-token" }, { G_VARIANT_PARSE_ERROR_UNKNOWN_KEYWORD, "G_VARIANT_PARSE_ERROR_UNKNOWN_KEYWORD", "unknown-keyword" }, { G_VARIANT_PARSE_ERROR_UNTERMINATED_STRING_CONSTANT, "G_VARIANT_PARSE_ERROR_UNTERMINATED_STRING_CONSTANT", "unterminated-string-constant" }, { G_VARIANT_PARSE_ERROR_VALUE_EXPECTED, "G_VARIANT_PARSE_ERROR_VALUE_EXPECTED", "value-expected" }, { 0, NULL, NULL } }; type = g_enum_register_static ("GVariantParseError", values); } return type; } #endif Glib-1.320/gperl-gtypes.h000644 001750 000024 00000006111 12636024471 016266 0ustar00bdmanningstaff000000 000000 #ifndef __GPERL_GTYPES_H__ #define __GPERL_GTYPES_H__ 1 #include G_BEGIN_DECLS /* --- Enums/Flags: --------------------------------------------------------- */ #define GPERL_TYPE_CONNECT_FLAGS gperl_connect_flags_get_type () GType gperl_connect_flags_get_type (void) G_GNUC_CONST; #if GLIB_CHECK_VERSION (2, 6, 0) #define GPERL_TYPE_KEY_FILE_FLAGS gperl_key_file_flags_get_type() GType gperl_key_file_flags_get_type (void) G_GNUC_CONST; #endif #define GPERL_TYPE_LOG_LEVEL_FLAGS gperl_log_level_flags_get_type () GType gperl_log_level_flags_get_type (void) G_GNUC_CONST; #if GLIB_CHECK_VERSION (2, 6, 0) #define GPERL_TYPE_OPTION_FLAGS gperl_option_flags_get_type () GType gperl_option_flags_get_type (void) G_GNUC_CONST; #endif #if GLIB_CHECK_VERSION (2, 12, 0) #define GPERL_TYPE_OPTION_ARG gperl_option_arg_get_type () GType gperl_option_arg_get_type (void) G_GNUC_CONST; #endif /* the obvious G_TYPE_PARAM_FLAGS is taken by GParamSpecFlags. */ #define GPERL_TYPE_PARAM_FLAGS gperl_param_flags_get_type () GType gperl_param_flags_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_SIGNAL_FLAGS gperl_signal_flags_get_type () GType gperl_signal_flags_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_SPAWN_FLAGS gperl_spawn_flags_get_type () GType gperl_spawn_flags_get_type (void) G_GNUC_CONST; #if GLIB_CHECK_VERSION (2, 14, 0) #define GPERL_TYPE_USER_DIRECTORY gperl_user_directory_get_type () GType gperl_user_directory_get_type (void) G_GNUC_CONST; #endif /* --- Error values: -------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 12, 0) #define GPERL_TYPE_BOOKMARK_FILE_ERROR gperl_bookmark_file_error_get_type () GType gperl_bookmark_file_error_get_type (void) G_GNUC_CONST; #endif /* GLIB_CHECK_VERSION (2, 12, 0) */ #define GPERL_TYPE_CONVERT_ERROR gperl_convert_error_get_type () GType gperl_convert_error_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_FILE_ERROR gperl_file_error_get_type () GType gperl_file_error_get_type (void) G_GNUC_CONST; #if GLIB_CHECK_VERSION (2, 6, 0) #define GPERL_TYPE_KEY_FILE_ERROR gperl_key_file_error_get_type () GType gperl_key_file_error_get_type (void) G_GNUC_CONST; #endif /* GLIB_CHECK_VERSION (2, 6, 0) */ #define GPERL_TYPE_IO_ERROR gperl_io_error_get_type () GType gperl_io_error_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_IO_CHANNEL_ERROR gperl_io_channel_error_get_type () GType gperl_io_channel_error_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_MARKUP_ERROR gperl_markup_error_get_type () GType gperl_markup_error_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_SHELL_ERROR gperl_shell_error_get_type () GType gperl_shell_error_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_SPAWN_ERROR gperl_spawn_error_get_type () GType gperl_spawn_error_get_type (void) G_GNUC_CONST; #define GPERL_TYPE_THREAD_ERROR gperl_thread_error_get_type () GType gperl_thread_error_get_type (void) G_GNUC_CONST; #if GLIB_CHECK_VERSION (2, 24, 0) #define GPERL_TYPE_VARIANT_PARSE_ERROR gperl_variant_parse_error_get_type () GType gperl_variant_parse_error_get_type (void); #endif G_END_DECLS #endif /* __GPERL_GTYPES_H__ */ Glib-1.320/gperl-private.h000644 001750 000024 00000002641 11776420676 016444 0ustar00bdmanningstaff000000 000000 /* * Copyright (c) 2006, 2012 by the gtk2-perl team (see the file AUTHORS) * * Licensed under the LGPL, see LICENSE file for more information. * * $Id$ */ /* * This is a private header file intended for functions that are used in more * than one xs file. These functions are not part of the public API. */ #ifndef _GPERL_PRIVATE_H_ #define _GPERL_PRIVATE_H_ /* * Thread-safety macros and helpers */ void _gperl_set_master_interp (PerlInterpreter *interp); PerlInterpreter *_gperl_get_master_interp (void); #define GPERL_SET_CONTEXT \ { \ PerlInterpreter *me = _gperl_get_master_interp (); \ if (me && !PERL_GET_CONTEXT) { \ PERL_SET_CONTEXT (me); \ } \ } #ifndef PERL_IMPLICIT_CONTEXT GThread * _gperl_get_main_tid (void); #endif /* * Misc. stuff */ SV * _gperl_sv_from_value_internal (const GValue * value, gboolean copy_boxed); SV * _gperl_fetch_wrapper_key (GObject * object, const char * name, gboolean create); #define SAVED_STACK_SV(expr) \ ({ \ SV *_saved_stack_sv; \ PUTBACK; \ _saved_stack_sv = expr; \ SPAGAIN; \ _saved_stack_sv; \ }) #define SAVED_STACK_PUSHs(expr) \ (void) ({ \ SV *_saved_stack_sv = SAVED_STACK_SV (expr); \ PUSHs (_saved_stack_sv); \ }) #define SAVED_STACK_XPUSHs(expr) \ (void) ({ \ SV *_saved_stack_sv = SAVED_STACK_SV (expr); \ XPUSHs (_saved_stack_sv); \ }) #endif /* _GPERL_PRIVATE_H_ */ Glib-1.320/gperl.h000644 001750 000024 00000040362 12636024471 014763 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2005, 2010, 2013 by the gtk2-perl team (see the file * AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ #ifndef _GPERL_H_ #define _GPERL_H_ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef WIN32 /* perl and glib disagree on a few macros... let the wookie win. */ # undef pipe # undef malloc # undef realloc # undef free #endif #include /* * --- filenames -------------------------------------------------------------- */ typedef gchar* GPerlFilename; typedef const gchar* GPerlFilename_const; typedef gchar* GPerlFilename_own; typedef GPerlFilename GPerlFilename_ornull; gchar *gperl_filename_from_sv (SV *sv); SV *gperl_sv_from_filename (const gchar *filename); /* * --- enums and flags -------------------------------------------------------- */ gboolean gperl_try_convert_enum (GType type, SV * sv, gint * val); gint gperl_convert_enum (GType type, SV * val); SV * gperl_convert_back_enum_pass_unknown (GType type, gint val); SV * gperl_convert_back_enum (GType type, gint val); gboolean gperl_try_convert_flag (GType type, const char * val_p, gint * val); gint gperl_convert_flag_one (GType type, const char * val_p); gint gperl_convert_flags (GType type, SV * val); SV * gperl_convert_back_flags (GType type, gint val); /* * --- fundamental types ------------------------------------------------------ */ typedef struct _GPerlValueWrapperClass GPerlValueWrapperClass; typedef SV* (*GPerlValueWrapFunc) (const GValue * value); typedef void (*GPerlValueUnwrapFunc) (GValue * value, SV * sv); struct _GPerlValueWrapperClass { GPerlValueWrapFunc wrap; GPerlValueUnwrapFunc unwrap; }; void gperl_register_fundamental (GType gtype, const char * package); void gperl_register_fundamental_alias (GType gtype, const char * package); void gperl_register_fundamental_full (GType gtype, const char * package, GPerlValueWrapperClass * wrapper_class); GType gperl_fundamental_type_from_package (const char * package); const char * gperl_fundamental_package_from_type (GType gtype); GPerlValueWrapperClass * gperl_fundamental_wrapper_class_from_type (GType gtype); /* * --- GErrors as exception objects ------------------------------------------- */ /* it is rare that you should ever want or need these two functions. */ SV * gperl_sv_from_gerror (GError * error); void gperl_gerror_from_sv (SV * sv, GError ** error); void gperl_register_error_domain (GQuark domain, GType error_enum, const char * package); void gperl_croak_gerror (const char * ignored, GError * err); /* * --- inheritance management ------------------------------------------------- */ /* push @{$parent_package}::ISA, $child_package */ void gperl_set_isa (const char * child_package, const char * parent_package); /* unshift @{$parent_package}::ISA, $child_package */ void gperl_prepend_isa (const char * child_package, const char * parent_package); /* these work regardless of what the actual type is (GBoxed, GObject, GEnum, * or GFlags). in general it's safer to use the most specific one, but this * is handy when you don't care. */ GType gperl_type_from_package (const char * package); const char * gperl_package_from_type (GType type); /* * --- gchar converters ------------------------------------------------------- */ typedef gchar gchar_length; /* length in bytes */ typedef gchar gchar_utf8_length; /* length in characters */ typedef gchar gchar_own; typedef gchar gchar_ornull; typedef gchar gchar_own_ornull; /* clean function wrappers for treating gchar* as UTF8 strings, in the * same idiom as the rest of the cast macros. these are wrapped up * as functions because comma expressions in macros get kinda tricky. */ /*const*/ gchar * SvGChar (SV * sv); SV * newSVGChar (const gchar * str); /* * --- 64 bit integer converters ---------------------------------------------- */ gint64 SvGInt64 (SV *sv); SV * newSVGInt64 (gint64 value); guint64 SvGUInt64 (SV *sv); SV * newSVGUInt64 (guint64 value); /* * --- GValue ----------------------------------------------------------------- */ gboolean gperl_value_from_sv (GValue * value, SV * sv); SV * gperl_sv_from_value (const GValue * value); /* * --- GBoxed ----------------------------------------------------------------- */ typedef struct _GPerlBoxedWrapperClass GPerlBoxedWrapperClass; typedef SV* (*GPerlBoxedWrapFunc) (GType gtype, const char * package, gpointer boxed, gboolean own); typedef gpointer (*GPerlBoxedUnwrapFunc) (GType gtype, const char * package, SV * sv); typedef void (*GPerlBoxedDestroyFunc) (SV * sv); struct _GPerlBoxedWrapperClass { GPerlBoxedWrapFunc wrap; GPerlBoxedUnwrapFunc unwrap; GPerlBoxedDestroyFunc destroy; }; GPerlBoxedWrapperClass * gperl_default_boxed_wrapper_class (void); void gperl_register_boxed (GType gtype, const char * package, GPerlBoxedWrapperClass * wrapper_class); void gperl_register_boxed_alias (GType gtype, const char * package); void gperl_register_boxed_synonym (GType registered_gtype, GType synonym_gtype); SV * gperl_new_boxed (gpointer boxed, GType gtype, gboolean own); SV * gperl_new_boxed_copy (gpointer boxed, GType gtype); gpointer gperl_get_boxed_check (SV * sv, GType gtype); GType gperl_boxed_type_from_package (const char * package); const char * gperl_boxed_package_from_type (GType type); /* * we need a GBoxed wrapper for a generic SV, so we can store SVs * in GObjects reliably. */ #define GPERL_TYPE_SV (gperl_sv_get_type ()) GType gperl_sv_get_type (void) G_GNUC_CONST; SV * gperl_sv_copy (SV * sv); void gperl_sv_free (SV * sv); /* * --- GObject ---------------------------------------------------------------- */ typedef GObject GObject_ornull; typedef GObject GObject_noinc; #define newSVGObject(obj) (gperl_new_object ((obj), FALSE)) #define newSVGObject_noinc(obj) (gperl_new_object ((obj), TRUE)) #define SvGObject(sv) (gperl_get_object_check (sv, G_TYPE_OBJECT)) #define SvGObject_ornull(sv) (gperl_sv_is_defined (sv) ? SvGObject (sv) : NULL) void gperl_register_object (GType gtype, const char * package); void gperl_register_object_alias (GType gtype, const char * package); typedef void (*GPerlObjectSinkFunc) (GObject *); void gperl_register_sink_func (GType gtype, GPerlObjectSinkFunc func); void gperl_object_set_no_warn_unreg_subclass (GType gtype, gboolean nowarn); const char * gperl_object_package_from_type (GType gtype); HV * gperl_object_stash_from_type (GType gtype); GType gperl_object_type_from_package (const char * package); SV * gperl_new_object (GObject * object, gboolean own); GObject * gperl_get_object (SV * sv); GObject * gperl_get_object_check (SV * sv, GType gtype); SV * gperl_object_check_type (SV * sv, GType gtype); void _gperl_attach_mg (SV * sv, void * ptr); MAGIC * _gperl_find_mg (SV * sv); void _gperl_remove_mg (SV * sv); /* * --- GSignal ---------------------------------------------------------------- */ SV * newSVGSignalFlags (GSignalFlags flags); GSignalFlags SvGSignalFlags (SV * sv); SV * newSVGSignalInvocationHint (GSignalInvocationHint * ihint); SV * newSVGSignalQuery (GSignalQuery * query); void gperl_signal_set_marshaller_for (GType instance_type, char * detailed_signal, GClosureMarshal marshaller); gulong gperl_signal_connect (SV * instance, char * detailed_signal, SV * callback, SV * data, GConnectFlags flags); /* * --- GClosure --------------------------------------------------------------- */ typedef struct _GPerlClosure GPerlClosure; struct _GPerlClosure { GClosure closure; SV * callback; SV * data; /* callback data */ gboolean swap; /* TRUE if target and data are to be swapped */ int id; }; /* evaluates to true if the instance and data are to be swapped on invocation */ #define GPERL_CLOSURE_SWAP_DATA(gpc) ((gpc)->swap) /* this is the one you want. */ GClosure * gperl_closure_new (SV * callback, SV * data, gboolean swap); /* very scary, use only if you really know what you are doing */ GClosure * gperl_closure_new_with_marshaller (SV * callback, SV * data, gboolean swap, GClosureMarshal marshaller); /* * --- GPerlCallback ---------------------------------------------------------- */ typedef struct _GPerlCallback GPerlCallback; struct _GPerlCallback { gint n_params; GType * param_types; GType return_type; SV * func; SV * data; void * priv; }; GPerlCallback * gperl_callback_new (SV * func, SV * data, gint n_params, GType param_types[], GType return_type); void gperl_callback_destroy (GPerlCallback * callback); void gperl_callback_invoke (GPerlCallback * callback, GValue * return_value, ...); /* * --- exception handling ----------------------------------------------------- */ int gperl_install_exception_handler (GClosure * closure); void gperl_remove_exception_handler (guint tag); void gperl_run_exception_handlers (void); /* * --- log handling for extensions -------------------------------------------- */ gint gperl_handle_logs_for (const gchar * log_domain); /* * --- GParamSpec ------------------------------------------------------------- */ typedef GParamSpec GParamSpec_ornull; SV * newSVGParamSpec (GParamSpec * pspec); GParamSpec * SvGParamSpec (SV * sv); #define newSVGParamSpec_ornull(sv) newSVGParamSpec(sv) SV * newSVGParamFlags (GParamFlags flags); GParamFlags SvGParamFlags (SV * sv); void gperl_register_param_spec (GType gtype, const char * package); const char * gperl_param_spec_package_from_type (GType gtype); GType gperl_param_spec_type_from_package (const char * package); /* * --- GKeyFile --------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 6, 0) SV * newSVGKeyFile (GKeyFile * key_file); GKeyFile * SvGKeyFile (SV * sv); SV * newSVGKeyFileFlags (GKeyFileFlags flags); GKeyFileFlags SvGKeyFileFlags (SV * sv); #endif /* GLIB_CHECK_VERSION (2, 6, 0) */ /* * --- GBookmarkFile ---------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 12, 0) SV * newSVGBookmarkFile (GBookmarkFile * bookmark_file); GBookmarkFile * SvGBookmarkFile (SV * sv); #endif /* GLIB_CHECK_VERSION (2, 12, 0) */ /* * --- GOption ---------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 6, 0) typedef GOptionContext GOptionContext_own; #define GPERL_TYPE_OPTION_CONTEXT (gperl_option_context_get_type ()) GType gperl_option_context_get_type (void); #define SvGOptionContext(sv) (gperl_get_boxed_check ((sv), GPERL_TYPE_OPTION_CONTEXT)) #define newSVGOptionContext(val) (gperl_new_boxed ((gpointer) (val), GPERL_TYPE_OPTION_CONTEXT, FALSE)) #define newSVGOptionContext_own(val) (gperl_new_boxed ((gpointer) (val), GPERL_TYPE_OPTION_CONTEXT, TRUE)) typedef GOptionGroup GOptionGroup_own; #define GPERL_TYPE_OPTION_GROUP (gperl_option_group_get_type ()) GType gperl_option_group_get_type (void); #define SvGOptionGroup(sv) (gperl_get_boxed_check ((sv), GPERL_TYPE_OPTION_GROUP)) #define newSVGOptionGroup(val) (gperl_new_boxed ((gpointer) (val), GPERL_TYPE_OPTION_GROUP, FALSE)) #define newSVGOptionGroup_own(val) (gperl_new_boxed ((gpointer) (val), GPERL_TYPE_OPTION_GROUP, TRUE)) #endif /* 2.6.0 */ /* * --- gutils.h / GUtils.xs --------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 14, 0) GUserDirectory SvGUserDirectory (SV *sv); SV * newSVGUserDirectory (GUserDirectory dir); #endif /* * --- GVariant --------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 24, 0) typedef GVariant GVariant_noinc; SV * newSVGVariant (GVariant * variant); SV * newSVGVariant_noinc (GVariant * variant); GVariant * SvGVariant (SV * sv); typedef GVariantType GVariantType_own; SV * newSVGVariantType (const GVariantType * type); SV * newSVGVariantType_own (const GVariantType * type); const GVariantType * SvGVariantType (SV * sv); #endif /* 2.24.0 */ /* * --- GBytes ----------------------------------------------------------------- */ #if GLIB_CHECK_VERSION (2, 32, 0) typedef GBytes GBytes_own; #define SvGBytes(sv) (gperl_get_boxed_check ((sv), G_TYPE_BYTES)) #define newSVGBytes(val) (gperl_new_boxed ((gpointer) (val), G_TYPE_BYTES, FALSE)) #define newSVGBytes_own(val) (gperl_new_boxed ((gpointer) (val), G_TYPE_BYTES, TRUE)) #endif /* * --- miscellaneous ---------------------------------------------------------- */ /* for use with the typemap */ typedef char char_ornull; typedef char char_own; typedef char char_own_ornull; typedef char char_byte; typedef char char_byte_ornull; /* never use this function directly. use GPERL_CALL_BOOT. */ void _gperl_call_XS (pTHX_ void (*subaddr) (pTHX_ CV *), CV * cv, SV ** mark); /* * call the boot code of a module by symbol rather than by name. * * in a perl extension which uses several xs files but only one pm, you * need to bootstrap the other xs files in order to get their functions * exported to perl. if the file has MODULE = Foo::Bar, the boot symbol * would be boot_Foo__Bar. */ #ifndef XS_EXTERNAL # define XS_EXTERNAL(name) XS(name) #endif #define GPERL_CALL_BOOT(name) \ { \ extern XS_EXTERNAL (name); \ _gperl_call_XS (aTHX_ name, cv, mark); \ } gpointer gperl_alloc_temp (int nbytes); gboolean gperl_str_eq (const char * a, const char * b); guint gperl_str_hash (gconstpointer key); typedef struct { int argc; char **argv; void *priv; } GPerlArgv; GPerlArgv * gperl_argv_new (void); void gperl_argv_update (GPerlArgv *pargv); void gperl_argv_free (GPerlArgv *pargv); char * gperl_format_variable_for_output (SV * sv); gboolean gperl_sv_is_defined (SV *sv); #define gperl_sv_is_ref(sv) \ (gperl_sv_is_defined (sv) && SvROK (sv)) #define gperl_sv_is_array_ref(sv) \ (gperl_sv_is_ref (sv) && SvTYPE (SvRV(sv)) == SVt_PVAV) #define gperl_sv_is_code_ref(sv) \ (gperl_sv_is_ref (sv) && SvTYPE (SvRV(sv)) == SVt_PVCV) #define gperl_sv_is_hash_ref(sv) \ (gperl_sv_is_ref (sv) && SvTYPE (SvRV(sv)) == SVt_PVHV) void gperl_hv_take_sv (HV *hv, const char *key, size_t key_length, SV *sv); /* helper wrapper for static string literals. concatenating with "" enforces * the restriction. */ #define gperl_hv_take_sv_s(hv, key, sv) \ gperl_hv_take_sv (hv, "" key "", sizeof(key) - 1, sv) /* internal trickery */ gpointer gperl_type_class (GType type); /* * helpful debugging stuff */ #define GPERL_OBJECT_VITALS(o) \ ((o) \ ? form ("%s(%p)[%d]", G_OBJECT_TYPE_NAME (o), (o), \ G_OBJECT (o)->ref_count) \ : "NULL") #define GPERL_WRAPPER_VITALS(w) \ ((SvTRUE (w)) \ ? ((SvROK (w)) \ ? form ("SvRV(%p)->%s(%p)[%d]", (w), \ sv_reftype (SvRV (w), TRUE), \ SvRV (w), SvREFCNT (SvRV (w))) \ : "[not a reference!]") \ : "undef") #endif /* _GPERL_H_ */ Glib-1.320/gperl_marshal.h000644 001750 000024 00000016267 11776420676 016514 0ustar00bdmanningstaff000000 000000 #ifndef __GPERL_MARSHAL_H__ #define __GPERL_MARSHAL_H__ /* * here lie a few macros to reduce the amount of copied code needed when * writing custom marshallers for GPerlClosures. you'll typically need * this if you are trying to make a signal's arguments writable, implement * custom handling of G_TYPE_POINTER arguments, or other special * circumstances. */ #if 0 /* comment with embedded C comments... */ =for example A typical marshaller skeleton will look like this: static void some_custom_marshaler (GClosure * closure, GValue * return_value, guint n_param_values, const GValue * param_values, gpointer invocation_hint, gpointer marshal_data) { dGPERL_CLOSURE_MARSHAL_ARGS; GPERL_CLOSURE_MARSHAL_INIT (closure, marshal_data); PERL_UNUSED_VAR (return_value); PERL_UNUSED_VAR (n_param_values); PERL_UNUSED_VAR (invocation_hint); ENTER; SAVETMPS; PUSHMARK (SP); GPERL_CLOSURE_MARSHAL_PUSH_INSTANCE (param_values); /* * push more parameters onto the perl stack... the ones * in which we are interested are param_values[1] through * param_values[n_param_values-1], because the 0th one * has been handled for us. */ GPERL_CLOSURE_MARSHAL_PUSH_DATA; PUTBACK; /* this example invokes the callback in array context. * other options are G_DISCARD and G_SCALAR. see C * in L. */ GPERL_CLOSURE_MARSHAL_CALL (G_ARRAY); /* * get return values, if needed, and clean up. * "count" will contain the number of values returned on the * stack. */ FREETMPS; LEAVE; } =cut #endif /* =item dGPERL_CLOSURE_MARSHAL_ARGS Declare several stack variables that the various GPERL_CLOSURE_MARSHAL macros will need. Declares C for you. This must go near the top of your C function, before any code statements. =cut */ #define dGPERL_CLOSURE_MARSHAL_ARGS \ GPerlClosure * pc; \ int count; \ SV * data; \ SV * instance; \ SV ** sp; /* =item GPERL_CLOSURE_MARSHAL_INIT (closure, marshal_data) This must be called as the first non-declaration statement in the marshaller function. In a threaded/threadable Perl, this ensures that all Perl API calls within the function happen in the same Perl interpreter that created the callback; if this is not first, strange things will happen. This statement also initalizes C (the perl closure object) on the stack. =cut */ #ifdef PERL_IMPLICIT_CONTEXT # define GPERL_CLOSURE_MARSHAL_INIT(closure, marshal_data) \ /* make sure we're executed by the same interpreter */ \ /* that created the closure object. */ \ PERL_SET_CONTEXT (marshal_data); \ SPAGAIN; \ pc = (GPerlClosure *) closure; #else # define GPERL_CLOSURE_MARSHAL_INIT(closure, marshal_data) \ PERL_UNUSED_VAR (marshal_data); \ SPAGAIN; \ pc = (GPerlClosure *) closure; #endif /* =item GPERL_CLOSURE_MARSHAL_PUSH_INSTANCE(param_values) This pushes the callback's instance (first parameter) onto the Perl argument stack, with XPUSHs. Handles the case of swapped instance and data. I is the array of GValues passed into your marshaller. Note that the instance comes from param_values[0], so you needn't worry about that one when putting the rest of the parameters on the arg stack. This assumes that n_param_values > 1. =cut */ /* note -- keep an eye on the refcounts of instance and data! */ #define GPERL_CLOSURE_MARSHAL_PUSH_INSTANCE(param_values) \ PUTBACK; \ if (GPERL_CLOSURE_SWAP_DATA (pc)) { \ /* swap instance and data */ \ data = gperl_sv_from_value (param_values); \ instance = SvREFCNT_inc (pc->data); \ } else { \ /* normal */ \ instance = gperl_sv_from_value (param_values); \ data = SvREFCNT_inc (pc->data); \ } \ SPAGAIN; \ if (!instance) \ instance = &PL_sv_undef; \ /* the instance is always the first item in @_ */ \ XPUSHs (sv_2mortal (instance)); /* =item GPERL_CLOSURE_MARSHAL_PUSH_DATA Push the callback's user data onto the Perl arg stack, with XPUSHs. Handles the case of swapped instance and data. The user data is not included in param_values. =cut */ #define GPERL_CLOSURE_MARSHAL_PUSH_DATA \ if (data) XPUSHs (sv_2mortal (data)); /* =item GPERL_CLOSURE_MARSHAL_CALL(flags) Invoke the callback. You must ensure that all the arguments are already on the stack, and that you've called PUTBACK. This will invoke call_sv(), adding G_EVAL to the I you supply, and store the return value in I on the stack (count is declared by C). It then refreshes the stack pointer. If an exception occurred, the function returns after running exception handlers. You'll be interested in the following values for I: G_DISCARD this is effectively "void return", as it discards whatever the callback put on the return stack. G_SCALAR invoke the callback in scalar context. you are pretty much guaranteed that one item will be on the stack, even if it is undef. G_ARRAY invoke the callback in array context. C (declared by C) will contain the number of items on the return stack. As the callback is always run with G_EVAL, call_sv() will clobber ERRSV ($@); since closures are typically part of a mechanism that is transparent to the layer of Perl code that calls them, we save and restore ERRSV. Thus, code like eval { something that fails } $button->clicked; # $@ still has value from eval above works as expected. See C in L for more information. =cut */ #define GPERL_CLOSURE_MARSHAL_CALL(flags) \ { \ /* copy is needed to keep the old value alive. */ \ /* mortal so it will die if not stolen by SvSetSV. */ \ SV * save_errsv = sv_2mortal (newSVsv (ERRSV)); \ count = call_sv (pc->callback, (flags) | G_EVAL); \ SPAGAIN; \ if (SvTRUE (ERRSV)) { \ gperl_run_exception_handlers (); \ SvSetSV (ERRSV, save_errsv); \ FREETMPS; \ LEAVE; \ return; \ } \ SvSetSV (ERRSV, save_errsv); \ } /***************************************************************************/ /* =item dGPERL_CALLBACK_MARSHAL_SP Declare the stack pointer such that it can be properly initialized by C. Do I just use C. This should always come last in a list of declarations as its expansion might contain statements under certain conditions. =item GPERL_CALLBACK_MARSHAL_INIT(callback) Initialize the callback stuff. This must happen before any other Perl API statements in the callback marshaller. In a threaded Perl, this ensures that the proper interpreter context is used; if this isn't first, you'll mix and match two contexts and bad things will happen. =cut */ #ifdef PERL_IMPLICIT_CONTEXT # define dGPERL_CALLBACK_MARSHAL_SP \ SV ** sp; # define GPERL_CALLBACK_MARSHAL_INIT(callback) \ PERL_SET_CONTEXT (callback->priv); \ SPAGAIN; #else # define dGPERL_CALLBACK_MARSHAL_SP \ dSP; # define GPERL_CALLBACK_MARSHAL_INIT(callback) \ /* nothing to do */ #endif #endif /* __GPERL_MARSHAL_H__ */ Glib-1.320/GSignal.xs000644 001750 000024 00000105520 12251766676 015414 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2004, 2009, 2012-2013 by the gtk2-perl team (see the * file AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ =head2 GSignal =over =cut /* #define NOISY */ #include "gperl.h" #include "gperl-gtypes.h" #include "gperl-private.h" /* for SAVED_STACK_SV */ /* * here's a nice G_LOCK-like front-end to GStaticRecMutex. we need this * to keep other threads from fiddling with the closures list while we're * modifying it. */ #ifdef G_THREADS_ENABLED # if GLIB_CHECK_VERSION (2, 32, 0) # define GPERL_REC_LOCK_DEFINE_STATIC(name) static GPERL_REC_LOCK_DEFINE (name) # define GPERL_REC_LOCK_DEFINE(name) GRecMutex G_LOCK_NAME (name) # define GPERL_REC_LOCK(name) g_rec_mutex_lock (&G_LOCK_NAME (name)) # define GPERL_REC_UNLOCK(name) g_rec_mutex_unlock (&G_LOCK_NAME (name)) # else # define GPERL_REC_LOCK_DEFINE_STATIC(name) \ GStaticRecMutex G_LOCK_NAME (name) = G_STATIC_REC_MUTEX_INIT # define GPERL_REC_LOCK(name) \ g_static_rec_mutex_lock (&G_LOCK_NAME (name)) # define GPERL_REC_UNLOCK(name) \ g_static_rec_mutex_unlock (&G_LOCK_NAME (name)) # endif #else # define GPERL_REC_LOCK_DEFINE_STATIC(name) extern void glib_dummy_decl (void) # define GPERL_REC_LOCK(name) # define GPERL_REC_UNLOCK(name) #endif SV * newSVGSignalFlags (GSignalFlags flags) { return gperl_convert_back_flags (GPERL_TYPE_SIGNAL_FLAGS, flags); } GSignalFlags SvGSignalFlags (SV * sv) { return gperl_convert_flags (GPERL_TYPE_SIGNAL_FLAGS, sv); } SV * newSVGSignalInvocationHint (GSignalInvocationHint * ihint) { HV * hv = newHV (); gperl_hv_take_sv_s (hv, "signal_name", newSVGChar (g_signal_name (ihint->signal_id))); gperl_hv_take_sv_s (hv, "detail", newSVGChar (g_quark_to_string (ihint->detail))); gperl_hv_take_sv_s (hv, "run_type", newSVGSignalFlags (ihint->run_type)); return newRV_noinc ((SV*)hv); } #define GET_NAME(name, gtype) \ (name) = gperl_package_from_type (gtype); \ if (!(name)) \ (name) = g_type_name (gtype); SV * newSVGSignalQuery (GSignalQuery * query) { HV * hv; AV * av; guint j; const char * pkgname; if (!query) return &PL_sv_undef; hv = newHV (); gperl_hv_take_sv_s (hv, "signal_id", newSViv (query->signal_id)); gperl_hv_take_sv_s (hv, "signal_name", newSVpv (query->signal_name, 0)); GET_NAME (pkgname, query->itype); if (pkgname) gperl_hv_take_sv_s (hv, "itype", newSVpv (pkgname, 0)); gperl_hv_take_sv_s (hv, "signal_flags", newSVGSignalFlags (query->signal_flags)); if (query->return_type != G_TYPE_NONE) { GType t = query->return_type & ~G_SIGNAL_TYPE_STATIC_SCOPE; GET_NAME (pkgname, t); if (pkgname) gperl_hv_take_sv_s (hv, "return_type", newSVpv (pkgname, 0)); } av = newAV (); for (j = 0; j < query->n_params; j++) { GType t = query->param_types[j] & ~G_SIGNAL_TYPE_STATIC_SCOPE; GET_NAME (pkgname, t); av_push (av, newSVpv (pkgname, 0)); } gperl_hv_take_sv_s (hv, "param_types", newRV_noinc ((SV*)av)); /* n_params is inferred by the length of the av in param_types */ return newRV_noinc ((SV*)hv); } #undef GET_NAME /* now back to our regularly-scheduled bindings. */ static GSList * closures = NULL; GPERL_REC_LOCK_DEFINE_STATIC (closures); static void forget_closure (SV * callback, GPerlClosure * closure) { #ifdef NOISY warn ("forget_closure %p / %p", callback, closure); #else PERL_UNUSED_VAR (callback); #endif GPERL_REC_LOCK (closures); closures = g_slist_remove (closures, closure); GPERL_REC_UNLOCK (closures); } static void remember_closure (GPerlClosure * closure) { #ifdef NOISY warn ("remember_closure %p / %p", closure->callback, closure); warn (" callback %s\n", SvPV_nolen (closure->callback)); #endif GPERL_REC_LOCK (closures); closures = g_slist_prepend (closures, closure); GPERL_REC_UNLOCK (closures); g_closure_add_invalidate_notifier ((GClosure *) closure, closure->callback, (GClosureNotify) forget_closure); } =item void gperl_signal_set_marshaller_for (GType instance_type, char * detailed_signal, GClosureMarshal marshaller) You need this function only in rare cases, usually as workarounds for bad signal parameter types or to implement writable arguments. Use the given I to marshal all handlers for I on I. C will look for marshallers registered here, and apply them to the GPerlClosure it creates for the given callback being connected. A canonical form of I will be used so that I is applied for all possible spellings of the signal name. Use the helper macros in gperl_marshal.h to help write your marshaller function. That header, which is installed with the Glib module but not #included through gperl.h, includes commentary and examples which you should follow closely to avoid nasty bugs. Use the Source, Luke. WARNING: Bend over backwards and turn your head around 720 degrees before attempting to write a GPerlClosure marshaller without using the macros in gperl_marshal.h. If you absolutely cannot use those macros, be certain to understand what those macros do so you can get the semantics correct, and keep your code synchronized with them, or you may miss very important bugfixes. =cut /* We need to store the custom marshallers indexed by (type, signal) tuples * since signal names are not unique (GtkDialog and GtkInfoBar both have a * "response" signal, for example). */ static GHashTable * marshallers_by_type = NULL; G_LOCK_DEFINE_STATIC (marshallers_by_type); /* gobject treats hyphens and underscores in signal names as equivalent. We * thus need to do this as well to ensure that a custom marshaller is used for * all spellings of a signal name. */ static char * canonicalize_signal_name (char * signal_name) { return g_strdelimit (signal_name, "_", '-'); } void gperl_signal_set_marshaller_for (GType instance_type, char * detailed_signal, GClosureMarshal marshaller) { g_return_if_fail (instance_type != 0); g_return_if_fail (detailed_signal != NULL); G_LOCK (marshallers_by_type); if (!marshaller && !marshallers_by_type) { /* nothing to do */ } else { GHashTable *marshallers_by_signal; char *canonical_detailed_signal; if (!marshallers_by_type) marshallers_by_type = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify) g_hash_table_destroy); marshallers_by_signal = g_hash_table_lookup ( marshallers_by_type, (gpointer) instance_type); if (!marshallers_by_signal) { marshallers_by_signal = g_hash_table_new_full ( g_str_hash, g_str_equal, g_free, NULL); g_hash_table_insert (marshallers_by_type, (gpointer) instance_type, marshallers_by_signal); } canonical_detailed_signal = canonicalize_signal_name ( g_strdup (detailed_signal)); if (marshaller) { g_hash_table_insert (marshallers_by_signal, canonical_detailed_signal, marshaller); } else { g_hash_table_remove (marshallers_by_signal, canonical_detailed_signal); g_free (canonical_detailed_signal); } } G_UNLOCK (marshallers_by_type); } /* Called with lock on marshallers_by_type held. */ static GClosureMarshal lookup_specific_marshaller (GType specific_type, char * detailed_signal) { GHashTable *marshallers_by_signal = g_hash_table_lookup (marshallers_by_type, (gpointer) specific_type); if (marshallers_by_signal) { char *canonical_detailed_signal; GClosureMarshal marshaller; canonical_detailed_signal = canonicalize_signal_name ( g_strdup (detailed_signal)); marshaller = g_hash_table_lookup (marshallers_by_signal, canonical_detailed_signal); g_free (canonical_detailed_signal); return marshaller; } return NULL; } static GClosureMarshal lookup_marshaller (GType instance_type, char * detailed_signal) { GClosureMarshal marshaller = NULL; G_LOCK (marshallers_by_type); if (marshallers_by_type) { GType type = instance_type; /* We need to walk the ancestry to make sure that, say, * GtkFileChooseDialog also gets the custom "response" * marshaller from GtkDialog. This always terminates because * g_type_parent (G_TYPE_OBJECT) == 0. */ while (marshaller == NULL && type != 0) { marshaller = lookup_specific_marshaller ( type, detailed_signal); type = g_type_parent (type); } /* We also need to look at interfaces. */ if (marshaller == NULL) { GType *interface_types = g_type_interfaces (instance_type, NULL); GType *interface = interface_types; /* interface_types is 0-terminated. */ while (marshaller == NULL && *interface != 0) { marshaller = lookup_specific_marshaller ( *interface, detailed_signal); interface++; } } } G_UNLOCK (marshallers_by_type); return marshaller; } =item gulong gperl_signal_connect (SV * instance, char * detailed_signal, SV * callback, SV * data, GConnectFlags flags) The actual workhorse behind GObject::signal_connect, the binding for g_signal_connect, for use from within XS. This creates a C wrapper for the given I and I, and connects that closure to the signal named I on the given GObject I. This is only good for named signals. I is the same as for g_signal_connect(). I may be NULL, but I must not be. Returns the id of the installed callback. =cut gulong gperl_signal_connect (SV * instance, char * detailed_signal, SV * callback, SV * data, GConnectFlags flags) { GObject * object; GPerlClosure * closure; GClosureMarshal marshaller = NULL; gulong id; object = gperl_get_object (instance); marshaller = lookup_marshaller (G_OBJECT_TYPE (object), detailed_signal); closure = (GPerlClosure *) gperl_closure_new_with_marshaller (callback, data, flags & G_CONNECT_SWAPPED, marshaller); /* after is true only if we're called as signal_connect_after */ id = g_signal_connect_closure (object, detailed_signal, (GClosure*) closure, flags & G_CONNECT_AFTER); if (id > 0) { closure->id = id; remember_closure (closure); } else { /* not connected, usually bad detailed_signal name */ g_closure_unref ((GClosure*) closure); } return id; } /* G_SIGNAL_MATCH_ID The signal id must be equal. G_SIGNAL_MATCH_DETAIL The signal detail be equal. G_SIGNAL_MATCH_CLOSURE The closure must be the same. G_SIGNAL_MATCH_FUNC The C closure callback must be the same. G_SIGNAL_MATCH_DATA The closure data must be the same. G_SIGNAL_MATCH_UNBLOCKED Only unblocked signals may matched. at the perl level, the CV replaces both the FUNC and CLOSURE. it's rare people will specify any of the others than FUNC and DATA, but i can see how they would be useful so let's support them. */ typedef guint (*sig_match_callback) (gpointer instance, GSignalMatchType mask, guint signal_id, GQuark detail, GClosure * closure, gpointer func, gpointer data); static guint foreach_closure_matched (gpointer instance, GSignalMatchType mask, guint signal_id, GQuark detail, SV * func, SV * data, sig_match_callback callback) { guint n = 0; GSList * i; if (mask & G_SIGNAL_MATCH_CLOSURE || /* this isn't too likely */ mask & G_SIGNAL_MATCH_FUNC || mask & G_SIGNAL_MATCH_DATA) { /* * to match against a function or data, we need to find the * scalars for those in the GPerlClosures; we'll have to * proxy this stuff. we'll replace the func and data bits * with closure in the mask. * however, we can't do the match for any of the other * flags at this level, so even though our design means one * closure per handler id, we still have to pass that closure * on to the real C functions to do any other filtering for * us. */ /* we'll compare SVs by their stringified values. cache the * stringified needles, but there's no way to cache the * haystack. */ const char * str_func = func ? SvPV_nolen (func) : NULL; const char * str_data = data ? SvPV_nolen (data) : NULL; mask &= ~(G_SIGNAL_MATCH_FUNC | G_SIGNAL_MATCH_DATA); mask |= G_SIGNAL_MATCH_CLOSURE; /* this is a little hairy because the callback may disconnect * a closure, which would modify the list while we're iterating * over it. */ GPERL_REC_LOCK (closures); i = closures; while (i != NULL) { GPerlClosure * c = (GPerlClosure*) i->data; i = i->next; if ((!func || strEQ (str_func, SvPV_nolen (c->callback))) && (!data || strEQ (str_data, SvPV_nolen (c->data)))) { n += callback (instance, mask, signal_id, detail, (GClosure*)c, NULL, NULL); } } GPERL_REC_UNLOCK (closures); } else { /* we're not matching against a closure, so we can just * pass this on through. */ n = callback (instance, mask, signal_id, detail, NULL, NULL, NULL); } return n; } static GType get_gtype_or_croak (SV * object_or_class_name) { GType gtype; if (gperl_sv_is_ref (object_or_class_name)) { GObject * object = SvGObject (object_or_class_name); if (!object) croak ("bad object in signal_query"); gtype = G_OBJECT_TYPE (object); } else { gtype = gperl_object_type_from_package (SvPV_nolen (object_or_class_name)); if (!gtype) croak ("package %s is not registered with GPerl", SvPV_nolen (object_or_class_name)); } return gtype; } static guint parse_signal_name_or_croak (const char * detailed_name, GType instance_type, GQuark * detail) /* return, NULL if not wanted */ { guint signal_id; if (!g_signal_parse_name (detailed_name, instance_type, &signal_id, detail, TRUE)) croak ("Unknown signal %s for object of type %s", detailed_name, g_type_name (instance_type)); return signal_id; } static GPerlCallback * gperl_signal_emission_hook_create (SV * func, SV * data) { GType param_types[2]; param_types[0] = GPERL_TYPE_SV; param_types[1] = GPERL_TYPE_SV; return gperl_callback_new (func, data, G_N_ELEMENTS (param_types), param_types, G_TYPE_BOOLEAN); } static gboolean gperl_signal_emission_hook (GSignalInvocationHint * ihint, guint n_param_values, const GValue * param_values, gpointer data) { GPerlCallback * callback = (GPerlCallback *) data; gboolean retval; AV * av; guint i; GValue return_value = {0, }; g_value_init (&return_value, G_TYPE_BOOLEAN); av = newAV(); for (i = 0 ; i < n_param_values ; i++) av_push (av, sv_2mortal (gperl_sv_from_value (param_values+i))); gperl_callback_invoke (callback, &return_value, newSVGSignalInvocationHint (ihint), newRV_noinc ((SV*) av)); retval = g_value_get_boolean (&return_value); g_value_unset (&return_value); return retval; } =back =cut MODULE = Glib::Signal PACKAGE = Glib::Signal =for position DESCRIPTION =head1 DESCRIPTION This page describes some functions related to signals in Glib. Since most things you can do with signals are tied to L instances, the majority of the signal functions are documented there. =head2 Thread safety Some libraries, most notably GStreamer, sometimes invoke signal handlers from a foreign thread that has no Perl interpreter associated with it. When this happens, we have no choice but to hand the marshalling over to the main loop which in turn later wakes up the main thread and lets it handle the request. We cannot invoke the signal handler from the foreign thread since the Perl interpreter may not be used concurrently. The downside to this approach is that the foreign thread is blocked until the main thread has finished executing the signal handler. This might lead to deadlocks. It might help in this case to wrap the crucial parts of the signal handler inside a L callback so that the signal handler can return directly. =cut =for see_also Glib::Object =cut BOOT: gperl_register_fundamental (GPERL_TYPE_SIGNAL_FLAGS, "Glib::SignalFlags"); gperl_register_fundamental (GPERL_TYPE_CONNECT_FLAGS, "Glib::ConnectFlags"); =for flags Glib::SignalFlags =cut MODULE = Glib::Signal PACKAGE = Glib::Object PREFIX = g_ ## ##/* --- typedefs --- */ ##typedef struct _GSignalQuery GSignalQuery; ##typedef struct _GSignalInvocationHint GSignalInvocationHint; ##typedef GClosureMarshal GSignalCMarshaller; ##typedef gboolean (*GSignalEmissionHook) (GSignalInvocationHint *ihint, ## guint n_param_values, ## const GValue *param_values, ## gpointer data); ##typedef gboolean (*GSignalAccumulator) (GSignalInvocationHint *ihint, ## GValue *return_accu, ## const GValue *handler_return, ## gpointer data); ### ### ## creating signals ## ### new signals are currently created as a byproduct of Glib::Type::register ### ## g_signal_newv ## g_signal_new_valist ## g_signal_new ### ### ## emitting signals ## ### all versions of g_signal_emit go through Glib::Object::signal_emit, ### which is mostly equivalent to g_signal_emit_by_name. ### ## g_signal_emitv ## g_signal_emit_valist ## g_signal_emit ## g_signal_emit_by_name ## heavily borrowed from gtk-perl and goran's code in gtk2-perl, which ## was inspired by pygtk's pyobject.c::pygobject_emit =for apidoc =for signature retval = $object->signal_emit ($name, ...) =for arg name (string) the name of the signal =for arg ... (list) any arguments to pass to handlers. Emit the signal I on I<$object>. The number and types of additional arguments in I<...> are determined by the signal; similarly, the presence and type of return value depends on the signal being emitted. =cut void g_signal_emit (instance, name, ...) GObject * instance char * name PREINIT: guint signal_id, i; GQuark detail; GSignalQuery query; GValue * params; PPCODE: #define ARGOFFSET 2 signal_id = parse_signal_name_or_croak (name, G_OBJECT_TYPE (instance), &detail); g_signal_query (signal_id, &query); if (((guint)(items-ARGOFFSET)) != query.n_params) croak ("Incorrect number of arguments for emission of signal %s in class %s; need %d but got %d", name, G_OBJECT_TYPE_NAME (instance), query.n_params, (gint) items-ARGOFFSET); /* set up the parameters to g_signal_emitv. this is an array * of GValues, where [0] is the emission instance, and the rest * are the query.n_params arguments. */ params = g_new0 (GValue, query.n_params + 1); g_value_init (¶ms[0], G_OBJECT_TYPE (instance)); g_value_set_object (¶ms[0], instance); for (i = 0 ; i < query.n_params ; i++) { g_value_init (¶ms[i+1], query.param_types[i] & ~G_SIGNAL_TYPE_STATIC_SCOPE); if (!gperl_value_from_sv (¶ms[i+1], ST (ARGOFFSET+i))) croak ("Couldn't convert value %s to type %s for parameter %d of signal %s on a %s", SvPV_nolen (ST (ARGOFFSET+i)), g_type_name (G_VALUE_TYPE (¶ms[i+1])), i, name, G_OBJECT_TYPE_NAME (instance)); } /* now actually call it. what we do depends on the return type of * the signal; if the signal returns anything we need to capture it * and push it onto the return stack. */ if (query.return_type != G_TYPE_NONE) { /* signal returns a value, woohoo! */ GValue ret = {0,}; g_value_init (&ret, query.return_type); g_signal_emitv (params, signal_id, detail, &ret); EXTEND (SP, 1); SAVED_STACK_PUSHs (sv_2mortal (gperl_sv_from_value (&ret))); g_value_unset (&ret); } else { g_signal_emitv (params, signal_id, detail, NULL); } /* clean up */ for (i = 0 ; i < query.n_params + 1 ; i++) g_value_unset (¶ms[i]); g_free (params); #undef ARGOFFSET ##guint g_signal_lookup (const gchar *name, ## GType itype); ##G_CONST_RETURN gchar* g_signal_name (guint signal_id); ##void g_signal_query (guint signal_id, GSignalQuery *query); =for apidoc Look up information about the signal I<$name> on the instance type I<$object_or_class_name>, which may be either a Glib::Object or a package name. See also C, which returns the same kind of hash refs as this does. Since 1.080. =cut SV * g_signal_query (SV * object_or_class_name, const char * name) PREINIT: GType itype; guint signal_id; GSignalQuery query; GObjectClass * oclass = NULL; CODE: itype = get_gtype_or_croak (object_or_class_name); if (G_TYPE_IS_CLASSED (itype)) { /* ref the class to ensure that the signals get created, * otherwise they may not exist at the time we query. */ oclass = g_type_class_ref (itype); if (!oclass) croak ("couldn't ref type %s", g_type_name (itype)); } signal_id = g_signal_lookup (name, itype); if (0 == signal_id) { RETVAL = &PL_sv_undef; } else { g_signal_query (signal_id, &query); RETVAL = newSVGSignalQuery (&query); } if (oclass) g_type_class_unref (oclass); OUTPUT: RETVAL ##guint* g_signal_list_ids (GType itype, ## guint *n_ids); ##gboolean g_signal_parse_name (const gchar *detailed_signal, ## GType itype, ## guint *signal_id_p, ## GQuark *detail_p, ## gboolean force_detail_quark); ##GSignalInvocationHint* g_signal_get_invocation_hint (gpointer instance); =for apidoc =for signature $ihint = $instance->signal_get_invocation_hint Get a reference to a hash describing the innermost signal currently active on C<$instance>. Returns undef if no signal emission is active. This invocation hint is the same object passed to signal emission hooks, and contains these keys: =over =item signal_name The name of the signal being emitted. =item detail The detail passed on for this emission. For example, a C signal will have the property name as the detail. =item run_type The current stage of signal emission, one of "run-first", "run-last", or "run-cleanup". =back =cut SV* g_signal_get_invocation_hint (GObject *instance) PREINIT: GSignalInvocationHint *ihint; CODE: ihint = g_signal_get_invocation_hint (instance); RETVAL = ihint ? newSVGSignalInvocationHint (ihint) : &PL_sv_undef; OUTPUT: RETVAL ##/* --- signal emissions --- */ ##void g_signal_stop_emission (gpointer instance, ## guint signal_id, ## GQuark detail); ##void g_signal_stop_emission_by_name (gpointer instance, ## const gchar *detailed_signal); void g_signal_stop_emission_by_name (GObject * instance, const gchar * detailed_signal); ##gulong g_signal_add_emission_hook (guint signal_id, ## GQuark quark, ## GSignalEmissionHook hook_func, ## gpointer hook_data, ## GDestroyNotify data_destroy); =for apidoc =for arg detailed_signal (string) of the form "signal-name::detail" =for arg hook_func (subroutine) Add an emission hook for a signal. The hook will be called for any emission of that signal, independent of the instance. This is possible only for signals which don't have the C flag set. The I<$hook_func> should be reference to a subroutine that looks something like this: sub emission_hook { my ($invocation_hint, $parameters, $hook_data) = @_; # $parameters is a reference to the @_ to be passed to # signal handlers, including the instance as $parameters->[0]. return $stay_connected; # boolean } This function returns an id that can be used with C. Since 1.100. =cut gulong g_signal_add_emission_hook (object_or_class_name, detailed_signal, hook_func, hook_data=NULL) SV * object_or_class_name const char * detailed_signal SV * hook_func SV * hook_data PREINIT: GType itype; GObjectClass * object_class; guint signal_id; GQuark quark; GPerlCallback * callback; CODE: itype = get_gtype_or_croak (object_or_class_name); /* See the xsub for g_object_find_property in GObject.xs for why the * class ref/unref stunt is necessary. */ object_class = g_type_class_ref (itype); signal_id = parse_signal_name_or_croak (detailed_signal, itype, &quark); callback = gperl_signal_emission_hook_create (hook_func, hook_data); RETVAL = g_signal_add_emission_hook (signal_id, quark, gperl_signal_emission_hook, callback, (GDestroyNotify)gperl_callback_destroy); g_type_class_unref (object_class); OUTPUT: RETVAL ##void g_signal_remove_emission_hook (guint signal_id, ## gulong hook_id); =for apidoc Remove a hook that was installed by C. Since 1.100. =cut void g_signal_remove_emission_hook (SV * object_or_class_name, const char * signal_name, gulong hook_id); PREINIT: guint signal_id; GType gtype; CODE: gtype = get_gtype_or_croak (object_or_class_name); signal_id = parse_signal_name_or_croak (signal_name, gtype, NULL); g_signal_remove_emission_hook (signal_id, hook_id); ## ## ##/* --- signal handlers --- */ ##gboolean g_signal_has_handler_pending (gpointer instance, ## guint signal_id, ## GQuark detail, ## gboolean may_be_blocked); ### ### ## connecting signals ## ### currently all versions of signal_connect go through ### Glib::Object::signal_connect, which acts like the g_signal_connect ### convenience function. ### ##gulong g_signal_connect_closure_by_id (gpointer instance, ## guint signal_id, ## GQuark detail, ## GClosure *closure, ## gboolean after); ##gulong g_signal_connect_closure (gpointer instance, ## const gchar *detailed_signal, ## GClosure *closure, ## gboolean after); ##gulong g_signal_connect_data (gpointer instance, ## const gchar *detailed_signal, ## GCallback c_handler, ## gpointer data, ## GClosureNotify destroy_data, ## GConnectFlags connect_flags); =for apidoc Glib::Object::signal_connect =for arg callback (subroutine) =for arg data (scalar) arbitrary data to be passed to each invocation of I Register I to be called on each emission of I<$detailed_signal>. Returns an identifier that may be used to remove this handler with C<< $object->signal_handler_disconnect >>. =cut =for apidoc Glib::Object::signal_connect_after Like C, except that I<$callback> will be run after the default handler. =cut =for apidoc Glib::Object::signal_connect_swapped Like C, except that I<$data> and I<$object> will be swapped on invocation of I<$callback>. =cut gulong g_signal_connect (instance, detailed_signal, callback, data=NULL) SV * instance char * detailed_signal SV * callback SV * data ALIAS: Glib::Object::signal_connect = 0 Glib::Object::signal_connect_after = 1 Glib::Object::signal_connect_swapped = 2 PREINIT: GConnectFlags flags = 0; CODE: if (ix == 1) flags |= G_CONNECT_AFTER; if (ix == 2) flags |= G_CONNECT_SWAPPED; RETVAL = gperl_signal_connect (instance, detailed_signal, callback, data, flags); OUTPUT: RETVAL void g_signal_handler_block (object, handler_id) GObject * object gulong handler_id void g_signal_handler_unblock (object, handler_id) GObject * object gulong handler_id void g_signal_handler_disconnect (object, handler_id) GObject * object gulong handler_id gboolean g_signal_handler_is_connected (object, handler_id) GObject * object gulong handler_id ## ## this would require a fair bit of the magic used in the *_by_func ## wrapper below... ## ##gulong g_signal_handler_find (gpointer instance, ## GSignalMatchType mask, ## guint signal_id, ## GQuark detail, ## GClosure *closure, ## gpointer func, ## gpointer data); ### ### the *_matched functions all have the same signature and thus all ### are handled by matched(). ### ## g_signal_handlers_block_matched ## g_signal_handlers_unblock_matched ## g_signal_handlers_disconnect_matched ##### FIXME oops, no typemap for GSignalMatchType... ##guint ##matched (instance, mask, signal_id, detail, func, data) ## SV * instance ## GSignalMatchType mask ## guint signal_id ## SV * detail ## SV * func ## SV * data ## ALIAS: ## Glib::Object::signal_handlers_block_matched = 0 ## Glib::Object::signal_handlers_unblock_matched = 1 ## Glib::Object::signal_handlers_disconnect_matched = 2 ## PREINIT: ## sig_match_callback callback = NULL; ## GQuark real_detail = 0; ## CODE: ## switch (ix) { ## case 0: callback = g_signal_handlers_block_matched; break; ## case 1: callback = g_signal_handlers_unblock_matched; break; ## case 2: callback = g_signal_handlers_disconnect_matched; break; ## } ## if (!callback) ## croak ("internal problem -- xsub aliased to invalid ix"); ## if (detail && SvPOK (detail)) { ## real_detail = g_quark_try_string (SvPV_nolen (detail)); ## if (!real_detail) ## croak ("no such detail %s", SvPV_nolen (detail)); ## } ## RETVAL = foreach_closure_matched (gperl_get_object (instance), ## mask, signal_id, real_detail, ## func, data); ## OUTPUT: ## RETVAL ### the *_by_func functions all have the same signature, and thus are ### handled by signal_handlers_block_by_func. ## g_signal_handlers_disconnect_by_func(instance, func, data) ## g_signal_handlers_block_by_func(instance, func, data) ## g_signal_handlers_unblock_by_func(instance, func, data) =for apidoc Glib::Object::signal_handlers_unblock_by_func =for arg func (subroutine) function to block =for arg data (scalar) data to match, ignored if undef =cut =for apidoc Glib::Object::signal_handlers_disconnect_by_func =for arg func (subroutine) function to block =for arg data (scalar) data to match, ignored if undef =cut =for apidoc =for arg func (subroutine) function to block =for arg data (scalar) data to match, ignored if undef =cut int signal_handlers_block_by_func (instance, func, data=NULL) GObject * instance SV * func SV * data ALIAS: Glib::Object::signal_handlers_unblock_by_func = 1 Glib::Object::signal_handlers_disconnect_by_func = 2 PREINIT: sig_match_callback callback = NULL; CODE: switch (ix) { case 0: callback = g_signal_handlers_block_matched; break; case 1: callback = g_signal_handlers_unblock_matched; break; case 2: callback = g_signal_handlers_disconnect_matched; break; default: g_assert_not_reached (); } RETVAL = foreach_closure_matched (instance, G_SIGNAL_MATCH_CLOSURE, 0, 0, func, data, callback); OUTPUT: RETVAL ##/* --- chaining for language bindings --- */ ##void g_signal_override_class_closure (guint signal_id, ## GType instance_type, ## GClosure *class_closure); ##void g_signal_chain_from_overridden (const GValue *instance_and_params, ## GValue *return_value); =for apidoc Chain up to an overridden class closure; it is only valid to call this from a class closure override. Translation: because of various details in how GObjects are implemented, the way to override a virtual method on a GObject is to provide a new "class closure", or default handler for a signal. This happens when a class is registered with the type system (see Glib::Type::register and L). When called from inside such an override, this method runs the overridden class closure. This is equivalent to calling $self->SUPER::$method (@_) in normal Perl objects. =cut void g_signal_chain_from_overridden (GObject * instance, ...) PREINIT: GSignalInvocationHint * ihint; GSignalQuery query; GValue * instance_and_params = NULL, return_value = {0,}; guint i; PPCODE: ihint = g_signal_get_invocation_hint (instance); if (!ihint) croak ("could not find signal invocation hint for %s(0x%p)", G_OBJECT_TYPE_NAME (instance), instance); g_signal_query (ihint->signal_id, &query); if ((guint)items != 1 + query.n_params) croak ("incorrect number of parameters for signal %s, " "expected %d, got %d", g_signal_name (ihint->signal_id), 1 + query.n_params, (gint) items); instance_and_params = g_new0 (GValue, 1 + query.n_params); g_value_init (&instance_and_params[0], G_OBJECT_TYPE (instance)); g_value_set_object (&instance_and_params[0], instance); for (i = 0 ; i < query.n_params ; i++) { g_value_init (&instance_and_params[i+1], query.param_types[i] & ~G_SIGNAL_TYPE_STATIC_SCOPE); gperl_value_from_sv (&instance_and_params[i+1], ST (i+1)); } if (query.return_type != G_TYPE_NONE) g_value_init (&return_value, query.return_type & ~G_SIGNAL_TYPE_STATIC_SCOPE); g_signal_chain_from_overridden (instance_and_params, &return_value); for (i = 0 ; i < 1 + query.n_params ; i++) g_value_unset (instance_and_params+i); g_free (instance_and_params); if (G_TYPE_NONE != (query.return_type & ~G_SIGNAL_TYPE_STATIC_SCOPE)) { SAVED_STACK_XPUSHs (sv_2mortal (gperl_sv_from_value (&return_value))); g_value_unset (&return_value); } Glib-1.320/GType.xs000644 001750 000024 00000243151 12251766676 015123 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2005, 2009, 2010, 2013 by the gtk2-perl team (see the * file AUTHORS for the full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ =head2 GType / GEnum / GFlags =over =cut #include "gperl.h" #include "gperl_marshal.h" #include "gperl-gtypes.h" #include "gperl-private.h" /* for _gperl_fetch_wrapper_key */ /* for fundamental types */ static GHashTable * types_by_package = NULL; static GHashTable * packages_by_type = NULL; static GHashTable * wrapper_class_by_type = NULL; /* locks for the above */ G_LOCK_DEFINE_STATIC (types_by_package); G_LOCK_DEFINE_STATIC (packages_by_type); G_LOCK_DEFINE_STATIC (wrapper_class_by_type); /* * this is just like gtk_type_class --- it keeps a reference on the classes * it returns so they stick around. this is most important for enums and * flags, which will be created and destroyed every time you look them up * unless you pull this trick. duplicates a pointer when you are using * gtk, but you aren't always using gtk and it's better to be safe than sorry. */ gpointer gperl_type_class (GType type) { static GQuark quark_static_class = 0; gpointer class; if (!G_TYPE_IS_ENUM (type) && !G_TYPE_IS_FLAGS (type)) { g_return_val_if_fail (G_TYPE_IS_OBJECT (type), NULL); } class = g_type_get_qdata (type, quark_static_class); if (!class) { if (!quark_static_class) quark_static_class = g_quark_from_static_string ("GPerlStaticTypeClass"); class = g_type_class_ref (type); g_assert (class != NULL); g_type_set_qdata (type, quark_static_class, class); } return class; } =item void gperl_register_fundamental (GType gtype, const char * package) register a mapping between I and I. this is for "fundamental" types which have no other requirements for metadata storage, such as GEnums, GFlags, or real GLib fundamental types like G_TYPE_INT, G_TYPE_FLOAT, etc. =cut void gperl_register_fundamental (GType gtype, const char * package) { char * p; G_LOCK (types_by_package); G_LOCK (packages_by_type); if (!types_by_package) { types_by_package = g_hash_table_new_full (g_str_hash, g_str_equal, NULL, NULL); packages_by_type = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify)g_free); } p = g_strdup (package); /* We need to insert into types_by_package first because there might * otherwise be trouble if we overwrite an entry: inserting into * packages_by_type frees the copied package name. * * Note also it's g_hash_table_replace() for types_by_package, because * the old key string will be freed when packages_by_type updates the * value there. */ g_hash_table_replace (types_by_package, p, (gpointer) gtype); g_hash_table_insert (packages_by_type, (gpointer) gtype, p); G_UNLOCK (types_by_package); G_UNLOCK (packages_by_type); if (g_type_is_a (gtype, G_TYPE_FLAGS) && gtype != G_TYPE_FLAGS) gperl_set_isa (package, "Glib::Flags"); } =item void gperl_register_fundamental_alias (GType gtype, const char * package) Makes I an alias for I. This means that the package name specified by I will be mapped to I by I, but I won't map I to I. This is useful if you want to change the canonical package name of a type while preserving backwards compatibility with code which uses I to specify I. In order for this to make sense, another package name should be registered for I with I or I. =cut void gperl_register_fundamental_alias (GType gtype, const char * package) { const char * res; G_LOCK (packages_by_type); res = (const char *) g_hash_table_lookup (packages_by_type, (gpointer) gtype); G_UNLOCK (packages_by_type); if (!res) { croak ("cannot register alias %s for the unregistered type %s", package, g_type_name (gtype)); } G_LOCK (types_by_package); g_hash_table_insert (types_by_package, (char *) package, (gpointer) gtype); G_UNLOCK (types_by_package); } =item GPerlValueWrapperClass Specifies the vtable that is to be used to convert fundamental types to and from Perl variables. typedef struct _GPerlValueWrapperClass GPerlValueWrapperClass; struct _GPerlValueWrapperClass { GPerlValueWrapFunc wrap; GPerlValueUnwrapFunc unwrap; }; The members are function pointers, each of which serves a specific purpose: =over =item GPerlValueWrapFunc Turns I into an SV. The caller assumes ownership of the SV. I is not to be modified. typedef SV* (*GPerlValueWrapFunc) (const GValue * value); =item GPerlValueUnwrapFunc Turns I into its fundamental representation and stores the result in the pre-configured I. I must not be overwritten; instead one of the various C functions must be used or the Cdata> pointer must be modifed directly. typedef void (*GPerlValueUnwrapFunc) (GValue * value, SV * sv); =back =cut =item void gperl_register_fundamental_full (GType gtype, const char * package, GPerlValueWrapperClass * wrapper_class) Like L, registers a mapping between I and I. In addition, this also installs the function pointers in I as the handlers for the type. See L. I does not copy the contents of I -- it assumes that I is statically allocated and that it will be valid for the whole lifetime of the program. =cut void gperl_register_fundamental_full (GType gtype, const char * package, GPerlValueWrapperClass * wrapper_class) { gperl_register_fundamental (gtype, package); G_LOCK (wrapper_class_by_type); if (!wrapper_class_by_type) { wrapper_class_by_type = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, NULL); } g_hash_table_insert (wrapper_class_by_type, (gpointer) gtype, wrapper_class); G_UNLOCK (wrapper_class_by_type); } =item GType gperl_fundamental_type_from_package (const char * package) look up the GType corresponding to a I registered by gperl_register_fundamental(). =cut GType gperl_fundamental_type_from_package (const char * package) { GType res; G_LOCK (types_by_package); res = (GType) g_hash_table_lookup (types_by_package, package); G_UNLOCK (types_by_package); return res; } /* objref should be a reference to a blessed something; the return is G_TYPE_NONE if it's any other SV. Is it worth making this public? Leave it private for now. */ static GType gperl_fundamental_type_from_obj (SV *objref) { SV *obj; const char *package; if (!gperl_sv_is_defined (objref)) return G_TYPE_NONE; /* ref is not defined */ obj = SvRV(objref); if (obj == NULL) return G_TYPE_NONE; /* ref is not a reference */ package = sv_reftype (obj, TRUE); return gperl_fundamental_type_from_package (package); } =item const char * gperl_fundamental_package_from_type (GType gtype) look up the package corresponding to a I registered by gperl_register_fundamental(). =cut const char * gperl_fundamental_package_from_type (GType gtype) { const char * res; G_LOCK (packages_by_type); res = (const char *) g_hash_table_lookup (packages_by_type, (gpointer) gtype); G_UNLOCK (packages_by_type); return res; } =item GPerlValueWrapperClass * gperl_fundamental_wrapper_class_from_type (GType gtype) look up the wrapper class corresponding to a I that has previously been registered with gperl_register_fundamental_full(). =cut GPerlValueWrapperClass * gperl_fundamental_wrapper_class_from_type (GType gtype) { GPerlValueWrapperClass * res = NULL; G_LOCK (wrapper_class_by_type); if (wrapper_class_by_type) { res = (GPerlValueWrapperClass *) g_hash_table_lookup (wrapper_class_by_type, (gpointer) gtype); } G_UNLOCK (wrapper_class_by_type); return res; } /**************************************************************************** * enum and flags handling (mostly from the original gtk2_perl code) */ static GEnumValue * gperl_type_enum_get_values (GType enum_type) { GEnumClass * class; g_return_val_if_fail (G_TYPE_IS_ENUM (enum_type), NULL); class = gperl_type_class (enum_type); return class->values; } static GFlagsValue * gperl_type_flags_get_values (GType flags_type) { GFlagsClass * class; g_return_val_if_fail (G_TYPE_IS_FLAGS (flags_type), NULL); class = gperl_type_class (flags_type); return class->values; } =item gboolean gperl_try_convert_enum (GType gtype, SV * sv, gint * val) return FALSE if I can't be mapped to a valid member of the registered enum type I; otherwise, return TRUE write the new value to the int pointed to by I. you'll need this only in esoteric cases. =cut gboolean gperl_try_convert_enum (GType type, SV * sv, gint * val) { GEnumValue * vals; char *val_p = SvPV_nolen(sv); if (*val_p == '-') val_p++; vals = gperl_type_enum_get_values (type); while (vals && vals->value_nick && vals->value_name) { if (gperl_str_eq (val_p, vals->value_nick) || gperl_str_eq (val_p, vals->value_name)) { *val = vals->value; return TRUE; } vals++; } return FALSE; } =item gint gperl_convert_enum (GType type, SV * val) croak if I is not part of I, otherwise return corresponding value =cut gint gperl_convert_enum (GType type, SV * val) { SV * r; int ret; GEnumValue * vals; if (gperl_try_convert_enum (type, val, &ret)) return ret; /* * This is an error, val should be included in the enum type. * croak with a message. note that we build the message in an * SV so it will be properly GC'd */ vals = gperl_type_enum_get_values (type); r = newSVpv ("", 0); while (vals && vals->value_nick) { sv_catpv (r, vals->value_nick); if (vals->value_name) { sv_catpv (r, " / "); sv_catpv (r, vals->value_name); } if (++vals && vals->value_nick) sv_catpv (r, ", "); } croak ("FATAL: invalid enum %s value %s, expecting: %s", g_type_name (type), SvPV_nolen (val), SvPV_nolen (r)); /* not reached */ return 0; } =item SV * gperl_convert_back_enum_pass_unknown (GType type, gint val) return a scalar containing the nickname of the enum value I, or the integer value of I if I is not a member of the enum I. =cut SV * gperl_convert_back_enum_pass_unknown (GType type, gint val) { GEnumValue * vals = gperl_type_enum_get_values (type); while (vals && vals->value_nick && vals->value_name) { if (vals->value == val) return newSVpv (vals->value_nick, 0); vals++; } return newSViv (val); } =item SV * gperl_convert_back_enum (GType type, gint val) return a scalar which is the nickname of the enum value val, or croak if val is not a member of the enum. =cut SV * gperl_convert_back_enum (GType type, gint val) { GEnumValue * vals = gperl_type_enum_get_values (type); while (vals && vals->value_nick && vals->value_name) { if (vals->value == val) return newSVpv (vals->value_nick, 0); vals++; } croak ("FATAL: could not convert value %d to enum type %s", val, g_type_name (type)); return NULL; /* not reached */ } =item gboolean gperl_try_convert_flag (GType type, const char * val_p, gint * val) like gperl_try_convert_enum(), but for GFlags. =cut gboolean gperl_try_convert_flag (GType type, const char * val_p, gint * val) { GFlagsValue * vals = gperl_type_flags_get_values (type); while (vals && vals->value_nick && vals->value_name) { if (gperl_str_eq (val_p, vals->value_name) || gperl_str_eq (val_p, vals->value_nick)) { *val = vals->value; return TRUE; } vals++; } return FALSE; } =item gint gperl_convert_flag_one (GType type, const char * val) croak if I is not part of I, otherwise return corresponding value. =cut gint gperl_convert_flag_one (GType type, const char * val_p) { SV *r; GFlagsValue * vals; gint ret; if (gperl_try_convert_flag (type, val_p, &ret)) return ret; /* This is an error, val should be included in the flags type, die */ vals = gperl_type_flags_get_values (type); r = newSVpv("", 0); while (vals && vals->value_nick) { sv_catpv (r, vals->value_nick); if (vals->value_name) { sv_catpv (r, " / "); sv_catpv (r, vals->value_name); } if (++vals && vals->value_nick) sv_catpv (r, ", "); } croak ("FATAL: invalid %s value %s, expecting: %s", g_type_name (type), val_p, SvPV_nolen (r)); /* not reached */ return 0; } =item gint gperl_convert_flags (GType type, SV * val) collapse a list of strings to an integer with all the correct bits set, croak if anything is invalid. =cut gint gperl_convert_flags (GType type, SV * val) { if (gperl_sv_is_ref (val) && sv_derived_from (val, "Glib::Flags")) return SvIV (SvRV (val)); if (gperl_sv_is_array_ref (val)) { AV* vals = (AV*) SvRV(val); gint value = 0; int i; for (i=0; i<=av_len(vals); i++) value |= gperl_convert_flag_one (type, SvPV_nolen (*av_fetch (vals, i, 0))); return value; } if (SvPOK (val)) return gperl_convert_flag_one (type, SvPV_nolen (val)); croak ("FATAL: invalid %s value %s, expecting a string scalar or an arrayref of strings", g_type_name (type), SvPV_nolen (val)); return 0; /* not reached */ } static SV * flags_as_arrayref (GType type, gint val) { GFlagsValue * vals = gperl_type_flags_get_values (type); AV * flags = newAV (); while (vals && vals->value_nick && vals->value_name) { if ((val & vals->value) == vals->value) { val -= vals->value; av_push (flags, newSVpv (vals->value_nick, 0)); } vals++; } return newRV_noinc ((SV*) flags); } =item SV * gperl_convert_back_flags (GType type, gint val) convert a bitfield to a list of strings. =cut SV * gperl_convert_back_flags (GType type, gint val) { const char * package; package = gperl_fundamental_package_from_type (type); if (package) { return sv_bless (newRV_noinc (newSViv (val)), gv_stashpv (package, TRUE)); } else { /* return as non-blessed array, and warn. */ warn ("GFlags %s has no registered perl package, returning as array", g_type_name (type)); return flags_as_arrayref (type, val); } } =back =head2 Inheritance management =over =item void gperl_set_isa (const char * child_package, const char * parent_package) tell perl that I inherits I, after whatever else is already there. equivalent to C<< push @{$parent_package}::ISA, $child_package; >> =cut void gperl_set_isa (const char * child_package, const char * parent_package) { char * child_isa_full; AV * isa; child_isa_full = g_strconcat (child_package, "::ISA", NULL); isa = get_av (child_isa_full, TRUE); /* create on demand */ /* warn ("--> @%s = qw(%s);\n", child_isa_full, parent_package); */ g_free (child_isa_full); av_push (isa, newSVpv (parent_package, 0)); } =item void gperl_prepend_isa (const char * child_package, const char * parent_package) tell perl that I inherits I, but before whatever else is already there. equivalent to C<< unshift @{$parent_package}::ISA, $child_package; >> =cut void gperl_prepend_isa (const char * child_package, const char * parent_package) { char * child_isa_full; AV * isa; child_isa_full = g_strconcat (child_package, "::ISA", NULL); isa = get_av (child_isa_full, TRUE); /* create on demand */ /* warn ("--> @%s = qw(%s);\n", child_isa_full, parent_package); */ g_free (child_isa_full); av_unshift (isa, 1); av_store (isa, 0, newSVpv (parent_package, 0)); } =item GType gperl_type_from_package (const char * package) Look up the GType associated with I, regardless of how it was registered. Returns 0 if no mapping can be found. =cut GType gperl_type_from_package (const char * package) { GType t; t = gperl_object_type_from_package (package); if (t) return t; t = gperl_boxed_type_from_package (package); if (t) return t; t = gperl_fundamental_type_from_package (package); if (t) return t; t = gperl_param_spec_type_from_package (package); if (t) return t; return 0; } =item const char * gperl_package_from_type (GType gtype) Look up the name of the package associated with I, regardless of how it was registered. Returns NULL if no mapping can be found. =cut const char * gperl_package_from_type (GType type) { const char * p; p = gperl_object_package_from_type (type); if (p) return p; p = gperl_boxed_package_from_type (type); if (p) return p; p = gperl_fundamental_package_from_type (type); if (p) return p; p = gperl_param_spec_package_from_type (type); if (p) return p; return NULL; } =back =head2 Boxed type support for SV In order to allow GValues to hold perl SVs we need a GBoxed wrapper. =over =item GPERL_TYPE_SV Evaluates to the GType for SVs. The bindings register a mapping between GPERL_TYPE_SV and the package 'Glib::Scalar' with gperl_register_boxed(). =item SV * gperl_sv_copy (SV * sv) implemented as C<< newSVsv (sv) >>. =item void gperl_sv_free (SV * sv) implemented as C<< SvREFCNT_dec (sv) >>. =cut void gperl_sv_free (SV * sv) { SvREFCNT_dec (sv); } SV * gperl_sv_copy (SV * sv) { return newSVsv (sv); } GType gperl_sv_get_type (void) { static GType sv_type = 0; if (sv_type == 0) sv_type = g_boxed_type_register_static ("GPerlSV", (GBoxedCopyFunc) gperl_sv_copy, (GBoxedFreeFunc) gperl_sv_free); return sv_type; } =back =head2 UTF-8 strings with gchar By convention, gchar* is assumed to point to UTF8 string data, and char* points to ascii string data. Here we define a pair of wrappers for the boilerplate of upgrading Perl strings. They are implemented as functions rather than macros, because comma expressions in macros are not supported by all compilers. These functions should be used instead of newSVpv and SvPV_nolen in all cases which deal with gchar* types. =over =item gchar * SvGChar (SV * sv) extract a UTF8 string from I. =cut /*const*/ gchar * SvGChar (SV * sv) { sv_utf8_upgrade (sv); return (/*const*/ gchar*) SvPV_nolen (sv); } =item SV * newSVGChar (const gchar * str) copy a UTF8 string into a new SV. if str is NULL, returns &PL_sv_undef. =cut SV * newSVGChar (const gchar * str) { SV * sv; if (!str) return &PL_sv_undef; /* sv_setpv ((SV*)$arg, $var); */ sv = newSVpv (str, 0); SvUTF8_on (sv); return sv; } =back =head2 64 bit integers On 32 bit machines and even on some 64 bit machines, perl's IV/UV data type can only hold 32 bit values. The following functions therefore convert 64 bit integers to and from Perl strings if normal IV/UV conversion does not suffice. =over =item gint64 SvGInt64 (SV *sv) Converts the string in I to a signed 64 bit integer. If appropriate, uses C instead. =cut #ifdef _MSC_VER # include #endif #if GLIB_CHECK_VERSION (2, 12, 0) # define PORTABLE_STRTOLL(str, end, base) g_ascii_strtoll (str, end, base) #elif defined(_MSC_VER) # if _MSC_VER >= 1300 # define PORTABLE_STRTOLL(str, end, base) _strtoi64 (str, end, base) # else # define PORTABLE_STRTOLL(str, end, base) _atoi64 (str) # endif #else # define PORTABLE_STRTOLL(str, end, base) strtoll (str, end, base) #endif #if defined(_MSC_VER) || defined(__MSVCRT__) # define PORTABLE_LL_FORMAT "%I64d" #else # define PORTABLE_LL_FORMAT "%lld" #endif gint64 SvGInt64 (SV *sv) { #ifdef USE_64_BIT_ALL return SvIV (sv); #else return PORTABLE_STRTOLL (SvPV_nolen (sv), NULL, 10); #endif } =item SV * newSVGInt64 (gint64 value) Creates a PV from the signed 64 bit integer in I. If appropriate, uses C instead. =cut SV * newSVGInt64 (gint64 value) { #ifdef USE_64_BIT_ALL return newSViv (value); #else char string[25]; STRLEN length; SV *sv; /* newSVpvf doesn't seem to work correctly. sv = newSVpvf (PORTABLE_LL_FORMAT, value); */ length = sprintf(string, PORTABLE_LL_FORMAT, value); sv = newSVpv (string, length); return sv; #endif } =item guint64 SvGUInt64 (SV *sv) Converts the string in I to an unsigned 64 bit integer. If appropriate, uses C instead. =cut #if GLIB_CHECK_VERSION (2, 2, 0) # define PORTABLE_STRTOULL(str, end, base) g_ascii_strtoull (str, end, base) #elif defined(_MSC_VER) && _MSC_VER >= 1300 # define PORTABLE_STRTOULL(str, end, base) _strtoui64 (str, end, base) #else # define PORTABLE_STRTOULL(str, end, base) strtoull (str, end, base) #endif #if defined(_MSC_VER) || defined(__MSVCRT__) # define PORTABLE_ULL_FORMAT "%I64u" #else # define PORTABLE_ULL_FORMAT "%llu" #endif guint64 SvGUInt64 (SV *sv) { #ifdef USE_64_BIT_ALL return SvUV (sv); #else return PORTABLE_STRTOULL (SvPV_nolen (sv), NULL, 10); #endif } =item SV * newSVGUInt64 (guint64 value) Creates a PV from the unsigned 64 bit integer in I. If appropriate, uses C instead. =cut SV * newSVGUInt64 (guint64 value) { #ifdef USE_64_BIT_ALL return newSVuv (value); #else char string[25]; STRLEN length; SV *sv; /* newSVpvf doesn't seem to work correctly. sv = newSVpvf (PORTABLE_ULL_FORMAT, value); */ length = sprintf(string, PORTABLE_ULL_FORMAT, value); sv = newSVpv (string, length); return sv; #endif } /**************************************************************************/ /* * support for pure-perl GObject subclasses. * * this includes * * creating new object properties * * creating new signals * * overriding the class closures (that is, default handlers) of * existing signals * * it looks like a huge quivering mass of scary-looking, visually dense * code, but it's really simple at the core; the verbosity comes from * lots of boilerplate translations and such. */ /* TODO/FIXME: utf8 safe??? */ /* muppetman: no, it's not utf8-safe, as it treats the string like ascii. * we implicitly assume in many places that package names will * be ascii; in practice this is the case, but it *is* possible * to get non-ascii package names. */ static char * sanitize_package_name (const char * pkg_name) { char * s; char * ctype_name; ctype_name = g_strdup (pkg_name); for (s = ctype_name; *s != '\0' ; s++) if (*s == ':') *s = '_'; return ctype_name; } static void gperl_signal_class_closure_marshal (GClosure *closure, GValue *return_value, guint n_param_values, const GValue *param_values, gpointer invocation_hint, gpointer marshal_data) { GSignalInvocationHint *hint = (GSignalInvocationHint *)invocation_hint; GSignalQuery query; gchar * tmp; SV * method_name; STRLEN i; HV *stash; SV **slot; /* see GClosure.xs and gperl_marshal.h for an explanation. we can't * use that code because this is a different style of closure, but we * need to emulate it very closely. */ #ifdef PERL_IMPLICIT_CONTEXT PERL_SET_CONTEXT (marshal_data); #else PERL_UNUSED_VAR (marshal_data); #endif PERL_UNUSED_VAR (closure); #ifdef NOISY warn ("gperl_signal_class_closure_marshal"); #endif g_return_if_fail(invocation_hint != NULL); g_signal_query (hint->signal_id, &query); /* construct method name for this class closure */ method_name = newSVpvf ("do_%s", query.signal_name); /* convert dashes to underscores. g_signal_name converts all the * underscores in the signal name to dashes, but dashes are not * valid in subroutine names. */ for (tmp = SvPV_nolen (method_name); *tmp != '\0'; tmp++) if (*tmp == '-') *tmp = '_'; stash = gperl_object_stash_from_type (query.itype); assert (stash); tmp = SvPV (method_name, i); slot = hv_fetch (stash, tmp, i, 0); /* does the function exist? then call it. */ if (slot && GvCV (*slot)) { SV * save_errsv; gboolean want_return_value; int flags; dSP; ENTER; SAVETMPS; PUSHMARK (SP); g_assert (n_param_values != 0); /* watch very carefully the reference counts on the scalar * object references, or else we can get indestructible * objects. */ EXTEND (SP, (int)n_param_values); for (i = 0; i < n_param_values; i++) SAVED_STACK_PUSHs (sv_2mortal (gperl_sv_from_value ((GValue*) ¶m_values[i]))); PUTBACK; /* now call it */ /* note: keep this as closely sync'ed as possible with the * definition of GPERL_CLOSURE_MARSHAL_CALL. */ save_errsv = sv_2mortal (newSVsv (ERRSV)); want_return_value = return_value && G_VALUE_TYPE (return_value); flags = G_EVAL | (want_return_value ? G_SCALAR : G_VOID|G_DISCARD); call_method (SvPV_nolen (method_name), flags); SPAGAIN; if (SvTRUE (ERRSV)) { gperl_run_exception_handlers (); } else if (want_return_value) { gperl_value_from_sv (return_value, POPs); PUTBACK; } SvSetSV (ERRSV, save_errsv); FREETMPS; LEAVE; } SvREFCNT_dec (method_name); } /** * gperl_signal_class_closure_get: * * Returns the GClosure used for the class closure of signals. When * called, it will invoke the method do_signalname (for the signal * "signalname"). * * Returns: the closure. */ GClosure * gperl_signal_class_closure_get(void) { /* FIXME does this need a lock? */ static GClosure *closure; if (closure == NULL) { closure = g_closure_new_simple (sizeof (GClosure), NULL); /* this is not a GPerlClosure, but the same caveats apply. * see GClosure.xs and gperl_marshal.h. */ #ifndef PERL_IMPLICIT_CONTEXT g_closure_set_marshal (closure, gperl_signal_class_closure_marshal); #else g_closure_set_meta_marshal (closure, aTHX, gperl_signal_class_closure_marshal); #endif g_closure_ref (closure); g_closure_sink (closure); } return closure; } typedef struct { GClosure * class_closure; GSignalFlags flags; GSignalAccumulator accumulator; GPerlCallback * accu_data; GType return_type; GType * param_types; guint n_params; } SignalParams; static SignalParams * signal_params_new (void) { SignalParams * s = g_new0 (SignalParams, 1); s->flags = G_SIGNAL_RUN_FIRST; s->return_type = G_TYPE_NONE; return s; } static void signal_params_free (SignalParams * s) { if (s) g_free (s->param_types); /* the closure will have been sunken and reffed by the signal. */ /* we are leaking the accumulator. i don't know any other way. */ g_free (s); } static gboolean gperl_real_signal_accumulator (GSignalInvocationHint *ihint, GValue *return_accu, const GValue *handler_return, gpointer data) { GPerlCallback * callback = (GPerlCallback *)data; SV * sv; int n; gboolean retval; dGPERL_CALLBACK_MARSHAL_SP; GPERL_CALLBACK_MARSHAL_INIT (callback); /* warn ("gperl_real_signal_accumulator"); */ /* invoke the callback, with custom marshalling */ ENTER; SAVETMPS; PUSHMARK (SP); PUSHs (sv_2mortal (newSVGSignalInvocationHint (ihint))); SAVED_STACK_PUSHs (sv_2mortal (gperl_sv_from_value (return_accu))); SAVED_STACK_PUSHs (sv_2mortal (gperl_sv_from_value (handler_return))); if (callback->data) XPUSHs (callback->data); PUTBACK; n = call_sv (callback->func, G_EVAL|G_ARRAY); if (SvTRUE (ERRSV)) { warn ("### WOAH! unhandled exception in a signal accumulator!\n" "### this is really uncool, and for now i'm not even going to\n" "### try to recover."); croak (Nullch); } if (n != 2) { warn ("###\n" "### signal accumulator functions must return two values on the perl stack:\n" "### the (possibly) modified return_acc\n" "### and a boolean value, true if emission should continue\n" "###\n" "### your sub returned %d value%s\n" "###\n" "### there's no resonable way to recover from this.\n" "### you must fix this code", n, n==1?"":"s"); croak (Nullch); } SPAGAIN; /* * pop the results off the stack... don't forget that they come back * in reverse order. (seems so obvious, but, well... i feel dumb.) */ sv = POPs; gperl_value_from_sv (return_accu, sv); sv = POPs; retval = SvTRUE (sv); PUTBACK; FREETMPS; LEAVE; return retval; } /* parse a hash describing a new signal into a SignalParams struct. all keys are allowed to default. we look for: flags => GSignalFlags, if not present, assumed to be run-first param_types => reference to a list of package names, if not present, assumed to be empty (no parameters) class_closure => reference to a subroutine to call as the class closure. may also be a string interpreted as the name of a subroutine to call, but you should be very very very careful about that. if not present, the library will attempt to call the method named "do_signal_name" for the signal "signal_name" (uses underscores). return_type => package name for return value. if undefined or not present, the signal expects no return value. if defined, the signal is expected to return a value; flags must be set such that the signal does not run only first (at least use 'run-last'). accumulator => quoting the Glib manual: "The signal accumulator is a special callback function that can be used to collect return values of the various callbacks that are called during a signal emission." */ static SignalParams * parse_signal_hash (GType instance_type, const gchar * signal_name, HV * hv) { SignalParams * s = signal_params_new (); SV ** svp; PERL_UNUSED_VAR (instance_type); PERL_UNUSED_VAR (signal_name); svp = hv_fetch (hv, "flags", 5, FALSE); if (svp && gperl_sv_is_defined (*svp)) s->flags = SvGSignalFlags (*svp); svp = hv_fetch (hv, "param_types", 11, FALSE); if (svp && gperl_sv_is_array_ref (*svp)) { guint i; AV * av = (AV*) SvRV (*svp); s->n_params = av_len (av) + 1; s->param_types = g_new (GType, s->n_params); for (i = 0 ; i < s->n_params ; i++) { svp = av_fetch (av, i, 0); if (!svp) croak ("how did this happen?"); s->param_types[i] = gperl_type_from_package (SvPV_nolen (*svp)); if (!s->param_types[i]) croak ("unknown or unregistered param type %s", SvPV_nolen (*svp)); } } svp = hv_fetch (hv, "class_closure", 13, FALSE); if (svp && *svp) { if (gperl_sv_is_defined (*svp)) s->class_closure = gperl_closure_new (*svp, NULL, FALSE); /* else the class closure is NULL */ } else { s->class_closure = gperl_signal_class_closure_get (); } svp = hv_fetch (hv, "return_type", 11, FALSE); if (svp && gperl_sv_is_defined (*svp)) { s->return_type = gperl_type_from_package (SvPV_nolen (*svp)); if (!s->return_type) croak ("unknown or unregistered return type %s", SvPV_nolen (*svp)); } svp = hv_fetch (hv, "accumulator", 11, FALSE); if (svp && *svp) { SV * func = *svp; svp = hv_fetch (hv, "accu_data", 9, FALSE); s->accumulator = gperl_real_signal_accumulator; s->accu_data = gperl_callback_new (func, svp ? *svp : NULL, 0, NULL, 0); } return s; } static void add_signals (GType instance_type, HV * signals, AV * interfaces) { HE * he; hv_iterinit (signals); while (NULL != (he = hv_iternext (signals))) { I32 keylen; char * signal_name; guint signal_id; SV * value; /* the key is the signal name */ signal_name = hv_iterkey (he, &keylen); /* if, at this point, the signal is already defined in the * ancestry or the interfaces we just added to instance_type, * we can only override the installed closure. trying to * create a new signal with the same name is an error. * * unfortunately, we cannot simply use instance_type to do the * lookup because g_signal_lookup would complain about it since * it hasn't been fully loaded yet. see * . * * FIXME: the "if (signal_id)" check in the hash ref block * below could be removed since g_signal_newv also checks this. * consequently, this lookup code could be moved into the class * closure block below. */ signal_id = g_signal_lookup (signal_name, g_type_parent (instance_type)); if (!signal_id && interfaces) { int i; for (i = 0; i <= av_len (interfaces); i++) { GType interface_type; SV ** svp = av_fetch (interfaces, i, FALSE); if (!svp || !gperl_sv_is_defined (*svp)) continue; interface_type = gperl_object_type_from_package (SvPV_nolen (*svp)); signal_id = g_signal_lookup (signal_name, interface_type); if (signal_id) break; } } /* parse the key's value... */ value = hv_iterval (signals, he); if (gperl_sv_is_hash_ref (value)) { /* * value is a hash describing a new signal. */ SignalParams * s; if (signal_id) { GSignalQuery q; g_signal_query (signal_id, &q); croak ("signal %s already exists in %s", signal_name, g_type_name (q.itype)); } s = parse_signal_hash (instance_type, signal_name, (HV*) SvRV (value)); signal_id = g_signal_newv (signal_name, instance_type, s->flags, s->class_closure, s->accumulator, s->accu_data, NULL, /* c_marshaller */ s->return_type, s->n_params, s->param_types); signal_params_free (s); if (signal_id == 0) croak ("failed to create signal %s", signal_name); } else if ((SvPOK (value) && SvLEN (value) > 0) || gperl_sv_is_code_ref (value)) { /* * a subroutine reference or method name to override * the class closure for this signal. */ GClosure * closure; if (!signal_id) croak ("can't override class closure for " "unknown signal %s", signal_name); closure = gperl_closure_new (value, NULL, FALSE); g_signal_override_class_closure (signal_id, instance_type, closure); } else { croak ("value for signal key '%s' must be either a " "subroutine (the class closure override) or " "a reference to a hash describing the signal" " to create", signal_name); } } } typedef struct { SV * getter; SV * setter; } PropHandler; static void prop_handler_free (PropHandler * p) { if (p->getter) SvREFCNT_dec (p->getter); if (p->setter) SvREFCNT_dec (p->setter); g_free (p); } static GHashTable * find_handlers_for_type (GType type, gboolean create) { GHashTable * handlers; static GHashTable * allhandlers = NULL; if (NULL == allhandlers) allhandlers = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify) g_hash_table_destroy); handlers = g_hash_table_lookup (allhandlers, (gpointer)type); if (!handlers && create) { handlers = g_hash_table_new_full (g_direct_hash, g_direct_equal, NULL, (GDestroyNotify) prop_handler_free); g_hash_table_insert (allhandlers, (gpointer)type, handlers); } return handlers; } static void prop_handler_install (GType instance_type, guint prop_id, SV * setter, SV * getter) { GHashTable * handlers; PropHandler * thishandler; handlers = find_handlers_for_type (instance_type, setter || getter); if (!handlers) return; thishandler = g_hash_table_lookup (handlers, GUINT_TO_POINTER (prop_id)); if (!thishandler) { thishandler = g_new (PropHandler, 1); g_hash_table_insert (handlers, GUINT_TO_POINTER (prop_id), thishandler); } else { if (thishandler->setter) SvREFCNT_dec (thishandler->setter); if (thishandler->getter) SvREFCNT_dec (thishandler->getter); } thishandler->setter = setter ? newSVsv (setter) : NULL; thishandler->getter = getter ? newSVsv (getter) : NULL; } static void prop_handler_lookup (GType instance_type, guint prop_id, SV ** setter, SV ** getter) { GHashTable * handlers; PropHandler * thishandler; handlers = find_handlers_for_type (instance_type, setter || getter); if (handlers && (NULL != (thishandler = g_hash_table_lookup (handlers, GUINT_TO_POINTER (prop_id))))) { if (setter) *setter = thishandler->setter; if (getter) *getter = thishandler->getter; } else { if (setter) *setter = NULL; if (getter) *getter = NULL; } } static void add_properties (GType instance_type, GObjectClass * oclass, AV * properties) { int propid; for (propid = 0; propid <= av_len (properties); propid++) { SV * sv = *av_fetch (properties, propid, 1); GParamSpec * pspec = NULL; if (sv_derived_from (sv, "Glib::ParamSpec")) pspec = SvGParamSpec (sv); else if (gperl_sv_is_hash_ref (sv)) { HV * hv = (HV*) SvRV (sv); SV ** svp; SV * setter = NULL; SV * getter = NULL; svp = hv_fetch (hv, "pspec", 5, FALSE); if (!svp) croak ("Param description hash at index %d " "for %s does not contain key pspec", propid, gperl_object_package_from_type (instance_type)); pspec = SvGParamSpec (*svp); svp = hv_fetch (hv, "get", 3, FALSE); if (svp) getter = *svp; svp = hv_fetch (hv, "set", 3, FALSE); if (svp) setter = *svp; prop_handler_install (instance_type, propid+1, setter, getter); } else { croak ("item %d (%s) in property list for %s is " "neither a Glib::ParamSpec nor a param " "description hash", propid, gperl_format_variable_for_output (sv), gperl_object_package_from_type (instance_type)); } g_object_class_install_property (oclass, propid + 1, pspec); } } /* * look for a function named _INSTALL_OVERRIDES in each package of the * ancestry of type, and call it if it exists. these are done from root * down to type, so that later classes may override what ancestors installed. * the package name corresponding to type is passed to each one, so the * (typically xs) implementations can find the right object class. */ static void install_overrides (GType type) { GSList * types = NULL, * i; GType t; const char * name = NULL; for (t = type ; t != 0 ; t = g_type_parent (t)) types = g_slist_prepend (types, (gpointer) t); for (i = types ; i != NULL ; i = i->next) { HV * stash; SV ** slot; t = (GType) i->data; stash = gperl_object_stash_from_type (t); slot = hv_fetch (stash, "_INSTALL_OVERRIDES", sizeof ("_INSTALL_OVERRIDES") - 1, FALSE); if (slot && GvCV (*slot)) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); if (!name) name = gperl_object_package_from_type (type); XPUSHs (sv_2mortal (newSVpv (name, 0))); PUTBACK; call_sv ((SV *)GvCV (*slot), G_VOID|G_DISCARD); FREETMPS; LEAVE; } } g_slist_free (types); } static void add_interfaces (GType instance_type, AV * interfaces) { int i; SV * class_name = newSVpv (gperl_object_package_from_type (instance_type), 0); for (i = 0; i <= av_len (interfaces); i++) { GType interface_type; SV ** svp = av_fetch (interfaces, i, FALSE); if (!svp || !gperl_sv_is_defined (*svp)) croak ("encountered undefined interface name"); interface_type = gperl_object_type_from_package (SvPV_nolen (*svp)); if (!interface_type) { croak ("encountered unregistered interface %s", SvPV_nolen (*svp)); } /* call the interface's setup function on this class. */ { dSP; ENTER; PUSHMARK (SP); EXTEND (SP, 2); PUSHs (*svp); /* interface type */ PUSHs (class_name); /* target type */ PUTBACK; /* this will fail if _ADD_INTERFACE is not defined. */ call_method ("_ADD_INTERFACE", G_VOID|G_DISCARD); LEAVE; } gperl_prepend_isa (SvPV_nolen (class_name), SvPV_nolen (*svp)); } SvREFCNT_dec (class_name); } static void gperl_type_get_property (GObject * object, guint property_id, GValue * value, GParamSpec * pspec) { HV *stash; SV **slot; SV * getter; prop_handler_lookup (pspec->owner_type, property_id, NULL, &getter); if (getter) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); PUSHs (sv_2mortal (gperl_new_object (object, FALSE))); PUTBACK; call_sv (getter, G_SCALAR); SPAGAIN; gperl_value_from_sv (value, POPs); PUTBACK; FREETMPS; LEAVE; return; } stash = gperl_object_stash_from_type (pspec->owner_type); assert (stash); slot = hv_fetch (stash, "GET_PROPERTY", sizeof ("GET_PROPERTY") - 1, 0); /* does the function exist? then call it. */ if (slot && GvCV (*slot)) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (sv_2mortal (gperl_new_object (object, FALSE))); XPUSHs (sv_2mortal (newSVGParamSpec (pspec))); PUTBACK; if (1 != call_sv ((SV *)GvCV (*slot), G_SCALAR)) croak ("%s->GET_PROPERTY didn't return exactly one value", HvNAME (stash)); SPAGAIN; gperl_value_from_sv (value, POPs); PUTBACK; FREETMPS; LEAVE; } else { /* no GET_PROPERTY; look in the wrapper hash. */ SV * val = _gperl_fetch_wrapper_key (object, g_param_spec_get_name (pspec), FALSE); if (val) gperl_value_from_sv (value, val); else { /* no value in the wrapper hash. get the pspec's * default, if it has one. */ g_param_value_set_default (pspec, value); } } } static void gperl_type_set_property (GObject * object, guint property_id, const GValue * value, GParamSpec * pspec) { HV * stash; SV ** slot; SV * setter; prop_handler_lookup (pspec->owner_type, property_id, &setter, NULL); if (setter) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); PUSHs (sv_2mortal (gperl_new_object (object, FALSE))); SAVED_STACK_XPUSHs (sv_2mortal (gperl_sv_from_value (value))); PUTBACK; call_sv (setter, G_VOID|G_DISCARD); SPAGAIN; FREETMPS; LEAVE; return; } stash = gperl_object_stash_from_type (pspec->owner_type); assert (stash); slot = hv_fetch (stash, "SET_PROPERTY", sizeof ("SET_PROPERTY") - 1, 0); /* does the function exist? then call it. */ if (slot && GvCV (*slot)) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (sv_2mortal (gperl_new_object (object, FALSE))); XPUSHs (sv_2mortal (newSVGParamSpec (pspec))); SAVED_STACK_XPUSHs (sv_2mortal (gperl_sv_from_value (value))); PUTBACK; call_sv ((SV *)GvCV (*slot), G_VOID|G_DISCARD); FREETMPS; LEAVE; } else { /* no SET_PROPERTY. fall back to setting the value into * a key with the pspec's name in the wrapper hash. */ SV * val = _gperl_fetch_wrapper_key (object, g_param_spec_get_name (pspec), TRUE); if (val) { SV * newval = sv_2mortal (gperl_sv_from_value (value)); SvSetMagicSV (val, newval); } else { /* XXX couldn't create the key. what to do? */ } } } static void gperl_type_finalize (GObject * instance) { int do_nonperl = 1; GObjectClass *class; /* BIG BUG: * we walk down the class hierarchy and call all * FINALIZE_INSTANCE functions for perl. * We also call the first non-perl finalize function. * This does NOT work when we have gobject -> perl -> non-perl -> perl. * In this case we should probably remove the perl SV so that later * invocations will not try to call into perl. (i.e. check wrapper_sv, steal wrapper_sv, finalize) */ class = G_OBJECT_GET_CLASS (instance); do { /* call finalize for each perl class and the topmost non-perl class */ if (class->finalize == gperl_type_finalize) { if (!PL_in_clean_objs) { HV *stash = gperl_object_stash_from_type (G_TYPE_FROM_CLASS (class)); SV **slot = hv_fetch (stash, "FINALIZE_INSTANCE", sizeof ("FINALIZE_INSTANCE") - 1, 0); instance->ref_count += 2; /* HACK: temporarily revive the object. */ /* does the function exist? then call it. */ if (slot && GvCV (*slot)) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (sv_2mortal (gperl_new_object (instance, FALSE))); PUTBACK; call_sv ((SV *)GvCV (*slot), G_VOID|G_DISCARD); FREETMPS; LEAVE; } instance->ref_count -= 2; /* HACK END */ } } else if (do_nonperl) { class->finalize (instance); do_nonperl = 0; } class = g_type_class_peek_parent (class); } while (class); } static void gperl_type_instance_init (GObject * instance) { /* * for new objects, this may be the place where the initial * perl object is created. we won't worry about the owner * semantics here, but since initializers are called from the * inside out, we will need to worry about making sure we get * blessed into the right class! */ SV *obj; HV *stash = gperl_object_stash_from_type (G_OBJECT_TYPE (instance)); SV **slot; g_assert (stash != NULL); /* we need to always create a wrapper, regardless of whether there is * an INIT_INSTANCE sub. otherwise, the fallback mechanism in * GType.xs' SET_PROPERTY handler will not have an HV to store the * properties in. * * we also need to ensure that the wrapper we create is not immediately * destroyed when we return from gperl_type_instance_init. otherwise, * instances of classes derived from GInitiallyUnowned might be * destroyed prematurely when code in INIT_INSTANCE manages to sink the * initial, floating reference. example: in a container subclass' * INIT_INSTANCE, adding a child and then calling the child's * get_parent() method. so we mortalize the wrapper before the * SAVETMPS/FREETMPS pair below. this should ensure that the wrapper * survives long enough so that it is still intact when the call to the * Perl constructor returns. * * if we always sank floating references, or if we forbade doing things * as described in the example, we could simply free the SV before we * return from gperl_type_instance_init. this would result in more * predictable reference counting. */ obj = sv_2mortal (gperl_new_object (instance, FALSE)); /* we need to re-bless the wrapper because classes change * during construction of an object. */ sv_bless (obj, stash); /* get the INIT_INSTANCE sub from this package. */ slot = hv_fetch (stash, "INIT_INSTANCE", sizeof ("INIT_INSTANCE") - 1, 0); #ifdef NOISY warn ("gperl_type_instance_init %s (%p) => %s\n", G_OBJECT_TYPE_NAME (instance), instance, SvPV_nolen (obj)); #endif /* does the function exist? then call it. */ if (slot && GvCV (*slot)) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); XPUSHs (obj); PUTBACK; call_sv ((SV *)GvCV (*slot), G_VOID|G_DISCARD); FREETMPS; LEAVE; } } static GQuark gperl_type_reg_quark (void) G_GNUC_CONST; static GQuark gperl_type_reg_quark (void) { static GQuark q = 0; if (!q) q = g_quark_from_static_string ("__gperl_type_reg"); return q; } typedef struct { GType instance_type; AV *interfaces; AV *properties; HV *signals; } GPerlClassData; static void gperl_type_class_init (GObjectClass * class, GPerlClassData * class_data) { class->finalize = gperl_type_finalize; class->get_property = gperl_type_get_property; class->set_property = gperl_type_set_property; if (class_data->properties) add_properties (class_data->instance_type, class, class_data->properties); if (class_data->signals) add_signals (class_data->instance_type, class_data->signals, class_data->interfaces); } static void gperl_type_base_init (gpointer class) { /* * tricksey little hobbitses... * * we use the same function pointer for all perl-derived types' * base_init functions. since we get the class structure and * nothing else, we have no way of knowing which class is actually * being booted. thus, we resort to trickery. * * we know that class initialization class class_init for your new * type, then goes inside out calling the base_inits for the types * in your ancestry. that means we'll get into this function once * for each type in a particular class instance's lineage. * * so, we keep a private hash of class structures we have seen * before, containing a list of the types remaining to be initialized. * each time we get in here, we find the first perl-derived type * (as marked by Glib::Type::register as something which will use * this function), and look for the INIT_BASE function in that type's * package. we pop items from the list so that we don't use them * twice. when we've hit the end of the list, we forget that class * instance to save memory; this is safe because we should never * get back in here for that instance anyway. * * remember that we must pass to the method the package corresponding * to the bottom of the hierarchy, so that client code knows what * class we are actually initializing. otherwise, INIT_BASE methods * implemented in XS would find the wrong GTypeClass and mangle things * rather badly. * * many thanks to Brett Kosinski for devising this evil^Wclever scheme. */ #if GLIB_CHECK_VERSION (2, 32, 0) /* GRecMutex in static storage do not need initialization */ static GRecMutex base_init_lock; #else static GStaticRecMutex base_init_lock = G_STATIC_REC_MUTEX_INIT; #endif /* 2.32 */ static GHashTable * seen = NULL; GSList * types; GType t; #if GLIB_CHECK_VERSION (2, 32, 0) g_rec_mutex_lock (&base_init_lock); #else g_static_rec_mutex_lock (&base_init_lock); #endif /* 2.32 */ if (!seen) seen = g_hash_table_new (g_direct_hash, g_direct_equal); types = g_hash_table_lookup (seen, class); if (!types) { /* haven't seen this class instance before */ t = G_TYPE_FROM_CLASS (class); do { types = g_slist_prepend (types, (gpointer) t); } while (0 != (t = g_type_parent (t))); } g_assert (types); /* start at the head of the list of types and find the next * perl-created type. */ while (types != NULL && !g_type_get_qdata ((GType)types->data, gperl_type_reg_quark())) { types = g_slist_delete_link (types, types); } t = types ? (GType) types->data : 0; /* and shift this one off so we don't use it again. */ types = g_slist_delete_link (types, types); /* clean up now, while we're thinking about it */ if (types) g_hash_table_replace (seen, class, types); else g_hash_table_remove (seen, class); if (t) { const char * package; HV * stash; SV ** slot; package = gperl_package_from_type (t); g_assert (package != NULL); stash = gv_stashpv (package, FALSE); g_assert (stash != NULL); slot = hv_fetch (stash, "INIT_BASE", sizeof ("INIT_BASE")-1, 0); if (slot && GvCV (*slot)) { dSP; ENTER; SAVETMPS; PUSHMARK (SP); /* remember, use the bottommost package name! */ XPUSHs (sv_2mortal (newSVpv (g_type_name (G_TYPE_FROM_CLASS (class)), 0))); PUTBACK; call_sv ((SV*) GvCV (*slot), G_VOID|G_DISCARD); FREETMPS; LEAVE; } } #if GLIB_CHECK_VERSION (2, 32, 0) g_rec_mutex_unlock (&base_init_lock); #else g_static_rec_mutex_unlock (&base_init_lock); #endif /* 2.32 */ } /* make sure we close the open list to keep from freaking out pod readers... */ =back =cut MODULE = Glib::Type PACKAGE = Glib::Type PREFIX = g_type_ =for object Glib::Type Utilities for dealing with the GLib Type system =for flags Glib::SignalFlags =cut =for position DESCRIPTION =head1 DESCRIPTION This package defines several utilities for dealing with the GLib type system from Perl. Because of some fundamental differences in how the GLib and Perl type systems work, a fair amount of the binding magic leaks out, and you can find most of that in the C functions, which register new types with the GLib type system. Most of the rest of the functions provide introspection functionality, such as listing properties and values and other cool stuff that is used mainly by Glib's reference documentation generator (see L). =cut BOOT: gperl_register_fundamental (G_TYPE_ENUM, "Glib::Enum"); gperl_register_fundamental (G_TYPE_FLAGS, "Glib::Flags"); gperl_register_fundamental (G_TYPE_CHAR, "Glib::Char"); gperl_register_fundamental (G_TYPE_UCHAR, "Glib::UChar"); gperl_register_fundamental (G_TYPE_INT, "Glib::Int"); gperl_register_fundamental (G_TYPE_UINT, "Glib::UInt"); gperl_register_fundamental (G_TYPE_LONG, "Glib::Long"); gperl_register_fundamental (G_TYPE_ULONG, "Glib::ULong"); gperl_register_fundamental (G_TYPE_INT64, "Glib::Int64"); gperl_register_fundamental (G_TYPE_UINT64, "Glib::UInt64"); gperl_register_fundamental (G_TYPE_FLOAT, "Glib::Float"); gperl_register_fundamental (G_TYPE_DOUBLE, "Glib::Double"); gperl_register_fundamental (G_TYPE_BOOLEAN, "Glib::Boolean"); #if GLIB_CHECK_VERSION (2, 10, 0) gperl_register_fundamental (G_TYPE_GTYPE, "Glib::GType"); #endif gperl_register_boxed (GPERL_TYPE_SV, "Glib::Scalar", NULL); /* i love nasty ugly hacks for backwards compat... Glib::UInt used * to be misspelled as Glib::Uint. by registering both names to the * same gtype, we get the mappings for two packages to one gtype, but * only one mapping (the last and correct one) from type to package. */ gperl_register_fundamental_alias (G_TYPE_UINT, "Glib::Uint"); /* register custom GTypes that do not have a better home. */ gperl_register_fundamental (GPERL_TYPE_SPAWN_FLAGS, "Glib::SpawnFlags"); =for apidoc =for arg parent_class (package) type from which to derive =for arg new_class (package) name of new type =for arg ... arguments for creation Register a new type with the GLib type system. This is a traffic-cop function. If I<$parent_type> derives from Glib::Object, this passes the arguments through to C. If I<$parent_type> is Glib::Flags or Glib::Enum, this strips I<$parent_type> and passes the remaining args on to C or C. See those functions' documentation for more information. =cut void g_type_register (class, const char * parent_class, new_class, ...) PREINIT: GType parent_type, base_type; char * sym; int n; SV ** oldargs; CODE: /* * we originally had just Glib::Type::register, and it only did * GObjects. the name implies that it can do anything, so it * should be able to. to make the code managable we broke the * actual work into separate functions, and do make the documentation * intelligible, we made those helpers public. this one, then, * exists to retain backward compatibility, and acts as a traffic * cop, farming out the work to the right helper function. * * i had written this traffic cop in Glib.pm, but getting the pod * to show up in Glib/Type.pod would've required a good amount of * tear-up in Glib::ParseXSDoc. So, here it is as an xsub. */ parent_type = gperl_type_from_package (parent_class); if (!parent_type) croak ("package %s is not registered with the GLib type system", parent_class); base_type = G_TYPE_FUNDAMENTAL (parent_type); switch (base_type) { case G_TYPE_OBJECT: sym = "Glib::Type::register_object"; break; case G_TYPE_ENUM: sym = "Glib::Type::register_enum"; break; case G_TYPE_FLAGS: sym = "Glib::Type::register_flags"; break; default: croak ("sorry, don't know how to derive from a %s in Perl", g_type_name (base_type)); } /* * because we need to strip an arg from the stack for register_enum * and register_flags, we can't just call_* right here. */ oldargs = & ST (0); n = items - 3; { gint i; ENTER; SAVETMPS; PUSHMARK (SP); EXTEND (SP, 3+n); PUSHs (oldargs[0]); if (base_type == G_TYPE_OBJECT) PUSHs (oldargs[1]); PUSHs (oldargs[2]); for (i = 0 ; i < n ; i++) PUSHs (oldargs[3+i]); PUTBACK; call_method (sym, G_VOID); SPAGAIN; FREETMPS; LEAVE; } =for apidoc =arg parent_package () name of the parent package, which must be a derivative of Glib::Object. =arg new_package usually __PACKAGE__. =for arg ... (list) key/value pairs controlling how the class is created. Register I as an officially GLib-sanctioned derivative of the (GObject derivative) I. This automatically sets up an @ISA entry for you, and creates a new GObjectClass under the hood. The I<...> parameters are key/value pairs, currently supporting: =over =item signals => HASHREF The C key contains a hash, keyed by signal names, which describes how to set up the signals for I. If the value is a code reference, the named signal must exist somewhere in I or its ancestry; the code reference will be used to override the class closure for that signal. This is the officially sanctioned way to override virtual methods on Glib::Objects. The value may be a string rather than a code reference, in which case the sub with that name in I will be used. (The function should not be inherited.) If the value is a hash reference, the key will be the name of a new signal created with the properties defined in the hash. All of the properties are optional, with defaults provided: =over =item class_closure => subroutine or undef Use this code reference (or sub name) as the class closure (that is, the default handler for the signal). If not specified, "do_I", in the current package, is used. =item return_type => package name or undef Return type for the signal. If not specified, then the signal has void return. =item param_types => ARRAYREF Reference to a list of parameter types (package names), I. Callbacks connected to this signal will receive the instance object as the first argument, followed by arguments with the types listed here, and finally by any user data that was supplied when the callback was connected. Not specifying this key is equivalent to supplying an empty list, which actually means instance and maybe data. =item flags => Glib::SignalFlags Flags describing this signal's properties. See the GObject C API reference' description of GSignalFlags for a complete description. =item accumulator => subroutine or undef The signal accumulator is a special callback that can be used to collect return values of the various callbacks that are called during a signal emission. Generally, you can omit this parameter; custom accumulators are used to do things like stopping signal propagation by return value or creating a list of returns, etc. See L for details. =back =item properties => ARRAYREF Array of Glib::ParamSpec objects, each describing an object property to add to the new type. These properties are available for use by all code that can access the object, regardless of implementation language. See L. This list may be empty; if it is not, the functions C and C in I<$new_package> will be called to get and set the values. Note that an object property is just a mechanism for getting and setting a value -- it implies no storage. As a convenience, however, Glib::Object provides fallbacks for GET_PROPERTY and SET_PROPERTY which use the property nicknames as hash keys in the object variable for storage. Additionally, you may specify ParamSpecs as a describing hash instead of as an object; this form allows you to supply explicit getter and setter methods which override GET_PROPERY and SET_PROPERTY. The getter and setter are both optional in the hash form. For example: Glib::Type->register_object ('Glib::Object', 'Foo', properties => [ # specified normally Glib::ParamSpec->string (...), # specified explicitly { pspec => Glib::ParamSpec->int (...), set => sub { my ($object, $newval) = @_; ... }, get => sub { my ($object) = @_; ... return $val; }, }, ] ); You can mix the two declaration styles as you like. If you have individual C / C methods with the operative code for a property then the C/C form is a handy way to go straight to that. =item interfaces => ARRAYREF Array of interface package names that the new object implements. Interfaces are the GObject way of doing multiple inheritance, thus, in Perl, the package names will be prepended to @ISA and certain inheritable and overrideable ALLCAPS methods will automatically be called whenever needed. Which methods exactly depends on the interface -- Gtk2::CellEditable for example uses START_EDITING, EDITING_DONE, and REMOVE_WIDGET. =back =cut void g_type_register_object (class, parent_package, new_package, ...); char * parent_package char * new_package PREINIT: int i; GTypeInfo type_info; GPerlClassData class_data; GTypeQuery query; GType parent_type, new_type; char * new_type_name; CODE: /* start with a clean slate */ memset (&type_info, 0, sizeof (GTypeInfo)); memset (&class_data, 0, sizeof (GPerlClassData)); type_info.base_init = (GBaseInitFunc) gperl_type_base_init; type_info.class_init = (GClassInitFunc) gperl_type_class_init; type_info.instance_init = (GInstanceInitFunc) gperl_type_instance_init; type_info.class_data = &class_data; /* yeah, i could just call gperl_object_type_from_package directly, * but i want the error messages to be more informative. */ parent_type = gperl_type_from_package (parent_package); if (!parent_type) croak ("package %s has not been registered with GPerl", parent_package); if (!g_type_is_a (parent_type, G_TYPE_OBJECT)) croak ("%s (%s) is not a descendent of Glib::Object (GObject)", parent_package, g_type_name (parent_type)); /* ask the type system for the missing values */ g_type_query (parent_type, &query); type_info.class_size = query.class_size; type_info.instance_size = query.instance_size; /* and now register with the gtype system */ /* mangle the name to remove illegal characters */ new_type_name = sanitize_package_name (new_package); new_type = g_type_register_static (parent_type, new_type_name, &type_info, 0); #ifdef NOISY warn ("registered %s, son of %s nee %s(%d), as %s(%d)", new_package, parent_package, g_type_name (parent_type), parent_type, new_type_name, new_type); #endif g_free (new_type_name); /* and with the bindings */ gperl_register_object (new_type, new_package); /* mark this type as "one of ours". */ g_type_set_qdata (new_type, gperl_type_reg_quark (), (gpointer) TRUE); /* put it into the class data so that add_signals and add_properties * can use it. */ class_data.instance_type = new_type; /* now look for things we should initialize, e.g. signals and * properties and interfaces. put the corresponding data into the * class_data struct. the interfaces will be handled directly further * below, while the properties and signals will be handled in the * class_init function so that they have access to the class instance. * this mimics the way things are supposed to be done in C: register * interfaces in the get_type function, and register properties and * signals in the class_init function. */ for (i = 3 ; i < items ; i += 2) { char * key = SvPV_nolen (ST (i)); if (strEQ (key, "signals")) { if (gperl_sv_is_hash_ref (ST (i+1))) class_data.signals = (HV*)SvRV (ST (i+1)); else croak ("signals must be a hash of signalname => signalspec pairs"); } else if (strEQ (key, "properties")) { if (gperl_sv_is_array_ref (ST (i+1))) class_data.properties = (AV*)SvRV (ST (i+1)); else croak ("properties must be an array of GParamSpecs"); } else if (strEQ (key, "interfaces")) { if (gperl_sv_is_array_ref (ST (i+1))) class_data.interfaces = (AV*)SvRV (ST (i+1)); else croak ("interfaces must be an array of package names"); } } /* add the interfaces to the type now before we create its class and * enter the class_init function. */ if (class_data.interfaces) add_interfaces (new_type, class_data.interfaces); /* instantiate the class right now. perl doesn't let classes go * away once they've been defined, so we'll just leak this ref and * let the GObjectClass live as long as the program. in fact, * because we don't really have class_init handlers like C, we * really don't want the class to die and be reinstantiated, because * some of the setup (namely all the class setup we just did and * the override installation coming up) will never happen * again. * this statement will cause an arbitrary amount of stuff to happen. */ g_type_class_ref (new_type); /* leak */ /* vfuncs cause a bit of a problem, because the normal mechanisms of * GObject don't give us a predefined way to handle them. here we * provide a way to override them in each child class as it is * derived. */ install_overrides (new_type); /* fin */ =for apidoc =for arg name package name for new enum type =for arg ... new enum's values; see description. =for signature Glib::Type->register_enum ($name, ...) Register and initialize a new Glib::Enum type with the provided "values". This creates a type properly registered GLib so that it can be used for property and signal parameter or return types created with C<< Glib::Type->register >> or C. The list of values is used to create the "nicknames" that are used in general Perl code; the actual numeric values used at the C level are automatically assigned, starting with 1. If you need to specify a particular numeric value for a nick, use an array reference containing the nickname and the numeric value, instead. You may mix and match the two styles. Glib::Type->register_enum ('MyFoo::Bar', 'value-one', # assigned 1 'value-two', # assigned 2 ['value-three' => 15 ], # explicit 15 ['value-four' => 35 ], # explicit 35 'value-five', # assigned 5 ); If you use the array-ref form, beware: the code performs no validation for unique values. =cut void g_type_register_enum (class, name, ...) const char * name PREINIT: int i = 0; char * ctype_name; SV * sv; SV ** av2sv; GType type; GEnumValue * values = NULL; CODE: if (items-2 < 1) croak ("Usage: Glib::Type->register_enums (new_package, LIST)\n" " no values supplied"); /* * we create a value table on the fly, and we can't free it without * causing problems. the value table is stored in the type * registration information, which conceivably may be called more * than once per program (which is why we don't use a class_finalize * to destroy it). unfortunately, there doesn't appear to be a * g_enum_register_dynamic(). * this means we will also leak the nickname strings, which must * be duplicated to keep them alive (perl will reuse those strings). * * note also that we don't clean up very well when things go wrong. * we build up the structure as we go, and an exception in the middle * will leak everything done up to that point. we could clean it up, * but it will make things uglier than they already are, and if * your script can't register the enums properly, it probably won't * live much longer. */ values = g_new0 (GEnumValue, items-1); /* leak (see above) */ for (i = 0; i < items-2; i++) { sv = (SV*)ST (i+2); /* default to the i based numbering */ values[i].value = i + 1; if (gperl_sv_is_array_ref (sv)) { /* [ name => value ] syntax */ AV * av = (AV*)SvRV(sv); /* value_name */ av2sv = av_fetch (av, 0, 0); if (av2sv && gperl_sv_is_defined (*av2sv)) values[i].value_name = SvPV_nolen (*av2sv); else croak ("invalid enum name and value pair, no name provided"); /* custom value */ av2sv = av_fetch (av, 1, 0); if (av2sv && gperl_sv_is_defined (*av2sv)) values[i].value = SvIV (*av2sv); } else if (gperl_sv_is_defined (sv)) { /* name syntax */ values[i].value_name = SvPV_nolen (sv); } else croak ("invalid type flag name"); /* make sure that the nickname stays alive as long as the * type is registered. */ values[i].value_name = g_strdup (values[i].value_name); /* let the nick and name match. there are few uses for the * name, anyway. */ values[i].value_nick = values[i].value_name; } ctype_name = sanitize_package_name (name); type = g_enum_register_static (ctype_name, values); gperl_register_fundamental (type, name); g_free (ctype_name); =for apidoc =for arg name package name of new flags type =for arg ... flag values, see discussion. =for signature Glib::Type->register_flags ($name, ...) Register and initialize a new Glib::Flags type with the provided "values". This creates a type properly registered GLib so that it can be used for property and signal parameter or return types created with C<< Glib::Type->register >> or C. The list of values is used to create the "nicknames" that are used in general Perl code; the actual numeric values used at the C level are automatically assigned, of the form 1<register_flags ('MyFoo::Baz', 'value-one', # assigned 1<<0 'value-two', # assigned 1<<1 ['value-three' => 1<<10 ], # explicit 1<<10 ['value-four' => 0x0f ], # explicit 0x0f 'value-five', # assigned 1<<4 ); If you use the array-ref form, beware: the code performs no validation for unique values. =cut void g_type_register_flags (class, name, ...) const char * name PREINIT: int i = 0; char * ctype_name; SV * sv; SV ** av2sv; GType type; GFlagsValue * values = NULL; CODE: if (items-2 < 1) croak ("Usage: Glib::Type->register_flags (new_package, LIST)\n" " no values supplied"); /* see the notes about memory management in register_enums -- they * all apply here. we can't combine the implementations because * GEnumValue and GFlagsValue are not typedefed together. */ values = g_new0 (GFlagsValue, items-1); for (i = 0; i < items-2; i++) { sv = (SV*)ST (i+2); /* default to the i based numbering */ values[i].value = 1 << i; if (gperl_sv_is_array_ref (sv)) { /* [ name => value ] syntax */ AV * av = (AV*)SvRV(sv); /* value_name */ av2sv = av_fetch (av, 0, 0); if (av2sv && gperl_sv_is_defined (*av2sv)) values[i].value_name = SvPV_nolen (*av2sv); else croak ("invalid flag name and value pair, no name provided"); /* custom value */ av2sv = av_fetch (av, 1, 0); if (av2sv && gperl_sv_is_defined (*av2sv)) values[i].value = SvIV (*av2sv); } else if (gperl_sv_is_defined (sv)) { /* name syntax */ values[i].value_name = SvPV_nolen (sv); } else croak ("invalid type flag name"); /* make sure that the nickname stays alive as long as the * type is registered. */ values[i].value_name = g_strdup (values[i].value_name); /* let the nick and name match. there are few uses for the * name, anyway. */ values[i].value_nick = values[i].value_name; } ctype_name = sanitize_package_name (name); type = g_flags_register_static (ctype_name, values); gperl_register_fundamental (type, name); g_free (ctype_name); =for apidoc List the ancestry of I, as seen by the GLib type system. The important difference is that GLib's type system implements only single inheritance, whereas Perl's @ISA allows multiple inheritance. This returns the package names of the ancestral types in reverse order, with the root of the tree at the end of the list. See also LB ($package)">. =cut void list_ancestors (class, package) gchar * package PREINIT: GType package_gtype; GType parent_gtype; const char * pkg; PPCODE: package_gtype = gperl_type_from_package (package); XPUSHs (sv_2mortal (newSVpv (package, 0))); if (!package_gtype) croak ("%s is not registered with either GPerl or GLib", package); parent_gtype = g_type_parent (package_gtype); while (parent_gtype) { pkg = gperl_package_from_type (parent_gtype); if (!pkg) croak("problem looking up parent package name, " "gtype %d", parent_gtype); XPUSHs (sv_2mortal (newSVpv (pkg, 0))); parent_gtype = g_type_parent (parent_gtype); } =for apidoc List the GInterfaces implemented by the type associated with I. The interfaces are returned as package names. =cut void list_interfaces (class, package) gchar * package PREINIT: int i; GType package_gtype; GType * interfaces; PPCODE: package_gtype = gperl_type_from_package (package); if (!package_gtype) croak ("%s is not registered with either GPerl or GLib", package); interfaces = g_type_interfaces (package_gtype, NULL); if (!interfaces) XSRETURN_EMPTY; for (i = 0; interfaces[i] != 0; i++) { const char * name = gperl_package_from_type (interfaces[i]); if (!name) { /* this is usually a sign that the bindings are * missing something. let's print a warning to make * this easier to find. */ name = g_type_name (interfaces[i]); warn ("GInterface %s is not registered with GPerl", name); } XPUSHs (sv_2mortal (newSVpv (name, 0))); } g_free (interfaces); =for apidoc List the signals associated with I. This lists only the signals for I, not any of its parents. The signals are returned as a list of anonymous hashes which mirror the GSignalQuery structure defined in the C API reference. =over =item - signal_id Numeric id of a signal. It's rare that you'll need this in Gtk2-Perl. =item - signal_name Name of the signal, such as what you'd pass to C. =item - itype The Instance I for which this signal is defined. =item - signal_flags GSignalFlags describing this signal. =item - return_type The return type expected from handlers for this signal. If undef or not present, then no return is expected. The type name is mapped to the corresponding Perl package name if it is known, otherwise you get the raw C name straight from GLib. =item - param_types The types of the parameters passed to any callbacks connected to the emission of this signal. The list does not include the instance, which is always first, and the user data from C, which is always last (unless the signal was connected with "swap", which swaps the instance and the data, but you get the point). =back =cut void list_signals (class, package) gchar * package PREINIT: guint i, num; guint * sigids; GType package_type; GSignalQuery siginfo; GObjectClass * oclass = NULL; PPCODE: package_type = gperl_type_from_package (package); if (!package_type) croak ("%s is not registered with either GPerl or GLib", package); if (!G_TYPE_IS_INSTANTIATABLE(package_type) && !G_TYPE_IS_INTERFACE (package_type)) XSRETURN_EMPTY; if (G_TYPE_IS_CLASSED (package_type)) { /* ref the class to ensure that the signals get created. */ oclass = g_type_class_ref (package_type); if (!oclass) XSRETURN_EMPTY; } sigids = g_signal_list_ids (package_type, &num); if (!num) XSRETURN_EMPTY; EXTEND(SP, num); for (i = 0; i < num; i++) { g_signal_query (sigids[i], &siginfo); PUSHs (sv_2mortal (newSVGSignalQuery (&siginfo))); } if (oclass) g_type_class_unref (oclass); =for apidoc List the legal values for the GEnum or GFlags type I<$package>. If I<$package> is not a package name registered with the bindings, this name is passed on to g_type_from_name() to see if it's a registered flags or enum type that just hasn't been registered with the bindings by C (see Glib::xsapi). If I<$package> is not the name of an enum or flags type, this function will croak. Returns the values as a list of hashes, one hash for each value, containing the value, name and nickname, eg. for Glib::SignalFlags { value => 8, name => 'G_SIGNAL_NO_RECURSE', nick => 'no-recurse' } =cut void list_values (class, const char * package) PREINIT: GType type; PPCODE: type = gperl_fundamental_type_from_package (package); if (!type) type = g_type_from_name (package); if (!type) croak ("%s is not registered with either GPerl or GLib", package); /* * GFlagsValue and GEnumValue are nearly the same, but differ in * that GFlagsValue is a guint for the value, but GEnumValue is gint * (and some enums do indeed use negatives, eg. GtkResponseType). */ if (G_TYPE_IS_ENUM (type)) { GEnumValue * v = gperl_type_enum_get_values (type); for ( ; v && v->value_nick && v->value_name ; v++) { HV * hv = newHV (); gperl_hv_take_sv_s (hv, "value", newSViv (v->value)); gperl_hv_take_sv_s (hv, "nick", newSVpv (v->value_nick, 0)); gperl_hv_take_sv_s (hv, "name", newSVpv (v->value_name, 0)); XPUSHs (sv_2mortal (newRV_noinc ((SV*)hv))); } } else if (G_TYPE_IS_FLAGS (type)) { GFlagsValue * v = gperl_type_flags_get_values (type); for ( ; v && v->value_nick && v->value_name ; v++) { HV * hv = newHV (); gperl_hv_take_sv_s (hv, "value", newSVuv (v->value)); gperl_hv_take_sv_s (hv, "nick", newSVpv (v->value_nick, 0)); gperl_hv_take_sv_s (hv, "name", newSVpv (v->value_name, 0)); XPUSHs (sv_2mortal (newRV_noinc ((SV*)hv))); } } else { croak ("%s is neither enum nor flags type", package); } =for apidoc Convert a C type name to the corresponding Perl package name. If no package is registered to that type, returns I<$cname>. =cut const char * package_from_cname (class, const char * cname) PREINIT: GType gtype; CODE: gtype = g_type_from_name (cname); if (!gtype) { croak ("%s is not registered with the GLib type system", cname); RETVAL = cname; } else { RETVAL = gperl_package_from_type (gtype); if (!RETVAL) RETVAL = cname; } OUTPUT: RETVAL MODULE = Glib::Type PACKAGE = Glib::Flags =for position DESCRIPTION =head1 DESCRIPTION Glib maps flag and enum values to the nicknames strings provided by the underlying C libraries. Representing flags this way in Perl is an interesting problem, which Glib solves by using some cool overloaded operators. The functions described here actually do the work of those overloaded operators. See the description of the flags operators in the "This Is Now That" section of L for more info. =cut =for apidoc Create a new flags object with given bits. This is for use from a subclass, it's not possible to create a C object as such. For example, my $f1 = Glib::ParamFlags->new ('readable'); my $f2 = Glib::ParamFlags->new (['readable','writable']); An object like this can then be used with the overloaded operators. =cut SV * new (const char *class, SV *a) PREINIT: GType gtype; CODE: gtype = gperl_fundamental_type_from_package (class); if (! gtype || ! g_type_is_a (gtype, G_TYPE_FLAGS)) { croak ("package %s is not registered with the GLib type system " "as a flags type", class); } if (gtype == G_TYPE_FLAGS) { croak ("cannot create Glib::Flags (only subclasses)"); } RETVAL = gperl_convert_back_flags (gtype, gperl_convert_flags (gtype, a)); OUTPUT: RETVAL =for apidoc =for signature bool = $f->bool =for arg ... (__hide__) Return 1 if any bits are set in $f, or 0 if none are set. This is the overload for $f in boolean context (like C, etc). You can call it as a method to get a true/false directly too. =cut int bool (SV *f, ...) PROTOTYPE: $;@ CODE: RETVAL = !!gperl_convert_flags ( gperl_fundamental_type_from_obj (f), f ); OUTPUT: RETVAL =for apidoc =for signature aref = $f->as_arrayref =for arg ... (__hide__) Return the bits of $f as a reference to an array of strings, like ['flagbit1','flagbit2']. This is the overload function for C<@{}>, ie. arrayizing $f. You can call it directly as a method too. Note that @$f gives the bits as a list, but as_arrayref gives an arrayref. If an arrayref is what you want then the method style somefunc()->as_arrayref can be more readable than [@{somefunc()}]. =cut SV * as_arrayref (SV *f, ...) PROTOTYPE: $;@ CODE: { /* overload @{} calls here with the usual three args "a,b,swap", but * "b" and "swap" have no meaning. Using "..." to ignore them lets * users call method-style with no args "$f->as_arrayref" too. */ GType gtype; gint f_; gtype = gperl_fundamental_type_from_obj (f); f_ = gperl_convert_flags (gtype, f); RETVAL = flags_as_arrayref (gtype, f_); } OUTPUT: RETVAL int eq (SV *a, SV *b, int swap) ALIAS: ne = 1 ge = 2 CODE: { GType gtype; gint a_, b_; gtype = gperl_fundamental_type_from_obj (a); a_ = gperl_convert_flags (gtype, swap ? b : a); b_ = gperl_convert_flags (gtype, swap ? a : b); RETVAL = FALSE; switch (ix) { case 0: RETVAL = a_ == b_; break; case 1: RETVAL = a_ != b_; break; case 2: RETVAL = (a_ & b_) == b_; break; } } OUTPUT: RETVAL SV * union (SV *a, SV *b, SV *swap) ALIAS: sub = 1 intersect = 2 xor = 3 all = 4 CODE: { GType gtype; gint a_, b_; gtype = gperl_fundamental_type_from_obj (a); a_ = gperl_convert_flags (gtype, SvTRUE (swap) ? b : a); b_ = gperl_convert_flags (gtype, SvTRUE (swap) ? a : b); switch (ix) { case 0: a_ |= b_; break; case 1: a_ &=~b_; break; case 2: a_ &= b_; break; case 3: a_ ^= b_; break; } RETVAL = gperl_convert_back_flags (gtype, a_); } OUTPUT: RETVAL Glib-1.320/GUtils.xs000644 001750 000024 00000035113 12251766676 015277 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2004-2005 by the gtk2-perl team (see the file AUTHORS for a * complete list) * * 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 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. * * $Id$ */ #include "gperl.h" #include "gperl-gtypes.h" #if GLIB_CHECK_VERSION (2, 14, 0) GUserDirectory SvGUserDirectory (SV *sv) { return gperl_convert_enum (GPERL_TYPE_USER_DIRECTORY, sv); } SV * newSVGUserDirectory (GUserDirectory dir) { return gperl_convert_back_enum (GPERL_TYPE_USER_DIRECTORY, dir); } #endif MODULE = Glib::Utils PACKAGE = Glib PREFIX = g_ BOOT: #if GLIB_CHECK_VERSION (2, 14, 0) gperl_register_fundamental (GPERL_TYPE_USER_DIRECTORY, "Glib::UserDirectory"); #endif =for object Glib::Utils Miscellaneous utility functions =cut =for position SYNOPSIS =head1 SYNOPSIS use Glib; Glib::set_application_name (Glib::get_real_name."'s Cool Program"); print "app name is ".Glib::get_application_name()."\n"; =for position DESCRIPTION =head1 DESCRIPTION Here are some useful miscellaneous utilities. GLib is a portability library, providing portable utility functions for C programs. As such, most of these functions seem to violate the Glib binding principle of not duplicating functionality that Perl already provides, but there's a distinction for each one, i swear. The functions for dealing with user information are provided on all GLib-supported platforms, not just where POSIX (which provides similar information) is available, and even work on platforms where %ENV may not include the expected information. Also, the "application name" referred to by (set|get)_application_name is a human readable name, distinct from the actual program name provided by Perl's own $0. =cut ### FIXME ### we should have a pod section called FUNCTIONS. =for apidoc Glib::get_real_name __function__ Get the current user's real name. =cut =for apidoc Glib::get_home_dir __function__ Find the current user's home directory, by system-dependent/appropriate means. =cut =for apidoc Glib::get_tmp_dir __function__ Get the temp dir as appropriate for the current system. See the GLib docs for info on how it works. =cut =for apidoc __function__ Get the current user's name by whatever system-dependent means necessary. =cut const gchar * g_get_user_name () ALIAS: Glib::get_real_name = 1 Glib::get_home_dir = 2 Glib::get_tmp_dir = 3 CODE: switch (ix) { case 0: RETVAL = g_get_user_name (); break; case 1: RETVAL = g_get_real_name (); break; case 2: RETVAL = g_get_home_dir (); break; case 3: RETVAL = g_get_tmp_dir (); break; default: RETVAL = NULL; g_assert_not_reached (); } OUTPUT: RETVAL #if GLIB_CHECK_VERSION (2, 6, 0) =for apidoc Glib::get_user_config_dir __function__ Gets the base directory in which to store user-specific application configuration information such as user preferences and settings. =cut =for apidoc Glib::get_user_cache_dir __function__ Gets the base directory in which to store non-essential, cached data specific to particular user. =cut =for apidoc __function__ Get the base directory for application data such as icons that is customized for a particular user. =cut const gchar * g_get_user_data_dir () ALIAS: Glib::get_user_config_dir = 1 Glib::get_user_cache_dir = 2 CODE: switch (ix) { case 0: RETVAL = g_get_user_data_dir (); break; case 1: RETVAL = g_get_user_config_dir (); break; case 2: RETVAL = g_get_user_cache_dir (); break; default: RETVAL = NULL; g_assert_not_reached (); } OUTPUT: RETVAL =for apidoc Glib::get_system_config_dirs __function__ Returns an ordered list of base directories in which to access system-wide configuration information. =cut =for apidoc Glib::get_language_names __function__ Computes a list of applicable locale names, which can be used to e.g. construct locale-dependent filenames or search paths. The returned list is sorted from most desirable to least desirable and always contains the default locale "C". =cut =for apidoc __function__ Returns an ordered list of base directories in which to access system-wide application data. =cut void g_get_system_data_dirs () ALIAS: Glib::get_system_config_dirs = 1 Glib::get_language_names = 2 PREINIT: const gchar * const * strings; int i; PPCODE: switch (ix) { case 0: strings = g_get_system_data_dirs (); break; case 1: strings = g_get_system_config_dirs (); break; case 2: strings = g_get_language_names (); break; default: strings = NULL; g_assert_not_reached (); } for (i = 0; strings[i]; i++) XPUSHs (sv_2mortal (newSVGChar (strings[i]))); #endif #if GLIB_CHECK_VERSION (2, 14, 0) =for apidoc __function__ Returns the full path of a special directory using its logical id. =cut const gchar* g_get_user_special_dir (GUserDirectory directory); #endif ##=for apidoc __function__ ##Set GLib's global program name. Glib will set this to the value of $0 for ##you when it loads; this function is provided to give you a way to set the ##internal variable used by the GLib C library, since it knows nothing about ##$0. ##=cut ##gchar_own * g_get_prgname (); ## ##=for apidoc __function__ ##=cut ##void g_set_prgname (const gchar *prgname); #if GLIB_CHECK_VERSION(2, 2, 0) =for apidoc __function__ Get the human-readable application name set by C. =cut const gchar * g_get_application_name (); =for apidoc __function__ Set the human-readable application name. =cut void g_set_application_name (const gchar *application_name); #endif ### ### This stuff is functionality provided by File::Spec and friends. ### Thus we will not bind it. ### #gboolean g_path_is_absolute (const gchar *file_name); #G_CONST_RETURN gchar* g_path_skip_root (const gchar *file_name); #gchar* g_get_current_dir (void); #gchar* g_path_get_basename (const gchar *file_name); #gchar* g_path_get_dirname (const gchar *file_name); # # ## Look for an executable in PATH, following execvp() rules #gchar* g_find_program_in_path (const gchar *program); =for apidoc __function__ Return a string describing the given errno value, like "No such file or directory" for ENOENT. This is translated into the user's preferred language and is a utf8 wide-char string (unlike a $! string (L) or POSIX::strerror (L) which are locale codeset bytes). =cut ## note the returned string can be overwritten by the next call, so must copy const gchar *g_strerror (gint err); =for apidoc __function__ Return a string describing the given signal number, like "Segmentation violation" for SIGSEGV. This is translated into the user's preferred language and is a utf8 wide-char string. =cut ## note the returned string can be overwritten by the next call, so must copy const gchar *g_strsignal (gint signum); ### ### Version information ### ## this is a ridiculous amount of doc for six numbers and one checker method. =for object Glib::version Library Versioning Utilities =cut =for position SYNOPSIS =head1 SYNOPSIS # require at least version 1.021 of the Glib module use Glib '1.021'; # g_set_application_name() was introduced in GLib 2.2.0, and # first supported by version 1.040 of the Glib Perl module. if ($Glib::VERSION >= 1.040 and Glib->CHECK_VERSION (2,2,0)) { Glib::set_application_name ('My Cool Program'); } =for position DESCRIPTION =head1 DESCRIPTION Both the Glib module and the GLib C library are works-in-progress, and their interfaces grow over time. As more features are added to each, and your code uses those new features, you will introduce version-specific dependencies, and naturally, you'll want to be able to code around them. Enter the versioning API. For simple Perl modules, a single version number is sufficient; however, Glib is a binding to another software library, and this introduces some complexity. We have three versions that fully specify the API available to you. =over =item Perl Bindings Version Perl modules use a version number, and Glib is no exception. I<$Glib::VERSION> is the version of the current Glib module. By ad hoc convention, gtk2-perl modules generally use version numbers in the form x.yyz, where even yy values denote stable releases and z is a patchlevel. $Glib::VERSION use Glib 1.040; # require at least version 1.040 =item Compile-time ("Bound") Library Version This is the version of the GLib C library that was available when the Perl module was compiled and installed. These version constants are equivalent to the version macros provided in the GLib C headers. GLib uses a major.minor.micro convention, where even minor versions are stable. (gtk2-perl does not officially support unstable versions.) Glib::MAJOR_VERSION Glib::MINOR_VERSION Glib::MICRO_VERSION Glib->CHECK_VERSION($maj,$min,$mic) =item Run-time ("Linked") Library Version This is the version of the GLib C library that is available at run time; it may be newer than the compile-time version, but should never be older. These are equivalent to the version variables exported by the GLib C library. Glib::major_version Glib::minor_version Glib::micro_version =back =head2 Which one do I use when? Where do you use which version? It depends entirely on what you're doing. Let's explain by example: =over =item o Use the Perl module version for bindings support issues You need to register a new enum for use as the type of an object property. This is something you can do with all versions of the underlying C library, but which wasn't supported in the Glib Perl module until $Glib::VERSION >= 1.040. =item o Use the bound version for library features You want to call Glib::set_application_name to set a human-readable name for your application (which is used by various parts of Gtk2 and Gnome2). g_set_application_name() (the underlying C function) was added in version 2.2.0 of glib, and support for it was introduced into the Glib Perl module in Glib version 1.040. However, you can build the Perl module against any stable 2.x.x version of glib, so you might not have that function available even if your Glib module is new enough! Thus, you need to check two things to see if the this function is available: if ($Glib::VERSION >= 1.040 && Glib->CHECK_VERSION (2,2,0)) { # it's available, and we can call it! Glib::set_application_name ('My Cool Application'); } Now what happens if you installed the Perl module when your system had glib 2.0.6, and you upgraded glib to 2.4.1? Wouldn't g_set_application_name() be available? Well, it's there, under the hood, but the bindings were compiled when it wasn't there, so you won't be able to call it! That's why we check the "bound" or compile-time version. By the way, to enable support for the new function, you'd need to reinstall (or upgrade) the Perl module. =item o Use the linked version for runtime work-arounds Suppose there's a function whose API did not change, but whose implementation had a bug in one version that was fixed in another version. To determine whether you need to apply a workaround, you would check the version that is actually being used at runtime. if (Glib::major_version == 2 && Glib::minor_version == 2 && Glib::micro_version == 1) { # work around bug that exists only in glib 2.2.1. } In practice, such situations are very rare. =back =cut =for apidoc Glib::MINOR_VERSION __function__ Provides access to the version information that Glib was compiled against. Essentially equivalent to the #define's GLIB_MINOR_VERSION. =cut =for apidoc Glib::MICRO_VERSION __function__ Provides access to the version information that Glib was compiled against. Essentially equivalent to the #define's GLIB_MICRO_VERSION. =cut =for apidoc Glib::major_version __function__ Provides access to the version information that Glib is linked against. Essentially equivalent to the global variable glib_major_version. =cut =for apidoc Glib::minor_version __function__ Provides access to the version information that Glib is linked against. Essentially equivalent to the global variable glib_minor_version. =cut =for apidoc Glib::micro_version __function__ Provides access to the version information that Glib is linked against. Essentially equivalent to the global variable glib_micro_version. =cut =for apidoc __function__ Provides access to the version information that Glib was compiled against. Essentially equivalent to the #define's GLIB_MAJOR_VERSION. =cut guint MAJOR_VERSION () ALIAS: Glib::MINOR_VERSION = 1 Glib::MICRO_VERSION = 2 Glib::major_version = 3 Glib::minor_version = 4 Glib::micro_version = 5 CODE: switch (ix) { case 0: RETVAL = GLIB_MAJOR_VERSION; break; case 1: RETVAL = GLIB_MINOR_VERSION; break; case 2: RETVAL = GLIB_MICRO_VERSION; break; case 3: RETVAL = glib_major_version; break; case 4: RETVAL = glib_minor_version; break; case 5: RETVAL = glib_micro_version; break; default: RETVAL = -1; g_assert_not_reached (); } OUTPUT: RETVAL =for apidoc =for signature (MAJOR, MINOR, MICRO) = Glib->GET_VERSION_INFO Shorthand to fetch as a list the glib version for which Glib was compiled. See C, etc. =cut void GET_VERSION_INFO (class) PPCODE: EXTEND (SP, 3); PUSHs (sv_2mortal (newSViv (GLIB_MAJOR_VERSION))); PUSHs (sv_2mortal (newSViv (GLIB_MINOR_VERSION))); PUSHs (sv_2mortal (newSViv (GLIB_MICRO_VERSION))); PERL_UNUSED_VAR (ax); =for apidoc Provides a mechanism for checking the version information that Glib was compiled against. Essentially equvilent to the macro GLIB_CHECK_VERSION. =cut gboolean CHECK_VERSION (class, guint required_major, guint required_minor, guint required_micro) CODE: RETVAL = GLIB_CHECK_VERSION (required_major, required_minor, required_micro); OUTPUT: RETVAL MODULE = Glib::Utils PACKAGE = Glib::Markup PREFIX = g_markup_ =for apidoc __function__ =cut # gchar* g_markup_escape_text (const gchar *text, gssize length); gchar_own * g_markup_escape_text (text) const gchar* text CODE: RETVAL = g_markup_escape_text (text, strlen (text)); OUTPUT: RETVAL Glib-1.320/GValue.xs000644 001750 000024 00000024144 12060470577 015243 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2003-2009 by the gtk2-perl team (see the file AUTHORS for the * full list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * * $Id$ */ =head2 GValue GValue is GLib's generic value container, and it is because of GValue that the run time type handling of GObject parameters and GClosure marshaling can function, and most usages of these functions will be from those two points. Client code will run into uses for gperl_sv_from_value() and gperl_value_from_sv() when trying to convert lists of parameters into GValue arrays and the like. =over =cut #include "gperl.h" /**************************************************************************** * GValue handling * * we have code here to handle the fundamental types listed in the API * reference, plus the G_TYPE_ENUM and G_TYPE_FLAGS fundamentals. new * fundamentals created by g_type_fundamental_next() are handled by the * GPerlValueWrapperClass machinery. */ =item gboolean gperl_value_from_sv (GValue * value, SV * sv) set a I from a whatever is in I. I must be initialized so the code knows what kind of value to coerce out of I. Return value is always TRUE; if the code knows how to perform the conversion, it croaks. (The return value is for backward compatibility.) In reality, this really ought to always succeed; a failed conversion should be considered a bug or unimplemented code! =cut gboolean gperl_value_from_sv (GValue * value, SV * sv) { GType type; if (!gperl_sv_is_defined (sv)) return TRUE; /* use the GValue type's default */ type = G_TYPE_FUNDAMENTAL (G_VALUE_TYPE (value)); /*printf ("TYPE: %d, S: %s\n", type, SvPV_nolen(sv));*/ switch (type) { case G_TYPE_INTERFACE: /* pygtk mentions something about only handling GInterfaces with a GObject prerequisite. i'm just blindly treating them as objects until this breaks and i understand what they mean. */ g_value_set_object(value, gperl_get_object(sv)); break; case G_TYPE_CHAR: { gchar *tmp = SvGChar (sv); #if GLIB_CHECK_VERSION(2, 32, 0) g_value_set_schar (value, (gint8)(tmp ? tmp[0] : 0)); #else g_value_set_char (value, (gchar)(tmp ? tmp[0] : 0)); #endif break; } case G_TYPE_UCHAR: { char *tmp = SvPV_nolen (sv); g_value_set_uchar (value, (guchar)(tmp ? tmp[0] : 0)); break; } case G_TYPE_BOOLEAN: /* undef is also false. */ g_value_set_boolean (value, SvTRUE (sv)); break; case G_TYPE_INT: g_value_set_int(value, SvIV(sv)); break; case G_TYPE_UINT: g_value_set_uint(value, SvIV(sv)); break; case G_TYPE_LONG: g_value_set_long(value, SvIV(sv)); break; case G_TYPE_ULONG: g_value_set_ulong(value, SvIV(sv)); break; case G_TYPE_INT64: g_value_set_int64(value, SvGInt64(sv)); break; case G_TYPE_UINT64: g_value_set_uint64(value, SvGUInt64(sv)); break; case G_TYPE_FLOAT: g_value_set_float(value, (gfloat)SvNV(sv)); break; case G_TYPE_DOUBLE: g_value_set_double(value, SvNV(sv)); break; case G_TYPE_STRING: g_value_set_string(value, SvGChar(sv)); break; case G_TYPE_POINTER: #if GLIB_CHECK_VERSION(2, 10, 0) /* The fundamental type for G_TYPE_GTYPE is * G_TYPE_POINTER, so we have to treat this * specially. */ if (G_VALUE_TYPE (value) == G_TYPE_GTYPE) { g_value_set_gtype (value, gperl_type_from_package (SvGChar (sv))); break; } #endif g_value_set_pointer (value, INT2PTR (gpointer, SvIV (sv))); break; case G_TYPE_BOXED: /* SVs need special treatment! */ if (G_VALUE_HOLDS (value, GPERL_TYPE_SV)) { g_value_set_boxed (value, gperl_sv_is_defined (sv) ? sv : NULL); } else { g_value_set_static_boxed ( value, gperl_get_boxed_check ( sv, G_VALUE_TYPE(value))); } break; case G_TYPE_PARAM: g_value_set_param(value, SvGParamSpec (sv)); break; case G_TYPE_OBJECT: g_value_set_object(value, gperl_get_object_check (sv, G_VALUE_TYPE(value))); break; case G_TYPE_ENUM: g_value_set_enum(value, gperl_convert_enum(G_VALUE_TYPE(value), sv)); break; case G_TYPE_FLAGS: g_value_set_flags(value, gperl_convert_flags(G_VALUE_TYPE(value), sv)); break; default: { GPerlValueWrapperClass *wrapper_class; wrapper_class = gperl_fundamental_wrapper_class_from_type (type); if (wrapper_class && wrapper_class->unwrap) { wrapper_class->unwrap (value, sv); break; } croak ("[gperl_value_from_sv] FIXME: unhandled type - %d (%s fundamental for %s)\n", type, g_type_name (type), G_VALUE_TYPE_NAME (value)); return FALSE; } } return TRUE; } /* * =item SV * _gperl_sv_from_value_internal (const GValue * value, gboolean copy_boxed) * * Coerce whatever is in I into a perl scalar and return it. * If I is true, boxed values will be copied. Values of type * GPERL_TYPE_SV are always copied (since that is merely a ref). * * Croaks if the code doesn't know how to perform the conversion. * * Might end up calling other Perl code. So if you use this function in XS * code for a generic GType, make sure the stack pointer is set up correctly * before the call, and restore it after the call. * * =cut */ SV * _gperl_sv_from_value_internal (const GValue * value, gboolean copy_boxed) { GType type = G_TYPE_FUNDAMENTAL (G_VALUE_TYPE (value)); switch (type) { case G_TYPE_INTERFACE: /* pygtk mentions something about only handling GInterfaces with a GObject prerequisite. i'm just blindly treating them as objects until this breaks and i understand what they mean. */ return gperl_new_object (g_value_get_object (value), FALSE); case G_TYPE_CHAR: #if GLIB_CHECK_VERSION(2, 32, 0) return newSViv (g_value_get_schar (value)); #else return newSViv (g_value_get_char (value)); #endif case G_TYPE_UCHAR: return newSVuv (g_value_get_uchar (value)); case G_TYPE_BOOLEAN: return newSViv(g_value_get_boolean(value)); case G_TYPE_INT: return newSViv(g_value_get_int(value)); case G_TYPE_UINT: return newSVuv(g_value_get_uint(value)); case G_TYPE_LONG: return newSViv(g_value_get_long(value)); case G_TYPE_ULONG: return newSVuv(g_value_get_ulong(value)); case G_TYPE_INT64: return newSVGInt64(g_value_get_int64(value)); case G_TYPE_UINT64: return newSVGUInt64(g_value_get_uint64(value)); case G_TYPE_FLOAT: return newSVnv(g_value_get_float(value)); case G_TYPE_DOUBLE: return newSVnv(g_value_get_double(value)); case G_TYPE_STRING: return newSVGChar (g_value_get_string (value)); case G_TYPE_POINTER: #if GLIB_CHECK_VERSION(2, 10, 0) /* The fundamental type for G_TYPE_GTYPE is * G_TYPE_POINTER, so we have to treat this * specially. */ if (G_VALUE_TYPE (value) == G_TYPE_GTYPE) { GType gtype = g_value_get_gtype (value); return newSVGChar ( gtype == G_TYPE_NONE ? NULL : gperl_package_from_type (gtype)); } #endif return newSViv (PTR2IV (g_value_get_pointer (value))); case G_TYPE_BOXED: /* special case for SVs, which are stored directly * rather than inside blessed wrappers. */ if (G_VALUE_HOLDS (value, GPERL_TYPE_SV)) { SV * sv = g_value_get_boxed (value); return sv ? g_value_dup_boxed (value) : &PL_sv_undef; } if (copy_boxed) return gperl_new_boxed_copy (g_value_get_boxed (value), G_VALUE_TYPE (value)); else return gperl_new_boxed (g_value_get_boxed (value), G_VALUE_TYPE (value), FALSE); case G_TYPE_PARAM: /* can have NULL here fetching object properties of * type G_TYPE_PARAM with no value set yet, or from * ->get_default_value of such a * property. newSVGParamSpec handles NULL by returning * undef. */ return newSVGParamSpec (g_value_get_param (value)); case G_TYPE_OBJECT: return gperl_new_object (g_value_get_object (value), FALSE); case G_TYPE_ENUM: return gperl_convert_back_enum (G_VALUE_TYPE (value), g_value_get_enum (value)); case G_TYPE_FLAGS: return gperl_convert_back_flags (G_VALUE_TYPE (value), g_value_get_flags (value)); default: { GPerlValueWrapperClass *wrapper_class; wrapper_class = gperl_fundamental_wrapper_class_from_type (type); if (wrapper_class && wrapper_class->wrap) return wrapper_class->wrap (value); croak ("[gperl_sv_from_value] FIXME: unhandled type - %d (%s fundamental for %s)\n", type, g_type_name (type), G_VALUE_TYPE_NAME (value)); } } return NULL; } =item SV * gperl_sv_from_value (const GValue * value) Coerce whatever is in I into a perl scalar and return it. Croaks if the code doesn't know how to perform the conversion. Might end up calling other Perl code. So if you use this function in XS code for a generic GType, make sure the stack pointer is set up correctly before the call, and restore it after the call. =cut SV * gperl_sv_from_value (const GValue * value) { return _gperl_sv_from_value_internal (value, FALSE); } =back =cut /* apparently this line is required by ExtUtils::ParseXS, but not by xsubpp. */ MODULE = Glib::Value PACKAGE = Glib::Value PREFIX = g_value_ PROTOTYPES: ENABLE Glib-1.320/GVariant.xs000644 001750 000024 00000051210 12636024471 015562 0ustar00bdmanningstaff000000 000000 /* * Copyright (C) 2014 by the gtk2-perl team (see the file AUTHORS for the full * list) * * This library is free software; you can redistribute it and/or modify it * under the terms of the GNU Library General Public License as published by * the Free Software Foundation; either version 2.1 of the License, or (at your * option) any later version. * * This library is distributed in the hope that it will be useful, but WITHOUT * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or * FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public * License for more details. * * You should have received a copy of the GNU Library General Public License * along with this library; if not, write to the Free Software Foundation, * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. * */ #include "gperl.h" /* --- GVariant --------------------------------------------------------------*/ /* --- basic wrappers --- */ static SV * variant_to_sv (GVariant * variant, gboolean own) { SV * sv; SV * rv; HV * stash; if (!variant) return &PL_sv_undef; sv = newSV (0); _gperl_attach_mg (sv, variant); if (own) { #if GLIB_CHECK_VERSION (2, 30, 0) g_variant_take_ref (variant); #elif GLIB_CHECK_VERSION (2, 26, 0) if (g_variant_is_floating (variant)) { g_variant_ref_sink (variant); } #else /* In this case, we have no way of finding out whether the * variant has a floating ref, so we just always ref_sink even * if this might cause a leak in some cases. */ g_variant_ref_sink (variant); #endif } else { g_variant_ref (variant); } rv = newRV_noinc (sv); stash = gv_stashpv ("Glib::Variant", TRUE); sv_bless (rv, stash); return rv; } static GVariant * sv_to_variant (SV * sv) { MAGIC * mg; if (!gperl_sv_is_ref (sv) || !(mg = _gperl_find_mg (SvRV (sv)))) return NULL; return (GVariant *) mg->mg_ptr; } /* --- GValue wrappers --- */ static SV * wrap_variant (const GValue * value) { return variant_to_sv (g_value_get_variant (value), FALSE); } static void unwrap_variant (GValue * value, SV * sv) { g_value_set_variant (value, sv_to_variant (sv)); } static GPerlValueWrapperClass variant_wrapper_class = { wrap_variant, unwrap_variant }; /* --- typemap glue --- */ SV * newSVGVariant (GVariant * variant) { return variant_to_sv (variant, FALSE); } SV * newSVGVariant_noinc (GVariant * variant) { return variant_to_sv (variant, TRUE); } GVariant * SvGVariant (SV * sv) { return sv_to_variant (sv); } /* --- GVariantType --------------------------------------------------------- */ /* --- boxed wrappers ---*/ static GPerlBoxedWrapperClass default_boxed_wrapper_class; static GPerlBoxedWrapperClass variant_type_wrapper_class; static gpointer unwrap_variant_type (GType gtype, const char * package, SV * sv) { if (!gperl_sv_is_ref (sv)) { GVariantType * vtype; vtype = g_variant_type_new (SvPV_nolen (sv)); sv = default_boxed_wrapper_class.wrap (gtype, package, vtype, TRUE); /* fall through */ } return default_boxed_wrapper_class.unwrap (gtype, package, sv); } /* --- typemap glue --- */ SV * newSVGVariantType (const GVariantType * type) { if (!type) return &PL_sv_undef; return gperl_new_boxed ((gpointer) type, G_TYPE_VARIANT_TYPE, FALSE); } SV * newSVGVariantType_own (const GVariantType * type) { return gperl_new_boxed ((gpointer) type, G_TYPE_VARIANT_TYPE, TRUE); } const GVariantType * SvGVariantType (SV * sv) { if (!gperl_sv_is_defined (sv)) return NULL; return gperl_get_boxed_check (sv, G_TYPE_VARIANT_TYPE); } /* -------------------------------------------------------------------------- */ /* --- helpers ---*/ static void sv_to_variant_array (SV * sv, GVariant *** array_p, gsize * n_p) { AV * av; gsize i; if (!gperl_sv_is_array_ref (sv)) croak ("Expected an array reference for 'children'"); av = (AV *) SvRV (sv); *n_p = av_len (av) + 1; *array_p = g_new0 (GVariant *, *n_p); for (i = 0; i < *n_p; i++) { SV ** svp = av_fetch (av, i, 0); if (svp) (*array_p)[i] = SvGVariant (*svp); } } static void sv_to_variant_type_array (SV * sv, const GVariantType *** array_p, gint * n_p) { AV * av; gint i; if (!gperl_sv_is_array_ref (sv)) croak ("Expected an array reference for 'items'"); av = (AV *) SvRV (sv); *n_p = av_len (av) + 1; *array_p = g_new0 (const GVariantType *, *n_p); for (i = 0; i < *n_p; i++) { SV ** svp = av_fetch (av, i, 0); if (svp) (*array_p)[i] = SvGVariantType (*svp); } } /* -------------------------------------------------------------------------- */ MODULE = Glib::Variant PACKAGE = Glib::Variant PREFIX = g_variant_ =for object Glib::Variant strongly typed value datatype =cut =for position SYNOPSIS =head1 SYNOPSIS my $v = Glib::Variant->new ('as', ['GTK+', 'Perl']); my $aref = $v->get ('as'); =for position DESCRIPTION =head1 DESCRIPTION There are two sets of APIs for creating and dealing with Cs: the low-level API described below under L, and the convenience API described in this section. =head2 CONVENIENCE API =over =item variant = Glib::Variant->new ($format_string, $value) =item (variant1, ...) = Glib::Variant->new ($format_string, $value1, ...) Constructs a variant from C<$format_string> and C<$value>. Also supports constructing multiple variants when the format string is a concatenation of multiple types. =item value = $variant->get ($format_string) Deconstructs C<$variant> according to C<$format_string>. =back The following symbols are currently supported in format strings: +------------------------------+---------------------------------+ | Symbol | Meaning | +------------------------------+---------------------------------+ | b, y, n, q, i, u, x, t, h, d | Boolean, byte and numeric types | | s, o, g | String types | | v | Variant types | | a | Arrays | | m | Maybe types | | () | Tuples | | {} | Dictionary entries | +------------------------------+---------------------------------+ Note that if a format string specifies an array, a tuple or a dictionary entry ("a", "()" or "{}"), then array references are expected by C and produced by C. For arrays of dictionary entries ("a{}"), hash references are also supported by C and handled as you would expect. For a complete specification, see the documentation at =over =item L =item L =item L =item L =back =cut =for see_also Glib::VariantType =cut BOOT: gperl_register_fundamental_full (G_TYPE_VARIANT, "Glib::Variant", &variant_wrapper_class); default_boxed_wrapper_class = variant_type_wrapper_class = * gperl_default_boxed_wrapper_class (); variant_type_wrapper_class.unwrap = unwrap_variant_type; gperl_register_boxed (G_TYPE_VARIANT_TYPE, "Glib::VariantType", &variant_type_wrapper_class); const GVariantType * g_variant_get_type (GVariant *value); const gchar * g_variant_get_type_string (GVariant *value); gboolean g_variant_is_of_type (GVariant *value, const GVariantType *type); gboolean g_variant_is_container (GVariant *value); char g_variant_classify (GVariant *value); GVariant_noinc * g_variant_new_boolean (class, gboolean value); C_ARGS: value GVariant_noinc * g_variant_new_byte (class, guchar value); C_ARGS: value GVariant_noinc * g_variant_new_int16 (class, gint16 value); C_ARGS: value GVariant_noinc * g_variant_new_uint16 (class, guint16 value); C_ARGS: value GVariant_noinc * g_variant_new_int32 (class, gint32 value); C_ARGS: value GVariant_noinc * g_variant_new_uint32 (class, guint32 value); C_ARGS: value GVariant_noinc * g_variant_new_int64 (class, gint64 value); C_ARGS: value GVariant_noinc * g_variant_new_uint64 (class, guint64 value); C_ARGS: value GVariant_noinc * g_variant_new_handle (class, gint32 value); C_ARGS: value GVariant_noinc * g_variant_new_double (class, gdouble value); C_ARGS: value # GVariant * g_variant_new_take_string (gchar *string); GVariant_noinc * g_variant_new_string (class, const gchar *string); C_ARGS: string # FIXME: # GLIB_AVAILABLE_IN_2_38 # GVariant * g_variant_new_printf (const gchar *format_string, ...) G_GNUC_PRINTF (1, 2); GVariant_noinc * g_variant_new_object_path (class, const gchar *object_path); C_ARGS: object_path gboolean g_variant_is_object_path (const gchar *string); GVariant_noinc * g_variant_new_signature (class, const gchar *signature); C_ARGS: signature gboolean g_variant_is_signature (const gchar *string); GVariant_noinc * g_variant_new_variant (class, GVariant *value); C_ARGS: value # FIXME: # GVariant * g_variant_new_strv (const gchar * const *strv, gssize length); # FIXME: # GLIB_AVAILABLE_IN_2_30 # GVariant * g_variant_new_objv (const gchar * const *strv, gssize length); #if GLIB_CHECK_VERSION (2, 26, 0) GVariant_noinc * g_variant_new_bytestring (class, const char_byte * string); C_ARGS: string # FIXME: # GVariant * g_variant_new_bytestring_array (const gchar * const *strv, gssize length); #endif # FIXME: # GLIB_AVAILABLE_IN_2_32 # GVariant * g_variant_new_fixed_array (const GVariantType *element_type, gconstpointer elements, gsize n_elements, gsize element_size); # FIXME: # GLIB_AVAILABLE_IN_2_36 # GVariant * g_variant_new_from_bytes (const GVariantType *type, GBytes *bytes, gboolean trusted); # FIXME: # GVariant * g_variant_new_from_data (const GVariantType *type, gconstpointer data, gsize size, gboolean trusted, GDestroyNotify notify, gpointer user_data); gboolean g_variant_get_boolean (GVariant *value); guchar g_variant_get_byte (GVariant *value); gint16 g_variant_get_int16 (GVariant *value); guint16 g_variant_get_uint16 (GVariant *value); gint32 g_variant_get_int32 (GVariant *value); guint32 g_variant_get_uint32 (GVariant *value); gint64 g_variant_get_int64 (GVariant *value); guint64 g_variant_get_uint64 (GVariant *value); gint32 g_variant_get_handle (GVariant *value); gdouble g_variant_get_double (GVariant *value); GVariant_noinc * g_variant_get_variant (GVariant *value); # gchar * g_variant_dup_string (GVariant *value, gsize *length); const gchar * g_variant_get_string (GVariant *value); C_ARGS: value, NULL # FIXME: # gchar ** g_variant_dup_strv (GVariant *value, gsize *length); # const gchar ** g_variant_get_strv (GVariant *value, gsize *length); # FIXME: # GLIB_AVAILABLE_IN_2_30 # gchar ** g_variant_dup_objv (GVariant *value, gsize *length); # const gchar ** g_variant_get_objv (GVariant *value, gsize *length); #if GLIB_CHECK_VERSION (2, 26, 0) # gchar * g_variant_dup_bytestring (GVariant *value, gsize *length); const char * g_variant_get_bytestring (GVariant *value); # FIXME: # gchar ** g_variant_dup_bytestring_array (GVariant *value, gsize *length); # const gchar ** g_variant_get_bytestring_array (GVariant *value, gsize *length); #endif GVariant_noinc * g_variant_new_maybe (class, const GVariantType *child_type, GVariant *child); C_ARGS: child_type, child GVariant * g_variant_new_array (class, const GVariantType *child_type, SV *children); PREINIT: GVariant ** children_c; gsize n_children; CODE: sv_to_variant_array (children, &children_c, &n_children); RETVAL = g_variant_new_array (child_type, children_c, n_children); g_free (children_c); OUTPUT: RETVAL GVariant * g_variant_new_tuple (class, SV *children); PREINIT: GVariant ** children_c; gsize n_children; CODE: sv_to_variant_array (children, &children_c, &n_children); RETVAL = g_variant_new_tuple (children_c, n_children); g_free (children_c); OUTPUT: RETVAL GVariant_noinc * g_variant_new_dict_entry (class, GVariant *key, GVariant *value); C_ARGS: key, value GVariant_noinc * g_variant_get_maybe (GVariant *value); gsize g_variant_n_children (GVariant *value); # void g_variant_get_child (GVariant *value, gsize index_, const gchar *format_string, ...); GVariant_noinc * g_variant_get_child_value (GVariant *value, gsize index_); # gboolean g_variant_lookup (GVariant *dictionary, const gchar *key, const gchar *format_string, ...); GVariant_noinc * g_variant_lookup_value (GVariant *dictionary, const gchar *key, const GVariantType *expected_type); # FIXME: # gconstpointer g_variant_get_fixed_array (GVariant *value, gsize *n_elements, gsize element_size); gsize g_variant_get_size (GVariant *value); # FIXME: # gconstpointer g_variant_get_data (GVariant *value); # GLIB_AVAILABLE_IN_2_36 # GBytes * g_variant_get_data_as_bytes (GVariant *value); # void g_variant_store (GVariant *value, gpointer data); # GString * g_variant_print_string (GVariant *value, GString *string, gboolean type_annotate); gchar_own * g_variant_print (GVariant *value, gboolean type_annotate); guint g_variant_hash (const GVariant * value); gboolean g_variant_equal (const GVariant * one, const GVariant * two); #if GLIB_CHECK_VERSION (2, 26, 0) gint g_variant_compare (const GVariant * one, const GVariant * two); #endif GVariant_noinc * g_variant_get_normal_form (GVariant *value); gboolean g_variant_is_normal_form (GVariant *value); GVariant_noinc * g_variant_byteswap (GVariant *value); # FIXME: # GLIB_AVAILABLE_IN_2_36 # GVariant * g_variant_new_from_bytes (const GVariantType *type, GBytes *bytes, gboolean trusted); # FIXME: # GVariant * g_variant_new_from_data (const GVariantType *type, gconstpointer data, gsize size, gboolean trusted, GDestroyNotify notify, gpointer user_data); void DESTROY (GVariant * variant) CODE: g_variant_unref (variant); # --------------------------------------------------------------------------- # # GVariantIter * g_variant_iter_new (GVariant *value); # gsize g_variant_iter_init (GVariantIter *iter, GVariant *value); # GVariantIter * g_variant_iter_copy (GVariantIter *iter); # gsize g_variant_iter_n_children (GVariantIter *iter); # void g_variant_iter_free (GVariantIter *iter); # GVariant * g_variant_iter_next_value (GVariantIter *iter); # gboolean g_variant_iter_next (GVariantIter *iter, const gchar *format_string, ...); # gboolean g_variant_iter_loop (GVariantIter *iter, const gchar *format_string, ...); # --------------------------------------------------------------------------- # # GLIB_AVAILABLE_IN_2_40 { # GVariantDict * g_variant_dict_new (GVariant *from_asv); # void g_variant_dict_init (GVariantDict *dict, GVariant *from_asv); # gboolean g_variant_dict_lookup (GVariantDict *dict, const gchar *key, const gchar *format_string, ...); # GVariant * g_variant_dict_lookup_value (GVariantDict *dict, const gchar *key, const GVariantType *expected_type); # gboolean g_variant_dict_contains (GVariantDict *dict, const gchar *key); # void g_variant_dict_insert (GVariantDict *dict, const gchar *key, const gchar *format_string, ...); # void g_variant_dict_insert_value (GVariantDict *dict, const gchar *key, GVariant *value); # gboolean g_variant_dict_remove (GVariantDict *dict, const gchar *key); # void g_variant_dict_clear (GVariantDict *dict); # GVariant * g_variant_dict_end (GVariantDict *dict); # GVariantDict * g_variant_dict_ref (GVariantDict *dict); # void g_variant_dict_unref (GVariantDict *dict); # } # --------------------------------------------------------------------------- # # GVariantBuilder * g_variant_builder_new (const GVariantType *type); # void g_variant_builder_unref (GVariantBuilder *builder); # GVariantBuilder * g_variant_builder_ref (GVariantBuilder *builder); # void g_variant_builder_init (GVariantBuilder *builder, const GVariantType *type); # GVariant * g_variant_builder_end (GVariantBuilder *builder); # void g_variant_builder_clear (GVariantBuilder *builder); # void g_variant_builder_open (GVariantBuilder *builder, const GVariantType *type); # void g_variant_builder_close (GVariantBuilder *builder); # void g_variant_builder_add_value (GVariantBuilder *builder, GVariant *value); # void g_variant_builder_add (GVariantBuilder *builder, const gchar *format_string, ...); # void g_variant_builder_add_parsed (GVariantBuilder *builder, const gchar *format, ...); # --------------------------------------------------------------------------- # # These are re-created in lib/Glib.pm. # GVariant * g_variant_new (const gchar *format_string, ...); # GVariant * g_variant_new_va (const gchar *format_string, const gchar **endptr, va_list *app); # void g_variant_get (GVariant *value, const gchar *format_string, ...); # void g_variant_get_va (GVariant *value, const gchar *format_string, const gchar **endptr, va_list *app); # GLIB_AVAILABLE_IN_2_34 # gboolean g_variant_check_format_string (GVariant *value, const gchar *format_string, gboolean copy_only); # --------------------------------------------------------------------------- # =for apidoc __function__ __gerror__ =cut GVariant_noinc * g_variant_parse (const GVariantType *type, const gchar *text) PREINIT: GError *error = NULL; CODE: RETVAL = g_variant_parse (type, text, NULL, NULL, &error); if (error) gperl_croak_gerror (NULL, error); OUTPUT: RETVAL # GVariant * g_variant_new_parsed (const gchar *format, ...); # GVariant * g_variant_new_parsed_va (const gchar *format, va_list *app); # GLIB_AVAILABLE_IN_2_40 # gchar * g_variant_parse_error_print_context (GError *error, const gchar *source_str); # --------------------------------------------------------------------------- # MODULE = Glib::Variant PACKAGE = Glib::VariantType PREFIX = g_variant_type_ =for see_also Glib::Variant =cut =for apidoc __function__ =cut gboolean g_variant_type_string_is_valid (const gchar *type_string); =for apidoc =for signature (type_string, rest) = Glib::VariantType::string_scan ($string) Scans the start of C<$string> for a complete type string and extracts it. If no type string can be found, an exception is thrown. =cut # gboolean g_variant_type_string_scan (const gchar *string, const gchar *limit, const gchar **endptr); void g_variant_type_string_scan (const char *string) PREINIT: const char *limit = NULL; const char *endptr = NULL; PPCODE: if (!g_variant_type_string_scan (string, limit, &endptr)) croak ("Could not find type string at the start of '%s'", string); PUSHs (sv_2mortal (newSVpvn (string, endptr-string))); if (endptr && *endptr) XPUSHs (sv_2mortal (newSVpv (endptr, 0))); GVariantType_own * g_variant_type_new (class, const gchar *type_string); C_ARGS: type_string # const gchar * g_variant_type_peek_string (const GVariantType *type); # gchar * g_variant_type_dup_string (const GVariantType *type); SV * g_variant_type_get_string (const GVariantType *type) PREINIT: const char * string; CODE: string = g_variant_type_peek_string (type); RETVAL = newSVpv (string, g_variant_type_get_string_length (type)); OUTPUT: RETVAL gboolean g_variant_type_is_definite (const GVariantType *type); gboolean g_variant_type_is_container (const GVariantType *type); gboolean g_variant_type_is_basic (const GVariantType *type); gboolean g_variant_type_is_maybe (const GVariantType *type); gboolean g_variant_type_is_array (const GVariantType *type); gboolean g_variant_type_is_tuple (const GVariantType *type); gboolean g_variant_type_is_dict_entry (const GVariantType *type); gboolean g_variant_type_is_variant (const GVariantType *type); guint g_variant_type_hash (const GVariantType *type); gboolean g_variant_type_equal (const GVariantType *type1, const GVariantType *type2); gboolean g_variant_type_is_subtype_of (const GVariantType *type, const GVariantType *supertype); const GVariantType * g_variant_type_element (const GVariantType *type); const GVariantType * g_variant_type_first (const GVariantType *type); const GVariantType * g_variant_type_next (const GVariantType *type); gsize g_variant_type_n_items (const GVariantType *type); const GVariantType * g_variant_type_key (const GVariantType *type); const GVariantType * g_variant_type_value (const GVariantType *type); GVariantType_own * g_variant_type_new_array (class, const GVariantType *element); C_ARGS: element GVariantType_own * g_variant_type_new_maybe (class, const GVariantType *element); C_ARGS: element GVariantType_own * g_variant_type_new_tuple (class, SV *items); PREINIT: const GVariantType ** items_c; gint n_items; CODE: sv_to_variant_type_array (items, &items_c, &n_items); RETVAL = g_variant_type_new_tuple (items_c, n_items); g_free (items_c); OUTPUT: RETVAL GVariantType_own * g_variant_type_new_dict_entry (class, const GVariantType *key, const GVariantType *value); C_ARGS: key, value Glib-1.320/lib/000755 001750 000024 00000000000 12636025764 014250 5ustar00bdmanningstaff000000 000000 Glib-1.320/LICENSE000644 001750 000024 00000063500 11701512040 014467 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-1.320/Makefile.PL000644 001750 000024 00000023001 12636025751 015444 0ustar00bdmanningstaff000000 000000 # Copyright (C) 2003-2009, 2013 by the gtk2-perl team (see the file AUTHORS # for the full list) # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. BEGIN { require 5.008; } use strict; use warnings; use ExtUtils::MakeMaker; use File::Spec; use Cwd; # minimum required version of dependencies we need to build our %build_reqs = ( 'glib' => '2.0.0', ); our %PREREQ_PM = ( 'ExtUtils::Depends' => '0.300', 'ExtUtils::PkgConfig' => '1.000', ); # Writing a fake Makefile ensures that CPAN will pick up the correct # dependencies and install them. unless (eval "use ExtUtils::Depends '$PREREQ_PM{'ExtUtils::Depends'}';" . "use ExtUtils::PkgConfig '$PREREQ_PM{'ExtUtils::PkgConfig'}';" . "1") { warn "$@\n"; WriteMakefile( NAME => 'Glib', PREREQ_FATAL => 1, PREREQ_PM => \%PREREQ_PM, ); exit 1; # not reached } # client modules may use Glib::MakeHelper -- he's not installed at this # point, so we have to require him directly. require 'lib/Glib/MakeHelper.pm'; mkdir 'build', 0777; # If the package can't be found, warn and exit with status 0 to indicate to # CPAN testers that their system is not supported. my %glibcfg; unless (eval { %glibcfg = ExtUtils::PkgConfig->find ("gobject-2.0 >= $build_reqs{glib}"); 1; }) { warn $@; exit 0; } # this is the order in which we want the api docs from the XS files to # appear in Glib::xsapi our @xs_files = qw( Glib.xs GError.xs GUtils.xs GLog.xs GType.xs GBoxed.xs GObject.xs GValue.xs GClosure.xs GSignal.xs GMainLoop.xs GIOChannel.xs GParamSpec.xs ); # Check version before including if (ExtUtils::PkgConfig->atleast_version ('glib-2.0', '2.6.0')) { push @xs_files, 'GKeyFile.xs'; push @xs_files, 'GOption.xs'; } if (ExtUtils::PkgConfig->atleast_version ('glib-2.0', '2.12.0')) { push @xs_files, 'GBookmarkFile.xs'; } if (ExtUtils::PkgConfig->atleast_version ('glib-2.0', '2.24.0')) { push @xs_files, 'GVariant.xs'; } my %meta_merge = ( q(meta-spec) => { version => '2', url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', }, author => ['gtk2-perl 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_IRC => "irc://irc.gimp.org/#gtk-perl", x_MailingList => 'https://mail.gnome.org/mailman/listinfo/gtk-perl-list', bugtracker => { web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Glib', mailto => 'bug-Glib [at] rt.cpan.org', }, repository => { url => 'git://git.gnome.org/perl-Glib', type => 'git', web => 'http://git.gnome.org/browse/perl-Glib', }, }, prereqs => { configure => { requires => {%PREREQ_PM}, # no direct ref for 5.14 compatibility }, }, no_index => { file => [@xs_files, qw/Makefile.PL xsapi.pod.head xsapi.pod.foot/], package => 'MY', }, ); our %pm_files = ( 'lib/Glib.pm' => '$(INST_LIBDIR)/Glib.pm', 'lib/Glib/Object/Subclass.pm' => '$(INST_LIBDIR)/Glib/Object/Subclass.pm', 'lib/Glib/ParseXSDoc.pm' => '$(INST_LIBDIR)/Glib/ParseXSDoc.pm', 'lib/Glib/GenPod.pm' => '$(INST_LIBDIR)/Glib/GenPod.pm', 'lib/Glib/CodeGen.pm' => '$(INST_LIBDIR)/Glib/CodeGen.pm', 'lib/Glib/MakeHelper.pm' => '$(INST_LIBDIR)/Glib/MakeHelper.pm', 'devel.pod' => '$(INST_LIBDIR)/Glib/devel.pod', ); our %pod_files = ( 'lib/Glib.pm' => '$(INST_MAN3DIR)/Glib.$(MAN3EXT)', 'lib/Glib/Object/Subclass.pm' => '$(INST_MAN3DIR)/Glib::Object::Subclass.$(MAN3EXT)', 'lib/Glib/ParseXSDoc.pm' => '$(INST_MAN3DIR)/Glib::ParseXSDoc.$(MAN3EXT)', 'lib/Glib/GenPod.pm' => '$(INST_MAN3DIR)/Glib::GenPod.$(MAN3EXT)', 'lib/Glib/CodeGen.pm' => '$(INST_MAN3DIR)/Glib::CodeGen.$(MAN3EXT)', 'lib/Glib/MakeHelper.pm' => '$(INST_MAN3DIR)/Glib::MakeHelper.$(MAN3EXT)', 'devel.pod' => '$(INST_MAN3DIR)/Glib::devel.$(MAN3EXT)', '$(INST_LIB)/$(FULLEXT)/xsapi.pod' => '$(INST_MAN3DIR)/Glib::xsapi.$(MAN3EXT)', Glib::MakeHelper->do_pod_files (@xs_files), ); # optional thread-safety my $nothreads; if($Config::Config{usethreads}) { $nothreads = grep /disable[-_]threadsafe/i, @ARGV; } else { $nothreads = 1; } my %gthreadcfg; if (!$nothreads) { eval { %gthreadcfg = ExtUtils::PkgConfig->find ('gthread-2.0'); }; $nothreads = 1 if $@; } else { warn " *** \n"; warn " *** configuring Glib to build without thread safety\n"; warn " *** \n"; %gthreadcfg = ( cflags => ' -DGPERL_DISABLE_THREADSAFE ', libs => '', ); } our $glib = ExtUtils::Depends->new ('Glib'); # add -I. and -I./build to the include path so we can find our own files. # this will be inherited by dependant modules, so they can find their # generated files. $glib->set_inc (' -I. ' . $glibcfg{cflags} . ' ' . $gthreadcfg{cflags}); $glib->set_libs ($glibcfg{libs} . ' ' . $gthreadcfg{libs}); my $cwd = cwd(); $glib->add_typemaps (map {File::Spec->catfile($cwd,$_)} 'typemap'); $glib->add_pm (%pm_files); $glib->add_xs (@xs_files); $glib->add_c (qw(gperl-gtypes.c)); $glib->install (qw(gperl.h gperl_marshal.h doctypes)); $glib->save_config ('build/IFiles.pm'); # exports list needed for win32, unused on others our @exports; require 'Glib.exports'; # On OpenBSD, any program that directly or indirectly wants to load # libpthread.so must do so from the start. But when perl is built without # ithreads, it will also most likely not be compiled with "-pthread". When # libglib/libgobject then go and try to load libpthread.so, the loader will # error out. my @openbsd_compat_flags = (); if ($^O eq 'openbsd' && $Config::Config{ldflags} !~ m/-pthread\b/) { warn " ***\n *** on OpenBSD, we either need perl linked with '-pthread',\n", " *** or we need to set LD_PRELOAD=libpthread.so; doing the latter now...\n ***\n"; @openbsd_compat_flags = ( macro => {FULLPERLRUN => 'LD_PRELOAD=libpthread.so $(FULLPERL)'}, ); } WriteMakefile( NAME => 'Glib', VERSION_FROM => 'lib/Glib.pm', # finds $VERSION ABSTRACT_FROM => 'lib/Glib.pm', # retrieve abstract from module PREREQ_PM => \%PREREQ_PM, XSPROTOARG => '-noprototypes', MAN3PODS => $glib ? \%pod_files : {}, FUNCLIST => \@exports, DL_FUNCS => { Glib => [] }, META_MERGE => \%meta_merge, $glib ? $glib->get_makefile_vars : (), @openbsd_compat_flags, ); =unstable print <<__EOW__; WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING This is an unstable development release of Glib. The API is not frozen and things are subject to change at any time. Report any bugs to gtk-perl-list AT gnome DOT org as soon as possible. Please use the 1.32x series for important work. WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING __EOW__ =cut =frozen print <<__EOW__; WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING This is an unstable development release of Glib. The API is frozen in accordance with the GNOME 2.16 schedule. Report any bugs to gtk-perl-list AT gnome DOT org as soon as possible. WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING __EOW__ =cut # rule to build the documentation sub MY::postamble { require 'lib/Glib/MakeHelper.pm'; # $glib will be undefined if any of our dependencies couldn't be found; # don't do anything in this case. return unless defined $glib; return " # these are special for Glib since it's providing the modules, # it just has to make sure that they are ready before it can go build/doc.pl :: \$(INST_LIB)/Glib/ParseXSDoc.pm build/podindex :: \$(INST_LIB)/Glib/GenPod.pm \$(INST_LIB)/\$(FULLEXT)/xsapi.pod :: build/doc.pl apidoc.pl xsapi.pod.head xsapi.pod.foot \$(NOECHO) \$(ECHO) Creating XS API documentation... \$(NOECHO) \$(FULLPERLRUN) apidoc.pl xsapi.pod.head xsapi.pod.foot build/doc.pl > \$@ " . Glib::MakeHelper->postamble_precompiled_headers (qw/gperl.h/) . Glib::MakeHelper->postamble_clean () . Glib::MakeHelper->postamble_docs_full ( DEPENDS => $glib, DOCTYPES => 'doctypes', COPYRIGHT_FROM => 'copyright.pod', ) . Glib::MakeHelper->postamble_rpms ( 'GLIB' => $build_reqs{'glib'}, 'PERL_EXTUTILS_DEPENDS' => $PREREQ_PM{'ExtUtils::Depends'}, 'PERL_EXTUTILS_PKGCONFIG' => $PREREQ_PM{'ExtUtils::PkgConfig'}, ); } __END__ Glib-1.320/MANIFEST000644 001750 000024 00000002152 12636025764 014633 0ustar00bdmanningstaff000000 000000 apidoc.pl AUTHORS ChangeLog.pre-git copyright.pod devel.pod doctypes GBookmarkFile.xs GBoxed.xs GClosure.xs GError.xs GIOChannel.xs GKeyFile.xs Glib.exports Glib.xs GLog.xs GMainLoop.xs GObject.xs GOption.xs GParamSpec.xs gperl-gtypes.c gperl-gtypes.h gperl-private.h gperl.h gperl_marshal.h GSignal.xs GType.xs GUtils.xs GValue.xs GVariant.xs lib/Glib.pm lib/Glib/CodeGen.pm lib/Glib/GenPod.pm lib/Glib/MakeHelper.pm lib/Glib/Object/Subclass.pm lib/Glib/ParseXSDoc.pm LICENSE Makefile.PL MANIFEST MANIFEST.SKIP NEWS perl-Glib.doap perl-Glib.spec.in README t/1.t t/2.t t/3.t t/4.t t/5.t t/6.t t/64bit.t t/7.t t/8.t t/9.t t/a.t t/b.t t/boxed_errors.t t/bytes.t t/c.t t/constants.t t/d.t t/e.t t/f.t t/filename.t t/g.t t/h.t t/lazy_loader.t t/make_helper.t t/module_versions.t t/options.t t/signal_emission_hooks.t t/signal_marshal.t t/signal_query.t t/tied_definedness.t t/tied_flags.t t/tied_set_property.t t/variant.t TODO typemap xsapi.pod.foot xsapi.pod.head META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Glib-1.320/MANIFEST.SKIP000644 001750 000024 00000000207 11664366512 015376 0ustar00bdmanningstaff000000 000000 ~$ \.bak$ blib \.bs$ build \.git \.gitignore$ G.+\.c$ Makefile$ Makefile\.old$ MAINTAINERS$ MYMETA\..+$ \.o$ \.spec$ \.sw.$ \.tar\.gz$ Glib-1.320/META.json000644 001750 000024 00000004237 12636025764 015131 0ustar00bdmanningstaff000000 000000 { "abstract" : "Perl wrappers for the GLib utility and Object libraries", "author" : [ "gtk2-perl Team " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001", "license" : [ "lgpl_2_1" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Glib", "no_index" : { "directory" : [ "t", "inc" ], "file" : [ "Glib.xs", "GError.xs", "GUtils.xs", "GLog.xs", "GType.xs", "GBoxed.xs", "GObject.xs", "GValue.xs", "GClosure.xs", "GSignal.xs", "GMainLoop.xs", "GIOChannel.xs", "GParamSpec.xs", "GKeyFile.xs", "GOption.xs", "GBookmarkFile.xs", "GVariant.xs", "Makefile.PL", "xsapi.pod.head", "xsapi.pod.foot" ], "package" : [ "MY" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::Depends" : "0.300", "ExtUtils::MakeMaker" : "0", "ExtUtils::PkgConfig" : "1.000" } }, "runtime" : { "requires" : { "ExtUtils::Depends" : "0.300", "ExtUtils::PkgConfig" : "1.000" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Glib [at] rt.cpan.org", "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Glib" }, "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", "web" : "http://git.gnome.org/browse/perl-Glib" }, "x_IRC" : "irc://irc.gimp.org/#gtk-perl", "x_MailingList" : "https://mail.gnome.org/mailman/listinfo/gtk-perl-list" }, "version" : "1.320" } Glib-1.320/META.yml000644 001750 000024 00000002477 12636025764 014765 0ustar00bdmanningstaff000000 000000 --- abstract: 'Perl wrappers for the GLib utility and Object libraries' author: - 'gtk2-perl Team ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::Depends: '0.300' ExtUtils::MakeMaker: '0' ExtUtils::PkgConfig: '1.000' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001' license: lgpl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Glib no_index: directory: - t - inc file: - Glib.xs - GError.xs - GUtils.xs - GLog.xs - GType.xs - GBoxed.xs - GObject.xs - GValue.xs - GClosure.xs - GSignal.xs - GMainLoop.xs - GIOChannel.xs - GParamSpec.xs - GKeyFile.xs - GOption.xs - GBookmarkFile.xs - GVariant.xs - Makefile.PL - xsapi.pod.head - xsapi.pod.foot package: - MY requires: ExtUtils::Depends: '0.300' ExtUtils::PkgConfig: '1.000' 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 homepage: http://gtk2-perl.sourceforge.net license: http://www.gnu.org/licenses/lgpl-2.1.html repository: git://git.gnome.org/perl-Glib version: '1.320' Glib-1.320/NEWS000644 001750 000024 00000130722 12636025546 014204 0ustar00bdmanningstaff000000 000000 Overview of changes in Glib 1.320 (stable) ============================================ * Makefile.PL: added IRC link to metadata block * Glib::GenPod: supply default namespace blurbs (Bugzilla #753468) * Properly escape dash in generated API index POD (Bugzilla #753467) Overview of changes in Glib 1.314 (unstable) ============================================ * Fix compilation on libglib < 2.26 * Add Glib::Bytes, a wrapper for GBytes * Sort the output of podify_signals in a deterministic way (BZ#743863) Overview of changes in Glib 1.313 (unstable) ============================================ * Fix compilation and test issues with Glib::Variant::ParseError * Add a short explanatory comment to the lazy-loading system Overview of changes in Glib 1.312 (unstable) ============================================ * Fix incorrect version in Glib::GenPod Overview of changes in Glib 1.311 (unstable) ============================================ * Add the GVariant converters to the win32 linker export list * Fix Glib::Variant::classify on big-endian machines Overview of changes in Glib 1.310 (unstable) ============================================ * Add Glib::Variant and Glib::VariantType * Add char_byte and char_byte_ornull typemaps * Reorder and reformat our header and typemap a little * Hush a compiler warning in GMainLoop.xs Overview of changes in Glib 1.308 (stable) ========================================== * Release to replace stable version of Glib deleted from CPAN by accident; closes RT#110119. There are no code changes for this release. Overview of changes in Glib 1.307 (stable) ========================================== * Fix hang of t/9.t on FreeBSD/NetBSD perls not built with "-pthread"; closes RT#82349 * Add code comments about the peculiar Glib::InitiallyUnowned sink handling Overview of changes in Glib 1.306 (stable) ========================================== * Fix libpthread-related building issues on OpenBSD Overview of changes in Glib 1.305 (stable) ========================================== * Disable the warning message when handing callbacks over to the main loop. Overview of changes in Glib 1.304 (stable) ========================================== * Fix compilation against glib < 2.34.0. Overview of changes in Glib 1.303 (stable) ========================================== * Revert the change to ref counting of initial wrappers of custom subclasses, introduced in Glib 1.300. It caused issues with subclasses inheriting from Glib::InitiallyUnowned. * Fix a test failure with perl >= 5.19.4. * Create a GType for GSpawnFlags and register it with the bindings. Overview of changes in Glib 1.302 (stable) ========================================== * Avoid misusing the macro PL_na, thus preventing issues when Glib is used in conjunction with certain XS modules, among them XML::Parser and String::Approx. * Avoid memory corruption when registering boxed synonyms repeatedly. Overview of changes in Glib 1.301 (stable) ========================================== * t/options.t: skip tests in non-UTF-8 locales; fixes RT#83490 Overview of changes in Glib 1.300 (stable) ========================================== * Stable release to coincide with the release of Perl 5.18.0 Since 1.28x (The previous stable release) ----------------------------------------- * Ensure timely destruction of initial wrapper of custom subclasses * Start changing module version numbers in all Perl modules in the distribution, not just lib/Glib.pm; (Bugzilla #690464) * Make Glib::Object subclassing more robust. This should in particular fix issues revealed by the change to hash randomization introduced in perl 5.17.6. * Correctly handle utf8-encoded strings in GPerlArgv. This should fix issues seen with utf8-encoded strings in @ARGV with, for example, Gtk2->init. Overview of changes in Glib 1.291 (unstable) ============================================ * Ensure timely destruction of initial wrapper of custom subclasses * Start changing module version numbers in all Perl modules in the distribution, not just lib/Glib.pm; (Bugzilla #690464) Overview of changes in Glib 1.290 (unstable) ============================================ * Make Glib::Object subclassing more robust. This should in particular fix issues revealed by the change to hash randomization introduced in perl 5.17.6. * Correctly handle utf8-encoded strings in GPerlArgv. This should fix issues seen with utf8-encoded strings in @ARGV with, for example, Gtk2->init. Overview of changes in Glib 1.280 (stable) ========================================== Since 1.26x (the previous stable series) ---------------------------------------- * Correctly handle the boxed type for GError. * Ensure that custom signal marshallers are always used irregardless of the spelling used for the signal name. * Make the stack handling of some marshallers more robust, in preparation for custom Glib::Boxed converters that call back into Perl code. * Add new C API gperl_register_boxed_synonym. Since 1.270 ----------- * Fix building with perl <= 5.14. Overview of changes in Glib 1.270 (unstable) ============================================ * Correctly handle the boxed type for GError. * Ensure that custom signal marshallers are always used irregardless of the spelling used for the signal name. * Make the stack handling of some marshallers more robust, in preparation for custom Glib::Boxed converters that call back into Perl code. * Add new C API gperl_register_boxed_synonym. Overview of changes in Glib 1.262 (stable) ========================================== * Properly specify our dependencies. * Distriubte a missing test file. Overview of changes in Glib 1.261 (stable) ========================================== * Add NEWS entries comparing 1.260 to 1.24x * Add the 64 bit integer converters to the linker exports * updated README file similar to Cairo (RT#74870) * Created %meta_merge which follows v2 of meta-spec Overview of changes in Glib 1.260 (stable) ========================================== Since 1.24x (the previous stable series) ---------------------------------------- * Make Glib::Object ref-counting compatible with perl >= 5.16. * Make signal marshalling more thread-safe. * Export the constants SOURCE_CONTINUE and SOURCE_REMOVE on request. * Create and register a GType for GConnectFlags. * Increase compatibility with older perls. Since 1.253 ----------- * Tell CPAN to ignore POD fragments in Makefile.PL. * Document that SOURCE_CONTINUE and _REMOVE can be exported. Overview of changes in Glib 1.253 ================================= * Export the constants SOURCE_CONTINUE and SOURCE_REMOVE on request. (RT #48070) * Create and register a GType for GConnectFlags. Overview of changes in Glib 1.252 ================================= * Make the recent thread-safety improvements work for non-threaded perls too. Overview of changes in Glib 1.251 ================================= * Make signal marshalling more thread-safe. When a signal handler is invoked from a foreign thread without associated Perl interpreter, hand the marshalling over to the main loop which in turn later wakes up the main thread and lets it handle the request. Since this approach is experimental, there is debug print for now whenever it is used: *** GPerl asked to invoke callback from a foreign thread; handing it over to the main loop Overview of changes in Glib 1.250 ================================= * Add a fallback implementation of SvMAGIC_set; Bugzilla bug #665266 * Avoid a syntax error on older perls * Glib::Object: make ref-counting compatible with perl >= 5.16 (RT#73650) * Fix some typos in POD (RT#73616) Overview of changes in Glib 1.242 ================================= * Glib::GenPod: fix typo in default pspec values (https://bugzilla.gnome.org/show_bug.cgi?id=665331) * Glib::GenPod: delete a duplicate key in %basic_types (https://bugzilla.gnome.org/show_bug.cgi?id=665332) * Change the FSF's address in all GPL license notices (RT#72664) Overview of changes in Glib 1.241 ================================= * Register the boxed type Glib::GString, based almost completely on a patch by Emmanuel Rodriguez (https://bugzilla.gnome.org/show_bug.cgi?id=663881). * Fix linking against perl < 5.9.4 on some platforms; Do not use SvREFCNT_inc_simple_void_NN as that was introduced in perl 5.9.4, which came after the 5.8.0 we require. Overview of changes in Glib 1.240 ================================= Since 1.22x (the previous stable series) ---------------------------------------- * Add Glib::Param::GType support. * Add Glib::Log->set_default_handler() and Glib::Log::default_handler(). * Add Glib::ParamSpec->override() and get_redirect_target(). * Add Glib::Param->get_default_value(). * Support the fundamental type Glib::GType. * Correctly handle variables with "magic" attached, like tied variables. * Don't copy boxed objects when passing from Perl to C. Since 1.233 ----------- * Nada. Overview of changes in Glib 1.233 ================================= * Change the way we handle objects with floating references again, to be more compatible. Overview of changes in Glib 1.232 ================================= * In the documentation generated by Glib::GenPod, show default values for properties. * Correctly handle objects which have floating references. * When checking whether a variable is a reference, correctly account for "get magic", which occurs for example for tied variables. Add gperl_sv_is_ref for other bindings to use. Overview of changes in Glib 1.231 ================================= * Add Glib::Log->set_default_handler() and Glib::Log::default_handler(). * Add Glib::ParamSpec->override() and get_redirect_target(). * Add Glib::Param->get_default_value(). * Make Glib::ParamSpec->value_validate() copy boxed objects if necessary. * Support the fundamental type Glib::GType. * Correctly store and look up custom signal marshallers. * Fix fetching default values for unichar properties of custom subclasses. * Fix subclassing with {pspec, get, set}-style properties. * Allow the Glib::Object "magic" to coexist with other extensions' "magic". * Make Glib::GenPod create docs for child and style properties. * Improve the documentation in a few places. * Fix a few build and test failures. Overview of changes in Glib 1.230 ================================= * Don't copy boxed objects when passing from Perl to C. This mainly affects Perl subclasses which have signal handlers that involve boxed objects and use signal_chain_from_overridden() to call parent signal handlers. With this change, the parent's handlers will now operator on the same object that the Perl code sees, and changes consequently propagate properly. * Correctly handle variables with "set" magic attached in the default SET_PROPERTY implementation for custom Perl subclasses. * Add Glib::Param::GType support. * Make Glib::Flags::bool() and as_arrayref() callable as methods. * Allow undef for default_value in Glib::ParamSpec->string. * Improve the documentation in a few places. * Add gperl_hv_take_sv, a wrapper for hv_store, to our C API. * Fix some build and test failures. Overview of changes in Glib 1.224 ================================= * Glib::ParamSpec->value_validate(): copy boxed objects if necessary. * Fix a test failure. Overview of changes in Glib 1.223 ================================= * Fix a few test failures. Overview of changes in Glib 1.222 ================================= * Properly handle slashes in copyright footers passed to Glib::MakeHelper. * Fix a test failure on s390. Overview of changes in Glib 1.221 ================================= * Fix a few build and test suite issues. Overview of changes in Glib 1.220 ================================= Since 1.20x (the previous stable series) ---------------------------------------- * Add constants Glib::SOURCE_CONTINUE and SOURCE_REMOVE for use in source-type callbacks. * Add Glib::Child::watch_add. * Add Glib::OptionContext and Glib::OptionGroup. * Allow calling Glib::Flags->as_arrayref directly, as an alternative to the @{} syntax. * Add Glib::ParamSpec->value_validate and Glib::ParamSpec->value_cmp. Since 1.214 ----------- * Nada. Overview of changes in Glib 1.214 ================================= * Fix a leak in the handling of callback arguments. * Fix many errors and glitches in the POD generated by Glib::GenPod. * Fix some test suite issues and documentation glitches. Overview of changes in Glib 1.213 ================================= * Make the various Glib::Flags methods more robust with respect to receiving undefined input. * Correctly handle signals with no return type when invoking signal class closures. * Deprecate Glib::MakeHelper->get_configure_requires_yaml in favor of ExtUtils::MakeMaker's new META_MERGE and META_ADD features. Overview of changes in Glib 1.212 ================================= * Allow calling Glib::Flags->as_arrayref directly, as an alternative to the @{} syntax. * Add Glib::ParamSpec->value_validate and Glib::ParamSpec->value_cmp. * Add documentation for Glib->filename_to_uri and filename_from_uri. * Always use Data::Dumper instead of Storable on MSWin32 for serialization work during documentation generation. * Make sure that messages with % chars in them make it through Glib->log and friends safely. Overview of changes in Glib 1.211 ================================= * Add Glib::OptionContext and Glib::OptionGroup, wrapping glib's command line option parser. * Make the internal package registration functions more robust. Overview of changes in Glib 1.210 ================================= * Add constants Glib::SOURCE_CONTINUE and SOURCE_REMOVE for use in source-type callbacks. * Add Glib::Child::watch_add. * Provide gperl_register_boxed_alias, gperl_register_fundamental_alias, and gperl_register_object_alias to register aliases for other registered types. * Improve the error message that occurs when an unknown interface is encountered while registering a new type. Overview of changes in Glib 1.200 ================================= Since 1.18x (the previous stable series) ---------------------------------------- * Add Glib::Flags::new, a constructor for flags objects. * Add Glib::strerror and Glib::strsignal. * Increase the robustness of stack handling in Glib::Object::get, of Glib::ParamSpec handling in general, of overloaded Glib::Flags operators, and of the Glib::Object lazy-loader. Since 1.193 ----------- * Update the TODO file. Overview of changes in Glib 1.193 ================================= * Make the stack handling in Glib::Object::get more robust. * Make the Glib::ParamSpec constructors return undef on failure. * Make sure the Glib::Object lazy loader can handle being invoked on packages which aren't registered with the Glib type system. * The recent fix for user data handling in callback invocation involved a change of semantics: modifying the user data directly had no effect anymore. Change that back while still fixing the original bug. Overview of changes in Glib 1.192 ================================= * Fix the POD index page generation. Overview of changes in Glib 1.191 ================================= * Make overloaded Glib::Flags operators more robust. * Handle unset GParamSpecs gracefully. Overview of changes in Glib 1.190 ================================= * Add Glib::Flags::new, a constructor for flags objects. * Add Glib::strerror and Glib::strsignal. Overview of changes in Glib 1.183 ================================= * Make Glib::signal_add_emission_hook work even if called before any object of the concerned type has been created. * Overload '!=' for Glib::Flags. * Avoid prematurely destroying callback user data in certain cases. * Improve the documentation of Glib::Object::Subclass' GET_PROPERTY and SET_PROPERTY. Overview of changes in Glib 1.182 ================================= * Fix build and test suite issues, especially on MSWin32 and cygwin. Overview of changes in Glib 1.181 ================================= * Fix Makefile.PL problems encountered by CPAN testers. Overview of changes in Glib 1.180 ================================= Since 1.16x (the previous stable series) ---------------------------------------- * Add Glib::MakeHelper::get_configure_requires_yaml. * Add Glib::Object::signal_get_invocation_hint. * Make our lazy-loader compatible with perl-5.10.0. * Allow Perl-derived GObjects to override GInterfaces that are implemented by parent classes. * Correct the way we check values for definedness: use the new function gperl_sv_is_defined. For convenience, also add gperl_sv_is_array_ref, gperl_sv_is_code_ref, and gperl_sv_is_hash_ref. Since 1.174 ----------- * Tell the compiler to always look for our headers in '.' first. * Add a hyphen to the NAME section of generated POD indices. Overview of changes in Glib 1.174 ================================= * Increase compatibility with different `make´s by not using Makefile conditionals for building our documentation. Overview of changes in Glib 1.173 ================================= * Make Glib::Type::list_values return the value of each enum/flags entry in addition to the name and nickname. Overview of changes in Glib 1.172 ================================= * Make inproper usage of Glib::Object methods result in an error message and not in a segfault. * Add Glib::Object::signal_get_invocation_hint. * In our lazy-loading machinery for packages, change the way we clear @ISA arrays to avoid problems with perl 5.10.0. * Add new helpers to the C API: gperl_sv_is_defined, gperl_sv_is_array_ref, gperl_sv_is_code_ref, and gperl_sv_is_hash_ref. * Allow Perl-derived GObjects to override GInterfaces that are implemented by parent classes. * Load GInterface types immediately, instead of lazily. This makes sure GInterfaces are set up by the time they are needed. Overview of changes in Glib 1.171 ================================= * Correct the way we check values for definedness: add gperl_sv_defined(), an XS version of perl's defined(), and use it everywhere. Among other things, this should fix the problems where tied values were reported as undefined. * Fix some build issues. Overview of changes in Glib 1.170 ================================= * Make our build output prettier. * Add Glib::MakeHelper::get_configure_requires_yaml. * Use the above to add configure_requires information to META.yml in order to publicize our Makefile.PL-time requirements. * Try to fix some portability issues. Overview of changes in Glib 1.164 ================================= * Allow Perl-derived GObjects to override GInterfaces that are implemented by parent classes. * Load GInterface types immediately, instead of lazily. This makes sure GInterfaces are set up by the time they are needed. Overview of changes in Glib 1.163 ================================= * In our lazy-loading machinery for packages, change the way we clear @ISA arrays to avoid problems with perl 5.10.0. * Fix a few build issues. Overview of changes in Glib 1.162 ================================= * Fix a build failure in the documentation generation phase. [Andreas König] Overview of changes in Glib 1.161 ================================= * Fix an assertion in Glib::Object::CLONE. * Make Makefile.PL more friendly to CPAN testers. Overview of changes in Glib 1.160 ================================= Since 1.14x (the previous stable series) ---------------------------------------- * Add Glib::get_user_special_dir. * Add Glib::KeyFile::load_from_dirs. * Add Glib::MainContext::is_owner. * Add Glib::Timeout::add_seconds. * Improve the automatic documentation generator. Since 1.153 ----------- * Nothing. Overview of changes in Glib 1.153 ================================= * Add char_own_ornull and gchar_own_ornull typemaps. [Torsten] * Fix some win32 test failures. [Torsten] * Make it possible to document specific packages in different POD files by providing a new =for object variant. [Torsten] * Parse preprocessor conditionals in the XS code to add Since: tags to methods' POD. [Torsten] Overview of changes in Glib 1.152 ================================= * Wrap g_main_context_is_owner. [Torsten] * Wrap g_timeout_add_seconds. [Torsten] Overview of changes in Glib 1.151 ================================= * Use BSD make syntax on BSD systems by default. [Slaven Rezic, Torsten] * Wrap g_key_file_load_from_dirs. [Torsten] * Wrap g_get_user_special_dir. [Torsten] Overview of changes in Glib 1.150 ================================= * Make it possible to mark objects and methods as deprecated with Glib::ParseXSDoc and Glib::GenPod. [Emmanuele] Overview of changes in Glib 1.144 ================================= * Use BSD make syntax on BSD systems by default. [Slaven Rezic, Torsten] Overview of changes in Glib 1.143 ================================= * Call g_threads_init before g_type_init. [Torsten] Overview of changes in Glib 1.142 ================================= * Switch back to WIN32 instead of G_OS_WIN32 to avoid compilation problems. [Torsten] * Use _strtoi64 and _strtoui64 on Win32 for large integer conversion. [Serguei Trouchelle] Overview of changes in Glib 1.141 ================================= * Fix a compilation problem on Win32. [Torsten] * Fix some POD errors. [Torsten] * Fix a few test suite issues. [Torsten] Overview of changes in Glib 1.140 ================================= Since 1.12x (the previous stable series) ---------------------------------------- * Add accessors for double types to Glib::KeyFile. * Add Glib::BookmarkFile * Add Glib::Object::find_property. Since 1.132 ----------- * Fix two test suite issues. Overview of changes in Glib 1.132 ================================= * Do some minor code cleanups here and there. [Torsten] Overview of changes in Glib 1.131 ================================= * Add Glib::Object::find_property. [Emmanuele] Overview of changes in Glib 1.130 ================================= * Wrap new GKeyFile API: [Torsten] - Glib::KeyFile::set_double, - Glib::KeyFile::get_double, - Glib::KeyFile::set_double_list, and - Glib::KeyFile::get_double_list * Register GInitiallyUnowned as Glib::InitiallyUnowned. [Torsten] * Add GBookmarkFile bindings. [Emmanuele] Overview of changes in Glib 1.120 ================================= Since 1.10x (the previous stable series) ---------------------------------------- * Comepletely revamp the way GObject types are mapped to Perl package names. The new algorithm is more robust and correct. * Add custom 64 bit integer handlers. * Add Glib::filename_display_name and Glib::filename_display_basename. * Improve thread safety. * Fix many bugs. Since 1.118 ----------- * Nada. Overview of changes in Glib 1.118 ================================= * Improve the thread safety of Glib by correctly setting up perl's thread-local storage in a few strategic places. [Torsten] Overview of changes in Glib 1.117 ================================= * Fix compilation against perl 5.8.8. [Torsten] Overview of changes in Glib 1.116 ================================= * Fix a bug that caused custom objects with properties that have no getter or setter to misbehave on perl 5.8.8. [muppet] * Optimize Glib::ParseXSDoc to use less memory. [muppet] Overview of changes in Glib 1.115 ================================= * Don't try to be thread safe if perl wasn't built with threading support. [Wim Lewis] * Don't create unique package names for types that have an ancestor which has the "don't warn about unregistered subclasses" bit set. Use this ancestor's package name to represent affected types. [muppet] Overview of changes in Glib 1.114 ================================= * Add bindings for g_filename_display_name and g_filename_display_basename. [muppet] * Fix a crash that occured when properties of undead objects were modified. [muppet] * Fix the undead object macros to work on 64-bit platforms. [Rafael Garcia-Suarez] * Completely redo the way GObject types are mapped to package names. This fixes the problem uncovered by the recent GInitiallyUnowned issue. See the ChangeLog for a detailed description of the changes. [muppet, Torsten] Overview of changes in Glib 1.113 ================================= * Improve the automatic interface registration for objects by making it independent of the order of package name registration. [Torsten] Overview of changes in Glib 1.112 ================================= * Allow undef for some arguments in the Glib::KeyFile API. [Emmanuele] * Register the package names Glib::Int64 and Glib::UInt64 for gint64 and guint64 fundamentals. [Torsten] Overview of changes in Glib 1.111 ================================= * Copy boxed objects coming from the GObject property interface to avoid holding on to dead pointers. [muppet] Overview of changes in Glib 1.110 ================================= * Add automatic package registration for interfaces. [Torsten] * Fix a serious reference counting bug. [Steven Walter] * Add custom 64 bit integer handlers that convert to and from strings if necessary. [Torsten] Overview of changes in Glib 1.105 ================================= * Fix a bug that caused custom objects with properties that have no getter or setter to misbehave on perl 5.8.8. [muppet] Overview of changes in Glib 1.104 ================================= * Don't use threading stuff if perl wasn't build with threading support. [Wim Lewis] * Don't create unique package names for types that have an ancestor which has the "don't warn about unregistered subclasses" bit set. Use this ancestor's package name to represent affected types. [muppet] Overview of changes in Glib 1.103 ================================= * Fix a crash that occured when properties of undead objects were modified. [muppet] * Fix the undead object macros to work on 64-bit platforms. [Rafael Garcia-Suarez] * Completely redo the way GObject types are mapped to package names. This fixes the problem uncovered by the recent GInitiallyUnowned issue. See the ChangeLog for a detailed description of the changes. [muppet, Torsten] * Allow undef for some arguments in the Glib::KeyFile API. [Emmanuele] Overview of changes in Glib 1.102 ================================= * Copy boxed objects coming from the GObject property interface to avoid holding on to dead pointers. [muppet] * Fix a serious reference counting bug. [Steven Walter] Overview of changes in Glib 1.101 ================================= * Fix a test suite issue. [Torsten] Overview of changes in Glib 1.100 ================================= Since 1.08x (the previous stable series) ---------------------------------------- * Add API that allows binding developers to specify conversion functions when registering wrappers for custom fundamental types. * Add Glib::Object::signal_add_emission_hook, Glib::Object::signal_remove_emission_hook and Glib::Markup::escape_text. * Add Glib::KeyFile and Glib::CodeGen. * Fix a thread-related crasher in the default log handler. Since 1.093 ----------- * Delete some cruft in CodeGen.pm. [muppet] Overview of changes in Glib 1.093 ================================= * Take out the Gtk2-specific portions of Gtk2::CodeGen, make it extensible, and call it Glib::CodeGen. [muppet] Overview of changes in Glib 1.092 ================================= * Fix a thread-related crasher in the default log handler. [Torsten] * Fix a test suite issue. [Torsten] * Fix Glib::IO::add_watch on win32. [Marc Lehmann] * Add Glib::Markup::escape_text. [Torsten] Overview of changes in Glib 1.091 ================================= * Add GKeyFile bindings. [Emmanuele] * Add tests for previously untested stuff. [Torsten] * Add a GSignalFlags typemap. [Torsten] Overview of changes in Glib 1.090 ================================= * Add API that allows binding developers to specify conversion functions when registering wrappers for custom fundamental types. [Torsten] * Add Glib::Object::signal_add_emission_hook and Glib::Object::signal_remove_emission_hook. [muppet] * Fix problems with the automatic creation of enum/flags listings. [Ross] Overview of changes in Glib 1.082 ================================= * Update and expand the test suite. [Torsten] * Fix a few bugs here and some typos there. [Torsten] * Fix enum listings in the generated documentation. [Ross] * Fix a thread-related crasher in the default log handler. [Torsten] Overview of changes in Glib 1.081 ================================= * Documentation updates. [Torsten] Overview of changes in Glib 1.080 ================================= Since 1.06x (the previous stable series) ---------------------------------------- * Support for GParamSpecUnichar and GStrv. * Timely delivery of Perl's asynchronous signals. * Fatal log messages call abort() rather than croak(). * Glib::MainLoop's are properly freed after use. * New API: - Glib::get_user_data_dir, - Glib::get_user_config_dir, - Glib::get_user_cache_dir, - Glib::get_system_data_dirs, - Glib::get_system_config_dirs, - Glib::get_language_names, - Glib::Object::signal_query. Since 1.074 ----------- * Nothing. Overview of changes in Glib 1.074 ================================= * Fix a reference counting bug that prevented Glib::MainLoop's from ever being freed. [Ross] Overview of changes in Glib 1.073 ================================= * Bind, doc, and test g_signal_query as Glib::Object::signal_query. [muppet] * Fatal log messages call abort() rather than croak(). Croaking wasn't all that useful (didn't stop in the perl debugger as expected), and aborting allows you to get a C backtrace in gdb. [muppet] * Fix Glib::MakeHelper::select_files_by_version on Win32. [muppet] * Implement missing support for the boxed type GStrv as a native perl anonymous array of strings. [muppet] * Docgen fixes. [muppet] * Test suite updates and fixes. [Ross, muppet] Overview of changes in Glib 1.072 ================================= * Ensure that asynchronous signals, deferred by perl's safe signal handling, are delivered on time when a main loop is running. [Jan Hudec, muppet] * Fix win32 linkage. [muppet, thanks to Tyler Hepworth] * Test fixes. [Ross] * Bind and test g_get_user_data_dir, g_get_user_config_dir, g_get_user_cache_dir, g_get_system_data_dirs, g_get_system_config_dirs, and g_get_language_names. [Torsten] * Documentation updates. [Torsten, muppet] Overview of changes in Glib 1.071 ================================= * Correct a warning message. [Torsten] Overview of changes in Glib 1.070 ================================= * Add support for GParamSpecUnichar. [Torsten] * Generate a correct META.yml. [muppet] Overview of Changes in Glib 1.062 ================================= * Properly create META.yml. [muppet] * Fix exports and some documentation. [muppet] * Fix RPM generation on x86_64. [Ross] * Fix test failure with newer versions of Test::More. [Ross] Overview of Changes in Glib 1.061 ================================= * Minor cleanup. [Torsten] Overview of Changes in Glib 1.060 ================================= Since 1.04x (the previous stable series) ---------------------------------------- * Documentation fixes and improvements, including bugfixes in the documentation generation system. * Improved error messages in several places. * Code cleanup. * Thread compatibility enhancements - Disabled internal stash caching, which was broken to begin with. - Added the ability to track Glib::Object instances so the bindings can maintain proper reference counts when the interpreter clones a new thread. This feature must be enabled manually by calling Glib->set_threadsafe(TRUE) before creating threads or GObjects. * More fundamental types are registered, e.g. Glib::UChar, Glib::Float, etc. This allows all paramspec types to be specified as package names. Glib::UInt was previously misspelled as Glib::Uint; the old name is still allowed, but the new name will be returned from Glib in all instances. * The OUTPUT variant of T_GPERL_GENERIC_WRAPPER can now handle leading "const" and trailing asterisks, like the INPUT variant. * Greatly expanded GParamSpec support. - Glib::ParamSpec instances are now blessed hash references containing a few special keys (same as the hashes previously returned from Glib::Object::list_properties()) to retain backwards compatibility. - There are now accessors for all the member variables of the various GParamSpec subclasses (e.g., GParamInt's minimum, maximum, and default value); this tree is mapped as Glib::Param::. - Glib::ParamSpec->param() now works. - All of this makes the Glib::Object "notify" signal usable. * Glib::Object subclassing enhancements - Glib::Object::Subclass can now be used in evals and other situations, thanks to the removal of the CHECK block. This change is otherwise transparent. - Added fallback and explicit handlers for Glib::Object properties; the fallback handlers store the property data in the instance variable under the hash key with the same name as the property. Explicit handlers may be specified at object creation time. See the docs for Glib::Type::register_object() for details. * API additions: - Glib::Object::notify() - char_own typedef and typemap. - Glib::MakeHelper::select_files_by_version() and Glib::MakeHelper::read_source_list_file() for use by Makefile.PLs. Since 1.055 ----------- * Release prep. Overview of Changes in Glib 1.055 ================================= * Documentation generation fixes. [Ross] Overview of Changes in Glib 1.054 ================================= * Documentation fixes and improvements. [Ross, muppet] Overview of Changes in Glib 1.053 ================================= * Add char_own typedef and typemap. [Torsten] * Add Glib::MakeHelper::select_files_by_version() and Glib::MakeHelper::read_source_list_file() for use by Makefile.PLs. [Torsten] Overview of Changes in Glib 1.052 ================================= * Remove CHECK block from Glib::Object::Subclass's import(), making it possible to use Subclass in evals. Changes should be perfectly backwards compatible, with a few bugs fixed. [muppet] * The OUTPUT variant of T_GPERL_GENERIC_WRAPPER can now handle leading "const" and trailing asterisks, like the INPUT variant. [Torsten] Overview of Changes in Glib 1.051 ================================= * Code fixes and cleanup for C89 compatibility. [Albert Chin, muppet] * Fine-tune error message format helper. [muppet] * Implement new fallback and explicit handlers for Glib::Object properties; the fallback handlers use the wrapper hash keys (as in the defaults provided by Glib::Object::Subclass), and explicit handlers may now be specified when creating properties. [muppet] * Handle undef gracefully in gperl_value_from_sv(). [muppet] Overview of Changes in Glib 1.050 ================================= * New unstable development branch. * Greatly expanded GParamSpec support. [muppet] - Glib::ParamSpec instances are now blessed hash references containing a few special keys (same as the hashes previously returned from Glib::Object::list_properties()) to retain backwards compatibility. - There are now accessors for all the member variables of the various GParamSpec subclasses (e.g., GParamInt's minimum, maximum, and default value); this tree is mapped as Glib::Param::. - Glib::ParamSpec->param() now works. - All of this makes the Glib::Object "notify" signal usable. * More fundamental types are registered, e.g. Glib::UChar, Glib::Float, etc. This allows all paramspec types to be specified as package names. Glib::UInt was previously misspelled as Glib::Uint; the old name is still allowed, but the new name will be returned from Glib in all instances. This needs testing to see if it breaks anything. [muppet] * Added autodetection of flags and enum types to the doc generation code, so that all enum and flags types used in the methods and functions listed on a page are documented on that page. The "=for enum" directives are still honored, and may be used to add descriptive text to the listings. [Ross] * Added code to allow Glib::Object tracking, which allows the binding to maintain proper reference counts on GObjects when the perl interpreter clones a new thread. Needs lots of testing, documentation, and needs a way to tell if thread support was compiled into perl. Right now it's enabled (if compiled in) by calling Glib::Object->set_threadsafe. [Ross] * Disable Glib::Object stash caching, which fixes a few bizarre things that go wrong when using perl threads. [muppet] * Add missing Glib::Object::notify() (to emit notify singals). [muppet] * As always, incremental documentation improvements. [Torsten] * Improved type-checking error messages, using the new helper function gperl_format_variable_for_output(). [Torsten] * Various odds and ends of minor cleanup and commentary. [Torsten, muppet] Overview of Changes in Glib 1.042 ================================= * Documentation improvements. [muppet, Torsten] - Fix grammar and spelling throughout. - Improve the docs for Glib::Object::Subclass and the documentation generation system itself. - Add the main module of the extension to the generated see also list. * Don't clobber $_ when warning of unhandled exceptions. [muppet] Overview of Changes in 1.041 ============================ * Don't segfault on bad filenames in gperl_sv_from_filename() [Marc Lehmann] * Hush compiler warnings. [Ross] * Make Glib::filename_from_unicode() actually do work. [muppet] Overview of Changes in 1.040 ============================ Since 1.02x (the previous stable series) ---------------------------------------- * Updated build requirement - ExtUtils::Depends >= 0.2 * Support for a few new API features in glib-2.4.x. * Functions that use GErrors in C throw magical Glib::Error exception objects; these objects overload the stringification operator, so old code won't be broken, but new code can match errors without worrying about translated error messages. User code and other extensions can register their own error domains. See the Glib::Error manpage for more info. * Glib::Type enhancements - Perl code can register enum and flags types for use as Glib::Object property types. - During Glib::Object class initialization, invoke INIT_BASE in the object's package, if it exists. (Analogue for GTypeClass's base_init.) - It is now possible to add GInterface implementations to Glib::Object types derived in Perl code. - New param spec, Glib::ParamSpec::scalar * Glib::MakeHelper is generally more helpful. * The POD generation tools allow specification of cumulative data type descriptions, and much finer control over the format and content of the generated documentation. * Glib can now export useful constants on request. * New versioning API, see Glib::version. Since 1.0391 ------------ * Nothing. :-) Overview of Changes in 1.0391 ============================= * Bump 2.3.x version checks to 2.4.0. * Portability fixes for Glib::MakeHelper. * Add, document, and test Glib::GET_VERSION_INFO. * Documentation fixes. Overview of Changes in Glib 1.039 ================================= * Add missing symbols to the exports list, so we have half a hope of not totally barfing on win32. [muppet] * Code sweep for FIXMEs resulted in miscellaneous bugfixes and cleanups. - Clean up properly when croaking on bad property name in Glib::Object::new. - Use the same 'bad property' message in Glib::Object::set and "::new. - Document the fact that Glib::ParamSpec::param_spec is unimplemented. * Document functions that can throw Glib::Error exceptions. [Ross] * Glib::MakeHelper enhancements [muppet] - verify that ExtUtils::Depends is >= 0.2 - Don't generate broken makefiles if there are no C or XS files to compile. * Using Data::Dumper on an object with tied write-only properties no longer results in an crash. [Ross] Overview of Changes in Glib 1.038 ================================= * The API is frozen at this release for the 1.04x series. * g_main_depth (new in 2.3.5) bound as Glib::main_depth. [Ross] * Glib::GenPod now works with strict, no user-visible changes. [Ross] * POD updates. [muppet] Overview of Changes in Glib 1.037 ================================= * Added bindings for missing utility functions, with tests and doc: g_get_user_name, g_get_real_name, g_get_home_dir, g_get_tmp_dir, g_get_application_name, g_set_application_name. [muppet] * Decided on versioning API, implemented, used, and documented it. There's more documentation on the versioning stuff than code to implement it. New functions: Glib->CHECK_VERSION, Glib::MAJOR_VERSION, Glib::MINOR_VERSION, Glib::MICRO_VERSION, Glib->check_version, Glib::major_version, Glib::minor_version, Glib::micro_version. [Ross, muppet] * GPerlClosure's exception handlers no longer clobber $_. [muppet] * Add the ability to register new error domains and throw Glib::Errors from Perl. New utility function, Glib::Error::matches (binding for g_error_matches), makes it easy to test errors. New xs utility function for parsing a perl data structure into a GError. [muppet] * POD generation cleanups and fixes and enhancements. [Ross] - Methods are now sorted for readability - Plain functions get proper non-method signatures - Hiding works better, more extensibly - Can now specify where in the file the POD should code. * Miscellaneous bug fixes. [Torsten, Ross, muppet] Overview of Changes in Glib 1.036 ================================= * GErrors are now translated into exception objects instead of plain, translatable strings; this is implemented as an additional functionality, so there is no break in either API or ABI. [muppet] * gperl_alloc_temp() now complains but does not crash when requested to allocate less than 1 byte. [Torsten] * Quell some doc generation noisiness. [muppet] * Updated copyright information in source code. [muppet] Overview of Changes in Glib 1.035 ================================= * Updated ExtUtils::Depends requirement to 0.200. * Added Glib::MakeHelper::postamble_docs_full(), a more featureful, easier to use, and more scalable front-end to the pod documentation generation tools. [muppet] * Extended Glib::Type::list_properties to handle properties on GInterfaces, which is a new feature in gtk+ 2.4. [Ross] * Added Glib::ParamSpec::scalar() for creating SV properties without needing to know about boxed types. [Ross] Overview of Changes in Glib 1.034 ================================= * Added infrastructure for installing Perl implementations of GObject vfuncs. [muppet] * Added infrastructure for adding GInterfaces to perl-derived GObject types. [muppet] * Added GPerlArgv utilities for unified @ARGV handling. [Torsten] * Added startup-time linked version checking. [Ross] * Several 64-bit portability fixes. [muppet] Overview of Changes in Glib 1.033 ================================= * apidoc improvements, GenPod/ParseXSDoc. ability to add to the list of see_also, and ways to orverride the copyright globals that GenPod uses. Overview of Changes in Glib 1.031 ================================= * New typemaps for gshort and gushort. [Torsten] * Updates to Glib::MakeHelper fix some build issues. [Ross] * Robustness fixes in the doc system's xs parser. [muppet] * Added $object->freeze_notify and $object->thaw_notify. [muppet] * Added a few new exportable constants. [muppet] Overview of Changes from Glib 1.02x to 1.030 ============================================ * MakeHelper's utilities now allow "disable-doc" on a Makefile.PL command-line to disable doc generation. This works for all Glib::MakeHelper-based projects. * It is now possible to register new GFlags and GEnum types from Perl. These are typically useful as types for object properties of perl-derived GObjects. * We now compile cleanly and pass tests on x86_64 platforms. Some tests are skipped until bugfixes in glib hit mainstream. Thanks to Jacek Konieczny. * Added documentation for tie_properties. * ParseXSDoc now supports continuation lines in xsubs, and properly hides things that want to be hidden. * Invocation of signal and event handlers no longer clobbers $@ at the application level. Thanks to Thierry Vignaud. * Added version information APIs. * Added filename_to_uri and filename_from_uri, but they have problems with localization. Need help debugging this. * Glib is now a proper Exporter, and can export the filename utilities. We also allow method invocation of those functions to quell controversy. Glib-1.320/perl-Glib.doap000644 001750 000024 00000001657 11664366512 016174 0ustar00bdmanningstaff000000 000000 Glib Perl wrappers for the GLib utility and Object libraries muppet sarringt Torsten Schönfeld tsch Glib-1.320/perl-Glib.spec.in000644 001750 000024 00000005470 11701512040 016562 0ustar00bdmanningstaff000000 000000 Summary: Glib Perl module Name: perl-Glib Version: @VERSION@ Release: 1 Packager: gtk-perl-list@gnome.org License: LGPL Group: Development/Libraries URL: http://search.cpan.org/dist/Glib/ BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root BuildRequires: perl >= 2:5.8.0 BuildRequires: glib2-devel >= @GLIB@ BuildRequires: perl-ExtUtils-Depends >= @PERL_EXTUTILS_DEPENDS@ BuildRequires: perl-ExtUtils-PkgConfig >= @PERL_EXTUTILS_PKGCONFIG@ Requires: glib2 >= %(pkg-config --modversion glib-2.0) Requires: %(perl -MConfig -le 'if (defined $Config{useithreads}) { print "perl(:WITH_ITHREADS)" } else { print "perl(:WITHOUT_ITHREADS)" }') Requires: %(perl -MConfig -le 'if (defined $Config{usethreads}) { print "perl(:WITH_THREADS)" } else { print "perl(:WITHOUT_THREADS)" }') Requires: %(perl -MConfig -le 'if (defined $Config{uselargefiles}) { print "perl(:WITH_LARGEFILES)" } else { print "perl(:WITHOUT_LARGEFILES)" }') Source0: @SOURCE@ %description This module provides perl access to GLib and GLib's GObject libraries. GLib is a portability and utility library; GObject provides a generic type system with inheritance and a powerful signal system. Together these libraries are used as the foundation for many of the libraries that make up the Gnome environment, and are used in many unrelated projects. %prep %setup -q -n Glib-%{version} %build CFLAGS="$RPM_OPT_FLAGS" perl Makefile.PL PREFIX=$RPM_BUILD_ROOT%{_prefix} make OPTIMIZE="$RPM_OPT_FLAGS" make test %install %makeinstall [ -x /usr/lib/rpm/brp-compress ] && /usr/lib/rpm/brp-compress find $RPM_BUILD_ROOT \( -name perllocal.pod -o -name .packlist \) -exec rm -v {} \; find $RPM_BUILD_ROOT/usr -type f -print | \ sed "s@^$RPM_BUILD_ROOT@@g" | \ grep -v perllocal.pod | \ grep -v "\.packlist" > %{name}-%{version}-filelist if [ "$(cat %{name}-%{version}-filelist)X" = "X" ] ; then exit -1 fi %clean rm -rf $RPM_BUILD_ROOT %files -f %{name}-%{version}-filelist %defattr(-,root,root) %changelog * @DATE@ gtk-perl-list@gnome.org - @VERSION@ - Specfile autogenerated. # Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full # list) # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/README000644 001750 000024 00000012627 12060470577 014367 0ustar00bdmanningstaff000000 000000 Glib ==== This module provides perl access to Glib and GLib's GObject libraries. GLib is a portability and utility library; GObject provides a generic type system with inheritance and a powerful signal system. Together these libraries are used as the foundation for many of the libraries that make up the Gnome environment, and are used in many unrelated projects. This wrapper attempts to provide a perlish interface while remaining as true as possible to the underlying C API, so that any reference materials you can find on using GLib may still apply to using the libraries from perl. Where GLib's functionality overlaps perl's, perl's is favored; for example, you will find perl lists and arrays in place of GSList or GList objects. Some concepts have been eliminated; you need never worry about reference-counting on GObjects or GBoxed structures. Other concepts have been converted to a perlish analogy; the GType id will never be seen in perl, as the package name serves that purpose. See the main Glib manpage for more information. This module also provides facilities for creating wrappers for other GObject-based libraries. The documentation page of the gtk2-perl project's website has information about this stuff; see http://gtk2-perl.sourceforge.net/ INSTALLATION ------------ To install this module type the following: perl Makefile.PL make make test make install To avoid installing to a system directory, since this is a beta release, you can change the installation prefix at Makefile.PL time with perl Makefile.PL PREFIX=/some/other/place This will install the module to the subdirectory lib/perl5 under the given prefix. If this is not already in perl's include path, you'll need to tell perl how to get to this library directory so you can use it; there are three ways: in your environment (the easiest): # assuming a bourne-style shell PERL5LIB=/some/other/place/lib/perl5/site_perl export PERL5LIB on the perl command line: perl -I /some/other/place/lib/perl5/site_perl yourscript in the code of your perl script: use lib '/some/other/place/lib/perl5/site_perl'; DEPENDENCIES ------------ In order to use perl bindings for glib, you must have glib 2.x and its prerequisites (pkg-config and a decent standard c library) installed. glib-2.x is available from http://www.gtk.org, http://www.gnome.org, etc. Glib uses unicode internally; therefore this module requires perl 5.8.0 or newer. You'll also need the following modules in order to build the Glib module from source: ExtUtils::Depends >= 0.300 ExtUtils::PkgConfig >= 1.00 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 [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 - submitting bugs via e-mail (open to anyone with e-mail): bug-Glib [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 Or, read-only access via HTTP: git clone http://git.gnome.org/browse/perl-Glib 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) 2003-2012 by the gtk2-perl team (see the file AUTHORS for the full list) See the LICENSE file in the top-level directory of this distribution for the full license terms. Glib-1.320/t/000755 001750 000024 00000000000 12636025764 013745 5ustar00bdmanningstaff000000 000000 Glib-1.320/TODO000644 001750 000024 00000001203 11664366512 014165 0ustar00bdmanningstaff000000 000000 - the ability to create new GSources in Perl could be handy, and wouldn't be hard to implement (a hash in place of GSourceFuncs). - GEnum type for G_PRIORITY_VALUES? - can't implement g_idle_remove_by_data because ... well, how would you search for the data value? - proper cleanup for bad parameter types in Glib::Object::new? - would require either iterating over the list twice or cleaning up before the croak. the latter is probably the way to go. - there is no way to clean up if gperl_sv_from_value() fails. - gperl_value_from_sv should change to void return since it croaks on error. (can't do this without breaking ABI) Glib-1.320/typemap000644 001750 000024 00000015403 12636024471 015101 0ustar00bdmanningstaff000000 000000 # Copyright (C) 2003-2005, 2010 by the gtk2-perl team (see the file AUTHORS for # the full list) # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # # $Id$ # TYPEMAP gboolean T_BOOL gint T_IV guint T_UV gint8 T_IV guint8 T_UV gint16 T_IV guint16 T_UV gint32 T_IV guint32 T_UV gint64 T_GINT64 guint64 T_GUINT64 gshort T_SHORT gushort T_U_SHORT glong T_IV gulong T_UV gunichar T_GUNICHAR gchar T_IV guchar T_UV gfloat T_FLOAT gdouble T_DOUBLE gsize T_UV gssize T_IV gpointer T_PTR gchar * T_GCHAR const gchar * T_GCHAR gchar_own * T_GCHAR_OWN gchar_length * T_GCHAR_LEN const gchar_length * T_GCHAR_LEN gchar_utf8_length * T_GCHAR_UTF8_LEN const gchar_utf8_length * T_GCHAR_UTF8_LEN gchar_ornull * T_GCHAR_ORNULL gchar_own_ornull * T_GCHAR_OWN_ORNULL const gchar_ornull * T_GCHAR_ORNULL char_ornull * T_CHAR_ORNULL char_own * T_CHAR_OWN char_own_ornull * T_CHAR_OWN_ORNULL const char_ornull * T_CHAR_ORNULL char_byte * T_CHAR_BYTE const char_byte * T_CHAR_BYTE char_byte_ornull * T_CHAR_BYTE_ORNULL const char_byte_ornull * T_CHAR_BYTE_ORNULL guchar * T_GUCHAR const guchar * T_GUCHAR GObject* T_GPERL_GENERIC_WRAPPER GObject_ornull* T_GPERL_GENERIC_WRAPPER GObject_noinc* T_GPERL_GENERIC_WRAPPER GParamSpec* T_GPERL_GENERIC_WRAPPER GParamSpec_ornull* T_GPERL_GENERIC_WRAPPER GParamFlags T_GPERL_GENERIC_WRAPPER GSignalFlags T_GPERL_GENERIC_WRAPPER GKeyFile* T_GPERL_GENERIC_WRAPPER GKeyFileFlags T_GPERL_GENERIC_WRAPPER GBookmarkFile* T_GPERL_GENERIC_WRAPPER GIOCondition T_G_TYPE_IO_CONDITION GMainContext* T_G_MAIN_CONTEXT GMainLoop* T_G_MAIN_LOOP GPerlFilename T_GPERL_FILENAME GPerlFilename_const T_GPERL_FILENAME GPerlFilename_own T_GPERL_FILENAME_OWN GPerlFilename_ornull T_GPERL_FILENAME_ORNULL GOptionContext * T_GPERL_GENERIC_WRAPPER GOptionContext_own * T_GPERL_GENERIC_WRAPPER GOptionGroup * T_GPERL_GENERIC_WRAPPER GOptionGroup_own * T_GPERL_GENERIC_WRAPPER GUserDirectory T_GPERL_GENERIC_WRAPPER GVariant * T_GPERL_GENERIC_WRAPPER const GVariant * T_GPERL_GENERIC_WRAPPER GVariant_noinc * T_GPERL_GENERIC_WRAPPER GVariantType * T_GPERL_GENERIC_WRAPPER const GVariantType * T_GPERL_GENERIC_WRAPPER GVariantType_own * T_GPERL_GENERIC_WRAPPER GBytes * T_GPERL_GENERIC_WRAPPER GBytes_own * T_GPERL_GENERIC_WRAPPER ############################################################################### INPUT # a general-purpose typemap... strips any trailing star and/or leading "const", # leaving only the type name in the form SvMyType. this allows you to make a # typedef such as "typedef MyType MyType_ornull", and SvMyType_ornull will be # called for those. T_GPERL_GENERIC_WRAPPER $var = Sv${(my $ntype = $type) =~ s/(?:const\s+)?([:\w]+)(?:\s*\*)$/$1/x; \$ntype} ($arg); T_GINT64 $var = SvGInt64 ($arg); T_GUINT64 $var = SvGUInt64 ($arg); T_GUNICHAR $var = g_utf8_get_char (SvGChar ($arg)); T_GCHAR /* same as SvGChar(), but not in a function */ sv_utf8_upgrade ($arg); $var = ($type)SvPV_nolen ($arg); T_GCHAR_ORNULL /* same as SvGChar(), but allows undef as NULL */ if (gperl_sv_is_defined ($arg)) { sv_utf8_upgrade ($arg); $var = ($type)SvPV_nolen ($arg); } else { $var = NULL; } T_GCHAR_LEN sv_utf8_upgrade ($arg); $var = ($type)SvPV ($arg, STRLEN_length_of_$var); XSauto_length_of_$var = STRLEN_length_of_$var; T_GCHAR_UTF8_LEN sv_utf8_upgrade ($arg); $var = ($type)SvPV ($arg, STRLEN_length_of_$var); XSauto_length_of_$var = g_utf8_strlen ($var, STRLEN_length_of_$var); T_GUCHAR $var = ($type)SvPV_nolen ($arg); T_CHAR_ORNULL if (gperl_sv_is_defined ($arg)) { $var = ($type)SvPV_nolen ($arg); } else { $var = NULL; } T_CHAR_BYTE $var = ($type)SvPVbyte_nolen ($arg); T_CHAR_BYTE_ORNULL if (gperl_sv_is_defined ($arg)) { $var = ($type)SvPVbyte_nolen ($arg); } else { $var = NULL; } T_G_TYPE_IO_CONDITION $var = gperl_convert_flags (G_TYPE_IO_CONDITION, $arg); T_G_MAIN_CONTEXT if (!gperl_sv_is_ref ($arg)) { $var = NULL; } else { $var = INT2PTR ($type, SvIV (SvRV ($arg))); } T_G_MAIN_LOOP $var = INT2PTR ($type, SvIV (SvRV ($arg))) T_GPERL_FILENAME $var = ($type) gperl_filename_from_sv ($arg) T_GPERL_FILENAME_ORNULL $var = ($type) (gperl_sv_is_defined ($arg) ? gperl_filename_from_sv ($arg) : NULL) ############################################################################### OUTPUT T_GPERL_GENERIC_WRAPPER $arg = newSV${(my $ntype = $type) =~ s/(?:const\s+)?([:\w]+)(?:\s*\*)$/$1/; \$ntype} ($var); T_GINT64 $arg = newSVGInt64 ($var); T_GUINT64 $arg = newSVGUInt64 ($var); T_GUNICHAR { gchar temp[6]; gint length = g_unichar_to_utf8 ($var, temp); sv_setpvn ((SV*)$arg, temp, length); SvUTF8_on ($arg); } T_GCHAR /* same as newSVGChar(), but not in a function */ sv_setpv ((SV*)$arg, $var); SvUTF8_on ($arg); T_GCHAR_ORNULL /* newSVGChar() allows NULL, but T_GCHAR does not. allow NULL. */ if ($var) { sv_setpv ((SV*)$arg, $var); SvUTF8_on ($arg); } else { SvSetSV ($arg, &PL_sv_undef); } T_GCHAR_OWN /* used when we can directly own the returned string. */ /* we have to copy in the case when perl's malloc != gtk's malloc, * so best copy all the time. */ sv_setpv ((SV*)$arg, $var); SvUTF8_on ($arg); g_free ($var); T_GCHAR_OWN_ORNULL if ($var) { sv_setpv ((SV*)$arg, $var); SvUTF8_on ($arg); g_free ($var); } else { SvSetSV ($arg, &PL_sv_undef); } T_CHAR_ORNULL if ($var) { sv_setpv ((SV*)$arg, $var); } else { SvSetSV ($arg, &PL_sv_undef); } T_CHAR_OWN_ORNULL if ($var) { sv_setpv ((SV*)$arg, $var); g_free ($var); } else { SvSetSV ($arg, &PL_sv_undef); } T_GUCHAR sv_setpv ((SV*)$arg, (char*)$var); T_CHAR_OWN sv_setpv ((SV*)$arg, $var); g_free ($var); T_G_TYPE_IO_CONDITION $arg = gperl_convert_back_flags (G_TYPE_IO_CONDITION, $var); T_G_MAIN_CONTEXT sv_setref_pv ($arg, \"Glib::MainContext\", $var); g_main_context_ref ($var); T_G_MAIN_LOOP sv_setref_pv ($arg, \"Glib::MainLoop\", $var); g_main_loop_ref ($var); T_GPERL_FILENAME sv_setsv ($arg, sv_2mortal (gperl_sv_from_filename ($var))); T_GPERL_FILENAME_OWN sv_setsv ($arg, sv_2mortal (gperl_sv_from_filename ($var))); g_free ($var); Glib-1.320/xsapi.pod.foot000644 001750 000024 00000002027 11701512040 016255 0ustar00bdmanningstaff000000 000000 =head1 SEE ALSO perlapi(1), perlguts(1), GLib Reference Manual, Glib(3pm), Glib::devel(3pm). =head1 AUTHORS This file was automatically generated from the source code of the Glib module, which is maintained by the gtk2-perl team. =head1 LICENSE Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. =cut Glib-1.320/xsapi.pod.head000644 001750 000024 00000000776 11664366512 016243 0ustar00bdmanningstaff000000 000000 =head1 NAME Glib::xsapi - internal API reference for GPerl. =head1 SYNOPSIS #include =head1 DESCRIPTION This is the binding developer's API reference for GPerl, automatically generated from the xs source files. This header defines the public interface for use when creating new Perl language bindings for GLib-based C libraries. gperl.h includes for you all the headers needed for writing XSUBs (EXTERN.h, perl.h, and XSUB.h), as well as all of GLib (via glib-object.h). =head1 API =cut Glib-1.320/t/1.t000644 001750 000024 00000006377 11701512040 014263 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # $Id$ # # Basic test for Glib fundamentals. make sure that the smoke does't get out, # and test most of the procedural things in Glib's toplevel namespace. use strict; use warnings; # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### use Test::More tests => 26; BEGIN { use_ok('Glib') }; ######################### ok (defined (Glib::major_version), 'major_version'); ok (defined (Glib::minor_version), 'minor_version'); ok (defined (Glib::micro_version), 'micro_version'); ok (Glib->CHECK_VERSION(0,0,0), 'CHECK_VERSION pass'); ok (!Glib->CHECK_VERSION(50,0,0), 'CHECK_VERSION fail'); my @version = Glib->GET_VERSION_INFO; print "Glib was compiled for glib version ".join(".",@version)."\n"; is (scalar (@version), 3, 'version info list is 3 items long'); is (Glib::MAJOR_VERSION, $version[0], 'MAJOR_VERSION'); is (Glib::MINOR_VERSION, $version[1], 'MINOR_VERSION'); is (Glib::MICRO_VERSION, $version[2], 'MICRO_VERSION'); ok (defined (Glib::get_user_name), "Glib::get_user_name"); ok (defined (Glib::get_real_name), "Glib::get_real_name"); ok (defined (Glib::get_home_dir), "Glib::get_home_dir"); ok (defined (Glib::get_tmp_dir), "Glib::get_tmp_dir"); SKIP: { skip "set_application_name is new in glib 2.2.0", 2 unless Glib->CHECK_VERSION (2,2,0); SKIP: { skip 'no undef on win32', 1 if $^O eq 'MSWin32'; # this will not hold after Gtk2::init, since gtk_init() calls # gdk_parse_args() which calls g_set_prgname(argv[0]). is (Glib::get_application_name (), undef, 'before any calls to anything'); } my $appname = 'Flurble Foo 2, Electric Boogaloo'; Glib::set_application_name ($appname); is (Glib::get_application_name (), $appname); } SKIP: { skip "new 2.6 stuff", 6 unless Glib->CHECK_VERSION (2,6,0); ok (defined Glib::get_user_data_dir ()); ok (defined Glib::get_user_config_dir ()); ok (defined Glib::get_user_cache_dir ()); ok (defined Glib::get_system_data_dirs ()); ok (defined Glib::get_system_config_dirs ()); ok (defined Glib::get_language_names ()); } SKIP: { skip 'new 2.14 stuff', 1 unless Glib->CHECK_VERSION (2, 14, 0); # qw/desktop documents download music pictures public-share templates videos/ ok (defined Glib::get_user_special_dir ('desktop')); } is (Glib::Markup::escape_text (""), "<gtk2-perl>"); ok (defined Glib::strerror (2)); ok (defined Glib::strsignal (11)); __END__ Copyright (C) 2003-2005 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/2.t000644 001750 000024 00000004264 11701512040 014255 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # $Id$ # # Really simple smoke tests for Glib::Object wrappers. # use strict; use warnings; # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 2.t' ######################### use Test::More tests => 10; BEGIN { use_ok('Glib'); Glib::Object->set_threadsafe (1); }; ######################### my $obj = Glib::Object->new; isa_ok ($obj, 'Glib::Object'); $obj->freeze_notify; $obj->thaw_notify; undef $obj; ok(1); # portability tests -- we should be able to pass pointers through UVs # with the get_data/set_data mechanism. (gtk uses this in a few places.) # we also test the new_from_pointer and get_pointer methods, and ensure # that the magical hash wrappers work correctly, all in one convoluted # test. $obj = Glib::Object->new; isa_ok ($obj, 'Glib::Object'); my $obj2 = Glib::Object->new; isa_ok ($obj, 'Glib::Object'); $obj2->{key} = 'val'; $obj->set_data (obj2 => $obj2->get_pointer); my $obj3_pointer = $obj->get_data ('obj2'); ok ($obj3_pointer); my $obj3 = Glib::Object->new_from_pointer ($obj3_pointer); isa_ok ($obj3, 'Glib::Object'); is ($obj3, $obj2); is ($obj3->{key}, $obj2->{key}); # regression tests # make sure calling a Glib::Object method on something invalid results in an # error message, not in a segmentation fault eval { Glib::Object->get (123); }; like ($@, qr/is not of type Glib::Object/); __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/3.t000644 001750 000024 00000003173 11701512040 014254 0ustar00bdmanningstaff000000 000000 # # check Glib::Object derivation -- make sure that INIT_INSTANCE and # FINALIZE_INSTANCE are called in the right order, and that objects # actually go away. since we're testing execution order, we don't # use a Test module. # print "1..6\n"; use strict; use warnings; use Glib; print "ok 1\n"; # this will set @ISA for Foo, and register the type. # note that if you aren't going to add properties, signals, or # virtual overrides, there's no reason to do this rather than # just re-blessing the object, so this is a rather contrived # example. my ($ok1, $ok2); sub Foo::INIT_INSTANCE { print "ok $ok1\n"; } sub Foo::FINALIZE_INSTANCE { print "ok $ok2\n"; } Glib::Type->register (Glib::Object::, Foo::); { $ok1 = 2; my $bar = new Foo; $ok2 = 3; undef $bar; $ok1 = 4; $bar = new Foo; $ok2 = 5; } print "ok 6\n"; $ok1 = $ok2 = -1; __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/4.t000644 001750 000024 00000007341 11701512040 014256 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # test Glib::Object derivation in Perl. # derive from a C object in perl, and derive from a Perl object in perl. # checks order of execution of initializers and finalizers, so the code # gets a little hairy. # use strict; use warnings; use Glib qw(:constants); # From 7.t. Do we need a test helper class? sub ok($$;$) { my($test, $num, $name) = @_; my $out = $test ? "ok" : "not ok"; $out .= " $num" if $num; $out .= " - $name" if defined $name; print "$out\n"; return $test; } sub pass($;$) { my($num, $name) = @_; return ok(1, $num, $name); } sub fail(;$) { my($name) = @_; return ok(0, 0, $name); } print "1..17\n"; pass 1; my $init_self; sub Foo::INIT_INSTANCE { $init_self = $_[0]*1; pass 2, 'Foo::INIT_INSTANCE'; } sub Foo::FINALIZE_INSTANCE { pass 9, 'Foo::FINALIZE_INSTANCE' } my $setprop_self; sub Foo::SET_PROPERTY { $setprop_self = $_[0]*1; pass $_[2], 'Foo::SET_PROPERTY'; } sub Foo::GET_PROPERTY { pass 6, 'Foo::GET_PROPERTY'; 6; } Glib::Type->register ( Glib::Object::, Foo::, properties => [ Glib::ParamSpec->string ( 'some_string', 'Some String Property', 'This property is a string that is used as an example', 'default value', [qw/readable writable/] ), ]); sub Bar::INIT_INSTANCE { pass 3, 'Bar::INIT_INSTANCE'; } sub Bar::FINALIZE_INSTANCE { pass 8, 'Bar::FINALIZE_INSTANCE'; } Glib::Type->register (Foo::, Bar::, properties => [ Glib::ParamSpec->int ('number', 'some number', 'number in bar but not in foo', 0, 10, 0, ['readable']), ]); { # instantiate a child. we should get messages from both initializers. my $bar = new Bar; # make sure we can set parent properties on the child $bar->set(some_string => 4); ok $init_self == $setprop_self, 5; ok $bar->get("some_string") == 6, 7; # should see messages from both finalizers here. } pass 10; # # ensure that any properties added to the subclass were only added to # the subclass, and not the parent. # ok defined Foo->find_property('some_string'), 11; ok !defined Foo->find_property('number'), 12; ok defined Bar->find_property('number'), 13; my @fooprops = Foo->list_properties; my @barprops = Bar->list_properties; ok @fooprops == 1, 14, 'property count for parent'; ok @barprops == 2, 15, 'property count for child'; my @ancestry = Glib::Type->list_ancestors ('Bar'); my $ancestry_ok = $ancestry[0] eq 'Bar' && $ancestry[1] eq 'Foo' && $ancestry[2] eq 'Glib::Object'; print "".($ancestry_ok ? "ok 16" : "not ok")." - ancestry for Bar\n"; my $cname_ok = Glib::Type->package_from_cname ('GObject') eq 'Glib::Object'; print "".($cname_ok ? "ok 17" : "not ok")." - package_from_cname\n"; __END__ Copyright (C) 2003-2006 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/5.t000644 001750 000024 00000006215 11701512040 014256 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # sanity-checking on the property interface. some of this could have gone # into 4.t, but it is here to keep these tests small and digestable since # they have freaky, spaghetti-like testing code. # use strict; use warnings; use Test::More; # for eq_array print "1..10\n"; use Glib; print "ok 1\n"; package MyClass; use Glib::Object::Subclass Glib::Object::, signals => { something_changed => { flags => [qw(run-first)], return_type => undef, param_types => [], }, }, properties => [ Glib::ParamSpec->string ( 'some_string', 'Some String Property', 'This property is a string that is used as an example', 'default value', [qw/readable writable/] ), ]; sub INIT_INSTANCE { print "ok 2\n"; } sub FINALIZE_INSTANCE { print "ok 9\n"; } sub grow_the_stack { 1 .. 500; } sub GET_PROPERTY { # grow the stack to trigger reallocation and movement of it in order to test # that Glib::Object->get handles the stack correctly my @list = grow_the_stack(); 77; } package main; { my $my = new MyClass; $my->set(some_string => "xyz"); print $my->{some_string} eq "xyz" ? "" : "not ", "ok 3\n"; print $my->get("some_string") == 77 ? "" : "not ", "ok 4\n"; # verify that invalid property names result in an exception. # there are two places to test this, new() and set(). eval { $my = new MyClass some_string => "foo", invalid_param => 1, some_string => "bar"; print "not ok - should not get here\n"; }; #print "\$@ = '$@'\n"; print ($@ !~ /does not support property/ ? "not " : "", "ok 5\n"); eval { $my->set (some_string => "foo", invalid_param => 1, some_string => "bar"); print "not ok - should not get here\n"; }; #print "\$@ = '$@'\n"; print ($@ !~ /does not support property/ ? "not " : "", "ok 6\n"); # set should have bailed out before setting some_string to bar. # cannot use get() here, because GET_PROPERTY always returns 77. print $my->{some_string} ne 'foo' ? "not " : "", "ok 7\n"; # verify that fetching multiple properties doesn't corrupt the stack. print eq_array([$my->get("some_string", "some_string")], [77, 77]) ? "" : "not ", "ok 8\n"; } print "ok 10\n"; __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/6.t000644 001750 000024 00000007475 11664366512 014313 0ustar00bdmanningstaff000000 000000 #!perl # # more derivation testing, ensuring that signals are inherited properly. # use strict; use warnings; use Glib; use vars qw/@one_base_ok @one_inst_ok @two_base_ok @two_inst_ok @three_base_ok @three_inst_ok @four_base_ok @four_inst_ok @member_ok @signal_ok/; # this looks a little hairy because i want to make sure that we test the # order of operations. the begin block at the top defines a few named # arrays of sequence numbers. the ok() function takes a string with the # the name of the array (minus the _ok) from which to shift the next # sequence number. this way we can change the order rather simply as we # modify the test, and allow each callback to be run more than once. BEGIN { print "1..31\n"; @one_base_ok = (1,3,5); @one_inst_ok = (8,11,12,14); @two_base_ok = (2,6); @two_inst_ok = (9,13); @three_base_ok = (4); @three_inst_ok = (15); @four_base_ok = (7); @four_inst_ok = (10); @member_ok = (16..23); @signal_ok = (24..31); } sub ok { no strict 'refs'; my $condition = shift; my $ary = \@{"$_[0]\_ok"}; my $seq = $ary->[0]; shift @$ary; print "".($condition ? "ok" : "not ok")." $seq - $_[0]\n"; } sub readwrite { [qw/readable writable/] } sub makeparam { my $name = shift; Glib::ParamSpec->string ($name, $name, $name, '', [qw/readable writable/]); } # # define several classes that form a hierarchy, deriving from one another. # package One; use Glib::Object::Subclass Glib::Object::, signals => { one => {} }, properties => [ ::makeparam('one'), ], ; sub INIT_BASE { ::ok(1, 'one_base'); } sub INIT_INSTANCE { $_[0]{one} = 'one'; ::ok(1, 'one_inst'); } sub one { shift->signal_emit ('one', @_); } package Two; sub INIT_BASE { ::ok(1, 'two_base'); } use Glib::Object::Subclass One::, signals => { two => {} }, properties => [ ::makeparam ('two'), ], ; sub INIT_INSTANCE { $_[0]{two} = 'two'; ::ok(1, 'two_inst'); } sub two { shift->signal_emit ('two', @_); } package Three; sub INIT_BASE { ::ok(1, 'three_base'); } use Glib::Object::Subclass One::, signals => { three => {} }, properties => [ ::makeparam ('three'), ], ; sub INIT_INSTANCE { $_[0]{three} = 'three'; ::ok(1, 'three_inst'); } sub three { shift->signal_emit ('three', @_); } package Four; sub INIT_BASE { ::ok(1, 'four_base'); } use Glib::Object::Subclass Two::, signals => { four => {} }, properties => [ ::makeparam ('four'), ], ; sub INIT_INSTANCE { $_[0]{four} = 'four'; ::ok(1, 'four_inst'); } sub four { shift->signal_emit ('four', @_); } package main; my $four = Four->new; my $one = One->new; my $two = Two->new; my $three = Three->new; # # the INIT_INSTANCE for each class should've run appropriately. let's # verify that by testing that each instance variable contains what we # think it should contain. # ok( $one->{one} eq 'one', 'member' ); ok( $two->{one} eq 'one', 'member' ); ok( $three->{one} eq 'one', 'member' ); ok( $four->{one} eq 'one', 'member' ); ok( $two->{two} eq 'two', 'member' ); ok( $four->{two} eq 'two', 'member' ); ok( $three->{three} eq 'three', 'member' ); ok( $four->{four} eq 'four', 'member' ); # # we'll get complaints from GLib if we try to connect to non-existent # signals. this verifies that signals we create for one type are # still valid for derivatives of that type. # sub do_ok { ok (1, 'signal'); } $one->signal_connect (one => \&do_ok); $two->signal_connect (one => \&do_ok); $three->signal_connect (one => \&do_ok); $four->signal_connect (one => \&do_ok); $two->signal_connect (two => \&do_ok); $four->signal_connect (two => \&do_ok); $three->signal_connect (three => \&do_ok); $four->signal_connect (four => \&do_ok); $one->one; $two->one; $three->one; $four->one; $two->two; $four->two; $three->three; $four->four; Glib-1.320/t/64bit.t000644 001750 000024 00000002641 11664366512 015064 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # Test the various things that deal with 64 bit integers. # use strict; use warnings; use Glib; use Test::More tests => 12; use constant { MIN_INT64 => "-9223372036854775807", MAX_INT64 => "9223372036854775807", MIN_UINT64 => "0", MAX_UINT64 => "18446744073709551615" }; my $spec_int64 = Glib::ParamSpec -> int64("int64", "Int", "Blurb", MIN_INT64, MAX_INT64, 0, [qw/readable writable/]); isa_ok($spec_int64, "Glib::Param::Int64"); is($spec_int64 -> get_minimum(), MIN_INT64); is($spec_int64 -> get_maximum(), MAX_INT64); is($spec_int64 -> get_default_value(), 0); my $spec_uint64 = Glib::ParamSpec -> uint64("uint64", "UInt", "Blurb", MIN_UINT64, MAX_UINT64, 0, [qw/readable writable/]); isa_ok($spec_uint64, "Glib::Param::UInt64"); is($spec_uint64 -> get_minimum(), MIN_UINT64); is($spec_uint64 -> get_maximum(), MAX_UINT64); is($spec_uint64 -> get_default_value(), 0); Glib::Type -> register_object( 'Glib::Object' => 'Foo', properties => [ $spec_int64, $spec_uint64 ] ); my $foo = Foo -> new(); $foo -> set(int64 => MIN_INT64); is($foo -> get("int64"), MIN_INT64); $foo -> set(int64 => MAX_INT64); is($foo -> get("int64"), MAX_INT64); $foo -> set(uint64 => MIN_UINT64); is($foo -> get("uint64"), MIN_UINT64); $foo -> set(uint64 => MAX_UINT64); is($foo -> get("uint64"), MAX_UINT64); Glib-1.320/t/7.t000644 001750 000024 00000023663 12251766676 014321 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl use strict; use warnings; =comment test some GSignal stuff - marshaling, exception trapping, order of operations. based on the Glib::Object::Subclass, since it already worked, but not in that test because it would confound too many issues. we do not use Test::More or even Test::Simple because we need to test order of execution... the ok() funcs from those modules assume you are doing all your tests in order, but our stuff will jump around. my apologies for the extreme density and ugliness of this code. =cut use Test::More import => ['diag']; print "1..36\n"; sub ok($$;$) { my($test, $num, $name) = @_; my $out = $test ? "ok" : "not ok"; $out .= " $num" if $num; $out .= " - $name" if defined $name; print "$out\n"; return $test; } sub pass($;$) { my($num, $name) = @_; return ok(1, $num, $name); } sub fail(;$) { my($name) = @_; return ok(0, 0, $name); } use Glib; pass(1, 'Glib compiled'); package MyClass; use Glib::Object::Subclass Glib::Object::, signals => { # a simple void-void signal something_changed => { class_closure => undef, # disable the class closure flags => [qw/run-last action/], return_type => undef, param_types => [], }, # test the marshaling of parameters test_marshaler => { flags => 'run-last', param_types => [qw/Glib::String Glib::Boolean Glib::Uint Glib::Object/], }, # one that returns a value returner => { flags => 'run-last', return_type => 'Glib::Double', # using the default accumulator, which just returns the last # value }, # more complicated/sophisticated value returner list_returner => { class_closure => sub { ::pass(32, "hello from the class closure"); -1 }, flags => 'run-last', return_type => 'Glib::Scalar', accumulator => sub { my ($ihint, $return_accu, $handler_return) = @_; # let's turn the return_accu into a list of all the handlers' # return values. this is weird, but the sort of thing you # might actually want to do. print "# in accumulator, got $handler_return, previously " . (defined ($return_accu) ? $return_accu : 'undef') . "\n"; if ('ARRAY' eq ref $return_accu) { push @{$return_accu}, $handler_return; } else { $return_accu = [$handler_return]; } # we must return two values --- a boolean that says whether # the signal keeps emitting, and the accumulated return value. # we'll stop emitting if the handler returns the magic # value 42. ($handler_return != 42, $return_accu) }, }, }, ; sub do_test_marshaler { print "# \$@ $@\n"; print "# do_test_marshaller: @_\n"; return 2.718; } sub do_emit { my $name = shift; print "\n\n".("="x79)."\n"; print "emitting: $name" . (__PACKAGE__->can ("do_$name") ? " (closure exists)" : "") . "\n"; my $ret = shift->signal_emit ($name, @_); #use Data::Dumper; #print Dumper( $ret ); print "\n".("-"x79)."\n"; return $ret; } sub do_returner { ::pass(24); -1.5; } sub something_changed { do_emit 'something_changed', @_ } sub test_marshaler { do_emit 'test_marshaler', @_ } sub list_returner { do_emit 'list_returner', @_ } sub returner { do_emit 'returner', @_ } ############# package main; my $a = 0; my $b = 0; sub func_a { ok(0==$a++, 4, "func_a"); } sub func_b { if (0==$b++) { pass(5, "func_b"); $_[0]->signal_handlers_disconnect_by_func (\&func_a); } else { pass(7, "func_b again"); } $_[0]->signal_stop_emission_by_name("something_changed"); } { my $my = new MyClass; pass(2, "instantiated MyClass"); $my->signal_connect (something_changed => \&func_a); my $id_b = $my->signal_connect (something_changed => \&func_b); pass(3, "connected handlers"); $my->something_changed; pass(6); $my->something_changed; pass(8); $my->signal_handler_block ($id_b); $my->signal_handler_unblock ($id_b); ok($my->signal_handler_is_connected ($id_b), 9); $my->signal_handler_disconnect ($id_b); $my->something_changed; # attempting to marshal the wrong number of params should croak. # this is part of the emission process going wrong, not a handler, # so it's a bug in the calling code, and thus we shouldn't eat it. eval { $my->test_marshaler (); }; ok( $@ =~ m/Incorrect number/, 10, "signal_emit barfs on bad input" ); $my->test_marshaler (qw/foo bar 15/, $my); pass(11); my $id = $my->signal_connect (test_marshaler => sub { ok( $_[0] == $my && $_[1] eq 'foo' && $_[2] && # string bar is true $_[3] == 15 && # expect an int $_[4] == $my && # object passes unmolested $_[5][1] eq 'two' # user-data is an array ref , 13, "marshalling" ); return 77.1; }, [qw/one two/, 3.1415]); ok($id, 12); $my->test_marshaler (qw/foo bar/, 15, $my); pass(14); $my->signal_handler_disconnect ($id); # here's a signal handler that has an exception. # we should be able to emit the signal all we like without catching # exceptions here, because we don't care what other people may have # connected to the signal. the signal's exception can be caught with # an installed exception handler. $id = $my->signal_connect (test_marshaler => sub { # signal handlers are always eval'd, so # $@ should be empty. warn "internal problem: \$@ is not empty in " . "signal handler!!!" if $@; die "ouch" }); my $tag; $tag = Glib->install_exception_handler (sub { ok( $tag, 16, "exception_handler" ); 0 # returning FALSE uninstalls }, [qw/foo bar/, 0]); ok($tag, 15, "installed exception handler"); # the exception in the signal handler should not affect the value of # $@ at this code layer. $@ = 'neener neener neener'; print "# before invocation: \$@ $@\n"; $my->test_marshaler (qw/foo bar/, 4154, $my); print "# after invocation: \$@ $@\n"; pass(17, "still alive after an exception in a callback"); ok($@ eq 'neener neener neener', 18, "$@ is preserved across signals") || diag "# expected 'neener neener neener'\n", " # got '$@'"; $tag = 0; # that was a single-shot -- the exception handler shouldn't run again. { local $SIG{__WARN__} = sub { if ($_[0] =~ m/unhandled/m) { pass(20, "unhandled exception just warns"); } elsif ($_[0] =~ m/isn't numeric/m) { pass(19, "string value isn't numeric"); } else { fail("got something unexpected in __WARN__: $_[0]\n"); } }; $my->test_marshaler (qw/foo bar baz/, $my); pass(21); } use Data::Dumper; $my->signal_connect (returner => sub { pass(23); 0.5 }); # the class closure should be called in between these two $my->signal_connect_after (returner => sub { pass(25); 42.0 }); pass(22); my $ret = $my->returner; # we should have the return value from the last handler ok( $ret == 42.0, 26 ) || diag("expected 42.0, got $ret"); # now with our special accumulator $my->signal_connect (list_returner => sub { pass(28); 10 }); $my->signal_connect (list_returner => sub { pass(29); '15' }); $my->signal_connect (list_returner => sub { pass(30); [20] }); $my->signal_connect (list_returner => sub { pass(31); {thing => 25} }); # class closure should before the "connect_after" ones, # and this one will stop everything by returning the magic value. $my->signal_connect_after (list_returner => sub { pass(33, "stopper"); 42 }); # if this one is called, the accumulator isn't working right $my->signal_connect_after (list_returner => sub { fail("shouldn't get here"); 0 }); pass(27); print Dumper( $my->list_returner ); # Check that a signal_connect() of a non-existant signal name doesn't # leak the subr passed to it, ie. doesn't keep it alive forever. # # Note $subr has to use $x or similar in its containing environment to be # a closure. If not then it's treated as part of the mainline code and # won't be gc'ed immediately -- or something like that. { my $x = 123; my $subr = sub { return $x }; # handler to suppress the warning message from nosuchsignal my $logid = Glib::Log->set_handler ('GLib-GObject', ['warning'], sub { }); my $sigid = $my->signal_connect ('nosuchsignal' => $subr); Glib::Log->remove_handler ('GLib-GObject', $logid); ok(! $sigid, 34, "'nosuchsignal' not connected"); require Scalar::Util; Scalar::Util::weaken ($subr); ok(! defined $subr, 35, "subr gc'ed after bad signal name"); } } pass(36); __END__ Copyright (C) 2003, 2009 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/8.t000644 001750 000024 00000006044 11701512040 014261 0ustar00bdmanningstaff000000 000000 #!env perl -w # # more tests for exception handling. # use strict; use warnings; use Test::More tests => 33; BEGIN { use_ok 'Glib'; } package MyClass; use Glib::Object::Subclass Glib::Object::, signals => { first => {}, second => {}, }, ; sub first { $_[0]->signal_emit ('first'); } sub second { $_[0]->signal_emit ('second'); } ############ package main; # keep stderr quiet, redirect it to stdout... $SIG{__WARN__} = sub { print $_[0]; }; my $tag = Glib->install_exception_handler (sub { $_[0] =~ s/\n/\\n/g; ok (1, "trapped exception '$_[0]'"); # this should be ignored, too, and should NOT create an # infinite loop. die "oh crap, another exception!\nthis one has multiple lines!\nappend something"; 1 }); ok( $tag, 'installed exception handler' ); ok( Glib->install_exception_handler (sub { if ($_[0] =~ /ouch/) { ok (1, 'saw ouch, uninstalling'); return 0; } else { ok (0, 'additional handler still installed'); return 1; } }), 'installed an additional handler' ); { my $my = new MyClass; $my->signal_connect (first => sub { ok (1, 'in first handler, calling second'); $_[0]->second; ok (1, "handler may die, but we shouldn't"); }); $my->signal_connect (second => sub { ok (!$@, "signal handlers are eval'd so \$@ should always be empty"); ok (1, "in second handler, dying with 'ouch\\n'"); die "ouch\n"; ok (0, "should NEVER get here"); }); $_ = $my; ok (1, 'calling second'); $my->second; ok (1, "handler may die, but we shouldn't be affected"); is ($_, $my, 'we should not clobber $_'); $_ = undef; # expect identical behavior in eval context eval { ok (1, 'calling second in eval'); $my->second; ok (1, "handler may die, but we shouldn't be affected"); }; is ($@, "", "exception should be cleared already"); # super double gonzo... ok (1, "calling first"); $my->first; ok (1, "after eval"); print " # calling first out of eval - should not result in crash\n"; $my->first; # more exception trapping behavior tests $@ = undef; $my->second; is ($@, undef, 'exception value should remain unchanged'); $@ = 'neener'; $my->first; is ($@, 'neener', 'exception value should remain unchanged'); } __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/9.t000644 001750 000024 00000017446 12446204427 014310 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # mainloop stuff. # use strict; use warnings; use Config; print "1..30\n"; use Glib qw/:constants/; my $have_fork = 0; my $fork_excuse; { my $pid = fork(); if (! defined $pid) { $fork_excuse = "error $!"; } elsif ($pid == 0) { # child exit (0); } elsif ($pid < 0) { # parent, perlfork $fork_excuse = "perlfork fakery"; waitpid ($pid, 0); } else { # parent, real fork $have_fork = 1; waitpid ($pid, 0); } } print "ok 1\n"; =out GPerlClosures are used for Timeouts, Idle and IO watch handlers in addition to GSignal stuff. =cut my $timeout = undef; print "ok 2\n"; Glib::Idle->add (sub {print "ok 4 - idle one-shot\n"; 0}); Glib::Idle->add (sub { print "ok 5 - another idle, but this one dies\n"; die "killer"; print "not ok - after die, shouldn't get here!\n"; 1 # return true from idle to be called again; we # should never get here, though }); $timeout = Glib::Timeout->add (1000, sub { warn "!!!! should never get called"; die "oops" }); # timeouts and idles only get executed when there's a mainloop. { my $loop = Glib::MainLoop->new; # the die will simply jump to the eval, leaving side effects in place. # we have to kill the mainloop ourselves. local $SIG{__DIE__} = sub { print "ok 6 - in __DIE__ handler\n"; $loop->quit; }; local $SIG{__WARN__} = sub { print "" . ($_[0] =~ /unhandled exception in callback/ ? "ok 7" : "not ok - got something unexpected in __WARN__" ) . "\n"; }; print "ok 3 - running in eval\n"; $loop->run; # remove this timeout to avoid confusing the next test. Glib::Source->remove ($timeout); } # again, without dying in an idle this time print "ok 8\n"; Glib::Timeout->add (100, sub { print "ok 10 - dying with 'waugh'\n"; die "waugh" }); my $loop = Glib::MainLoop->new; print "ok 9 - running in eval\n"; Glib->install_exception_handler (sub { print "ok 11 - killing loop from exception handler\n"; $loop->quit; 0}); $loop->run; # this time with IO watchers use Data::Dumper; # There's a bug in glib which prevents io channels from marshalling # properly here. we don't have versioning API in Glib (yet), so # we can't do much but just skip this. if ($Config{archname} =~ m/^(x86_64|mipsel|mips|alpha)/ && (!Glib->CHECK_VERSION (2,2,4))) { print "ok 12 # skip bug in glib\n"; print "ok 13 # skip bug in glib\n"; print "ok 14 # skip bug in glib\n"; } elsif ($^O eq "MSWin32") { print "ok 12 # skip add_watch on win32\n"; print "ok 13 # skip add_watch on win32\n"; print "ok 14 # skip add_watch on win32\n"; } else { print "ok 12\n"; open IN, $0 or die "can't open file\n"; Glib::IO->add_watch (fileno IN, [qw/in err hup nval/], sub { local $/ = undef; #print Dumper(\@_); $_ = ; #print "'$_'"; #print "eof - ".eof ($_[0])."\n"; if (eof $_[0]) { print "ok 14 - eof, dying with 'done\\n'\n"; die "done\n"; } 1; }); $loop = Glib::MainLoop->new; print "ok 13 - running in eval\n"; Glib->install_exception_handler (sub {$loop->quit; 0}); $loop->run; } # 1.072 fixes the long-standing "bug" that perl's safe signal handling # caused asynchronous signals not to be delivered while a main loop is # running (because control stays in C). let's make sure that we can # get a 1 second alarm before a 5 second timeout has a chance to fire. if ($^O eq 'MSWin32') { # XXX Win32 doesn't do SIGALRM the way unix does; either the alarm # doesn't interrupt the poll, or alarm just doesn't work. my $reason = "async signals don't work on win32 like they do on unix"; print "ok 15 # skip $reason\n"; print "ok 16 # skip $reason\n"; } else { $loop = Glib::MainLoop->new; $SIG{ALRM} = sub { print "ok 15 - ALRM handler\n"; $loop->quit; }; my $timeout_fired = 0; Glib::Timeout->add (5000, sub { $timeout_fired++; $loop->quit; 0; }); alarm 1; $loop->run; print "" . ($timeout_fired ? "not ok" : "ok") . " 16 - 1 sec alarm handler fires before 5 sec timeout\n"; } if (Glib->CHECK_VERSION (2, 4, 0)) { print Glib::main_depth() == 0 ? "ok 17\n" : "not ok 17\n"; } else { print "ok 17 # skip main_depth\n"; } print $loop->is_running ? "not ok 18\n" : "ok 18\n"; print Glib::MainContext->new ? "ok 19\n" : "not ok 19\n"; print Glib::MainContext->default ? "ok 20\n" : "not ok 20\n"; print $loop->get_context ? "ok 21\n" : "not ok 21\n"; print Glib::MainContext->new->pending ? "not ok 22\n" : "ok 22\n"; if (Glib->CHECK_VERSION (2, 12, 0)) { print Glib::MainContext->new->is_owner ? "not ok 23\n" : "ok 23\n"; print Glib::MainContext::is_owner(undef) ? "not ok 24\n" : "ok 24\n"; } else { print "ok 23 # skip\n"; print "ok 24 # skip\n"; } if (Glib->CHECK_VERSION (2, 14, 0)) { my $loop = Glib::MainLoop->new; Glib::Timeout->add_seconds (1, sub { print "ok 25 - in timeout handler\n"; $loop->quit; return FALSE; }); $loop->run; } else { print "ok 25 # skip\n"; } { my $skip_reason = undef; if (! $have_fork) { $skip_reason = "no fork: $fork_excuse"; } if (! Glib->CHECK_VERSION (2, 4, 0)) { $skip_reason = 'need glib >= 2.4'; } if ($^O eq 'freebsd' || $^O eq 'netbsd') { if ($Config{ldflags} !~ m/-pthread\b/) { $skip_reason = 'need a perl built with "-pthread" on freebsd/netbsd'; } } if (defined $skip_reason) { print "ok 26 # skip: $skip_reason\n"; print "ok 27 # skip\n"; print "ok 28 # skip\n"; print "ok 29 # skip\n"; print "ok 30 # skip\n"; goto SKIP_CHILD_TESTS; } my $pid = fork(); if (! defined $pid) { die "oops, cannot fork: $!"; } if ($pid == 0) { # child require POSIX; POSIX::_exit(42); # no END etc cleanups } # parent my $loop = Glib::MainLoop->new; my $userdata = [ 'hello' ]; my $id = Glib::Child->watch_add ($pid, sub { die; }, $userdata); require Scalar::Util; Scalar::Util::weaken ($userdata); print '', (defined $userdata ? 'ok' : 'not ok'), " 26 - child userdata kept alive\n"; print '', (Glib::Source->remove($id) ? 'ok' : 'not ok'), " 27 - child source removal\n"; print '', (! defined $userdata ? 'ok' : 'not ok'), " 28 - child userdata now gone\n"; # No test of $status here, yet, since it may be a raw number on ms-dos, # instead of a waitpid() style "code*256". Believe there's no # POSIX::WIFEXITED() etc on dos either to help examining the value. my $timer_id; Glib::Child->watch_add ($pid, sub { my ($pid, $status, $userdata) = @_; print '', ($userdata eq 'hello' ? 'ok' : 'not ok'), " 29 - child callback userdata value\n"; print "ok 30 - child callback\n"; $loop->quit; }, 'hello'); $timer_id = Glib::Timeout->add (30_000, # 30 seconds should be more than enough for child exit sub { die "Oops, child watch callback didn't run\n"; }); $loop->run; Glib::Source->remove ($timer_id); } SKIP_CHILD_TESTS: __END__ Copyright (C) 2003-2005 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/a.t000644 001750 000024 00000014600 11701512040 014327 0ustar00bdmanningstaff000000 000000 #!/usr/bin/env perl # # message logging. # use strict; use warnings; use Data::Dumper; use Test::More; use Glib; use Config; if ($Config{archname} =~ m/^(x86_64|mipsel|mips|alpha)/ and not Glib->CHECK_VERSION (2,2,4)) { # there is a bug in glib which makes g_log print messages twice # on 64-bit x86 platforms. yosh has fixed this on the 2.2.x branch # and in 2.4.0 (actually 2.3.2). plan skip_all => "g_log doubles messages by accident on 64-bit platforms"; } else { plan tests => 30; } package Foo; use Glib::Object::Subclass 'Glib::Object'; package main; $SIG{__WARN__} = sub { chomp (my $msg = $_[0]); ok(1, "in __WARN__: $msg"); }; #$SIG{__DIE__} = sub { ok(1, 'in __DIE__'); }; Glib->message (undef, 'whee message'); Glib->critical (undef, 'whee critical'); Glib->warning (undef, 'whee warning'); my $id = Glib::Log->set_handler (__PACKAGE__, [qw/ error critical warning message info debug /], sub { ok(1, "in custom handler $_[1][0]"); }); Glib->message (__PACKAGE__, 'whee message'); Glib->critical (__PACKAGE__, 'whee critical'); Glib->warning (__PACKAGE__, 'whee warning'); Glib->log (__PACKAGE__, qw/ warning /, 'whee log warning'); Glib::Log->remove_handler (__PACKAGE__, $id); SKIP: { # See . skip 'using multiple log levels breaks g_log on some platforms', 2 if (!Glib->CHECK_VERSION(2, 20, 1) && $Config{archname} =~ /powerpc|amd64|s390/); my $id = Glib::Log->set_handler (undef, [qw/ error critical warning message info debug /], sub { ok(1, "in custom handler $_[1][0]"); }); Glib->log (undef, [qw/ info debug /], 'whee log warning'); Glib::Log->remove_handler (undef, $id); } # i would expect this to call croak, but it actually just aborts. :-( #eval { Glib->error (__PACKAGE__, 'error'); }; Glib::Log::default_handler ('Test-Domain', ['info'], 'ignore this message'); Glib::Log::default_handler ('Test-Domain', ['info'], 'another message to ignore', 'userdata'); SKIP: { skip "new 2.6 stuff", 18 unless Glib->CHECK_VERSION (2,6,0); Glib->log ('An-Unknown-Domain', ['info'], 'this is a test message'); is (Glib::Log->set_default_handler(undef), \&Glib::Log::default_handler, 'default log handler: install undef, prev default'); Glib->log ('An-Unknown-Domain', ['info'], 'this is a test message'); is (Glib::Log->set_default_handler(\&Glib::Log::default_handler), \&Glib::Log::default_handler, 'default log handler: install default, prev default'); Glib->log ('An-Unknown-Domain', ['info'], 'this is another test message'); # anon subs like $sub1 and $sub2 must refer to something like $x in the # environment or they're not gc-ed immediately my $x = 123; my $sub1 = sub { my @args = @_; is (scalar @args, 3, 'sub1 arg count'); is ($args[0], 'An-Unknown-Domain', 'sub1 domain'); isa_ok ($args[1], 'Glib::LogLevelFlags', 'sub1 flags type'); ok ($args[1] == ['info'], 'sub1 flags value'); is ($args[2], 'a message', 'sub1 message'); return $x }; is (Glib::Log->set_default_handler($sub1), \&Glib::Log::default_handler, 'default log handler: install sub1, prev default'); Glib->log ('An-Unknown-Domain', ['info'], 'a message'); my $sub2 = sub { my @args = @_; is (scalar @args, 4, 'sub2 arg count'); is ($args[0], 'Another-Unknown-Domain', 'sub2 domain'); isa_ok ($args[1], 'Glib::LogLevelFlags', 'sub2 flags type'); ok ($args[1] == ['warning'], 'sub2 flags value'); is ($args[2], 'a message', 'sub2 message'); is ($args[3], 'some userdata', 'sub2 userdata'); return $x }; is (Glib::Log->set_default_handler($sub2,'some userdata'), $sub1, 'default log handler: install sub2, prev sub1'); require Scalar::Util; Scalar::Util::weaken ($sub1); is ($sub1, undef, 'sub1 garbage collected by weakening'); Glib->log ('Another-Unknown-Domain', ['warning'], 'a message'); is (Glib::Log->set_default_handler(undef), $sub2, 'default log handler: install undef, prev sub2'); Glib->log ('Another-Unknown-Domain', ['info'], 'this is a test message'); is (Glib::Log->set_default_handler(undef), \&Glib::Log::default_handler, 'default log handler: install undef, prev default'); Glib->log ('Another-Unknown-Domain', ['info'], 'this is yet another a test message'); # test that a custom log handler can safely call the default log handler Glib::Log->set_default_handler(sub { Glib::Log::default_handler (@_); }); Glib->log ('Another-Unknown-Domain', ['info'], 'custom to default test'); Glib::Log->set_default_handler(undef); } # when you try to connect to a non-existant signal, you get a CRITICAL # log message... my $object = Foo->new; { ok(1, 'attempting to connect a non-existant signal'); local $SIG{__WARN__} = sub { ok( $_[0] =~ /nonexistant/, 'should warn' ); }; $object->signal_connect (nonexistant => sub { ok(0, "shouldn't get here") }); delete $SIG{__WARN__}; } ## try that again with a fatal mask #Glib::Log->set_always_fatal (['critical', 'fatal-mask']); #{ #local $SIG{__DIE__} = sub { ok(1, 'should die'); }; #eval { #$object->signal_connect (nonexistant => sub { ok(0, "shouldn't get here") }); #}; #print "$@\n"; #} # Check that messages with % chars make it through unaltered and don't cause # crashes { my $id = Glib::Log->set_handler ( __PACKAGE__, qw/debug/, sub { is($_[2], '%s %d %s', 'a message with % chars'); }); Glib->log (__PACKAGE__, qw/debug/, '%s %d %s'); Glib::Log->remove_handler (__PACKAGE__, $id); } Glib::Log->set_fatal_mask (__PACKAGE__, [qw/ warning message /]); Glib::Log->set_always_fatal ([qw/ info debug /]); __END__ Copyright (C) 2003, 2009 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/b.t000644 001750 000024 00000004557 11701512040 014342 0ustar00bdmanningstaff000000 000000 #!env perl -w # # tied properties. # use strict; use warnings; use Test::More tests => 8; BEGIN { use_ok 'Glib'; } package MyClass; use Glib::Object::Subclass Glib::Object::, properties => [ Glib::ParamSpec->string ( 'some_string', 'Some String Property', 'This is a property string', 'default', [qw/readable writable/], ), Glib::ParamSpec->string ( 'read_string', 'Read String Property', 'This is a read only property string', 'default', [qw/readable/], ), Glib::ParamSpec->scalar ( 'some_scalar', 'Some Scalar Property', 'This property is a scalar that is used as an example', [qw/readable writable/] ), ] ; sub GET_PROPERTY { my ($self, $pspec) = @_; $self->{'__real_'.$pspec->get_name}; } sub SET_PROPERTY { my ($self, $pspec, $newval) = @_; $self->{'__real_'.$pspec->get_name} = $newval; } sub INIT_INSTANCE { my $self = shift; $self->{__real_some_string} = 'one'; $self->{__real_read_string} = 'two'; } ############ package main; my $obj = new MyClass; $obj->tie_properties; ok(1, '$obj->tie_properites'); is ($obj->{some_string}, 'one', '$obj->{some_string} empty'); is ($obj->{read_string}, 'two', '$obj->{read_string} empty'); $obj->{some_string} = 42; eval { $obj->{read_string} = 44; 1; }; ok ($@ =~ /property read_string is read-only/, '$obj->{read_string} read only croak'); is ($obj->{some_string}, 42, '$obj->{some_string} 42'); is ($obj->{read_string}, 'two', '$obj->{read_string} empty'); my $foo = 'hello'; $obj->set(some_scalar => $foo); is ($obj->get("some_scalar"), 'hello', '$obj->{some_scalar} hello'); __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/boxed_errors.t000644 001750 000024 00000001370 11776420676 016635 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # Test the GBoxed wrapper for GError. use strict; use warnings; use Test::More; use Glib ':constants'; if (Glib->CHECK_VERSION (2, 26, 0)) { plan tests => 5; } else { plan skip_all => 'new in 2.26'; } Glib::Type->register_object ( 'Glib::Object', 'Foo', signals => { throw => { param_types => [qw(Glib::Error)], }, }, ); my $foo = Glib::Object::new ('Foo'); $foo->signal_connect (throw => \&throw_handler, 23); $foo->signal_emit ('throw', Glib::File::Error->new ('io', 'End of file reached')); sub throw_handler { my ($instance, $error, $data) = @_; is ($instance, $foo); is ($data, 23); isa_ok ($error, 'Glib::File::Error'); is ($error->value, 'io'); is ($error->message, 'End of file reached'); } Glib-1.320/t/bytes.t000644 001750 000024 00000001734 12636024471 015257 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # Test the GBytes wrappers. # use strict; use warnings; use Glib; use Test::More; unless (Glib -> CHECK_VERSION (2, 32, 0)) { plan skip_all => 'GBytes is new in 2.32'; } else { plan tests => 13; } # Basic API. my $data = pack 'C*', 0..255; my $bytes = Glib::Bytes->new ($data); isa_ok ($bytes, 'Glib::Bytes'); isa_ok ($bytes, 'Glib::Boxed'); is ($bytes->get_size, length $data); is ($bytes->get_data, $data); ok (defined $bytes->hash); ok ($bytes->equal ($bytes)); is ($bytes->compare ($bytes), 0); # Overloading. is ("$bytes", $data, '"" overloading'); ok ($bytes eq $data, 'eq overloading'); is (length $bytes, length $data, 'length overloading'); # Wide characters. eval { my $wstring = "\x{2665}"; my $bytes = Glib::Bytes->new ($wstring); }; like ($@, qr/Wide character/); eval { my $wstring = "\x{2665}"; utf8::encode ($wstring); my $bytes = Glib::Bytes->new ($wstring); is ($bytes->get_data, pack ('C*', 0xE2,0x99,0xA5)); }; is ($@, ''); Glib-1.320/t/c.t000644 001750 000024 00000015373 11701512040 014341 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # vim: set filetype=perl : # # $Id$ # # # enums and flags. # use strict; use warnings; ######################### use Test::More tests => 57; BEGIN { use_ok('Glib') }; ######################### # # Flags basics # my $f = Glib::ParamFlags->new (['readable', 'writable']); # with array isa_ok ($f, 'Glib::Flags'); isa_ok ($f, 'Glib::ParamFlags'); ok ($f == ['readable', 'writable'], "value"); $f = Glib::ParamFlags->new ('readable'); # with plain string isa_ok ($f, 'Glib::Flags'); isa_ok ($f, 'Glib::ParamFlags'); ok ($f == ['readable'], "value"); my $g = Glib::ParamFlags->new ($f + 'writable'); # from another isa_ok ($g, 'Glib::ParamFlags'); ok ($g >= $f); $@ = undef; eval { my $h = Glib::Flags->new (['readable']); }; ok ($@, "Will croak on trying to create plain old Glib::Flags"); { my $f = Glib::ParamFlags->new (['readable']); my $g = $f; $g += 'writable'; ok ($g == ['readable', 'writable'], "overloaded +="); ok ($f == ['readable'], "overloaded += leaves original unchanged"); } foreach my $method (qw(bool as_arrayref eq union sub intersect xor all)) { my $func = Glib::Flags->can($method); ok ($func, "Glib::Flags::$method() func found"); no warnings; ok (do { eval { $func->(undef, undef, 0) }; 1 }, 'Glib::Flags::$method() no segfault if passed a non-reference'); } ######################### $@ = undef; eval { Glib::Type->register_enum ('TestEnum', qw/value-one value-two value-three/, [ 'value-four', 42 ], 'value-five', ['value-six']); 1; }; ok (!$@, 'register_enum'); is_deeply ([Glib::Type->list_ancestors ('TestEnum')], ['TestEnum', 'Glib::Enum']); $@ = undef; eval { Glib::Type->register_flags ('TestFlags', qw/value-one value-two value-three/, [ 'value-four', 1 << 16 ], 'value-five', ['value-six']); 1; }; ok (!$@, 'register_flags'); is_deeply ([Glib::Type->list_ancestors ('TestFlags')], ['TestFlags', 'Glib::Flags']); $@ = undef; eval { Glib::Type->register_enum ('TestEnum1', qw/value-one value-two value-three/, [ 'value-four', 42 ], 'value-five', []); 1; }; ok ($@, 'failed register_enum with empty array ref'); $@ = undef; eval { Glib::Type->register_enum ('TestEnum2', qw/value-one value-two value-three/, [ 'value-four', 42 ], 'value-five', undef); 1; }; ok ($@, 'failed register_enum with undef'); $@ = undef; eval { Glib::Type->register_flags ('TestFlags1', qw/value-one value-two value-three/, [ 'value-four', 1 << 16 ], 'value-five', []); 1; }; ok ($@, 'failed register_flag with empty array ref'); $@ = undef; eval { Glib::Type->register_flags ('TestFlags2', qw/value-one value-two value-three/, [ 'value-four', 1 << 16 ], 'value-five', undef); 1; }; ok ($@, 'failed register_flag with undef'); my @actual_values = Glib::Type->list_values ('TestEnum'); my @expected_values = ( { value => 1, name => 'value-one', nick => 'value-one', }, { value => 2, name => 'value-two', nick => 'value-two', }, { value => 3, name => 'value-three', nick => 'value-three', }, { value => 42, name => 'value-four', nick => 'value-four', }, { value => 5, name => 'value-five', nick => 'value-five', }, { value => 6, name => 'value-six', nick => 'value-six', }, ); is_deeply (\@actual_values, \@expected_values, 'list_interfaces'); package Tester; use Test::More; Glib::Type->register ( Glib::Object::, __PACKAGE__, signals => { sig1 => { class_closure => sub { is ($_[1], 'value-two', 'closure enum'); ok ($_[2]->isa ('TestFlags'), 'closure flags'); }, return_type => undef, param_types => [ 'TestEnum', 'TestFlags' ], }, }, properties => [ Glib::ParamSpec->enum ( 'some_enum', 'Some Enum Property', 'This is a test of a perl created enum', 'TestEnum', 'value-one', [qw/readable writable/], ), Glib::ParamSpec->flags ( 'some_flags', 'Some Flags Property', 'This is a test of a perl created flags', 'TestFlags', [qw/value-one value-five/], [qw/readable writable/], ) ]); sub GET_PROPERTY { $_[0]->{$_[1]->get_name}; } sub SET_PROPERTY { $_[0]->{$_[1]->get_name} = $_[2]; } sub INIT_INSTANCE { my $self = shift; $self->{some_enum} = 'value-one'; $self->{some_flags} = ['value-one']; } sub sig1 { shift->signal_emit ('sig1', @_); } package main; # # App-registered flags. # my $obj = Tester->new; $obj->sig1 ('value-two', ['value-one', 'value-two']); is ($obj->get ('some_enum'), 'value-one', 'enum property'); $obj->set (some_enum => 'value-two'); is ($obj->get ('some_enum'), 'value-two', 'enum property, after set'); is_deeply (\@{ $obj->get ('some_flags') }, ['value-one'], 'flags property'); is_deeply ($obj->get('some_flags')->as_arrayref, ['value-one'], 'flags property'); is (($obj->get('some_flags') ? "true" : "false"), "true", 'flags property, boolean context'); is ($obj->get('some_flags')->bool, 1, 'flags property, bool()'); $obj->set (some_flags => ['value-one', 'value-two']); is_deeply (\@{ $obj->get ('some_flags') }, ['value-one', 'value-two'], 'flags property, after set'); ok ($obj->get ('some_flags') & $obj->get ('some_flags'), '& is overloaded'); eval { $obj->set (some_flags => []); $obj->set (some_flags => undef); }; ok ($@ eq '', 'empty flags values do not croak'); ok ($obj->get ('some_flags') == [], 'empty flags values work'); is_deeply (\@{ $obj->get ('some_flags') }, [], 'empty flags @{}'); is_deeply ($obj->get('some_flags')->as_arrayref, [], 'empty flags, as_arrayref()'); is (($obj->get('some_flags') ? "true" : "false"), "false", 'empty flags, boolean context'); is ($obj->get('some_flags')->bool, 0, 'empty flags, bool()'); $obj->set (some_flags => [qw/value-one value-two/]); ok ($obj->get ('some_flags') == [qw/value-one value-two/], '== is overloaded'); ok ($obj->get ('some_flags') != [qw/value-one/], '!= is overloaded'); ok ($obj->get ('some_flags') eq [qw/value-one value-two/], 'eq is overloaded'); ok ($obj->get ('some_flags') ne [qw/value-one/], 'ne is overloaded'); __END__ Copyright (C) 2003-2005, 2009 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/constants.t000644 001750 000024 00000003023 11747045561 016143 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # test the constants exported by Glib. # use strict; use warnings; use Glib qw(:constants); use Test::More tests => 9; ok(TRUE, "TRUE"); ok(!FALSE, "FALSE"); ok( G_PRIORITY_HIGH < G_PRIORITY_DEFAULT, "G_PRIORITY_HIGH < G_PRIORITY_DEFAULT" ); ok( G_PRIORITY_DEFAULT < G_PRIORITY_HIGH_IDLE, "G_PRIORITY_DEFAULT < G_PRIORITY_HIGH_IDLE" ); ok( G_PRIORITY_HIGH_IDLE < G_PRIORITY_DEFAULT_IDLE, "G_PRIORITY_HIGH_IDLE < G_PRIORITY_DEFAULT_IDLE" ); ok( G_PRIORITY_DEFAULT_IDLE < G_PRIORITY_LOW, "G_PRIORITY_DEFAULT_IDLE < G_PRIORITY_LOW" ); my $rw = G_PARAM_READWRITE; is_deeply( [ sort @{ $rw } ], ['readable', 'writable'], "G_PARAM_READWRITE" ); ok(SOURCE_CONTINUE, "SOURCE_CONTINUE"); ok(!SOURCE_REMOVE, "SOURCE_REMOVE"); __END__ Copyright (C) 2003-2012 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/d.t000644 001750 000024 00000006372 11664366512 014364 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl -w # # $Id$ # # # Glib::Error # use strict; use Test::More tests => 36; use Glib; # this is obviously invalid and should result in an exception. eval { Glib::filename_from_uri 'foo://bar'; }; ok ($@, "\$@ is defined"); isa_ok ($@, "Glib::Error", "it's a Glib exception object"); isa_ok ($@, "Glib::Convert::Error", "specifically, it's a conversion error"); is ($@->code, 4, "numeric code"); is ($@->value, 'bad-uri', "code's nickname"); is ($@->domain, 'g_convert_error', 'error domain (implies class)'); ok ($@->message, "should have an error message, may be translated"); ok ($@->location, "should have an error location, may be translated"); is ($@, $@->message.$@->location, "stringification operator is overloaded"); # # create a new exception class... # Glib::Type->register_enum ('Test::ErrorCode', qw(frobbed fragged fubar b0rked help-me-please)); Glib::Error::register ('Test::Error', 'Test::ErrorCode'); is_deeply (\@Test::Error::ISA, ['Glib::Error'], 'register sets up ISA'); # # create a new instance, something we can pass to croak. # my $error = Test::Error->new ('fubar', "I'm fscked up beyond repair"); ok ($error, '$error should be defined'); isa_ok ($error, 'Glib::Error', "it's an exception object"); isa_ok ($error, 'Test::Error', "it's one our new exception objects"); is ($error->code, 3, 'numeric code'); is ($error->value, 'fubar', "code's nickname"); is ($error->domain, 'test-error', "domain should be mangled from package"); is ($error->message, "I'm fscked up beyond repair", "message should be unaltered"); ok ($error->location, 'should have error location'); is ($error, $error->message.$error->location, "stringification operator is overloaded"); # # now try to throw one of those with the Glib::Error syntax. # eval { Test::Error->throw ('fragged', "Here is a message"); }; ok ($@, '$@ should be defined'); isa_ok ($@, 'Glib::Error', "it's an exception object"); isa_ok ($@, 'Test::Error', "it's one our new exception objects"); is ($@->code, 2, 'numeric code'); is ($@->value, 'fragged', "code's nickname"); is ($@->domain, 'test-error', "domain should be mangled from package"); is ($@->message, "Here is a message", "message should be unaltered"); ok ($@->location, 'should have error location'); is ($@, $@->message.$@->location, "stringification operator is overloaded"); # various good tests for the matches function ok (Glib::Error::matches ($@, 'Test::Error', 'fragged'), "is"); ok (!Glib::Error::matches (undef, 'Test::Error', 'fragged'), "isn't"); ok (!Glib::Error::matches ($@, 'Test::Error', 'b0rked'), "isn't"); ok (!Glib::Error::matches ($@, 'Glib::File::Error', 'noent'), "isn't"); ok (Glib::Error::matches ($@, 'test-error', 2), "is"); my $raw = { domain => 'test-error', code => 2, message => 'dummy', }; ok (Glib::Error::matches ($raw, 'Test::Error', 'fragged'), "unblessed hash"); ok (Glib::Error::matches (bless ($raw, 'Glib::Error'), 'Test::Error', 'fragged'), "from Glib::Error, but with domain"); ok (!Glib::Error::matches (bless ($raw, 'Glib::Error'), 'Glib::File::Error', 'isdir'), "from Glib::Error, but with domain"); __END__ Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full list). See LICENSE for more information. Glib-1.320/t/e.t000644 001750 000024 00000032605 11664366512 014363 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # ParamSpec stuff. # use strict; use utf8; use Glib ':constants'; use Test::More tests => 312; # first register some types with which to play below. Glib::Type->register_enum ('Fish', qw(one two red blue)); Glib::Type->register_flags ('Rain', qw(warm cold light heavy)); Glib::Type->register_object ('Glib::Object', 'Skeezle'); my @params; my $pspec; # compares only three decimal places of a floating point number. sub is_float { my ($a, $b, $blurb) = @_; is (sprintf ('%.3f', $a), sprintf ('%.3f', $b), $blurb); } # # assumes: # name = lc $nick # type = Glib::Param::$nick # value_type = Glib::$nick (unless you supply a specific one) # blurb is set and not '' # pspec has not been added to an object class (owner_type is undef) # sub pspec_common_ok { my ($pspec, $nick, $flags, $value_type) = @_; $value_type = "Glib::$nick" unless $value_type; isa_ok ($pspec, 'Glib::ParamSpec'); isa_ok ($pspec, "Glib::Param::$nick"); is ($pspec->get_name, lc $nick, "$nick name"); is ($pspec->get_nick, $nick, "$nick nick"); ok ($pspec->get_blurb, "$nick blurb"); ok ($pspec->get_flags == $flags, "$nick flags"); # overloaded eq is ($pspec->get_value_type, $value_type, "$nick value type"); ok (! $pspec->get_owner_type, "$nick owner type (hasn't been added to a class yet)"); # for hysterical raisons and backward compatibility, the paramspec # objects have four keys in them: is ($pspec->{name}, $pspec->get_name, "$nick -> {name}"); # not valid if there's a - in the name! is ($pspec->{type}, $pspec->get_value_type, "$nick -> {type}"); ok ($pspec->{flags} == $pspec->get_flags, "$nick -> {flags}"); is ($pspec->{descr}, $pspec->get_blurb, "$nick -> {descr}"); } $pspec = Glib::ParamSpec->boolean ('boolean', 'Boolean', 'Is you is, or is you ain\'t my baby', TRUE, 'readable'); pspec_common_ok ($pspec, 'Boolean', 'readable'); ok ($pspec->get_default_value, "Boolean default (expect TRUE)"); push @params, $pspec; { $pspec = Glib::ParamSpec->boolean ('boolean-default-false', 'Boolean-default-false', 'Blurb', FALSE, 'readable'); is ($pspec->get_default_value, ''); # boolSV style empty '' return } $pspec = Glib::ParamSpec->string ('string', 'String', 'Stringing you along with NULL default.', undef, 'readable'); pspec_common_ok ($pspec, 'String', 'readable', 'Glib::String'); is ($pspec->get_default_value, undef, "String default NULL"); push @params, $pspec; # # all of the integer types have the same interface. # foreach my $inttype ( [ 'Char', 'It builds character', -10, 120, 64, 'writable'], [ 'UChar', 'Give me sign! I have no sign!', 10, 250, 128, ['readable', 'writable']], [ 'Int', 'most bugs show up in integration', -65535, 65535, 1138, ['readable', 'writable', 'construct']], [ 'UInt', 'UInt good enough for her', 256, 2**30, 7879, ['readable', 'writable', 'construct-only']], [ 'Long', 'Why the long face?', -10000, 10000, 0, G_PARAM_READWRITE], [ 'ULong', 'What do ulong for?', 0, 1000000, 100, G_PARAM_READWRITE], ) { my ($nick, $blurb, $min, $max, $default, $flags) = @$inttype; my $name = lc $nick; $pspec = Glib::ParamSpec->$name ($name, @$inttype); pspec_common_ok ($pspec, $nick, $flags); is ($pspec->get_minimum, $min, "$nick min"); is ($pspec->get_maximum, $max, "$nick max"); is ($pspec->get_default_value, $default, "$nick default"); push @params, $pspec; } # # floating-point types add get_epsilon to the integer interface. # we also need to use a more sophisticated comparison of the float # values, since == is rarely sufficient. # foreach my $floattype ( ['Float', 'In the event of a water landing, your seat coushin may be used as a floation device.', -2.718, 3.141529, 0.707, G_PARAM_READWRITE], ['Double', 'Double your pleasure, double your fun', 1.23456789, 9876543.21, 2.0, G_PARAM_READWRITE], ) { my ($nick, $blurb, $min, $max, $default, $flags) = @$floattype; my $name = lc $nick; $pspec = Glib::ParamSpec->$name ($name, @$floattype); pspec_common_ok ($pspec, $nick, $flags); is_float ($pspec->get_minimum, $min, "$nick minimum"); is_float ($pspec->get_maximum, $max, "$nick maximum"); is_float ($pspec->get_default_value, $default, "$nick default"); ok ($pspec->get_epsilon > 0.0, "$nick epsilon"); push @params, $pspec; } # # and now the rest. # $pspec = Glib::ParamSpec->enum ('enum', 'Enum', 'U Pluribus Enum.', 'Fish', 'blue', G_PARAM_READWRITE); pspec_common_ok ($pspec, 'Enum', G_PARAM_READWRITE, 'Fish'); is ($pspec->get_enum_class, 'Fish', 'enum class'); is ($pspec->get_default_value, 'blue', "Enum default"); push @params, $pspec; $pspec = Glib::ParamSpec->flags ('flags', 'Flags', 'Are people loyal to ideas or to flags?', 'Rain', ['light', 'warm'], G_PARAM_READWRITE); pspec_common_ok ($pspec, 'Flags', G_PARAM_READWRITE, 'Rain'); is ($pspec->get_flags_class, 'Rain', 'flags class'); ok ($pspec->get_default_value == ['light', 'warm'], 'Flags default'); push @params, $pspec; $pspec = Glib::ParamSpec->boxed ('boxed', 'Boxed', 'Big things come in little boxes', # we only know one boxed type at this point. 'Glib::Scalar', G_PARAM_READWRITE); pspec_common_ok ($pspec, 'Boxed', G_PARAM_READWRITE, 'Glib::Scalar'); is ($pspec->get_default_value, undef, 'Boxed default'); push @params, $pspec; $pspec = Glib::ParamSpec->object ('object', 'Object', 'I object, Your Honor, that\'s pure conjecture!', 'Skeezle', G_PARAM_READWRITE); pspec_common_ok ($pspec, 'Object', G_PARAM_READWRITE, 'Skeezle'); is ($pspec->get_default_value, undef, 'Object default'); push @params, $pspec; $pspec = Glib::ParamSpec->param_spec ('param-spec', 'ParamSpec', '', 'Glib::Param::Enum', G_PARAM_READWRITE); isa_ok ($pspec, 'Glib::ParamSpec'); isa_ok ($pspec, 'Glib::Param::Param'); is ($pspec->get_name, 'param_spec', 'Param name (modified)'); is ($pspec->{name}, 'param-spec', 'Param name (unmodified)'); is ($pspec->get_nick, 'ParamSpec', 'Param nick'); is ($pspec->get_blurb, '', 'Param blurb'); ok ($pspec->get_flags == G_PARAM_READWRITE, 'Param flags'); is ($pspec->get_value_type, 'Glib::Param::Enum', 'Param value type'); ok (! $pspec->get_owner_type, 'Param owner type'); is ($pspec->get_default_value, undef, 'Param default'); push @params, $pspec; $pspec = Glib::ParamSpec->unichar ('unichar', 'Unichar', 'is that like unixsex?', 'ö', qw/readable/); pspec_common_ok ($pspec, 'Unichar', qw/readable/, 'Glib::UInt'); is ($pspec->get_default_value, 'ö', 'Unichar default'); push @params, $pspec; { $pspec = Glib::ParamSpec->unichar ('unichar-nul', 'Unichar-Nul', 'Blurb', "\0", # default qw/readable/); is ($pspec->get_default_value, "\0", 'ParamSpec unichar - default zero byte'); $pspec = Glib::ParamSpec->unichar ('unichar-nul', 'Unichar-Nul', 'Blurb', "0", # default qw/readable/); is ($pspec->get_default_value, "0", 'ParamSpec unichar - default zero digit'); } # # specific to the perl bindings # $pspec = Glib::ParamSpec->IV ('iv', 'IV', 'This is the same as Int', -20, 10, -5, G_PARAM_READWRITE); isa_ok ($pspec, 'Glib::Param::Long', 'IV is actually Long'); is ($pspec->get_default_value, -5, 'IV default'); push @params, $pspec; $pspec = Glib::ParamSpec->UV ('uv', 'UV', 'This is the same as UInt', 10, 20, 15, G_PARAM_READWRITE); isa_ok ($pspec, 'Glib::Param::ULong', 'UV is actually ULong'); is ($pspec->get_default_value, 15, 'UV default'); push @params, $pspec; $pspec = Glib::ParamSpec->scalar ('scalar', 'Scalar', 'This is the same as Boxed', G_PARAM_READWRITE); isa_ok ($pspec, 'Glib::Param::Boxed', 'Scalar is actually Boxed'); is ($pspec->get_value_type, 'Glib::Scalar', 'boxed holding scalar'); is ($pspec->get_default_value, undef, 'Scalar default'); push @params, $pspec; # # now add all of these properties to an object class and verify that # the owner types are correct. # Glib::Type->register ( 'Glib::Object' => 'Bar', properties => \@params ); foreach (@params) { is ($_->get_owner_type, 'Bar', ref($_)." owner type after adding"); } { my $object = Bar->new; # exercise default GET_PROPERTY fetching pspec default value foreach my $pspec (@params) { if ($pspec->get_flags & 'readable') { my $pname = $pspec->get_name; $object->get($pname); } } is ($object->get_property('unichar'), ord('ö'), 'get_property() unichar default value (unicode code point number)'); } SKIP: { skip "GParamSpecOverride is new in glib 2.4.0", 27 unless Glib->CHECK_VERSION (2, 4, 0); my $pbase = Glib::ParamSpec->boolean ('obool','obool', 'Blurb', 0, G_PARAM_READWRITE); is ($pspec->get_redirect_target, undef); $pspec = Glib::ParamSpec->override ('over', $pbase); isa_ok ($pspec, 'Glib::Param::Override'); is_deeply ($pspec->get_redirect_target, $pbase); { my $pbase = Glib::ParamSpec->boolean ('obool', 'Obool', 'pbase blurb', 0, G_PARAM_READWRITE); is ($pbase->get_default_value, ''); is ($pbase->get_redirect_target, undef); # p1 targetting pbase my $p1 = Glib::ParamSpec->override ('over', $pbase); isa_ok ($p1, 'Glib::Param::Override'); # is_deeply() because paramspec is GBoxed, so no identical objects is_deeply ($p1->get_redirect_target, $pbase); is ($p1->get_blurb, 'pbase blurb'); is ($p1->get_nick, 'Obool'); is ($p1->get_default_value, ''); # p2 targetting p1 my $p2 = Glib::ParamSpec->override ('over-over', $p1); isa_ok ($p2, 'Glib::Param::Override'); # is_deeply() because paramspec is GBoxed, so no identical objects is_deeply ($p2->get_redirect_target, $pbase); is ($p2->get_blurb, 'pbase blurb'); is ($p2->get_nick, 'Obool'); is ($p2->get_default_value, ''); } { my $pbase = Glib::ParamSpec->unichar ('ounichar', 'Ounichar', 'pbase blurb', 'z', G_PARAM_READWRITE); is ($pbase->get_default_value, 'z'); is ($pbase->get_redirect_target, undef); # p1 targetting pbase my $p1 = Glib::ParamSpec->override ('over', $pbase); isa_ok ($p1, 'Glib::Param::Override'); # is_deeply() because paramspec is GBoxed, so no identical objects is_deeply ($p1->get_redirect_target, $pbase); is ($p1->get_blurb, 'pbase blurb'); is ($p1->get_nick, 'Ounichar'); is ($p1->get_default_value, 'z'); # p2 targetting p1 my $p2 = Glib::ParamSpec->override ('over-over', $p1); isa_ok ($p2, 'Glib::Param::Override'); # is_deeply() because paramspec is GBoxed, so no identical objects is_deeply ($p2->get_redirect_target, $pbase); is ($p2->get_blurb, 'pbase blurb'); is ($p2->get_nick, 'Ounichar'); is ($p2->get_default_value, 'z'); } } # # Since this is conditional on version, we don't want to overcomplicate # the testing logic above. # SKIP: { skip "GParamSpecGType is new in glib 2.10.0", 18 unless Glib->CHECK_VERSION (2, 10, 0); @params = (); $pspec = Glib::ParamSpec->gtype ('object', 'Object Type', "Any object type", Glib::Object::, G_PARAM_READWRITE); isa_ok ($pspec, 'Glib::Param::GType'); isa_ok ($pspec, 'Glib::ParamSpec'); is ($pspec->get_is_a_type, 'Glib::Object'); is ($pspec->get_value_type, 'Glib::GType'); push @params, $pspec; $pspec = Glib::ParamSpec->gtype ('type', 'Any type', "Any type", undef, G_PARAM_READWRITE); isa_ok ($pspec, 'Glib::Param::GType'); isa_ok ($pspec, 'Glib::ParamSpec'); is ($pspec->get_is_a_type, undef); is ($pspec->get_value_type, 'Glib::GType'); push @params, $pspec; Glib::Type->register ('Glib::Object' => 'Baz', properties => \@params); my $baz = Glib::Object::new ('Baz'); isa_ok ($baz, 'Glib::Object'); is ($baz->get ('object'), 'Glib::Object'); is ($baz->get ('type'), undef); $baz = Glib::Object::new ('Baz', object => 'Bar', type => 'Glib::ParamSpec'); isa_ok ($baz, 'Glib::Object'); is ($baz->get ('object'), 'Bar'); is ($baz->get ('type'), 'Glib::ParamSpec'); $baz->set (type => 'Bar'); is ($baz->get ('type'), 'Bar'); $baz->set (type => 'Glib::ParamSpec'); is ($baz->get ('type'), 'Glib::ParamSpec'); $baz->set (object => 'Glib::Object'); is ($baz->get ('object'), 'Glib::Object'); $baz->set (object => 'Glib::InitiallyUnowned'); is ($baz->get ('object'), 'Glib::InitiallyUnowned'); } # # verify that NULL param specs are handled gracefully # my $object = Bar->new; my $x = $object->get ('param_spec'); is ($x, undef); # # value_validate() and value_cmp() # { my $p = Glib::ParamSpec->int ('name','nick','blurb', 20, 50, 25, G_PARAM_READWRITE); ok (! scalar ($p->value_validate('30')), "value 30 valid"); my @a = $p->value_validate('30'); is (@a, 2); ok (! $a[0], "value 30 bool no modify (array context)"); is ($a[1], 30, "value 30 value unchanged"); my ($modif, $newval) = $p->value_validate(70); ok ($modif, 'modify 70 to be in range'); is ($newval, 50, 'clamp 70 down to be in range'); ($modif, $newval) = $p->value_validate(-70); ok ($modif, 'modify -70 to be in range'); is ($newval, 20, 'clamp -70 down to be in range'); is ($p->values_cmp(22, 33), -1); is ($p->values_cmp(33, 22), 1); is ($p->values_cmp(22, 22), 0); } Glib-1.320/t/f.t000644 001750 000024 00000021206 11664366512 014357 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl -w =doc Tests for new property features. These should probably go into 4.t and 5.t, but the test suite is a mess of order-of-operations spaghetti tests and i don't really want to mess with that. Someday we'll have to overhaul this suite, but it's late on Sunday night and i don't have the energy to fix what ain't really broke. This stuff makes Glib::Object::Subclass's GET_PROPERTY()/SET_PROPERTY() replacements unnecessary. Any ideas how to obsolete its new() replacement? =cut use Test::More tests => 54; use Glib ':constants'; use Data::Dumper; use strict; # we'll test, for paranoia's sake, that things work the same both with and # without Glib::Object::Subclass; to simplify things, let's use the exact # same list of properties for both. however, since the GObjects take # ownership of the pspecs, we can't share them. just use the same code # to create them: sub make_properties { # a basic one Glib::ParamSpec->string ('name', '', '', 'Joe', G_PARAM_READWRITE), # now with the new explicit handler syntax: { # with no handlers, this is the same as not using the hash pspec => Glib::ParamSpec->string ('middle', '', '', 'Momma', G_PARAM_READWRITE), }, { pspec => Glib::ParamSpec->string ('nickname', '', '', 'Jimmy-John', G_PARAM_READWRITE), get => sub { ok(1, 'explicit getter for nickname'); $_[0]->{nickname} }, set => sub { ok(1, 'explicit setter for nickname'); $_[0]->{nickname} = $_[1] }, }, { # if you leave out a getter, you get the default behavior pspec => Glib::ParamSpec->string ('surname', '', '', 'Jones', G_PARAM_READWRITE), set => sub { ok(1, 'explicit setter for surname'); $_[0]->{surname} = $_[1] }, }, { # same for leaving out a setter pspec => Glib::ParamSpec->string ('title', '', '', 'Mr', G_PARAM_READWRITE), get => sub { ok(1, 'explicit getter for title'); $_[0]->{title} }, }, }; # create a new object type by hand (no Glib::Object::Subclass) Glib::Type->register_object ('Glib::Object', 'Foo', properties => [ &make_properties ]); # now create one with Subclass, with the same properties. package Bar; use Glib::Object::Subclass 'Glib::Object', properties => [ &main::make_properties ]; package main; sub prop_names { map { UNIVERSAL::isa ($_, 'Glib::ParamSpec') ? $_->get_name : $_->{pspec}->get_name } @_ } sub Glib::Object::_list_property_names { prop_names $_[0]->list_properties } sub default_values { map { $_->get_default_value } $_[0]->list_properties } my @names = prop_names &make_properties; # start tests is_deeply ([prop_names (Foo->list_properties)], \@names, 'props created correctly for Foo'); my $foo = Foo->new; isa_ok ($foo, 'Foo', 'it\'s a Foo'); is (scalar keys %$foo, 0, 'new Foo has no keys'); # initially all props should have all default values, except for the ones # with explicit getters, as the explicit getters don't handle default values. my @initial_values = default_values ('Foo'); $initial_values[2] = undef; $initial_values[4] = undef; my @values = $foo->get (@names); is_deeply ([$foo->get (@names)], \@initial_values, 'all defaults except for explicit ones'); is (scalar keys %$foo, 0, 'Foo still has no keys after get'); my @default_values = default_values ('Foo'); $foo->set (map { $names[$_], $default_values[$_] } 0..$#names); is (scalar keys %$foo, 5, 'new Foo has keys after setting'); is_deeply ([ map {$foo->{$_}} @names ], [ @default_values ], 'and they have values'); # now add a GET_PROPERTY and SET_PROPERTY that will be called when no # explicit ones are supplied. sub get_property { ok (1, 'fallback GET_PROPERTY called'); return 'fallback'; } sub set_property { ok (1, 'fallback SET_PROPERTY called'); $_[0]->{$_[1]->get_name} = 'fallback'; } { no warnings; *Foo::GET_PROPERTY = \&get_property; *Foo::SET_PROPERTY = \&set_property; } # start over. $foo = Foo->new; isa_ok ($foo, 'Foo', 'it\'s a Foo'); is (scalar keys %$foo, 0, 'new Foo has no keys'); # with the overrides in place, none of the implicit keys will have values # in get, because Subclass's GET doesn't handle defaults. my @expected = map { defined $_ ? 'fallback' : undef } @initial_values; @values = $foo->get (@names); is_deeply ([$foo->get (@names)], \@expected, 'fallback called for implicit getters'); is (scalar keys %$foo, 0, 'Foo still has no keys after get'); @expected = @default_values; $expected[0] = 'fallback'; $expected[1] = 'fallback'; $expected[4] = 'fallback'; $foo->set (map { $names[$_], $default_values[$_] } 0..$#names); is (scalar keys %$foo, 5, 'new Foo has keys after setting'); is_deeply ([ map {$foo->{$_}} @names ], [ @expected ], 'and they have values'); # # now verify that Subclass still works as expected. # my $bar = Bar->new; is (scalar keys %$bar, 0, 'bar has no keys on creation'); @expected = @default_values; $expected[2] = undef; $expected[4] = undef; is_deeply ([$bar->get (@names)], \@expected, 'Subclass works just like registering by hand'); $bar->set (map { $names[$_], $default_values[$_] } 0..$#names); is (scalar keys %$bar, 5, 'new Foo has keys after setting'); is_deeply ([ map {$bar->{$_}} @names ], [ @default_values ], 'and they have values'); { # Prior to 1.240 a subclass of a class with a pspec/get/set did not reach # the specified get/set funcs. my @getter_args; my @setter_args; { package BaseGetSet; use Glib::Object::Subclass 'Glib::Object', properties => [ { pspec => Glib::ParamSpec->string ('my-prop', 'My-Prop', 'Blurb one', 'default one', ['readable','writable']), get => sub { @getter_args = @_; }, set => sub { @setter_args = @_; }, }, ]; } { package SubGetSet; use Glib::Object::Subclass 'BaseGetSet'; } my $obj = SubGetSet->new; @getter_args = (); @setter_args = (); $obj->get ('my-prop'); is_deeply (\@getter_args, [$obj], 'my-prop reaches BaseGetSet'); is_deeply (\@setter_args, [], 'my-prop reaches BaseGetSet'); @getter_args = (); @setter_args = (); $obj->set (my_prop => 'zzz'); is_deeply (\@getter_args, [], 'my-prop reaches BaseGetSet'); is_deeply (\@setter_args, [$obj,'zzz'], 'my-prop reaches BaseGetSet'); } { # Prior to 1.240 a class with a pspec/get/set which is subclassed with # another separate pspec/get/set property called to the subclass get/set # funcs, not the superclass ones. my @baseone_getter_args; my @baseone_setter_args; { package BaseOne; use Glib::Object::Subclass 'Glib::Object', properties => [ { pspec => Glib::ParamSpec->string ('prop-one', 'Prop-One', 'Blurb one', 'default one', ['readable','writable']), get => sub { @baseone_getter_args = @_; }, set => sub { # Test::More::diag('baseone setter'); @baseone_setter_args = @_; }, }, ]; } my @subtwo_getter_args; my @subtwo_setter_args; { package SubTwo; use Glib::Object::Subclass 'BaseOne', properties => [ { pspec => Glib::ParamSpec->string ('prop-two', 'Prop-Two', 'Blurb two', 'default two', ['readable','writable']), get => sub { @subtwo_getter_args = @_; }, set => sub { # Test::More::diag('subtwo setter'); @subtwo_setter_args = @_; }, }, ]; } my $obj = SubTwo->new; @baseone_getter_args = (); @subtwo_getter_args = (); $obj->get ('prop-two'); is_deeply (\@baseone_getter_args, [], 'prop-two goes to subtwo'); is_deeply (\@subtwo_getter_args, [$obj], 'prop-two goes to subtwo'); @baseone_getter_args = (); @subtwo_getter_args = (); $obj->get ('prop-one'); is_deeply (\@baseone_getter_args, [$obj], 'prop-one goes to baseone'); is_deeply (\@subtwo_getter_args, [], 'prop-one goes to baseone'); @baseone_setter_args = (); @subtwo_setter_args = (); $obj->set (prop_two => 'xyz'); is_deeply (\@baseone_setter_args, [], 'prop-two goes to subtwo'); is_deeply (\@subtwo_setter_args, [$obj,'xyz'], 'prop-two goes to subtwo'); @baseone_setter_args = (); @subtwo_setter_args = (); $obj->set (prop_one => 'abc'); is_deeply (\@baseone_setter_args, [$obj,'abc'], 'prop-one goes to baseone'); is_deeply (\@subtwo_setter_args, [], 'prop-one goes to baseone'); } Glib-1.320/t/filename.t000644 001750 000024 00000004111 11664366512 015706 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # vim: set filetype=perl : # # Test the filename conversion facilities in Glib # use strict; use warnings; use Glib qw(:functions); use Test::More tests => 26; my $filename = "test"; is(Glib->filename_to_unicode($filename), $filename); is(Glib::filename_to_unicode($filename), $filename); is(filename_to_unicode($filename), $filename); is(Glib->filename_from_unicode($filename), $filename); is(Glib::filename_from_unicode($filename), $filename); is(filename_from_unicode($filename), $filename); # # These URI related tests are deliberately permissive so as not to fail on # MSWin32. # use Cwd qw(cwd); my $path = cwd() . "/" . $filename; my $host = "localhost"; my $uri = "file://$host/$filename"; my $expected = qr/\Q$filename\E/; like(Glib->filename_to_uri($path, undef), $expected); like(Glib::filename_to_uri($path, undef), $expected); like(filename_to_uri($path, undef), $expected); like(Glib->filename_to_uri($path, $host), $expected); like(Glib::filename_to_uri($path, $host), $expected); like(filename_to_uri($path, $host), $expected); like(Glib->filename_from_uri($uri), $expected); like(Glib::filename_from_uri($uri), $expected); like(filename_from_uri($uri), $expected); like(filename_from_uri("file:///$filename"), $expected); { # note in the return "localhost" is downgraded to undef on msdos, so don't # check $ret[1] eq 'localhost' my @ret; @ret = Glib->filename_from_uri($uri); like ($ret[0], $expected); @ret = filename_from_uri($uri); like ($ret[0], $expected); @ret = filename_from_uri("file:///$filename"); like ($ret[0], $expected); is ($ret[1], undef); } SKIP: { skip "g_filename_display_name was added glib 2.6.0", 6 unless Glib->CHECK_VERSION (2, 6, 0); ok (Glib::filename_display_name ("test")); ok (Glib::filename_display_basename ("test")); ok (Glib::filename_display_name ("/tmp/test")); ok (Glib::filename_display_basename ("/tmp/test")); # should not fail even on invalid stuff my $something = "/tmp/test\x{fe}\x{03}invalid"; ok (Glib::filename_display_name ($something)); ok (Glib::filename_display_basename ($something)); } Glib-1.320/t/g.t000644 001750 000024 00000013205 11701512040 014335 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # KeyFile stuff. # use strict; use warnings; use Cwd qw(cwd); use File::Spec; # for catfile() use Glib ':constants'; use Test::More tests => 33; my $str = <<__EOK__ #top of the file [mysection] intkey=42 stringkey=hello boolkey=1 doublekey=3.1415 [listsection] intlist=1;1;2;3;5;8;13; stringlist=Some;Values;In;A;List; boollist=false;true;false doublelist=23.42;3.1415 [locales] #some string mystring=Good morning mystring[it]=Buongiorno mystring[es]=Buenas dias mystring[fr]=Bonjour mystring[de]=Guten Tag __EOK__ ; SKIP: { skip "Glib::KeyFile is new in glib 2.6.0", 33 unless Glib->CHECK_VERSION (2, 6, 0); ok (defined Glib::KeyFile->new ()); my $key_file = Glib::KeyFile->new; isa_ok ($key_file, 'Glib::KeyFile'); my @groups; @groups = $key_file->get_groups; is (@groups, 0, 'we have no groups'); ok ($key_file->load_from_data( $str, [ 'keep-comments', 'keep-translations' ] )); @groups = $key_file->get_groups; is (@groups, 3, 'now we have two groups'); is ($key_file->get_comment(undef, undef), "top of the file\n", 'we reached the top'); my $start_group = 'mysection'; ok ($key_file->has_group($start_group)); is ($key_file->get_start_group, $start_group, 'start group'); ok ($key_file->has_key($key_file->get_start_group, 'stringkey')); my $intval = 42; my $stringval = 'hello'; my $boolval = TRUE; is ($key_file->get_string($start_group, 'stringkey'), $stringval, 'howdy?'); is ($key_file->get_value($start_group, 'intkey'), $intval, 'the answer'); is ($key_file->get_integer($start_group, 'intkey'), $intval, 'the answer, reloaded'); is ($key_file->get_boolean($start_group, 'boolkey'), $boolval, 'we stay true to ourselves'); ok ($key_file->has_group('listsection')); my @integers = $key_file->get_integer_list('listsection', 'intlist'); is (@integers, 7, 'fibonacci would be proud'); my @strings = $key_file->get_string_list('listsection', 'stringlist'); eq_array (\@strings, ['Some', 'Values', 'In', 'A', 'List'], 'we are proud too'); my @bools = $key_file->get_boolean_list('listsection', 'boollist'); is (@bools, 3); eq_array (\@bools, [FALSE, TRUE, FALSE]); ok ($key_file->has_group('locales')); is ($key_file->get_comment('locales', 'mystring'), "some string\n"); is ($key_file->get_string('locales', 'mystring'), 'Good morning'); is ($key_file->get_locale_string('locales', 'mystring', 'it'), 'Buongiorno'); $key_file->set_locale_string_list('locales', 'mystring', 'en', 'one', 'two', 'three'); is_deeply([$key_file->get_locale_string_list('locales', 'mystring', 'en')], ['one', 'two', 'three']); $key_file->set_string_list('listsection', 'stringlist', 'one', 'two', 'three'); $key_file->set_locale_string('locales', 'mystring', 'en', 'one'); $key_file->set_comment('locales', 'mystring', 'comment'); is ($key_file->get_comment('locales', 'mystring'), "comment\n"); $key_file->set_comment('locales', undef, "another comment\n"); is ($key_file->get_comment('locales', undef), "#another comment\n#"); $key_file->set_comment(undef, undef, 'one comment more'); is ($key_file->get_comment(undef, undef), "one comment more\n"); $key_file->set_boolean($start_group, 'boolkey', FALSE); $key_file->set_value($start_group, 'boolkey', '0'); is_deeply([$key_file->get_keys('mysection')], ['intkey', 'stringkey', 'boolkey', 'doublekey']); SKIP: { skip "double stuff", 4 unless Glib->CHECK_VERSION (2, 12, 0); my $epsilon = 1e-6; ok($key_file->get_double('mysection', 'doublekey') - 3.1415 < $epsilon); $key_file->set_double('mysection', 'doublekey', 23.42); ok($key_file->get_double('mysection', 'doublekey') - 23.42 < $epsilon); my @list = $key_file->get_double_list('listsection', 'doublelist'); ok($list[0] - 23.42 < $epsilon && $list[1] - 3.1415 < $epsilon); $key_file->set_double_list('listsection', 'doublelist', 3.1415, 23.42); @list = $key_file->get_double_list('listsection', 'doublelist'); ok($list[0] - 3.1415 < $epsilon && $list[1] - 23.42 < $epsilon); } $key_file->remove_comment('locales', 'mystring'); $key_file->remove_comment('locales', undef); $key_file->remove_comment(undef, undef); $key_file->remove_key('locales', 'mystring'); $key_file->remove_group('mysection'); $key_file->remove_group('listsection'); $key_file->remove_group('locales'); is($key_file->to_data(), ""); $key_file->set_list_separator(ord(':')); SKIP: { skip "load_from_dirs", 3 unless Glib->CHECK_VERSION (2, 14, 0); my $file = 'tmp.ini'; open my $fh, '>', $file or skip "load_from_dirs, can't create temporary file", 3; print $fh $str; close $fh; my $key_file = Glib::KeyFile->new; my ($success, $path) = $key_file->load_from_dirs($file, [ 'keep-comments' ], cwd(), '/tmp'); ok ($success); is (File::Spec->canonpath($path), File::Spec->catfile(cwd(), $file)); is ($key_file->get_comment(undef, undef), "top of the file\n", 'we reached the top again'); unlink $file; } } __END__ Copyright (C) 2005 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/h.t000644 001750 000024 00000012337 11701512040 014343 0ustar00bdmanningstaff000000 000000 # # BookmarkFile # use strict; use warnings; use Glib ':constants'; use Test::More tests => 30; our $str = <<__EOB__ Test File Some test file __EOB__ ; SKIP: { skip "Glib::BookmarkFile is new in glib 2.12.0", 30 unless Glib->CHECK_VERSION (2, 12, 0); ok (defined Glib::BookmarkFile->new (), 'test constructor'); my $bookmark_file = Glib::BookmarkFile->new; isa_ok ($bookmark_file, 'Glib::BookmarkFile', 'test ISA'); my $size; $size = $bookmark_file->get_size; is ($size, 0, 'we have no bookmarks'); $bookmark_file->load_from_data ($str); $size = $bookmark_file->get_size; is ($size, 1, 'we have one bookmark'); my @uris = $bookmark_file->get_uris; is (@uris, $size, 'check size'); eq_array (\@uris, [ 'file:///tmp/test-file.txt' ]); ok ($bookmark_file->has_item($uris[0]), 'check has item'); is ($bookmark_file->get_title($uris[0]), 'Test File', 'check get_title'); $bookmark_file->set_title($uris[0], 'Test file'); is ($bookmark_file->get_title($uris[0]), 'Test file', 'check set_title'); is ($bookmark_file->get_description($uris[0]), 'Some test file', 'check get_description'); $bookmark_file->set_description($uris[0], 'Foo'); is ($bookmark_file->get_description($uris[0]), 'Foo', 'check set_description'); is ($bookmark_file->get_mime_type($uris[0]), 'text/plain', 'check get_mime_type'); $bookmark_file->set_mime_type($uris[0], 'image/png'); is ($bookmark_file->get_mime_type($uris[0]), 'image/png', 'check set_mime_type'); my $uri = 'file:///tmp/another-file.txt'; $bookmark_file->set_title($uri, 'Another file'); $bookmark_file->set_description($uri, 'Yet another test file'); $bookmark_file->add_group($uri, 'Editors'); $bookmark_file->add_group($uri, 'Stuff'); my @groups = $bookmark_file->get_groups($uri); is (@groups, 2, 'check add group'); $bookmark_file->remove_group($uri, 'Stuff'); ok (!$bookmark_file->has_group($uri, 'Stuff'), 'check has_group'); $bookmark_file->add_application($uri, 'Gedit', 'gedit %u'); ok ($bookmark_file->has_application($uri, 'Gedit'), 'check add_application'); ok (!$bookmark_file->has_application($uri, 'Vim'), 'check has_application'); $bookmark_file->add_application($uri, 'Vim', 'gvim %f'); $bookmark_file->add_application($uri, 'Gedit', 'gedit %u'); my ($exec, $count, $stamp) = $bookmark_file->get_app_info($uri, 'Gedit'); is ($exec, "gedit $uri", 'check get_app_info/1'); is ($count, '2', 'check get_app_info/2'); my $now = time (); $bookmark_file->set_app_info($uri, 'Vim', 'gvim %f', 42, $now); is ($now, $bookmark_file->get_modified($uri), 'check set_app_info/1'); (undef, $count, $stamp) = $bookmark_file->get_app_info($uri, 'Vim'); is ($count, 42, 'check set_app_info/2'); is ($stamp, $now, 'check set_app_info/3'); $bookmark_file->set_app_info($uri, 'Gedit', '', 0, 1); ok (!$bookmark_file->has_application($uri, 'Gedit'), 'check set_app_info/4'); $bookmark_file->remove_application($uri, 'Vim'); ok (!$bookmark_file->has_application($uri, 'Vim'), 'check remove_application'); my $new_uri = 'file:///tmp/some-other-test.txt'; $bookmark_file->move_item($uri, $new_uri); ok ($bookmark_file->has_item($new_uri), 'check move_item/1'); ok (!$bookmark_file->has_item($uri), 'check move_item/2'); $bookmark_file->move_item($new_uri, undef); ok (!$bookmark_file->has_item($new_uri), 'check move_item/3'); $bookmark_file->remove_item($uris[0]); is ($bookmark_file->get_size, 0, 'check_remove_item'); $bookmark_file->set_added($uri, $now); is ($bookmark_file->get_added($uri), $now, 'check added accessors'); $bookmark_file->set_modified($uri, $now); is ($bookmark_file->get_modified($uri), $now, 'check modified accessors'); $bookmark_file->set_visited($uri, $now); is ($bookmark_file->get_visited($uri), $now, 'check visited accessors'); } __END__ Copyright (C) 2006 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Glib-1.320/t/lazy_loader.t000644 001750 000024 00000001142 11664366512 016434 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # # Test some aspects of the lazy loader # use strict; use warnings; use Glib; use Test::More tests => 1; SKIP: { skip 'need Glib::InitiallyUnowned', 1 unless Glib->CHECK_VERSION(2, 10, 0); # Setup a strange hierarchy that tests whether the lazy loader can deal with # being invoked on a package that only indirectly inherits from a registered # package. @NotThere::ISA = (); @NotHere::ISA = (); @Foo::ISA = qw/NotThere Glib::InitiallyUnowned/; @Bar::ISA = qw/NotHere Foo/; ok (Bar->isa (qw/Glib::Object/), 'the lazy loader correctly set up the hierarchy'); } Glib-1.320/t/make_helper.t000644 001750 000024 00000000460 11664366512 016405 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; use Glib ':constants'; BEGIN { use_ok('Glib::MakeHelper'); } my $configure_requires = Glib::MakeHelper->get_configure_requires_yaml(Bla => 0.1, Foo => 0.006); like($configure_requires, qr/Bla/); like($configure_requires, qr/Foo/); Glib-1.320/t/module_versions.t000644 001750 000024 00000001037 12125455576 017351 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::ConsistentVersion"; plan skip_all => "Test::ConsistentVersion required " . "for checking module versions" if $@; Test::ConsistentVersion::check_consistent_versions( # We don't use the version in the README no_readme => 1, # We don't maintain a ChangeLog file, we use NEWS instead no_changelog => 1, # Test::Pod::Content lookѕ for VERSION blocks in POD, which (currently) # don't exist in Glib's autogenerated POD files no_pod => 1, ); Glib-1.320/t/options.t000644 001750 000024 00000013552 12221715327 015622 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # $Id$ use strict; use warnings; use utf8; use Test::More; use Glib qw(TRUE FALSE); unless (Glib -> CHECK_VERSION (2, 6, 0)) { plan skip_all => 'the option stuff is new in 2.6'; } else { plan tests => 33; } # --------------------------------------------------------------------------- # my ($none, $string, $int, $filename, $string_array, $filename_array); my $entries = [ { long_name => 'none', short_name => 'n', flags => [qw/reverse in-main/], arg_type => 'none', arg_value => \$none, description => 'none desc.', arg_description => 'none arg desc.' }, { long_name => 'string', short_name => 's', arg_type => 'string', arg_value => \$string }, { long_name => 'int', short_name => 'i', arg_type => 'int', arg_value => \$int }, { long_name => 'filename', short_name => undef, arg_type => 'filename', arg_value => \$filename }, { long_name => 'string-array', arg_type => 'string-array', arg_value => \$string_array }, [ 'filename-array', undef, 'filename-array', \$filename_array ], ]; # --------------------------------------------------------------------------- # # Misc. non-parse API. { my $context = Glib::OptionContext -> new('- urgsify your life'); isa_ok($context, 'Glib::OptionContext'); $context -> set_help_enabled(TRUE); is($context -> get_help_enabled(), TRUE); $context -> set_ignore_unknown_options(TRUE); is($context -> get_ignore_unknown_options(), TRUE); my $group = Glib::OptionGroup -> new(name => 'urgs', description => 'Urgs Urgs Urgs', help_description => 'Help with Urgs', entries => $entries); isa_ok($group, 'Glib::OptionGroup'); $context -> set_main_group($group); isa_ok($context -> get_main_group(), 'Glib::OptionGroup'); } # --------------------------------------------------------------------------- # # Translation stuff. Commented out since it aborts the program. { my $context = Glib::OptionContext -> new('- urgsify your life'); my $group = Glib::OptionGroup -> new(name => 'urgs', description => 'Urgs Urgs Urgs', help_description => 'Help with Urgs', entries => $entries); $group -> set_translation_domain('de_DE'); $group -> set_translate_func(sub { my ($string, $data) = @_; warn $string; warn $data; return reverse $string; }, 'atad'); $context -> add_group($group); #@ARGV = qw(--help); #@ARGV = qw(--help-urgs); #$context -> parse(); } # --------------------------------------------------------------------------- # # Parsing. { my $context = Glib::OptionContext -> new('- urgsify your life'); $context -> add_main_entries($entries, 'de_DE'); # Test that undef is preserved. { @ARGV = qw(); $context -> parse(); is ($none, FALSE); # FIXME? is ($string, undef); is ($int, 0); # FIXME? is ($filename, undef); is ($string_array, undef); is ($filename_array, undef); } # Test that existing values are not overwritten. { $none = TRUE; $string = 'ürgs'; $int = 23; $filename = $^X; $string_array = [qw/á é í ó ú/]; $filename_array = [$^X, $0]; @ARGV = qw(); $context -> parse(); is ($none, TRUE); is ($string, 'ürgs'); is ($int, 23); is ($filename, $^X); is_deeply ($string_array, [qw/á é í ó ú/]); is_deeply ($filename_array, [$^X, $0]); } # Test actual parsing. { @ARGV = qw(-n -s bla -i 42 --filename ~/Foo --string-array aaa --string-array bbb --filename-array /usr/bin/bla --filename-array ./harness); $context -> parse(); is ($none, FALSE); is ($string, 'bla'); is ($int, 42); is ($filename, '~/Foo'); is_deeply ($string_array, [qw/aaa bbb/]); is_deeply ($filename_array, [qw(/usr/bin/bla ./harness)]); } # Test that there is no double-encoding for utf8-encoded strings. SKIP: { my $codeset; # This eval() was taken from # and from a suggestion from Kevin Ryde eval { require I18N::Langinfo; $codeset = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); }; # If there was an error requiring I18N::Langinfo, then skip this block of # tests; we need I18N::Langinfo to check LC_ALL/LANG skip("Can't check LC_ALL/LANG, I18N::Langinfo unavailable; $@", 4) if ( length($@) > 0 ); # If LC_ALL/LANG is not some variant of UTF-8 (8-bit, wide/multibyte # characters), skip this block of tests skip("Can't test parsing of wide-byte args (non-UTF-8 locale: $codeset)", 4) if ( $codeset !~ /UTF-8|utf8/i ); @ARGV = qw(-s ❤ ❤); $context -> parse(); is ($string, '❤'); is (length $string, 1); is ($ARGV[0], '❤'); is (length $ARGV[0], 1); } } # --------------------------------------------------------------------------- # SKIP: { skip 'new 2.12 stuff', 6 unless Glib->CHECK_VERSION(2, 12, 0); my ($double, $int64); my $entries = [ [ 'double', 'd', 'double', \$double ], [ 'int64', 'i', 'int64', \$int64 ], ]; my $context = Glib::OptionContext -> new('- urgsify your life'); $context -> add_main_entries($entries, 'de_DE'); # Test that undef is preserved. { @ARGV = qw(); $context -> parse(); is ($double, 0); # FIXME? is ($int64, 0); # FIXME? } # Test that existing values are not overwritten. { $double = 0.23; $int64 = 23; @ARGV = qw(); $context -> parse(); ok ($double - 0.23 < 1e-6); is ($int64, 23); } # Test actual parsing. { @ARGV = qw(-d 0.42 -i 42); $context -> parse(); ok ($double - 0.42 < 1e-6); is ($int64, 42); } } Glib-1.320/t/signal_emission_hooks.t000644 001750 000024 00000012674 11664366512 020531 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl -w # test out signal emission hooks. use strict; use warnings; use Test::More tests => 77; use Glib ':constants'; Glib::Type->register_object ( 'Glib::Object', 'Foo', signals => { wave => {}, nod => { param_types => [qw(Glib::String Glib::Int)], }, wink => { flags => ['run-last', 'detailed'], param_types => [qw(Glib::Boolean)], return_type => 'Glib::Boolean', }, gesture => { flags => ['no-hooks'], }, }, ); Glib::Type->register_object ('Foo', 'Bar'); my $foo = Glib::Object::new ('Foo'); isa_ok ($foo, 'Foo'); isa_ok ($foo, 'Glib::Object'); # add each emission hook a different way my $wave_hook = $foo->signal_add_emission_hook (wave => \&generic_hook_data, {foo=>'bar'}); ok ($wave_hook, 'added hook for wave'); my $wink_hook = Foo->signal_add_emission_hook (wink => \&generic_hook_no_data); ok ($wave_hook, 'added hook for wink'); my $nod_hook = Glib::Object::signal_add_emission_hook ('Foo', 'nod', 'generic_hook_no_data'); ok ($wave_hook, 'added hook for nod'); { # This shouldn't work, as the signal is flagged as no-hooks. # It appears to generate a warning from GLib through g_log; let's # trap that. local $SIG{__WARN__} = sub { ok(1, "got warning text $_[0]"); }; my $gesture_hook = Glib::Object::signal_add_emission_hook ('Foo', 'gesture', 'generic_hook_data', {foo=>'bar'}); ok (!$gesture_hook, 'can\'t add a hook for gesture'); } # connect with detail; notify is the obvious choice, but it is defined # as no-hooks, so that won't work. let's just make something up. my $detailed_hook = Foo->signal_add_emission_hook ('wink::sly', \&generic_hook_no_data); ok ($detailed_hook, 'added hook for wink::sly'); # we can connect a hook to an inherited signal. the hook will be invoked # for emission of the signal from *any* class. my $bar_wave_hook = Bar->signal_add_emission_hook (wave => \&generic_hook_no_data); ok ($bar_wave_hook); $foo->signal_connect ("wink" => sub { ok (1, "plain old wink")}); $foo->signal_connect ("wink::sly" => sub { ok (1, "wink::sly")}); # emit some signals... # these variables communicate with generic_hook_no_data(). my $emission_count = 0; my %emissions = (); my $detail = undef; # there are two hooks connected to this one. print "\nemitting wave\n"; $foo->signal_emit ('wave'); is ($emissions{wave}, 2); print "\nemitting nod\n"; $foo->signal_emit ('nod', "Whee!", 42); print "\nemitting wink\n"; my $ret = $foo->signal_emit ('wink', TRUE); $detail = 'sly'; print "\nemitting wink::$detail\n"; my $n_before = $emission_count; $foo->signal_emit ("wink::$detail", FALSE); is ($emission_count - $n_before, 2, 'detailed emission results in two hooks'); print "\nemitting gesture\n"; $n_before = $emission_count; $foo->signal_emit ('gesture'); is ($emission_count, $n_before, 'no hook here'); print "\n"; is ($emission_count, 6, 'total emissions'); is ($emissions{'wave'}, 2, 'emissions for wave'); is ($emissions{'nod'}, 1, 'emissions for nod'); is ($emissions{'wink'}, 3, 'emissions for wink'); is ($emissions{'gesture'}, undef, 'emissions for gesture'); # remove all the hooks and emit again. # the emission count should not change. Foo->signal_remove_emission_hook (wave => $wave_hook); Foo->signal_remove_emission_hook (wave => $bar_wave_hook); Foo->signal_remove_emission_hook (nod => $nod_hook); Foo->signal_remove_emission_hook (wink => $wink_hook); Foo->signal_remove_emission_hook (wink => $detailed_hook); $n_before = $emission_count; $foo->signal_emit ('wave'); $foo->signal_emit ('nod', "Whee!", 42); $ret = $foo->signal_emit ('wink', TRUE); $foo->signal_emit ("wink::$detail", FALSE); $foo->signal_emit ('gesture'); is ($emission_count, $n_before, 'no hooks here'); # test a self-removing hook. Foo->signal_add_emission_hook (wave => sub { ok (1, 'got hooked'); $emission_count++; FALSE }); $n_before = $emission_count; $foo->signal_emit ('wave'); $foo->signal_emit ('wave'); is ($emission_count - $n_before, 1, 'two emissions, one hook'); sub generic_hook_no_data { my ($ihint, $param_list) = @_; print "in hook for $ihint->{signal_name} $ihint->{run_type}\n"; $emission_count++; $emissions{$ihint->{signal_name}}++; use Data::Dumper; print Dumper([$ihint, $param_list]); isa_ok ($ihint, 'HASH'); ok (exists $ihint->{signal_name}, 'ihint is valid'); is ($ihint->{detail}, $detail, 'detail'); isa_ok ($param_list, 'ARRAY'); ok (@$param_list > 0, 'at least one thing in param_list'); # GSignal doesn't care what the instance's type is, but we only # bind it to Glib::Object. isa_ok ($param_list->[0], 'Glib::Object'); my $info = $param_list->[0]->signal_query ($ihint->{signal_name}); ok (defined $info, 'found info about the signal'); is (scalar(@$param_list), 1 + scalar(@{ $info->{param_types} }), 'parameter count'); return TRUE; } sub generic_hook_data { my ($ihint, $param_list, $user_data) = @_; isa_ok ($user_data, 'HASH'); is ($user_data->{foo}, 'bar', 'user data is valid'); # verify the invocation hint. my $other_hint = $param_list->[0]->signal_get_invocation_hint(); is_deeply ($ihint, $other_hint); return generic_hook_no_data ($ihint, $param_list); } # vim: set et ts=4 sw=4 sts=4 syntax=perl : Glib-1.320/t/signal_marshal.t000644 001750 000024 00000001470 11664366512 017117 0ustar00bdmanningstaff000000 000000 #!perl package MyClass; use strict; use warnings; use Glib; use Glib::Object::Subclass 'Glib::Object', signals => { mysig => { param_types => [], return_type => undef }, }; sub INIT_INSTANCE { my ($self) = @_; } sub do_mysig { return 123; } package MySubClass; use strict; use warnings; use Glib; use Glib::Object::Subclass 'MyClass', signals => { mysig => \&_do_mysubclass_mysig }; sub INIT_INSTANCE { my ($self) = @_; } our $MYSIG_RUNS = 0; sub _do_mysubclass_mysig { my ($self) = @_; $self->signal_chain_from_overridden; $MYSIG_RUNS++; } package main; use strict; use warnings; use Glib; use Test::More tests => 1; my $obj = MySubClass->new; $obj->signal_emit ('mysig'); is($MySubClass::MYSIG_RUNS, 1, 'marshaling a signal with no return type'); Glib-1.320/t/signal_query.t000644 001750 000024 00000004026 11664366512 016635 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl -w # # Test querying signal information with Glib::Type::list_signals and # Glib::Object::signal_query (g_signal_query). # use strict; use Glib; use Test::More tests => 24; my $quuxed_reg_info = { flags => [ 'run-last', 'action' ], return_type => 'Glib::Float', param_types => [ 'Glib::Int', 'Glib::Boolean' ], }; Glib::Type->register_object ('Glib::Object' => 'Foo', signals => { fooed => {}, # all defaults barred => { flags => 'run-last', return_type => 'Glib::Boolean', }, quuxed => $quuxed_reg_info, }); Glib::Type->register_object ('Foo' => 'Bar', signals => { bazzed => { flags => 'run-last', return_type => 'Glib::Int', }, }); my @foo_signals = Glib::Type->list_signals ('Foo'); my @bar_signals = Glib::Type->list_signals ('Bar'); is (scalar (@foo_signals), 3); is (scalar (@bar_signals), 1); # signal_query and list_signals should give back the same data structures. # as a special test, we should be able to get all of the signals from Bar, # as they are inherited from Foo -- list_signals, on the other hand, doesn't # do inheritance. foreach my $sig (@foo_signals, @bar_signals) { is_deeply (Bar->signal_query ($sig->{signal_name}), $sig, "$sig->{signal_name}"); # keys that should always exist ok (exists $sig->{signal_flags}); ok ($sig->{itype}); isa_ok ($sig->{param_types}, 'ARRAY'); } # let's verify that querying a specific signal gives back the expected values. my $info = Bar->signal_query ('quuxed'); is ($info->{signal_name}, 'quuxed', 'name'); # we asked Bar for the info, but the signal comes from Foo. is ($info->{itype}, 'Foo', 'instance type'); # don't use is to test flags -- some Test::Mores disable overloading. ok ($info->{signal_flags} == $quuxed_reg_info->{flags}, 'signal_flags'); is_deeply ($info->{param_types}, $quuxed_reg_info->{param_types}, 'param_types'); is ($info->{return_type}, $quuxed_reg_info->{return_type}, 'return_type'); # querying a non-existent signal should return undef is (Bar->signal_query ('non-existent'), undef, 'non-existent signal'); Glib-1.320/t/tied_definedness.t000644 001750 000024 00000002431 11664366512 017425 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl # This is based on a test case sent to gtk-perl-list by Giuliano. package ClassFoo; use strict; use warnings; use Glib; use Glib::Object::Subclass Glib::Object::, properties => [ Glib::ParamSpec->boxed('title', 'title', 'The title', 'Glib::Scalar', [qw/writable readable/]), ]; sub INIT_INSTANCE { my $self = shift; $self->{prop_title} = undef; } sub SET_PROPERTY { my ($self, $pspec, $val) = @_; my $propname = $pspec->get_name; if ($propname eq 'title') { $self->{prop_title} = $val; } else { die "unknown property ``$propname''"; } } sub GET_PROPERTY { my ($self, $pspec) = @_; my $propname = $pspec->get_name; if ($propname eq 'title') { return $self->{prop_title}; } else { die "unknown property ``$propname''"; } } # --------------------------------------------------------------------------- # package main; use strict; use warnings; use Tie::Hash; use Test::More tests => 1; my $hashref = {}; tie %$hashref, 'Tie::StdHash'; $hashref->{Title} = 'foo'; my $w = ClassFoo->new; $w->set_property ('title', $hashref->{Title}); is ($w->get_property ('title'), $hashref->{Title}); Glib-1.320/t/tied_flags.t000644 001750 000024 00000000642 11664366512 016234 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Glib; use Tie::Hash; use Test::More tests => 1; tie my %hash, 'Tie::StdHash'; my $pspec = Glib::ParamSpec->boxed('t', 't', 't', 'Glib::Scalar', [qw/writable readable/]); $hash{flags} = $pspec->get_flags; ok (eval { Glib::ParamSpec->boxed('t', 't', 't', 'Glib::Scalar', $hash{flags}); 1 }); Glib-1.320/t/tied_set_property.t000644 001750 000024 00000002265 11664366512 017702 0ustar00bdmanningstaff000000 000000 #!/usr/bin/perl package main; use strict; use warnings; use Test::More tests => 1; #------------------------------------------------------------------------------ package MaiTai; use strict; use warnings; sub TIESCALAR { my ($class) = @_; return bless {}, $class; } my $mai_tai_store_called; sub STORE { my ($self) = @_; $mai_tai_store_called = 1; } #------------------------------------------------------------------------------ package MyObject; use strict; use warnings; use Glib; use Glib::Object::Subclass Glib::Object::, properties => [ Glib::ParamSpec->int ('myprop', 'myprop', 'Blurb', 0, 100, 0, [qw/writable readable/]), ]; sub INIT_INSTANCE { my $self = shift; tie $self->{'myprop'}, 'MaiTai'; } #------------------------------------------------------------------------------ package main; my $obj = MyObject->new; $mai_tai_store_called = 0; $obj->set (myprop => 50); is ($mai_tai_store_called, 1, 'MaiTai tied store function called'); exit 0; Glib-1.320/t/variant.t000644 001750 000024 00000023036 12636024471 015574 0ustar00bdmanningstaff000000 000000 #!perl use strict; use warnings; use utf8; use Glib qw/TRUE FALSE/; use Test::More; use constant { MIN_INT64 => "-9223372036854775807", MAX_INT64 => "9223372036854775807", MIN_UINT64 => "0", MAX_UINT64 => "18446744073709551615" }; if (Glib->CHECK_VERSION (2, 24, 0)) { plan tests => 211; } else { plan skip_all => 'Need libglib >= 2.24'; } my @leafs = ( [ 'new_boolean', 'get_boolean', 'b', TRUE ], [ 'new_byte', 'get_byte', 'y', 2**8-1 ], [ 'new_int16', 'get_int16', 'n', 2**15-1 ], [ 'new_uint16', 'get_uint16', 'q', 2**16-1 ], [ 'new_int32', 'get_int32', 'i', 2**31-1 ], [ 'new_uint32', 'get_uint32', 'u', 2**32-1 ], [ 'new_int64', 'get_int64', 'x', MAX_INT64 ], [ 'new_uint64', 'get_uint64', 't', MAX_UINT64 ], [ 'new_handle', 'get_handle', 'h', 2**31-1 ], [ 'new_double', 'get_double', 'd', 0.25 ], [ 'new_string', 'get_string', 's', 'äöü⁂üöä' ], [ 'new_object_path', 'get_string', 'o', '/a/b/c' ], [ 'new_signature', 'get_string', 'g', 'ii' ], ); { foreach my $l (@leafs) { my ($ctor, $getter, $type_string, $value) = @$l; note ($ctor); my $v = Glib::Variant->$ctor ($value); isa_ok ($v, 'Glib::Variant'); isa_ok ($v->get_type, 'Glib::VariantType'); ok ($v->is_of_type ($v->get_type)); is ($v->get_type_string, $type_string); ok (!$v->is_container); is ($v->classify, $type_string); is ($v->$getter, $value); } ok (Glib::Variant::is_object_path ('/a/b/c')); ok (Glib::Variant::is_signature ('ii')); } note ('new_variant'); { { my $child = Glib::Variant->new_byte (23); my $wrapper = Glib::Variant->new_variant ($child); isa_ok ($wrapper, 'Glib::Variant'); is ($wrapper->get_type_string, 'v'); is ($wrapper->classify, 'v'); { my $wrapped_child = $wrapper->get_variant; is ($wrapped_child->get_byte, 23); } undef $child; { my $wrapped_child = $wrapper->get_variant; is ($wrapped_child->get_byte, 23); } } { my $child = Glib::Variant->new_byte (23); my $wrapper = Glib::Variant->new_variant ($child); undef $wrapper; is ($child->get_byte, 23); } } note ('new_bytestring'); SKIP: { skip 'new_bytestring', 6 unless Glib->CHECK_VERSION (2, 26, 0); { my $bs = "\x{a3}\x{ff}"; my $v = Glib::Variant->new_bytestring ($bs); isa_ok ($v, 'Glib::Variant'); is ($v->get_type_string, 'ay'); is ($v->classify, 'a'); is ($v->get_bytestring, $bs); } { my $bs = "\x{a3}\x{ff}"; utf8::upgrade ($bs); my $v = Glib::Variant->new_bytestring ($bs); is ($v->get_bytestring, $bs); } { my $bs = "\x{a3}\x{ff}"; utf8::encode ($bs); my $v = Glib::Variant->new_bytestring ($bs); is ($v->get_bytestring, $bs); } } note ('new_maybe'); { my $child_type = 'y'; my $child = Glib::Variant->new_byte (42); { my $wrapper = Glib::Variant->new_maybe ($child_type, undef); isa_ok ($wrapper, 'Glib::Variant'); is ($wrapper->get_type_string, 'my'); is ($wrapper->classify, 'm'); ok (! defined $wrapper->get_maybe); is ($wrapper->n_children, 0); } { my $wrapper = Glib::Variant->new_maybe (undef, $child); isa_ok ($wrapper, 'Glib::Variant'); is ($wrapper->get_type_string, 'my'); is ($wrapper->classify, 'm'); is ($wrapper->get_maybe->get_byte, $child->get_byte); is ($wrapper->n_children, 1); is ($wrapper->get_child_value (0)->get_byte, 42); } { my $wrapper = Glib::Variant->new_maybe ($child_type, $child); isa_ok ($wrapper, 'Glib::Variant'); is ($wrapper->get_type_string, 'my'); is ($wrapper->classify, 'm'); is ($wrapper->get_maybe->get_byte, $child->get_byte); is ($wrapper->n_children, 1); is ($wrapper->get_child_value (0)->get_byte, $child->get_byte); } } note ('new_array'); { my $child_type = 'y'; my $children = [map { Glib::Variant->new_byte ($_) } (23, 42, 65)]; { my $array = Glib::Variant->new_array ($child_type, []); isa_ok ($array, 'Glib::Variant'); is ($array->get_type_string, 'ay'); is ($array->classify, 'a'); is ($array->n_children, 0); } { my $array = Glib::Variant->new_array (undef, $children); isa_ok ($array, 'Glib::Variant'); is ($array->get_type_string, 'ay'); is ($array->classify, 'a'); is ($array->n_children, 3); is ($array->get_child_value (2)->get_byte, $children->[2]->get_byte); } { my $array = Glib::Variant->new_array ($child_type, $children); isa_ok ($array, 'Glib::Variant'); is ($array->get_type_string, 'ay'); is ($array->classify, 'a'); is ($array->n_children, 3); is ($array->get_child_value (2)->get_byte, $children->[2]->get_byte); } } note ('new_tuple'); { my $children = [Glib::Variant->new_byte (23), Glib::Variant->new_string ('forty-two'), Glib::Variant->new_double (0.25)]; { my $tuple = Glib::Variant->new_tuple ([]); isa_ok ($tuple, 'Glib::Variant'); is ($tuple->get_type_string, '()'); is ($tuple->classify, '('); is ($tuple->n_children, 0); } { my $tuple = Glib::Variant->new_tuple ($children); isa_ok ($tuple, 'Glib::Variant'); is ($tuple->get_type_string, '(ysd)'); is ($tuple->classify, '('); is ($tuple->n_children, 3); is ($tuple->get_child_value (2)->get_double, $children->[2]->get_double); } } note ('new_dict_entry'); { my $key = Glib::Variant->new_string ('forty-two'); my $value = Glib::Variant->new_byte (23); { my $entry = Glib::Variant->new_dict_entry ($key, $value); isa_ok ($entry, 'Glib::Variant'); is ($entry->get_type_string, '{sy}'); is ($entry->classify, '{'); is ($entry->get_child_value (1)->get_byte, $value->get_byte); } } note ('lookup_value'); { my $entries = [map { Glib::Variant->new_dict_entry (Glib::Variant->new_string ($_->[0]), Glib::Variant->new_byte ($_->[1])) } (['one' => 1], ['two' => 2], ['four' => 4], ['eight' => 8])]; my $array = Glib::Variant->new_array ('{sy}', $entries); is ($array->lookup_value ('one', 'y')->get_byte, 1); is ($array->lookup_value ('two', undef)->get_byte, 2); ok (! defined $array->lookup_value ('fourr', undef)); } note ('printing and parsing'); { { my $a = Glib::Variant->new_byte (23); my $text = $a->print (TRUE); is ($text, 'byte 0x17'); is (Glib::Variant::parse (undef, $text)->get_byte, 23); is (Glib::Variant::parse ('y', $text)->get_byte, 23); } SKIP: { skip 'parse error tests', 1 unless Glib->CHECK_VERSION (2, 28, 0); my $text = 'byte 0x17'; eval { Glib::Variant::parse ('b', $text)->get_byte }; ok (Glib::Error::matches ($@, 'Glib::Variant::ParseError', 'type-error')); } } note ('misc.'); { my $a = Glib::Variant->new_byte (23); my $b = Glib::Variant->new_byte (42); ok (defined $a->get_size); ok (defined $a->hash); ok ($a->equal ($a)); ok (! $a->equal ($b)); is ($a->get_normal_form->get_byte, $a->get_byte); ok ($a->is_normal_form); is ($a->byteswap->get_byte, $a->get_byte); SKIP: { skip 'compare', 2 unless Glib->CHECK_VERSION (2, 26, 0); cmp_ok ($a->compare ($b), '<', 0); cmp_ok ($b->compare ($a), '>', 1); } } note ('convenience constructor and accessor'); { note (' leafs'); foreach my $l (@leafs) { my ($ctor, $getter, $type_string, $value) = @$l; my $v = Glib::Variant->new ($type_string, $value); is ($v->get_type_string, $type_string); is ($v->get ($type_string), $value); } note (' list context'); { my ($v) = Glib::Variant->new ('i', 23); is ($v->get ('i'), 23); my ($v1, $v2, $v3) = Glib::Variant->new ('ids', 23, 0.25, 'äöü'); is ($v1->get ('i'), 23); is ($v2->get ('d'), 0.25); is ($v3->get ('s'), 'äöü'); } note (' variant'); { my $child = Glib::Variant->new_byte (23); my $wrapper = Glib::Variant->new ('v', $child); is ($wrapper->get_type_string, 'v'); { my $wrapped_child = $wrapper->get ('v'); is ($wrapped_child->get_byte, 23); } } note (' array'); { my $v1 = Glib::Variant->new ('as', ['äöü', 'Perl', '💑']); is_deeply ($v1->get ('as'), ['äöü', 'Perl', '💑']); my $v2 = Glib::Variant->new ('aai', [[23, 42], [2, 3], [4, 2]]); is_deeply ($v2->get ('aai'), [[23, 42], [2, 3], [4, 2]]); is (Glib::Variant->new ('ai', [])->n_children, 0); is (Glib::Variant->new ('ai', undef)->n_children, 0); } note (' maybe'); { my $v1 = Glib::Variant->new ('mi', undef); ok (! defined $v1->get ('mi')); my $v2 = Glib::Variant->new ('mi', 23); is ($v2->get ('mi'), 23); my $v3 = Glib::Variant->new ('mai', undef); ok (! defined $v3->get ('mai')); my $v4 = Glib::Variant->new ('mai', [23, 42]); is_deeply ($v4->get ('mai'), [23, 42]); } note (' tuple'); { my $v1 = Glib::Variant->new ('()'); is ($v1->n_children, 0); my $v2 = Glib::Variant->new ('(si)', ['äöü', 23]); is_deeply ($v2->get ('(si)'), ['äöü', 23]); my $v3 = Glib::Variant->new ('a(si)', [['äöü', 23], ['Perl', 42], ['💑', 2342]]); is_deeply ($v3->get ('a(si)'), [['äöü', 23], ['Perl', 42], ['💑', 2342]]); } note (' dict entry'); { my $v1 = Glib::Variant->new ('{si}', ['äöü', 23]); is_deeply ($v1->get ('{si}'), ['äöü', 23]); my $v2 = Glib::Variant->new ('a{si}', [['äöü', 23], ['Perl', 42], ['💑', 2342]]); is_deeply ($v2->get ('a{si}'), [['äöü', 23], ['Perl', 42], ['💑', 2342]]); my $v3 = Glib::Variant->new ('a{si}', {'äöü' => 23, 'Perl' => 42, '💑' => 2342}); is_deeply ($v2->get ('a{si}'), [['äöü', 23], ['Perl', 42], ['💑', 2342]]); } } Glib-1.320/lib/Glib/000755 001750 000024 00000000000 12636025764 015125 5ustar00bdmanningstaff000000 000000 Glib-1.320/lib/Glib.pm000644 001750 000024 00000065164 12636024574 015475 0ustar00bdmanningstaff000000 000000 # Copyright (C) 2003-2013 by the gtk2-perl team (see the file AUTHORS for # the full list) # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # # $Id$ # package Glib; use 5.008; use strict; use warnings; use Exporter; require DynaLoader; our @ISA = qw(DynaLoader Exporter); our $VERSION = '1.320'; use constant { TRUE => 1, FALSE => !1, # can't use !TRUE at this point SOURCE_CONTINUE => 1, SOURCE_REMOVE => !1, G_PRIORITY_HIGH => -100, G_PRIORITY_DEFAULT => 0, G_PRIORITY_HIGH_IDLE => 100, G_PRIORITY_DEFAULT_IDLE => 200, G_PRIORITY_LOW => 300, G_PARAM_READWRITE => [qw/readable writable/], }; # export nothing by default. # export functions and constants by request. our %EXPORT_TAGS = ( constants => [qw/ TRUE FALSE SOURCE_CONTINUE SOURCE_REMOVE G_PRIORITY_HIGH G_PRIORITY_DEFAULT G_PRIORITY_HIGH_IDLE G_PRIORITY_DEFAULT_IDLE G_PRIORITY_LOW G_PARAM_READWRITE /], functions => [qw/ filename_to_unicode filename_from_unicode filename_to_uri filename_from_uri filename_display_name filename_display_basename /], ); our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{all} = \@EXPORT_OK; sub dl_load_flags { $^O eq 'darwin' ? 0x00 : 0x01 } Glib->bootstrap ($VERSION); package Glib::Flags; use overload 'bool' => \&bool, '+' => \&union, '|' => \&union, '-' => \&sub, '>=' => \&ge, '==' => \&eq, 'eq' => \&eq, '!=' => \&ne, 'ne' => \&ne, '*' => \&intersect, '&' => \&intersect, '/' => \&xor, '^' => \&xor, '@{}' => \&as_arrayref, '""' => sub { "[ @{$_[0]} ]" }, fallback => 1; package Glib::Error; use overload '""' => sub { $_[0]->message.$_[0]->location }, fallback => 1; sub location { $_[0]->{location} } sub message { $_[0]->{message} } sub domain { $_[0]->{domain} } sub value { $_[0]->{value} } sub code { $_[0]->{code} } package Glib::Bytes; use overload '""' => sub { $_[0]->get_data }, fallback => 1; package Glib::Object::Property; use Carp; sub TIESCALAR { # in the array reference the elements are: # [0] Glib::Object # [1] property name bless [ $_[1], $_[2] ], $_[0]; } sub STORE { croak 'property '.$_[0][1].' is read-only'; } sub FETCH { '[write-only]'; } package Glib::Object::Property::Readable; our @ISA = qw/Glib::Object::Property/; sub FETCH { $_[0][0]->get_property ($_[0][1]); } package Glib::Object::Property::Writable; our @ISA = qw/Glib::Object::Property/; sub STORE { $_[0][0]->set_property ($_[0][1], $_[1]); } package Glib::Object::Property::ReadWrite; our @ISA = qw/Glib::Object::Property/; *FETCH = \&Glib::Object::Property::Readable::FETCH; *STORE = \&Glib::Object::Property::Writable::STORE; package Glib::Object; use Carp; sub tie_properties { my $self = shift; # the object my $all = shift; # add all properties, up heirarchy my @props = $self->list_properties; my $package = ref $self; my $name; foreach my $prop (@props) { # skip to next if it doesn't belong to this package and # they don't want everything tied next if ($prop->{owner_type} ne $package and not $all); $name = $prop->{name}; $name =~ s/-/_/g; carp "overwriting existing non-tied hash key $name" if (exists ($self->{$name}) and not tied $self->{$name}); if ($prop->{flags} >= ["readable", "writable"]) { tie $self->{$name}, 'Glib::Object::Property::ReadWrite', $self, $name; } elsif ($prop->{flags} >= "readable") { tie $self->{$name}, 'Glib::Object::Property::Readable', $self, $name; } elsif ($prop->{flags} >= "writable") { tie $self->{$name}, 'Glib::Object::Property::Writable', $self, $name; } else { # if it's not readable and not writable what is it? } } } package Glib::Object::_LazyLoader; use strict; no strict qw(refs); use vars qw($AUTOLOAD); push @Carp::CARP_NOT, __PACKAGE__; # These two overrides won't keep explicit calls to UNIVERSAL::(isa|can) # from breaking if called before anything is loaded, but those should # be quite rare. sub isa { # we really shouldn't get in here at all if $_[0] is undefined. _load (ref($_[0]) || $_[0]); $_[0]->SUPER::isa ($_[1]); } sub can { # we really shouldn't get in here at all if $_[0] is undefined. _load (ref($_[0]) || $_[0]); $_[0]->SUPER::can ($_[1]); } sub AUTOLOAD { (my $method = $AUTOLOAD) =~ s/^.*:://; (my $lazy_class = $AUTOLOAD) =~ s/::[^:]*$//; my $object_or_type = shift; _load ($lazy_class); die "Something is very broken, couldn't lazy load $lazy_class" if $object_or_type->isa (__PACKAGE__); # try again return $object_or_type->$method (@_); } package Glib::Variant; my %LEAF_HANDLERS = ( b => ['new_boolean', 'get_boolean'], y => ['new_byte', 'get_byte'], n => ['new_int16', 'get_int16'], q => ['new_uint16', 'get_uint16'], i => ['new_int32', 'get_int32'], u => ['new_uint32', 'get_uint32'], x => ['new_int64', 'get_int64'], t => ['new_uint64', 'get_uint64'], h => ['new_handle', 'get_handle'], d => ['new_double', 'get_double'], s => ['new_string', 'get_string'], o => ['new_object_path', 'get_string'], g => ['new_signature', 'get_string'], ); # Documented in GVariant.xs. sub new { my ($class, $format, @values) = @_; if (!defined $format || $format eq '') { return; } my ($ts, $format_rest) = Glib::VariantType::string_scan ($format); my ($value, @values_rest) = @values; my $t = Glib::VariantType->new ($ts); my $v; if ($t->is_basic) { my $ctor = $LEAF_HANDLERS{$t->get_string}->[0]; $v = Glib::Variant->$ctor ($value); } elsif ($t->is_variant) { $v = Glib::Variant->new_variant ($value); } elsif ($t->is_array) { my $et = $t->element; my @children; if (eval { defined $#$value }) { @children = map { Glib::Variant->new ($et->get_string, $_) } @$value; } elsif ($et->is_dict_entry && eval { defined scalar %$value }) { while (my ($ek, $ev) = each %$value) { push @children, Glib::Variant->new ($et->get_string, [$ek, $ev]); } } else { Carp::croak ('Expected an array ref'); } $v = Glib::Variant->new_array ($et, \@children); } elsif ($t->is_maybe) { my $et = $t->element; my $child = defined $value ? Glib::Variant->new ($et->get_string, $value) : undef; $v = Glib::Variant->new_maybe ($et, $child); } elsif ($t->is_tuple) { my $n = $t->n_items; if ($n && !eval { $#$value+1 == $n }) { Carp::croak ("Expected an array ref with $n elements"); } my @children; for (my ($i, $et) = (0, $t->first); $et; $i++, $et = $et->next) { push @children, Glib::Variant->new ($et->get_string, $value->[$i]); } $v = Glib::Variant->new_tuple (\@children); } elsif ($t->is_dict_entry) { my $kt = $t->first; my $vt = $kt->next; my $kv = Glib::Variant->new ($kt->get_string, $value->[0]); my $vv = Glib::Variant->new ($vt->get_string, $value->[1]); $v = Glib::Variant->new_dict_entry ($kv, $vv); } else { Carp::croak ("Cannot handle the part '$ts' in the format string '$format'"); } return wantarray ? ($v, Glib::Variant->new ($format_rest, @values_rest)) : $v; } # Documented in GVariant.xs. sub get { my ($v, $format) = @_; if (!defined $format || $format eq '') { return; } my ($ts, $format_rest) = Glib::VariantType::string_scan ($format); if (defined $format_rest) { Carp::carp ("Unhandled rest of format string detected: '$format_rest'"); } my $t = Glib::VariantType->new ($ts); my $value; if ($t->is_basic) { my $getter = $LEAF_HANDLERS{$t->get_string}->[1]; $value = $v->$getter; } elsif ($t->is_variant) { $value = $v->get_variant; } elsif ($t->is_array) { my $et = $t->element; my @children; foreach my $i (1 .. $v->n_children) { push @children, $v->get_child_value ($i-1)->get ($et->get_string); } $value = \@children; } elsif ($t->is_maybe) { my $et = $t->element; my $wrapper = $v->get_maybe; $value = defined $wrapper ? $wrapper->get ($et->get_string) : undef; } elsif ($t->is_tuple) { my $n = $t->n_items; my @children; for (my ($i, $et) = (0, $t->first); $et; $i++, $et = $et->next) { push @children, $v->get_child_value ($i)->get ($et->get_string); } $value = \@children; } elsif ($t->is_dict_entry) { my $kt = $t->first; my $vt = $kt->next; my $kv = $v->get_child_value (0)->get ($kt->get_string); my $vv = $v->get_child_value (1)->get ($vt->get_string); $value = [$kv, $vv]; } else { Carp::croak ("Cannot handle the part '$ts' in the format string '$format'"); } return $value; } package Glib; 1; __END__ =head1 NAME Glib - Perl wrappers for the GLib utility and Object libraries =head1 SYNOPSIS use Glib; =head1 ABSTRACT This module provides perl access to GLib and GLib's GObject libraries. GLib is a portability and utility library; GObject provides a generic type system with inheritance and a powerful signal system. Together these libraries are used as the foundation for many of the libraries that make up the Gnome environment, and are used in many unrelated projects. =head1 DESCRIPTION This wrapper attempts to provide a perlish interface while remaining as true as possible to the underlying C API, so that any reference materials you can find on using GLib may still apply to using the libraries from perl. This module also provides facilities for creating wrappers for other GObject-based libraries. The L section contains pointers to all sorts of good information. =head1 PERL VERSUS C GLib provides to C programs many of the same facilities Perl offers natively. Where GLib's functionality overlaps Perl's, Perl's is favored. Some concepts have been eliminated entirely, as Perl is a higher-level language than C. In other instances we've had to add or change APIs to make sense in Perl. Here's a quick run-down: =head2 Perl Already Does That The GLib types GList (a doubly-linked list), GSList (singly-linked list), GHashTable, GArray, etc have all been replaced by native Perl datatypes. In fact, many functions which take GLists or arrays simply accept lists on the Perl stack. For the most part, GIOChannels are no more functional than Perl file handles, so you won't see any GIOChannels. GClosures are not visible at the Perl level, because Perl code references do the same thing. Just about any function taking either a C function pointer or a GClosure will accept a code reference in Perl. (In fact, you can probably get away with just a subroutine name in many spots, provided you aren't using strict subs.) =head2 Don't Worry About That Some concepts have been eliminated; you need never worry about reference-counting on GObjects or having to free GBoxed structures. Perl is a garbage-collected language, and we've put a lot of work into making the bindings take care of memory for you in a way that feels natural to a Perl developer. You won't see GValues in Perl (that's just a C structure with Perl scalar envy, anyway). =head2 This Is Now That Other GLib concepts have been converted to an analogous Perl concept. The GType id will never be seen in Perl, as the package name serves that purpose. Several packages corresponding to the GTypes of the fundamental types have been registered for you: G_TYPE_STRING Glib::String G_TYPE_INT Glib::Int G_TYPE_UINT Glib::UInt G_TYPE_DOUBLE Glib::Double G_TYPE_BOOLEAN Glib::Boolean The remaining fundamentals (char/uchar, short, float, etc) are also registered so that we can properly interact with properties of C objects, but perl really only uses ints, uints, and doubles. Oh, and we created a GBoxed type for Perl scalars so you can use scalars where any boxed type would be allowed (e.g. GtkTreeModel columns): Glib::Scalar Functions that can return false and set a GError in C raise an exception in Perl, using an exception object based on the GError for $@; see L. Trapping exceptions in signals is a sticky issue, so they get their own section; see L. Enumerations and flags are treated as strings and arrays of strings, respectively. GLib provides a way to register nicknames for enumeration values, and the Perl bindings use these nicknames for the real values, so that we never have to deal with numbers in Perl. This can get a little cumbersome for bitfields, but it's very nice when you forget a flag value, as the bindings will tell you what values are accepted when you pass something invalid. Also, the bindings consider the - and _ characters to be equivalent, so that signal and property names can be properly stringified by the => operator. For example, the following are equivalent: # property foo-matic of type FooType, using the # value FOO_SOMETHING_COOL. its nickname would be # 'something-cool'. you may use either the full # name or the nickname when supplying values to perl. $object->set ('foo-matic', 'FOO_SOMETHING_COOL'); $object->set ('foo_matic', 'something_cool'); $object->set (foo_matic => 'something-cool'); Beware that Perl will always return to you the nickname form, with the dash. Flags have some additional magic abilities in the form of overloaded operators: + or | union of two flagsets ("add") - difference of two flagsets ("sub", "remove") * or & intersection of two bitsets ("and") / or ^ symmetric difference ("xor", you will rarely need this) >= contains-operator ("is the left set a superset of the right set?") == equality In addition, flags in boolean context indicate whether they are empty or not, which allows you to write common operations naturally: $widget->set_events ($widget->get_events - "motion_notify_mask"); $widget->set_events ($widget->get_events - ["motion_notify_mask", "button_press_mask"]); # shift pressed (both work, it's a matter of taste) if ($event->state >= "shift-mask") { ... if ($event->state * "shift-mask") { ... # either shift OR control pressed? if ($event->state * ["shift-mask", "control-mask"]) { ... # both shift AND control pressed? if ($event->state >= ["shift-mask", "control-mask"]) { ... In general, C<+> and C<-> work as expected to add or remove flags. To test whether I bits are set in a mask, you use C<$mask * ...>, and to test whether I bits are set in a mask, you use C<< $mask >= ... >>. When dereferenced as an array C<@$flags> or C<< $flags->[...] >>, you can access the flag values directly as strings (but you are not allowed to modify the array), and when stringified C<"$flags"> a flags value will output a human-readable version of its contents. =head2 It's All the Same For the most part, the remaining bits of GLib are unchanged. GMainLoop is now Glib::MainLoop, GObject is now Glib::Object, GBoxed is now Glib::Boxed, etc. =head1 FILENAMES, URIS AND ENCODINGS Perl knows two datatypes, unicode text and binary bytes. Filenames on a system that doesn't use a utf-8 locale are often stored in a local encoding ("binary bytes"). Gtk+ and descendants, however, internally work in unicode most of the time, so when feeding a filename into a GLib/Gtk+ function that expects a filename, you first need to convert it from the local encoding to unicode. This involves some elaborate guessing, which perl currently avoids, but GLib and Gtk+ do. As an exception, some Gtk+ functions want a filename in local encoding, but the perl interface usually works around this by automatically converting it for you. In short: Everything should be in unicode on the perl level. The following functions expose the conversion algorithm that GLib uses. These functions are only necessary when you want to use perl functions to manage filenames returned by a GLib/Gtk+ function, or when you feed filenames into GLib/Gtk+ functions that have their source outside your program (e.g. commandline arguments, readdir results etc.). These functions are available as exports by request (see L), and also support method invocation syntax for pathological consistency with the OO syntax of the rest of the bindings. =over 4 =item $filename = filename_to_unicode $filename_in_local_encoding =item $filename = Glib->filename_to_unicode ($filename_in_local_encoding) Convert a perl string that supposedly contains a filename in local encoding into a filename represented as unicode, the same way that GLib does it internally. Example: $gtkfilesel->set_filename (filename_to_unicode $ARGV[1]); This function will croak() if the conversion cannot be made, e.g., because the utf-8 is invalid. =item $filename_in_local_encoding = filename_from_unicode $filename =item $filename_in_local_encoding = Glib->filename_from_unicode ($filename) Converts a perl string containing a filename into a filename in the local encoding in the same way GLib does it. Example: open MY, "<", filename_from_unicode $gtkfilesel->get_filename; =back It might be useful to know that perl currently has no policy at all regarding filename issues, if your scalar happens to be in utf-8 internally it will use utf-8, if it happens to be stored as bytes, it will use it as-is. When dealing with filenames that you need to display, there is a much easier way, as of Glib 1.120 and glib 2.6.0: =over 4 =item $uft8_string = filename_display_name ($filename) =item $uft8_string = filename_display_basename ($filename) Given a I<$filename> in filename encoding, return the filename, or just the file's basename, in utf-8. Unlike the other functions described above, this one is guaranteed to return valid utf-8, but the conversion is not necessarily reversible. These functions are intended to be used for failsafe display of filenames, for example in gtk+ labels. Since glib 2.6, Glib 1.12 =back The following convert filenames to and from URI encoding. (See also L.) =over 4 =item $string = filename_to_uri ($filename, $hostname) =item $string = Glib->filename_to_uri ($filename, $hostname) Return a "file://" schema URI for a filename. Unsafe and non-ascii chars in C<$filename> are escaped with URI "%" forms. C<$filename> must be an absolute path as a byte string in local filesystem encoding. C<$hostname> is a utf-8 string, or empty or C for no host specified. For example, filename_to_uri ('/my/x%y//foo.html', undef); # returns 'file:///my/x%25y/%3Cdir%3E/foo.html' If C<$filename> is a relative path or C<$hostname> doesn't look like a hostname then C croaks with a C. When using the class style C<< Glib->filename_to_uri >> remember that the C<$hostname> argument is mandatory. If you forget then it looks like a 2-argument call with filename of "Glib" and hostname of what you meant to be the filename. =item $filename = filename_from_uri ($uri) =item ($filename, $hostname) = filename_from_uri ($uri) Extract the filename and hostname from a "file://" schema URI. In scalar context just the filename is returned, in array context both filename and hostname are returned. The filename returned is bytes in the local filesystem encoding and with the OS path separator character. The hostname returned is utf-8. For example, ($f,$h) = filename_from_uri ('file://foo.com/r%26b/bar.html'); # returns '/r&b/bar.html' and 'foo.com' on Unix If C<$uri> is not a "file:", or is mal-formed, or the hostname part doesn't look like a host name then C croaks with a C. =back =head1 EXCEPTIONS The C language doesn't support exceptions; GLib is a C library, and of course doesn't support exceptions either. In Perl, we use die and eval to raise and trap exceptions as a rather common practice. So, the bindings have to work a little black magic behind the scenes to keep GLib from exploding when the Perl program uses exceptions. Unfortunately, a little of this magic has to leak out to where you can see it at the Perl level. Signal and event handlers are run in an eval context; if an exception occurs in such a handler and you don't catch it, Perl will report that an error occurred, and then go on about its business like nothing happened. You may register subroutines as exception handlers, to be called when such an exception is trapped. Another function removes them for you. $tag = Glib->install_exception_handler (\&my_handler); Glib->remove_exception_handler ($tag); The exception handler will get a fresh copy of the $@ of the offending exception on the argument stack, and is expected to return non-zero if the handler is to remain installed. If it returns false, the handler will be removed. sub my_handler { if ($_[0] =~ m/ftang quisinart/) { clean_up_after_ftang (); } 1; # live to fight another day } You can register as many handlers as you like; they will all run independently. An important thing to remember is that exceptions do not cross main loops. In fact, exceptions are completely distinct from main loops. If you need to quit a main loop when an exception occurs, install a handler that quits the main loop, but also ask yourself if you are using exceptions for flow control or exception handling. =head1 LOG MESSAGES GLib's g_log function provides a flexible mechanism for reporting messages, and most GLib-based C libraries use this mechanism for warnings, assertions, critical messages, etc. The Perl bindings offer a mechanism for routing these messages through Perl's native system, warn() and die(). Extensions should register the log domains they wrap for this to happen fluidly. [FIXME say more here] =head1 64 BIT INTEGERS Since perl's integer data type can only hold 32 bit values on all 32 bit machines and even on some 64 bit machines, Glib converts 64 bit integers to and from strings if necessary. These strings can then be used to feed one of the various big integer modules. Make sure you don't let your strings get into numerical context before passing them into a Glib function because in this case, perl will convert the number to scientific notation which at this point is not understood by Glib's converters. Here is an overview of what big integer modules are available. First of all, there's Math::BigInt. It has everything you will ever need, but its pure-Perl implementation is also rather slow. There are multiple ways around this, though. =over =item L L can help avoid the glacial speed of vanilla L. Recent versions of L will automatically use L in place of L when available. Other options include L or L, which however have much larger dependencies. =item L Then there's L, which uses native Perl integer operations as long as Perl integers have sufficient range, and upgrades itself to L when Perl integers would overflow. This must be used in place of L. =item L / L / L Finally, there's the bigint/bignum/bigfloat pragmata, which automatically load the corresponding Math:: modules and which will autobox constants. bignum/bigint will automatically use L if it's available. =back =head1 EXPORTS For the most part, gtk2-perl avoids exporting things. Nothing is exported by default, but some functions and constants in Glib are available by request; you can also get all of them with the export tag "all". =over =item Tag: constants TRUE FALSE SOURCE_CONTINUE SOURCE_REMOVE G_PRIORITY_HIGH G_PRIORITY_DEFAULT G_PRIORITY_HIGH_IDLE G_PRIORITY_DEFAULT_IDLE G_PRIORITY_LOW G_PARAM_READWRITE =item Tag: functions filename_from_unicode filename_to_unicode filename_from_uri filename_to_uri filename_display_basename filename_display_name =back =head1 SEE ALSO L explains how to create your own gobject subclasses in Perl. L lists the automatically-generated API reference for the various packages in Glib. This module is the basis for the Gtk2 module, so most of the references you'll be able to find about this one are tied to that one. The perl interface aims to be very simply related to the C API, so see the C API reference documentation: GLib - http://developer.gnome.org/doc/API/2.0/glib/ GObject - http://developer.gnome.org/doc/API/2.0/gobject/ This module serves as the foundation for any module which needs to bind GLib-based C libraries to perl. Glib::devel - Binding developer's overview of Glib's internals Glib::xsapi - internal API reference for GPerl Glib::ParseXSDoc - extract API docs from xs sources. Glib::GenPod - turn the output of Glib::ParseXSDoc into POD Glib::MakeHelper - Makefile.PL utilities for Glib-based extensions Yet another document, available separately, ties it all together: http://gtk2-perl.sourceforge.net/doc/binding_howto.pod.html For gtk2-perl itself, see its website at gtk2-perl - http://gtk2-perl.sourceforge.net/ A mailing list exists for discussion of using gtk2-perl and related modules. Archives and subscription information are available at http://lists.gnome.org/. =head1 AUTHORS =encoding utf8 muppet, Escott at asofyet dot orgE, who borrowed heavily from the work of Göran Thyni, Egthyni at kirra dot netE and Guillaume Cottenceau Egc at mandrakesoft dot comE on the first gtk2-perl module, and from the sourcecode of the original gtk-perl and pygtk projects. Marc Lehmann Epcg at goof dot comE did lots of great work on the magic of making Glib::Object wrapper and subclassing work like they should. Ross McFarland wrote quite a bit of the documentation generation tools. Torsten Schoenfeld contributed little patches and tests here and there. =head1 COPYRIGHT AND LICENSE Copyright 2003-2011 by muppet and the gtk2-perl team 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-1.320/lib/Glib/CodeGen.pm000644 001750 000024 00000051357 12636024625 016775 0ustar00bdmanningstaff000000 000000 package Glib::CodeGen; use strict; use warnings; use Carp; use IO::File; our $VERSION = '1.320'; # type handlers should look like this: # sub gen_foo_stuff { # my ($typemacro, $classname, $base, $package) = @_; # ... # } # # DO NOT manipulate this data structure directly. Use add_type_handler(). my %type_handler = ( GEnum => \&gen_enum_stuff, GFlags => \&gen_flags_stuff, GBoxed => \&gen_boxed_stuff, GObject => \&gen_object_stuff, # we treat GInterfaces as GObjects for these purposes. GInterface => \&gen_object_stuff, GError => \&gen_error_domain_stuff, ); =head1 NAME Glib::CodeGen - code generation utilities for Glib-based bindings. =head1 SYNOPSIS # usually in Makefile.PL use Glib::CodeGen; # most common, use all defaults Glib::CodeGen->parse_maps ('myprefix'); Glib::CodeGen->write_boot; # more exotic, change everything Glib::CodeGen->parse_maps ('foo', input => 'foo.maps', header => 'foo-autogen.h', typemap => 'foo.typemap', register => 'register-foo.xsh'); Glib::CodeGen->write_boot (filename => 'bootfoo.xsh', glob => 'Foo*.xs', ignore => '^(Foo|Foo::Bar)$'); # add a custom type handler (rarely necessary) Glib::CodeGen->add_type_handler (FooType => \&gen_foo_stuff); # (see the section EXTENDING TYPE SUPPORT for more info.) =head1 DESCRIPTION This module packages some of the boilerplate code needed for performing code generation typically used by perl bindings for gobject-based libraries, using the Glib module as a base. The default output filenames are in the subdirectory 'build', which usually will be present if you are using ExtUtils::Depends (as most Glib-based extensions probably should). =head2 METHODS =over =item Glib::CodeGen->write_boot; =item Glib::CodeGen->write_boot (KEY => VAL, ...) Many GObject-based libraries to be bound to perl will be too large to put in a single XS file; however, a single PM file typically only bootstraps one XS file's code. C generates an XSH file to be included from the BOOT section of that one bootstrapped module, calling the boot code for all the other XS files in the project. Options are passed to the function in a set of key/val pairs, and all options may default. filename the name of the output file to be created. the default is 'build/boot.xsh'. glob a glob pattern that specifies the names of the xs files to scan for MODULE lines. the default is 'xs/*.xs'. xs_files use this to supply an explicit list of file names (as an array reference) to use instead of a glob pattern. the default is to use the glob pattern. ignore regular expression matching any and all module names which should be ignored, i.e. NOT included in the list of symbols to boot. this parameter is extremely important for avoiding infinite loops at startup; see the discussion for an explanation and rationale. the default is '^[^:]+$', or, any name that contains no colons, i.e., any toplevel package name. This function performs a glob (using perl's builtin glob operator) on the pattern specified by the 'glob' option to retrieve a list of file names. It then scans each file in that list for lines matching the pattern "^MODULE" -- that is, the MODULE directive in an XS file. The module name is pulled out and matched against the regular expression specified by the ignore parameter. If this module is not to be ignored, we next check to see if the name has been seen. If not, the name will be converted to a boot symbol (basically, s/:/_/ and prepend "boot_") and this symbol will be added to a call to GPERL_CALL_BOOT in the generated file; it is then marked as seen so we don't call it again. What is this all about, you ask? In order to bind an XSub to perl, the C function must be registered with the interpreter. This is the function of the "boot" code, which is typically called in the bootstrapping process. However, when multiple XS files are used with only one PM file, some other mechanism must call the boot code from each XS file before any of the function therein will be available. A typical setup for a multiple-XS, single-PM module will be to call the various bits of boot code from the BOOT: section of the toplevel module's XS file. To use Gtk2 as an example, when you do 'use Gtk2', Gtk2.pm calls bootstrap on Gtk2, which calls the C function boot_Gtk2. This function calls the boot symbols for all the other xs files in the module. The distinction is that the toplevel module, Gtk2, has no colons in its name. C generates the boot function's name by replacing the colons in the MODULE name with underscores and prepending "boot_". We need to be careful not to include the boot code for the bootstrapped module, (say Toplevel, or Gtk2, or whatever) because the bootstrap code in Toplevel.pm will call boot_Toplevel when loaded, and boot_Toplevel should actually include the file we are creating here. The default value for the ignore parameter ignores any name not containing colons, because it is assumed that this will be a toplevel module, and any other packages/modules it boots will be I this namespace, i.e., they will contain colons. This assumption holds true for Gtk2 and Gnome2, but obviously fails for something like Gnome2::Canvas. To boot that module properly, you must use a regular expression such as "^Gnome2::Canvas$". Note that you can, of course, match more than just one name, e.g. "^(Foo|Foo::Bar)$", if you wanted to have Foo::Bar be included in the same dynamically loaded object but only be booted when absolutely necessary. (If you get that to work, more power to you.) Also, since this code scans for ^MODULE, you must comment the MODULE section out with leading # marks if you want to hide it from C. =cut sub write_boot { my $class = shift; my %opts = ( ignore => '^[^:]+$', # ignore package with no colons in it filename => 'build/boot.xsh', 'glob' => 'xs/*.xs', @_, ); my $ignore = $opts{ignore}; my $file = IO::File->new (">$opts{filename}") or carp "Cannot write $opts{filename}: $!"; print $file "\n\n/* This file is automatically generated, any changes made here will be lost! */\n\n"; my %boot=(); my @xs_files = 'ARRAY' eq ref $opts{xs_files} ? @{ $opts{xs_files} } : glob $opts{'glob'}; foreach my $xsfile (@xs_files) { my $in = IO::File->new ($xsfile) or die "can't open $xsfile: $!\n"; while (<$in>) { next unless m/^MODULE\s*=\s*(\S+)/; #warn "found $1 in $&\n"; my $package = $1; next if $package =~ m/$ignore/; $package =~ s/:/_/g; my $sym = "boot_$package"; print $file "GPERL_CALL_BOOT ($sym);\n" unless $boot{$sym}; $boot{$sym}++; } close $in; } close $file; } =item Glib::CodeGen->parse_maps (PREFIX, [KEY => VAL, ...]) Convention within Glib/Gtk2 and friends is to use preprocessor macros in the style of SvMyType and newSVMyType to get values in and out of perl, and to use those same macros from both hand-written code as well as the typemaps. However, if you have a lot of types in your library (such as the nearly 200 types in Gtk+ 2.x), then writing those macros becomes incredibly tedious, especially so when you factor in all of the variants and such. So, this function can turn a flat file containing terse descriptions of the types into a header containing all the cast macros, a typemap file using them, and an XSH file containing the proper code to register each of those types (to be included by your module's BOOT code). The I is mandatory, and is used in some of the resulting filenames, You can also override the defaults by providing key=>val pairs: input input file name. default is 'maps'. if this key's value is an array reference, all the filenames in the array will be scanned. header name of the header file to create, default is build/$prefix-autogen.h typemap name of the typemap file to create, default is build/$prefix.typemap register name of the xsh file to contain all of the type registrations, default is build/register.xsh the maps file is a table of type descriptions, one per line, with fields separated by whitespace. the fields should be: TYPE macro e.g., GTK_TYPE_WIDGET class name e.g. GtkWidget, name of the C type base type one of GObject, GBoxed, GEnum, GFlags. To support other base types, see EXTENDING TYPE SUPPORT for info on on how to add a custom type handler. package name of the perl package to which this class name should be mapped, e.g. Gtk2::Widget As a special case, you can also use this same format to register error domains; in this case two of the four columns take on slightly different meanings: domain macro e.g., GDK_PIXBUF_ERROR enum type macro e.g., GDK_TYPE_PIXBUF_ERROR base type GError package name of the Perl package to which this class name should be mapped, e.g., Gtk2::Gdk::Pixbuf::Error. =back =cut # when we parse the maps, type handlers will call several helper functions # to add header lines, typemaps, and boot lines. we store those here. # these are private. see the add_foo functions, below. # there my (@header, @typemap, @input, @output, @boot); sub parse_maps { my $class = shift; my $prefix = shift; my %props = ( input => 'maps', header => "build/$prefix-autogen.h", typemap => "build/$prefix.typemap", register => 'build/register.xsh', @_, ); local *IN; local *OUT; my %seen = (); @header = (); @typemap = (); @input = (); @output = (); @boot = (); my @files = 'ARRAY' eq ref $props{input} ? @{ $props{input} } : $props{input}; foreach my $file (@files) { open IN, "< $file" or die "can't open $file for reading: $!\n"; my $n = 0; while () { chomp; s/#.*//; my ($typemacro, $classname, $base, $package) = split; next unless defined $package; if (exists $type_handler{$base}) { $type_handler{$base}->($typemacro, $classname, $base, $package); $seen{$base}++; } else { warn "unhandled type $typemacro $classname $base $package\n"; $seen{unhandled}++; } $n++; } close IN; #print "Loaded $n type definitions from $file\n"; } # create output # the header open OUT, "> $props{header}" or die "can't open $props{header} for writing: $!\n"; print OUT join("\n", "/* This file is automatically generated. Any changes made here will be lost. */\n", "/* This header defines simple perlapi-ish macros for creating SV wrappers", " * and extracting the GPerl value from SV wrappers. These macros are used", " * by the autogenerated typemaps, and are defined here so that you can use", " * the same logic anywhere in your code (e.g., if you handle the argument", " * stack by hand instead of using the typemap). */\n", @header, ); close OUT; # the typemaps open OUT, "> $props{typemap}" or die "can't open $props{typemap} for writing: $!\n"; print OUT join("\n", "# This file is automatically generated. Any changes made here will be lost.", "# This typemap is a trivial one-to-one mapping of each type, to avoid the", "# need for bizarre typedefs and other tricks often used with XS.", "TYPEMAP\n", @typemap, "\nINPUT\n", @input, "\nOUTPUT\n", @output); close OUT; # the boot code open OUT, "> $props{register}" or die "can't open $props{register} for writing: $!\n"; print OUT join("\n", "/* This file is automatically generated. Any changes made here will be lost. */", @boot, ); print OUT "\n"; close OUT; # mini report to stdout # foreach (sort keys %seen) { # printf " %3d %s\n", $seen{$_}, $_; # } # fin. } =head1 EXTENDING TYPE SUPPORT C uses the base type entry in each maps record to decide how to generate output for that type. In the base module, type support is included for the base types provided by Glib. It is easy to add support for your own types, by merely adding a type handler. This type handler will call utility functions to add typemaps, BOOT lines, and header lines. =over =item Glib::CodeGen->add_type_handler ($base_type => $handler) =over =item $base_type (string) C name of the base type to handle. =item $handler (subroutine) Callback used to handle this type. =back Use I<$handler> to generate output for records whose base type is I<$base_type>. I<$base_type> is the C type name as found in the third column of a maps file entry. I<$handler> will be called with the (possibly preprocessed) contents of the current maps file record, and should call the C, C, and C functions to set up the necessary C/XS glue for that type. For example: Glib::CodeGen->add_type_handler (CoolThing => sub { my ($typemacro, $classname, $base, $package) = @_; # $typemacro is the C type macro, like COOL_TYPE_THING. # $classname is the actual C type name, like CoolFooThing. # $base is the C name of the base type. If CoolFooThing # isa CoolThing, $base will be CoolThing. This # parameter is useful when using the same type handler # for multiple base types. # $package is the package name that corresponds to # $classname, as specified in the maps file. ... }); =cut sub add_type_handler { my (undef, $root_type, $handler) = @_; $type_handler{$root_type} = $handler; } =item add_typemap $type, $typemap [, $input, $output] Add a typemap entry for C<$type>, named C<$typemap>. If I<$input> and/or I<$output> are defined, their text will be used as the C and/or C typemap implementations (respectively) for I<$typemap>. Note that in general, you'll use C or some other existing typemap for I<$typemap>, so I<$input> and I<$output> are very rarely used. Example: # map $classname pointers and all their variants to the generic # wrapper typemap. add_typemap "$classname *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "const $classname *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_ornull *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "const $classname\_ornull *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_own *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_copy *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_own_ornull *", "T_GPERL_GENERIC_WRAPPER"; # custom code for an int-like enum: add_typemap $class => T_FOO, "\$var = foo_unwrap (\$arg);", # input "\$arg = foo_wrap (\$var);"; # output =cut sub add_typemap { my ($type, $typemap, $input, $output) = @_; push @typemap, "$type\t$typemap" if defined $typemap; push @input, $input if defined $input; push @output, $output if defined $output; } =item add_register $text Add I<$text> to the generated C. This is usually used for registering types with the bindings, e.g.: add_register "#ifdef $typemacro\n" . "gperl_register_object ($typemacro, \"$package\");\n" . "#endif /* $typemacro */"; =cut sub add_register { push @boot, shift; } =item add_header $text Add I<$text> to the generated C header. You'll put variant typedefs and wrap/unwrap macros in the header, and will usually want to wrap the declarations in C<#ifdef $typemacro> for safety. =cut sub add_header { push @header, shift; } # # generator subs # sub gen_enum_stuff { my ($typemacro, $classname, undef, $package) = @_; add_header "#ifdef $typemacro /* GEnum $classname */ # define Sv$classname(sv) (($classname)gperl_convert_enum ($typemacro, sv)) # define newSV$classname(val) (gperl_convert_back_enum ($typemacro, val)) #endif /* $typemacro */ "; add_typemap $classname, "T_GPERL_GENERIC_WRAPPER"; add_register "#ifdef $typemacro gperl_register_fundamental ($typemacro, \"$package\"); #endif /* $typemacro */" unless $package eq '-'; } sub gen_flags_stuff { my ($typemacro, $classname, undef, $package) = @_; add_header "#ifdef $typemacro /* GFlags $classname */ # define Sv$classname(sv) (($classname)gperl_convert_flags ($typemacro, sv)) # define newSV$classname(val) (gperl_convert_back_flags ($typemacro, val)) #endif /* $typemacro */ "; add_typemap $classname, "T_GPERL_GENERIC_WRAPPER"; add_register "#ifdef $typemacro gperl_register_fundamental ($typemacro, \"$package\"); #endif /* $typemacro */" unless $package eq '-'; } sub gen_boxed_stuff { my ($typemacro, $classname, undef, $package) = @_; add_header "#ifdef $typemacro /* GBoxed $classname */ typedef $classname $classname\_ornull; # define Sv$classname(sv) (($classname *) gperl_get_boxed_check ((sv), $typemacro)) # define Sv$classname\_ornull(sv) (gperl_sv_is_defined (sv) ? Sv$classname (sv) : NULL) typedef $classname $classname\_own; typedef $classname $classname\_copy; typedef $classname $classname\_own_ornull; # define newSV$classname(val) (gperl_new_boxed ((gpointer) (val), $typemacro, FALSE)) # define newSV$classname\_ornull(val) ((val) ? newSV$classname(val) : &PL_sv_undef) # define newSV$classname\_own(val) (gperl_new_boxed ((gpointer) (val), $typemacro, TRUE)) # define newSV$classname\_copy(val) (gperl_new_boxed_copy ((gpointer) (val), $typemacro)) # define newSV$classname\_own_ornull(val) ((val) ? newSV$classname\_own(val) : &PL_sv_undef) #endif /* $typemacro */ "; add_typemap "$classname *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "const $classname *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_ornull *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "const $classname\_ornull *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_own *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_copy *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_own_ornull *", "T_GPERL_GENERIC_WRAPPER"; add_register "#ifdef $typemacro gperl_register_boxed ($typemacro, \"$package\", NULL); #endif /* $typemacro */" unless $package eq '-'; } sub gen_object_stuff { my ($typemacro, $classname, $root, $package) = @_; my $get_wrapper = 'gperl_new_object (G_OBJECT (val), FALSE)'; my $header_text = "#ifdef $typemacro /* $root derivative $classname */ # define Sv$classname(sv) (($classname*)gperl_get_object_check (sv, $typemacro)) # define newSV$classname(val) ($get_wrapper) typedef $classname $classname\_ornull; # define Sv$classname\_ornull(sv) (gperl_sv_is_defined (sv) ? Sv$classname(sv) : NULL) # define newSV$classname\_ornull(val) (((val) == NULL) ? &PL_sv_undef : $get_wrapper) "; add_typemap "$classname *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "const $classname *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_ornull *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "const $classname\_ornull *", "T_GPERL_GENERIC_WRAPPER"; add_register "#ifdef $typemacro gperl_register_object ($typemacro, \"$package\"); #endif /* $typemacro */"; if ($root eq 'GObject') { # for GObjects, add a _noinc and a noinc_ornull variant for # returning GObjects from constructors. $header_text .= "typedef $classname $classname\_noinc; #define newSV$classname\_noinc(val) (gperl_new_object (G_OBJECT (val), TRUE)) typedef $classname $classname\_noinc_ornull; #define newSV$classname\_noinc_ornull(val) ((val) ? newSV$classname\_noinc(val) : &PL_sv_undef) "; add_typemap "$classname\_noinc *", "T_GPERL_GENERIC_WRAPPER"; add_typemap "$classname\_noinc_ornull *", "T_GPERL_GENERIC_WRAPPER"; } # close the header ifdef $header_text .= "#endif /* $typemacro */\n"; add_header $header_text; } sub gen_error_domain_stuff { my ($domain, $enum, undef, $package) = @_; add_register "#if defined($domain) /* && defined($enum) */ gperl_register_error_domain ($domain, $enum, \"$package\"); #endif /* $domain */ "; } 1; __END__ =back =head1 BUGS GInterfaces are mostly just ignored. The code is ugly. =head1 AUTHOR muppet =head1 COPYRIGHT Copyright (C) 2003-2005, 2013 by the gtk2-perl team (see the file AUTHORS for the full list) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. =cut Glib-1.320/lib/Glib/GenPod.pm000644 001750 000024 00000116401 12636024655 016640 0ustar00bdmanningstaff000000 000000 # # # # TODO: # should we look at signals etc. for enums/flags? # we're getting warnings about unregistered types with new enums/flags # stuff, quell them. # package Glib::GenPod; our $VERSION = '1.320'; use strict; use warnings; use Carp; use File::Spec; use Data::Dumper; use POSIX qw(strftime); use Glib; use base 'Exporter'; our @EXPORT = qw( add_types xsdoc2pod podify_properties podify_child_properties podify_style_properties podify_values podify_signals podify_ancestors podify_interfaces podify_methods podify_enums_and_flags podify_deprecated_by ); our $COPYRIGHT = undef; our $AUTHORS = 'Gtk2-Perl Team'; our $MAIN_MOD = undef; our $YEAR = strftime "%Y", gmtime; our ($xspods, $data); =head1 NAME Glib::GenPod - POD generation utilities for Glib-based modules =head1 SYNOPSIS use Glib::GenPod; # use the defaults: xsdoc2pod ($xsdocparse_output_file, $destination_dir); # or take matters into your own hands require $xsdocparse_output_file; foreach my $package (sort keys %$data) { print "=head1 NAME\n\n$package\n\n"; print "=head1 METHODS\n\n" . podify_methods ($package) . "\n\n"; } =head1 DESCRIPTION This module includes several utilities for creating pod for xs-based Perl modules which build on the Glib module's foundations. The most important bits are the logic to convert the data structures created by xsdocparse.pl to describe xsubs and pods into method docs, with call signatures and argument descriptions, and converting C type names into Perl type names. The rest of the module is mostly boiler-plate code to format and pretty-print information that may be queried from the Glib type system. To make life easy for module maintainers, we also include a do-it-all function, xsdoc2pod(), which does pretty much everything for you. All of the pieces it uses are publically usable, so you can do whatever you like if you don't like the default output. =head1 DOCUMENTING THE XS FILES All of the information used as input to the methods included here comes from the XS files of your project, and is extracted by Glib::ParseXSDoc's C. This function creates an file containing Perl code that may be eval'd or require'd to recreate the parsed data structures, which are a list of pods from the verbatim C portion of the XS file (the xs api docs), and a hash of the remaining data, keyed by package name, and including the pods and xsubs read from the rest of each XS file following the first MODULE line. Several custom POD directives are recognized in the XSubs section. Note that each one is sought as a paragraph starter, and must follow a C<=cut> directive. =over =item =for object Package::Name All xsubs and pod from here until the next object directive or MODULE line will be placed under the key 'I' in xsdocparse's data structure. Everything from this line to the next C<=cut> is included as a description POD. =item =for object Package::Name (Other::Package::Name) Generate POD in I but for the package I. This is useful if you want POD to appear in a different namespace but still want the automatically generated hierarchy, signal and property listing, etc. from the original namespace. For example: =for object Gnome2::PanelApplet::main (Gnome2::PanelApplet) =cut This will create Gnome2/PanelApplet/main.pod containing the automatically generated documentation for Gnome2::PanelApplet (hierarchy, signals, etc.) plus the method listing from the current XS file. =item =for enum Package::Name =item =for flags Package::Name This causes xsdoc2pod to call C on I when writing the pod for the current package (as set by an object directive or MODULE line). Any text in this paragraph, to the next C<=cut>, is included in that section. =item =for deprecated_by Package::Name Used to add a deprecation warning, indicating I as an alternative way to achieve the same functionality. There may be any number these in each package. =item =for see_also L Used to add extra see alsos onto the end of the parents, if any, for a given object. Anything following the space behind see_also up to the end of the line will be placed onto the list of "see also"s. There may be any number of these in each package. =item =for apidoc =item =for apidoc Full::Symbol::name Paragraphs of this type document xsubs, and are associated with the xsubs by xsdocparse.pl. If the full symbol name is not included, the paragraph must be attached to the xsub declaration (no blank lines between C<=cut> and the xsub). Within the apidoc PODs, we recognize a few special directives (the "for\s+" is optional on these): =over =item =for signature ... Override the generated call signature with the ... text. If you include multiple signature directives, they will all be used. This is handy when you want to change the return type or list different ways to invoke an overloaded method, like this: =for apidoc =signature bool Class->foo =signature ($thing, @other) = $object->foo ($it, $something) Text in here is included in the generated documentation. You can actually include signature and arg directives at any point in this pod -- they are stripped after. In fact, any pod is valid in here, until the =cut. =cut void foo (...) PPCODE: /* crazy code follows */ =item =for arg name (type) description =item =for arg name description The arg directive adds or overrides an argument description. The description text is optional, as is the type specification (the part in parentheses). If you want to hide an argument, specify C<__hide__> as its type. The arg name does I need to include a sigil, as dollar signs will be added. FIXME what about @ for lists? =back Also, we honor a couple of "modifiers" on the =for apidoc line, following the symbol name, if present: =over =item - __hide__ Do not document this xsub. This is handy in certain situations, e.g., for private functions. DESTROY always has this turned on, for example. =item - __gerror__ This function or method can generate a Glib::Error exception. =item - __function__ Generate a function-style signature for this xsub. The default is to generate method-style signatures. =item - __deprecated__ This function or method is deprecated and should not be used in newly written code. =back (These are actually handled by Glib::ParseXSDoc, but we list them here because, well, they're an important part of how you document the XS files.) =back =head1 FUNCTIONS =over =cut =item xsdoc2pod ($datafile, $outdir='blib/lib', index=undef) Given a I<$datafile> containing the output of xsdocparse.pl, create in I<$outdir> a pod file for each package, containing everything we can think of for that module. Output is controlled by the C<=for object> directives and such in the source code. If you don't want each package to create a separate pod file, then use this function's code as a starting point for your own pretty-printer. =cut sub xsdoc2pod { my $datafile = shift(); my $outdir = shift() || 'blib/lib'; my $index = shift; mkdir $outdir unless (-d $outdir); die "usage: $0 datafile [outdir]\n" unless defined $datafile; require $datafile; my @files = (); my $pkgdata; my $ret; foreach my $package (sort { ($a->isa('Glib::Object') ? -1 : 1) } keys %$data) { $pkgdata = $data->{$package}; my $pod = File::Spec->catfile ($outdir, split /::/, $package) . '.pod'; my (undef, @dirs, undef) = File::Spec->splitpath ($pod); mkdir_p (File::Spec->catdir (@dirs)); open POD, ">$pod" or die "can't open $pod for writing: $!\n"; select POD; $package = $pkgdata->{object} if (exists $pkgdata->{object}); preprocess_pod ($_) foreach (@{$pkgdata->{pods}}); push @files, { name => $package, file => $pod, blurb => $pkgdata->{blurb}, }; # podify_pods() always returns proper POD with a =cut at the # end. But all the other =head1 below need a closing =cut. print "=head1 NAME\n\n$package"; if (exists ($pkgdata->{blurb})) { print ' - '.$pkgdata->{blurb}; } else { my $cname = convert_to_cname ($package); if (defined $cname) { print " - wrapper for $cname"; } } print "\n\n=cut\n\n"; # pods , position $ret = podify_pods ($pkgdata->{pods}, 'SYNOPSIS'); print "$ret\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'DESCRIPTION'); print "$ret\n\n" if ($ret); my $parents; ($ret, $parents) = podify_ancestors ($package); print "=head1 HIERARCHY\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'post_hierarchy'); print "$ret\n\n" if ($ret); $ret = podify_interfaces ($package); print "=head1 INTERFACES\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'post_interfaces'); print "$ret\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}); print "$ret\n\n" if ($ret); $ret = podify_deprecated_by ($package, @{ $pkgdata->{deprecated_bys} }); print "\n=head1 DEPRECATION WARNING\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_methods ($package, $pkgdata->{xsubs}); print "\n=head1 METHODS\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'post_methods'); print "$ret\n\n" if ($ret); $ret = podify_properties ($package); print "\n=head1 PROPERTIES\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_child_properties ($package); print "\n=head1 CHILD PROPERTIES\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_style_properties ($package); print "\n=head1 STYLE PROPERTIES\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'post_properties'); print "$ret\n\n" if ($ret); $ret = podify_signals ($package); print "\n=head1 SIGNALS\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'post_signals'); print "$ret\n\n" if ($ret); $ret = podify_enums_and_flags ($pkgdata, $package); print "\n=head1 ENUMS AND FLAGS\n\n$ret\n\n=cut\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'post_enums'); print "$ret\n\n" if ($ret); $ret = podify_pods ($pkgdata->{pods}, 'SEE_ALSO'); if ($ret) { print "$ret\n\n"; } else { # don't link to yourself pop @$parents; # link to the toplevel, if we can. unshift @$parents, $MAIN_MOD if $MAIN_MOD; $ret = podify_see_alsos (@$parents, $pkgdata->{see_alsos} ? @{ $pkgdata->{see_alsos} } : ()); print "\n=head1 SEE ALSO\n\n$ret\n\n=cut\n\n" if ($ret); } $ret = podify_pods ($pkgdata->{pods}, 'COPYRIGHT'); if ($ret) { # copyright over-ridden print "$ret\n\n" } else { # use normal copyright system $ret = get_copyright (); print "\n=head1 COPYRIGHT\n\n$ret\n\n=cut\n\n" if ($ret); } close POD; } if ($index) { open INDEX, ">$index" or die "can't open $index for writing: $!\b"; select INDEX; foreach (sort {$a->{name} cmp $b->{name}} @files) { print join("\t", $_->{file}, $_->{name}, $_->{blurb} ? $_->{blurb} : () ) . "\n"; } close INDEX; } } # more sensible names for the basic types our %basic_types = ( # the perl wrappers for the GLib fundamentals 'Glib::Scalar' => 'scalar', 'Glib::String' => 'string', 'Glib::Int' => 'integer', 'Glib::Uint' => 'unsigned', 'Glib::Double' => 'double', 'Glib::Float' => 'float', 'Glib::Boolean' => 'boolean', # sometimes we can get names that are already mapped... # e.g., from =for arg lines. pass them unbothered. scalar => 'scalar', subroutine => 'subroutine', integer => 'integer', string => 'string', package => 'package', list => 'list', # other C names which may sneak through bool => 'boolean', # C++ keyword, but provided by the perl api boolean => 'boolean', int => 'integer', uint => 'unsigned', float => 'double', double => 'double', char => 'string', unsigned => 'unsigned', gboolean => 'boolean', gint => 'integer', gint8 => 'integer', gint16 => 'integer', gint32 => 'integer', guint8 => 'unsigned', guint16 => 'unsigned', guint32 => 'unsigned', glong => 'integer', gulong => 'unsigned', gshort => 'integer', guint => 'integer', gushort => 'unsigned', gint64 => '64 bit integer', guint64 => '64 bit unsigned', gfloat => 'double', gdouble => 'double', gsize => 'unsigned', gssize => 'integer', goffset => '64 bit integer', gchar => 'string', SV => 'scalar', UV => 'unsigned', IV => 'integer', CV => 'subroutine', AV => 'arrayref', gchar_length => 'string', gchar_utf8_length => 'string', char_byte => 'byte string', FILE => 'file handle', time_t => 'unix timestamp', GPerlFilename => 'localized file name', GPerlFilename_const => 'localized file name', ); unless (Glib->CHECK_VERSION (2, 4, 0)) { $basic_types{'Glib::Strv'} = 'ref to array of strings'; } =item add_types (@filenames) Parse the given I<@filenames> for entries to add to the C<%basic_types> used for C type name to Perl package name mappings of types that are not registered with the Glib type system. The file format is dead simple: blank lines are ignored; /#.*$/ is stripped from each line as comments; the first token on each line is considered to be a C type name, and the remaining tokens are the description of that type. For example, a valid file may look like this: # a couple of special types FooBar Foo::Bar Frob localized frobnicator C type decorations such as "const" and "*" are implied (do not include them), and the _ornull variant is handled for you. =cut sub add_types { my @files = @_; foreach my $f (@files) { open IN, $f or die "can't open types file $f: $!\n"; my $n = 0; while () { chomp; s/#.*//; next if m/^\s*$/; my ($c_name, @bits) = split; if (@bits) { $basic_types{$c_name} = join ' ', @bits; $n++; } else { warn "$f:$.: no description for $c_name\n" } } print "Loaded $n extra types from $f\n"; close IN; } } =item $string = podify_properties ($packagename) Pretty-print the object properties owned by the Glib::Object derivative I<$packagename> and return the text as a string. Returns undef if there are no properties or I<$package> is not a Glib::Object. =cut sub podify_properties { my $package = shift; my @properties; eval { @properties = Glib::Object::list_properties($package); 1; } || return undef; return _podify_pspecs($package, @properties); } sub _podify_pspecs { my ($package, @properties) = @_; return undef unless (@properties); # we have a non-zero number of properties, but there may still be # none for this particular class. keep a count of how many # match this class, so we can return undef if there were none. my $nmatch = 0; my $str = "=over\n\n"; foreach my $p (sort { $a->{name} cmp $b->{name} } @properties) { next unless $p->{owner_type} eq $package; ++$nmatch; my $stat = join " / ", @{ $p->{flags} }; my $type = exists $basic_types{$p->{type}} ? $basic_types{$p->{type}} : $p->{type}; my $default = _pspec_formatted_default($p); $str .= "=item '$p->{name}' ($type : default $default : $stat)\n\n"; $str .= "$p->{descr}\n\n" if (exists ($p->{descr})); } $str .= "=back\n\n"; return $nmatch ? $str : undef; } # return a POD string which is the default value of $pspec, nicely formatted sub _pspec_formatted_default { my ($pspec) = @_; my $default = $pspec->get_default_value; if (! defined $default) { return 'undef'; } my $pname = $pspec->get_name; my $type = $pspec->get_value_type; # Crib: "eq" here because Glib::Boolean->isa('Glib::Boolean') is false, # it's not an actual perl module if ($type eq 'Glib::Boolean') { $default = ($default ? 'true' : 'false'); } elsif ($type->isa('Glib::Flags')) { $default = join ",", @$default; } elsif ($pspec->isa('Glib::Param::Unichar')) { # $default is a single-char string, show as ordinal and string. # $type is only Glib::UInt, so this must be before plain UInts below. # Eg. Gtk2::Entry property "invisible-char". $default = ord($default) . ' ' . Data::Dumper->new([$default]) ->Useqq(1)->Terse(1)->Indent(0)->Dump; } elsif ($type eq 'Glib::Double' && $default == POSIX::DBL_MAX()) { # Show DBL_MAX symbolically. # Eg. Gtk2::Range property "fill-level" is DBL_MAX. $default = "DBL_MAX"; } elsif ($type eq 'Glib::Double' && $default == - POSIX::DBL_MAX()) { $default = "-DBL_MAX"; } elsif ($type eq 'Glib::Float' && $default == POSIX::FLT_MAX()) { $default = "FLT_MAX"; } elsif ($type eq 'Glib::Float' && $default == - POSIX::FLT_MAX()) { $default = "-FLT_MAX"; } elsif ($type eq 'Glib::Double' || $type eq 'Glib::Float') { # Limit the decimals shown in floats, # eg. Gtk2::Menu style property "arrow-scaling" is 0.7 and comes out as # 0.6999999999 if not restricted a bit $default = sprintf '%.6g', $default; } elsif ($pname =~ /keyval/ && $type eq 'Glib::UInt' && eval { require Gtk2; 1 }) { # Keyvals in hex the same as gdkkeysyms.h, and show the symbol if known. # The pspec type of keyvals is only UInt, must guess from the property # name whether a uint is in fact a keyval. # eg. Gtk2::Label property "mnemonic-keyval" is 0xFFFFFF=VoidSymbol my $keyname = Gtk2::Gdk->keyval_name ($default); $default = sprintf '0x%02X', $default; # two or more hex digits if (defined $keyname) { $default = "$default $keyname"; } } elsif ($type eq 'Glib::Int' && $default == POSIX::INT_MAX()) { # Show INT_MAX symbolically # eg. Gtk2::Paned property "max-position" is INT_MAX $default = "INT_MAX"; } elsif ($type eq 'Glib::Int' && $default == POSIX::INT_MIN()) { $default = "INT_MIN"; } elsif ($type eq 'Glib::UInt' && $default == POSIX::UINT_MAX()) { $default = "UINT_MAX"; } else { # Strings quoted for clarity, unprintables shown backslashed # eg. Gtk2::UIManager property "ui" has newlines # eg. Gtk2::TreeView style property "tree-line-pattern" is bytes "\001\001" $default = Data::Dumper->new([$default]) ->Useqq(1)->Terse(1)->Indent(0)->Dump; } # Escape "<" to E etc. # eg. Gtk2::UIManager property "ui" is "" $default = _pod_escape($default); return $default; } # Return $str with characters escaped ready to appear in pod. This means # non-ascii escaped to E<123> and "<" to E. Strictly speaking "<" only # has to be escaped if it would be B<... etc, but it's easier to do it # always and might help some of the pod formatters. $str is assumed to have # no non-printables (control chars etc). # (ENHANCE-ME: Is there a module to do char->pod like this? Pod::Escapes is # the converse pod->char ...) sub _pod_escape { my ($str) = @_; $str =~ s{([^[:ascii:]])|(<)} {defined $1 ? ('E<'.ord($1).'>') : 'E'}eg; return $str; } =item $string = podify_child_properties ($packagename) Pretty-print the child properties owned by the Gtk2::Container derivative I<$packagename> and return the text as a string. Returns undef if there are no child properties or I<$package> is not a Gtk2::Container or similar class with a C method. =cut sub podify_child_properties { my ($package) = shift; # Call list_child_properties() as a method so as to perhaps work on # Goo::Canvas::Item which has a similar child properties scheme of # its own (it's not a Gtk2::Container subclass), though that method # is not wrapped as of Goo::Canvas 0.06. if ($package->can('list_child_properties')) { return _podify_pspecs($package, $package->list_child_properties); } else { return undef; } } =item $string = podify_style_properties ($packagename) Pretty-print the style properties owned by the Gtk2::Widget derivative I<$packagename> and return the text as a string. Returns undef if there are no style properties or I<$package> is not a Gtk2::Widget or similar class with a C method. =cut sub podify_style_properties { my ($package) = shift; my @properties; if ($package->can('list_style_properties')) { return _podify_pspecs($package, $package->list_style_properties); } else { return undef; } } =item $string = podify_values ($packagename) List and pretty-print the values of the GEnum or GFlags type I<$packagename>, and return the text as a string. Returns undef if I<$packagename> isn't an enum or flags type. =cut sub podify_values { my $package = shift; my @values; eval { @values = Glib::Type->list_values ($package); 1; }; return undef unless (@values or not $@); return "=over\n\n" . join ("\n\n", map { "=item * '$_->{nick}' / '$_->{name}'" } @values) . "\n\n=back\n\n"; } =item $string = podify_signals ($packagename) Query, list, and pretty-print the signals associated with I<$packagename>. Returns the text as a string, or undef if there are no signals or I<$packagename> is not a Glib::Object derivative. =cut sub podify_signals { my $str = undef; eval { my @sigs = Glib::Type->list_signals (shift); return undef unless @sigs; $str = "=over\n\n"; foreach (sort {$a->{signal_name} cmp $b->{signal_name} } @sigs) { $str .= '=item '; $str .= convert_type ($_->{return_type}).' = ' if exists $_->{return_type}; $str .= "B<$_->{signal_name}> ("; $str .= join ', ', map { convert_type ($_) } $_->{itype}, @{$_->{param_types}}; $str .= ")\n\n"; } $str .= "=back\n\n"; }; return $str } =item $string = podify_deprecated_by ($packagename, @deprecated_by) Creates a deprecation warning for $packagename, suggesting using the items inside @deprecated_by instead. =cut sub podify_deprecated_by { my $package = shift; my @deprecated_by = @_; return undef unless scalar @deprecated_by; my $str = "$package has been marked as deprecated, and should not be " . "used in newly written code.\n\n"; # create the deprecated for list $str .= "You should use " . join (', ', map { if (/^\s*L"; } } @deprecated_by) . " instead of $package.\n"; return $str; } sub podify_enums_and_flags { my $pkgdata = shift; my $package = shift; my %types = (); my $name; my $pod; my %info = (); foreach (@{$pkgdata->{enums}}) { $name = convert_type ($_->{name}); $pod = $_->{pod}; shift @{ $pod->{lines} }; pop @{ $pod->{lines} } if $pod->{lines}[-1] =~ /^=cut/; $info{$name} = { type => $_->{type}, pod => $pod->{lines}, }; $types{$name}++; } foreach my $xsub (@{$pkgdata->{xsubs}}) { if ($xsub->{return_type}) { foreach my $ret (@{$xsub->{return_type}}) { $name = convert_type ($ret); $types{$name}++; } } if ($xsub->{args}) { foreach my $arg (@{$xsub->{args}}) { if ($arg->{type}) { $name = convert_type ($arg->{type}); $types{$name}++; } } } } if ($package) { my @props; eval { @props = Glib::Object::list_properties($package); 1; }; foreach my $prop (@props) { next unless ($prop->{type}); next unless $prop->{owner_type} eq $package; $name = convert_type ($prop->{type}); $types{$name}++; } my @sigs; eval { @sigs = Glib::Type->list_signals ($package); 1; }; foreach my $sig (@sigs) { if ($sig->{return_type}) { $name = convert_type ($sig->{return_type}); $types{$name}++; } foreach (@{$sig->{param_types}}) { next unless ($_); $name = convert_type ($_); $types{$name}++; } } } my $ret = ''; foreach (sort keys %types) { s/\s.*//; next if $_ eq 'Glib::Enum' || $_ eq 'Glib::Flags'; my $values_pod = podify_values ($_); if ($values_pod || exists $info{$_}) { my $type = UNIVERSAL::isa ($_, 'Glib::Flags') ? 'flags' : 'enum'; $ret .= "=head2 $type $_\n\n"; $ret .= join ("\n", @{$info{$_}{pod}}) . "\n\n" if ($info{$_}{pod}); $ret .= podify_values ($_) . "\n"; } } return $ret; } =item $string = podify_pods ($pods, $position) Helper function to allow specific placement of generic pod within the auto generated pages. Pod sections starting out with =for position XXX, where XXX is one of the following will be placed at a specified position. In the case of pod that is to be placed after a particular section that doesn't exist, that pod will be still be placed there. This function is called at all of the specified points through out the process of generating pod for a page. Any pod matching the I passed will be returned, undef if no matches were found. If I is undef all pods without sepcific postion information will be returned. I is a reference to an array of pod hashes. =over =item * SYNOPSIS After the NAME section =item * DESCRIPTION After the SYNOPSIS section. =item * post_hierarchy After the HIERARCHY section. =item * post_interfaces After the INTERFACE section. =item * post_methods After the METHODS section. =item * post_properties After the PROPERTIES section. =item * post_signals After the SIGNALS section. =item * post_enums After the ENUMS AND FLAGS section. =item * SEE_ALSO Replacing the autogenerated SEE ALSO section completely. =item * COPYRIGHT Replacing the autogenerated COPYRIGHT section completely. =back =cut sub podify_pods { my $pods = shift; my $position = shift; my $ret = ''; if ($position) { foreach (@$pods) { $ret .= join ("\n", @{$_->{lines}})."\n\n" if (exists ($_->{position}) and $_->{position} eq $position); } } else { foreach (@$pods) { $ret .= join ("\n", @{$_->{lines}})."\n\n" unless ($_->{position}); } } return $ret ne '' ? $ret : undef; } =item $string = podify_ancestors ($packagename) Pretty-prints the ancestry of I<$packagename> from the Glib type system's point of view. This uses Glib::Type->list_ancestors; see that function's docs for an explanation of why that's different from looking at @ISA. Returns the new text as a string, or undef if I<$packagename> is not a registered GType. =cut sub podify_ancestors { my @anc; eval { @anc = Glib::Type->list_ancestors (shift); 1; }; return undef unless (@anc or not $@); my $parents = [ reverse @anc ]; my $depth = 0; my $str = ' '.pop(@anc)."\n"; foreach (reverse @anc) { $str .= " " . " "x$depth . "+----$_\n"; $depth++; } $str .= "\n"; return ($str, $parents); } =item $string = podify_interfaces ($packagename) Pretty-print the list of GInterfaces that I<$packagename> implements. Returns the text as a string, or undef if the type implements no interfaces. =cut sub podify_interfaces { my @int; eval { @int = Glib::Type->list_interfaces (shift); 1; }; return undef unless (@int or not defined ($@)); return ' '.join ("\n ", @int)."\n\n"; } =item $string = podify_methods ($packagename) Call C on all the xsubs under the key I<$packagename> in the data extracted by xsdocparse.pl. Returns the new text as a string, or undef if there are no xsubs in I<$packagename>. =cut sub podify_methods { my $package = shift; my $xsubs = shift; return undef unless $xsubs && @$xsubs; # we will be re-using $package from here on out. my $str = ''; my $nfound = 0; my $nused = 0; my $method; # based on rm's initial thought and then code/ideas by Marc 'HE' # Brockschmidt, and Peter Haworth @$xsubs = sort { my ($at, $bt); for ($at=$a->{symname}, $bt=$b->{symname}) { # remove prefixes s/^.+:://; # new's goto the front s/^new/\x00/; # group set's/get'ss s/^(get|set)_(.+)/$2_$1/; # put \'s with \'s s/^(get|set)$/get_$1/; } # now actually do the sorting compare $at cmp $bt; } @$xsubs; #$str .= "=over\n\n"; foreach (@$xsubs) { # skip if the method is hidden next if ($_->{hidden}); $_->{symname} =~ m/^(?:([\w:]+)::)?([\w]+)$/; $package = $1 || $_->{package}; $method = $2; # skip DESTROY altogether next if $method eq 'DESTROY'; ++$nfound; # don't document it if we can't actually call it. if ($package->can ($method)) { $str .= xsub_to_pod ($_, '=head2'); ++$nused; } else { # this print should only be temporary print STDERR "missing: $package->$method\n"; } } #$str .= "=back\n\n"; if ($nused == 0) { # no xsubs were used. if ($nfound > 0) { # but some were found and not used. # say something to that effect. print STDERR "No methods found for $package\n"; $str = " Some methods defined for $package are not available in the particular library versions against which this module was compiled. "; } else { # no methods found, nothing to say $str = undef; } } $str; } =item $string = podify_see_alsos (@entries) Creates a list of links to be placed in the SEE ALSO section of the page. Returns undef if nothing is in the input list. =cut sub podify_see_alsos { my @entries = @_; return undef unless scalar @entries; # create the see also list join (', ', map { if (/^\s*L"; } } @entries) . "\n"; } =item $string = get_copyright Returns a string that will/should be placed on each page. You can control the text of this string by calling the class method I. If no text has been set, we will attempt to create one for you, using what has been passed to I, I, and I. The year defaults to the current year, the authors default to 'The Gtk2-Perl Team', and the main mod is empty by default. You want the main mod to be set to the main module of your extension for the SEE ALSO section, and on the assumption that a decent license notice can be found in that module's doc, we point the reader there. So, in general, you will want to specify at least one of these, so that you don't credit your work to us under the LGPL. To set them do something similar to the following in the first part of your postamble section in Makefile.PL. All occurences of
in the copyright are replaced with newlines, to make it easier to put in a multi-line string. POD_SET=Glib::GenPod::set_copyright(qq{Copyright 1999 team-foobar
LGPL}); Glib::MakeHelper::postamble_docs_full() does this sort of thing for you. =cut sub get_copyright { my $str = $COPYRIGHT; if (! $str) { # construct a default. $str = "\nCopyright (C) $YEAR $AUTHORS\n\n"; $str .= "This software is licensed under the LGPL;" . " see $MAIN_MOD for a full notice.\n" if $MAIN_MOD; } # a way to make returns $str =~ s/
/\n/g; return $str."\n"; } sub set_copyright { $COPYRIGHT = shift; } sub set_year { $YEAR = shift; } sub set_authors { $AUTHORS = shift; } sub set_main_mod { $MAIN_MOD = shift; } sub preprocess_pod { my $pod = shift; foreach (@{$pod->{lines}}) { # =for include filename # =for include !cmd if (/^=for\s+include\s+(!)?(.*)$/) { if ($1) { chomp($_ = `$2`); } else { if (open INC, "<$2") { local $/ = undef; $_ = ; } else { carp "\n\nunable to open $2 for inclusion, at ". $pod->{filename}.':'.$pod->{line}; } } } } } =back =head2 Helpers =over =item $perl_type = convert_type ($ctypestring) Convert a C type name to a Perl type name. Uses %Glib::GenPod::basic_types to look for some known basic types, and uses Glib::Type->package_from_cname to look up the registered package corresponding to a C type name. If no suitable mapping can be found, this just returns the input string. =cut sub convert_type { my $typestr = shift; $typestr =~ /^\s* # leading space (?:const\s+)? # maybe a const ([:\w]+) # the name (\s*\*)? # maybe a star \s*$/x; # trailing space my $ctype = $1 || '!!'; if ($ctype eq '!!') { warn "Glib::GenPod: Unable to parse type '$typestr'"; } # variant type $ctype =~ s/(?:_(ornull|copy|own_ornull|own|noinc_ornull|noinc))$//; my $variant = $1 || ""; my $perl_type; if (exists $basic_types{$ctype}) { $perl_type = $basic_types{$ctype}; } elsif ($ctype =~ m/::/) { # :: is not valid in GLib type names, so there's no point # in asking the GLib type system if it knows this name, # because it's probably already a perl type name. $perl_type = $ctype; } else { eval { $perl_type = Glib::Type->package_from_cname ($ctype); 1; } or do { # this warning will have something to do with the # package not being registered, a fact which will # of interest to a person documenting or developing # the documented module, but not to us developing # the documentation generator. thus, this warning # doesn't need a line number attribution. # let's strip that... $@ =~ s/\s*at (.*) line \d+\.$/./; warn "$@"; # ... and fall back gracefully. $perl_type = $ctype; } } if ($variant && $variant =~ m/ornull/) { $perl_type .= " or undef"; } $perl_type } =item $string = xsub_to_pod ($xsub, $sigprefix='') Convert an xsub hash into a string of pod describing it. Includes the call signature, argument listing, and description, honoring special switches in the description pod (arg and signature overrides). =cut sub xsub_to_pod { my $xsub = shift; my $sigprefix = shift || ''; my $alias = $xsub->{symname}; my $str; # ensure that if there's pod for this xsub, we have it now. # this should probably happen somewhere outside of this function, # but, eh... my @podlines = (); if (defined $xsub->{pod}) { @podlines = @{ $xsub->{pod}{lines} }; } # look for annotations in the pod lines. # stuff in the pods overrides whatever we'd generate. my @signatures = (); if (@podlines) { # since we're modifying the list while traversing # it, go back to front. for (my $i = $#podlines ; $i >= 0 ; $i--) { if ($podlines[$i] =~ s/^=(for\s+)?signature\s+//) { unshift @signatures, $podlines[$i]; splice @podlines, $i, 1; } elsif ($podlines[$i] =~ /^=(?:for\s+)?arg\s+ (\$?[\w.]+) # arg name (?:\s*\(([^)]*)\))? # type \s* (.*)$/x) { # desc # this is a little convoluted, because we # need to ensure that the args array and # hash exist before using them. we may be # getting an =arg command on something that # doesn't list this name in the xsub # declaration. $xsub->{args} = [] if not exists $xsub->{args}; my ($a, undef) = grep { $_->{name} eq $1 } @{ $xsub->{args} }; $a = {}, push @{$xsub->{args}}, $a if not defined $a; $a->{name} = $1 if not defined $a->{name}; $a->{desc} = $3; if ($2) { if ($2 =~ m/^_*hide_*$/i) { $a->{hide}++; } else { $a->{type} = $2; } } # "just eat it! eat it! get yourself and # egg and beat it!" -- weird al splice @podlines, $i, 1; } } } # # the call signature(s). # push @signatures, compile_signature ($xsub) unless @signatures; foreach (@signatures) { s/>(\w+)/>B<$1>/; $str .= "$sigprefix $_\n\n"; } # # list all the arg types. # my @args; @args = @{ $xsub->{args} } if ($xsub->{args}); shift @args unless $xsub->{function}; $str .= "=over\n\n" if @args; foreach my $a (@args) { my $type; next if $a->{hide}; if ($a->{name} eq '...') { $type = 'list'; } else { if (not defined $a->{type}) { warn "$alias: no type defined for arg" . " \$$a->{name}\n"; $type = "(unknown)"; } else { $type = convert_arg_type ($a->{type}); } } $str .= "=item * " . fixup_arg_name ($a->{name}) . " ($type) " . ($a->{desc} ? $a->{desc} : "") . "\n\n"; } $str .= "=back\n\n" if @args; if (@podlines) { shift @podlines; pop @podlines; $str .= join("\n", @podlines)."\n\n"; } $str .= "May croak with a L in \$@ on failure.\n\n" if ($xsub->{gerror}); $str .= "This method is deprecated and should not be used in newly written code.\n\n" if ($xsub->{deprecated}); # When there are multiple version guards of the same type, we only want # the innermost. my %version_conditions; my %prefix_to_name = ( GTK => 'gtk+', ); foreach (@{ $xsub->{preprocessor_conditionals} }) { if (m/^\s*(\w+)_CHECK_VERSION\s*\((\d+),\s*(\d+)/) { my $lib_name = $prefix_to_name{$1} || lc $1; $version_conditions{$lib_name} = "$2.$3"; } } foreach my $lib_name (keys %version_conditions) { $str .= "Since: $lib_name $version_conditions{$lib_name}\n\n"; } $str } =item $string = compile_signature ($xsub) Given an xsub hash, return a string with the call signature for that xsub. =cut sub compile_signature { my $xsub = shift; my @args; @args = @{ $xsub->{args} } if ($xsub->{args}); my $call; if ($xsub->{function}) { $call = $xsub->{symname}; } else { # find the method's short name my $method = $xsub->{symname}; $method =~ s/^(.*):://; my $package = $1 || $xsub->{package}; # methods always eat the first arg as the instance. my $instance = shift @args; my $obj = defined ($instance->{type}) ? '$'.$instance->{name} : $package; $call = "$obj\-E$method"; } # compile the arg list string my $argstr = join ", ", map { fixup_arg_name ($_->{name}) . (defined $_->{default} ? '='.fixup_default ($_->{default}) : '') } @args; # compile the return list string my @outlist = map { $_->{name} } @{ $xsub->{outlist} }; if (defined $xsub->{return_type}) { my @retnames = map { convert_return_type_to_name ($_) } @{ $xsub->{return_type} }; unshift @outlist, @retnames; } my $retstr = @outlist ? (@outlist > 1 ? "(".join (", ", @outlist).")" : $outlist[0] )." = " : (defined $xsub->{codetype} and $xsub->{codetype} eq 'PPCODE' ? 'list = ' : '' ); "$retstr$call ".($argstr ? "($argstr)" : ""); } =item $string = fixup_arg_name ($name) Prepend a $ to anything that's not the literal ellipsis string '...'. =cut sub fixup_arg_name { my $name = shift; my $sigil = $name eq '...' ? '' : '$'; return $sigil.$name; } =item fixup_default Mangle default parameter values from C to Perl values. Mostly, this does NULL => undef. =cut sub fixup_default { my $value = shift; return (defined ($value) ? ($value eq 'NULL' ? 'undef' : $value) : ''); } =item convert_arg_type C type to Perl type conversion for argument types. =cut sub convert_arg_type { convert_type (@_) } =item convert_return_type_to_name C type to Perl type conversion suitable for return types. =cut sub convert_return_type_to_name { my $type = convert_type (@_); if ($type =~ s/^.*:://) { $type = lc $type; } return $type; } sub mkdir_p { my $path = shift; my @dirs = File::Spec->splitdir ($path); my $p = shift @dirs; do { mkdir $p or die "can't create dir $p: $!\n" unless -d $p; $p = File::Spec->catdir ($p, shift @dirs); } while (@dirs); } sub convert_to_cname { my $perlname = shift; my $cname = $perlname; $cname =~ s/^Gtk2::Gdk::/Gdk/; $cname =~ s/^Gtk2::/Gtk/; $cname =~ s/^Gnome2::Bonobo::/Bonobo/; $cname =~ s/^Gnome2::/Gnome/; $cname =~ s/:://g; my $tmp; eval { $tmp = Glib::Type->package_from_cname($cname); }; if ($@ || $tmp ne $perlname) { return; } return $cname; } 1; __END__ =back =head1 SEE ALSO L =head1 AUTHORS muppet bashed out the xsub signature generation in a few hours on a wednesday night when band practice was cancelled at the last minute; he and ross mcfarland hacked this module together via irc and email over the next few days. =head1 COPYRIGHT AND LICENSE Copyright (C) 2003-2004, 2010-2013 by the gtk2-perl team 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-1.320/lib/Glib/MakeHelper.pm000644 001750 000024 00000043274 12636024676 017513 0ustar00bdmanningstaff000000 000000 # # $Id$ # package Glib::MakeHelper; our $VERSION = '1.320'; =head1 NAME Glib::MakeHelper - Makefile.PL utilities for Glib-based extensions =head1 SYNOPSIS eval "use Glib::MakeHelper; 1" or complain_that_glib_is_too_old_and_die(); %xspod_files = Glib::MakeHelper->do_pod_files (@xs_files); package MY; sub postamble { return Glib::MakeHelper->postamble_clean () . Glib::MakeHelper->postamble_docs (@main::xs_files) . Glib::MakeHelper->postamble_rpms ( MYLIB => $build_reqs{MyLib}, ); } =head1 DESCRIPTION The Makefile.PL for your typical Glib-based module is huge and hairy, thanks to all the crazy hoops you have to jump through to get things right. This module wraps up some of the more intense and error-prone bits to reduce the amount of copied code and potential for errors. =cut use strict; use warnings; use Carp; use Cwd; our @gend_pods = (); =head1 METHODS =over =item HASH = Glib::MakeHelper->do_pod_files (@xs_files) Scan the I<@xs_files> and return a hash describing the pod files that will be created. This is in the format wanted by WriteMakefile(). If @ARGV contains the string C an empty list will be returned and thus no apidoc pod will be generated speeding up the build process. =cut sub do_pod_files { return () if (grep /disable[-_]apidoc/i, @ARGV); print STDERR "Including generated API documentation...\n"; shift; # package name # try to get it from pwd first, then fall back to installed # this is so Glib will get associated copy, and everyone else # should use the installed glib copy eval { require 'lib/Glib/ParseXSDoc.pm'; 1; } or require Glib::ParseXSDoc; $@ = undef; import Glib::ParseXSDoc; my %pod_files = (); open PARSE, '>build/doc.pl'; select PARSE; my $pods = xsdocparse (@_); select STDOUT; @gend_pods = (); foreach (@$pods) { my $pod = $_; my $path = '$(INST_LIB)'; $pod = File::Spec->catfile ($path, split (/::/, $_)) . ".pod"; push @gend_pods, $pod; $pod_files{$pod} = '$(INST_MAN3DIR)/'.$_.'.$(MAN3EXT)'; } $pod_files{'$(INST_LIB)/$(FULLEXT)/index.pod'} = '$(INST_MAN3DIR)/$(NAME)::index.$(MAN3EXT)'; return %pod_files; } =item LIST = Glib::MakeHelper->select_files_by_version ($stem, $major, $minor) Returns a list of all files that match "$stem-\d+\.\d+" and for which the first number is bigger than I<$major> and the second number is bigger than I<$minor>. If I<$minor> is odd, it will be incremented by one so that the version number of an upcoming stable release can be used during development as well. =cut sub select_files_by_version { my ($class, $stem, $major, $minor) = @_; # make minors even, so that we don't have to deal with stable/unstable # file naming changes. $minor++ if ($minor % 2); my @files = (); foreach (glob $stem . '-*.*') { if (/$stem-(\d+)\.(\d+)/) { push @files, $_ if $1 <= $major and $2 <= $minor; } } return @files; } =item LIST = Glib::MakeHelper->read_source_list_file ($filename) Reads I<$filename>, removes all comments (starting with "#") and leading and trailing whitespace, and returns a list of all lines that survived the treatment. =cut sub read_source_list_file { my ($class, $filename) = @_; my @list = (); open IN, $filename or die "can't read $filename: $!\n"; while () { s/#.*$//; # eat comments s/^\s*//; # trim leading space s/\s*$//; # trim trailing space push @list, $_ if $_; # keep non-blanks } close IN; return @list; } =item string = Glib::MakeHelper->get_configure_requires_yaml (%module_to_version) Generates YAML code that lists every module found in I<%module_to_version> under the C key. This can be used with L's C parameter to specify which modules are needed at I time. This function is B since L 6.46 removed support for C in favor of the new keys C and C. =cut sub get_configure_requires_yaml { shift; # package name my %prereqs = @_; my $yaml = "configure_requires:\n"; while (my ($module, $version) = each %prereqs) { $yaml .= " $module: $version\n"; } return $yaml; } =item string = Glib::MakeHelper->postamble_clean (@files) Create and return the text of a realclean rule that cleans up after much of the autogeneration performed by Glib-based modules. Everything in @files will be deleted, too (it may be empty). The reasoning behind using this instead of just having you use the 'clean' or 'realclean' keys is that this avoids you having to remember to put Glib's stuff in your Makefile.PL's WriteMakefile arguments. =cut our @ADDITIONAL_FILES_TO_CLEAN = (); sub postamble_clean { shift; # package name " realclean :: -\$(RM_RF) build perl-\$(DISTNAME).spec @ADDITIONAL_FILES_TO_CLEAN @_ "; } =item string = Glib::MakeHelper->postamble_docs (@xs_files) NOTE: this is The Old Way. see L for The New Way. Create and return the text of Makefile rules to build documentation from the XS files with Glib::ParseXSDoc and Glib::GenPod. Use this in your MY::postamble to enable autogeneration of POD. This updates dependencies with the list of pod names generated by an earlier run of C. There is a special Makefile variable POD_DEPENDS that should be set to the list of files that need to be created before the doc.pl step is run, include files. There is also a variable BLIB_DONE which should be used as a dependency anywhere a rule needs to be sure that a loadable and working module resides in the blib directory before running. =cut sub postamble_docs { my ($class, @xs_files) = @_; return Glib::MakeHelper->postamble_docs_full (XS_FILES => \@xs_files); } =item string = Glib::MakeHelper->postamble_docs_full (...) Create and return the text of Makefile rules to build documentation from the XS files with Glib::ParseXSDoc and Glib::GenPod. Use this in your MY::postamble to enable autogeneration of POD. This updates dependencies with the list of pod names generated by an earlier run of C. There is a special Makefile variable POD_DEPENDS that should be set to the list of files that need to be created before the doc.pl step is run, include files. There is also a variable BLIB_DONE which should be used as a dependency anywhere a rule needs to be sure that a loadable and working module resides in the blib directory before running. The parameters are a list of key=>value pairs. You must specify at minimum either DEPENDS or XS_FILES. =over =item DEPENDS => ExtUtils::Depends object Most gtk2-perl modules use ExtUtils::Depends to find headers, typemaps, and other data from parent modules and to install this data for child modules. We can find from this object the list of XS files to scan for documentation, doctype mappings for parent modules, and other goodies. =item XS_FILES => \@xs_file_names A list of xs files to scan for documentation. Ignored if DEPENDS is used. =item DOCTYPES => \@doctypes_file_names List of filenames to pass to C. May be omitted. =item COPYRIGHT => string POD text to be inserted in the 'COPYRIGHT' section of each generated page. May be omitted. =item COPYRIGHT_FROM => file name The name of a file containing the POD to be inserted in the 'COPYRIGHT' section of each generated page. May be omitted. =item NAME => extension name The name of the extension, used to set the main mod for Glib::GenPod (used in the generated see-also listings). May be omitted in favor of the name held inside the ExtUtils::Depends object. If DEPENDS is also specified, NAME wins. =back =cut sub postamble_docs_full { my $class = shift; # package name my %params = @_; croak "Usage: $class\->postamble_docs_full (...)\n" . " where ... is a list of key/value pairs including at the\n" . " very least one of DEPENDS=>\$extutils_depends_object or\n" . " XS_FILES=>\@xs_files\n" . " " unless $params{DEPENDS} or $params{XS_FILES}; my @xs_files = (); my @doctypes = (); my $add_types = ''; my $copyright = ''; my $name = ''; if ($params{DOCTYPES}) { @doctypes = ('ARRAY' eq ref $params{DOCTYPES}) ? @{$params{DOCTYPES}} : ($params{DOCTYPES}); } if (UNIVERSAL::isa ($params{DEPENDS}, 'ExtUtils::Depends')) { my $dep = $params{DEPENDS}; # fetch list of XS files from depends object. # HACK ALERT: the older versions of ExtUtils::Depends # (<0.2) use a different key layout and don't store enough # metadata about the dependencies, so we require >=0.2; # however, the older versions don't support import version # checking (in fact they don't support version-checking at # all), so the "use" test in a Makefile.PL can't tell if # it has loaded a new enough version! # the rewrite at version 0.200 added the get_dep() method, # which we use, so let's check for that. unless (defined &ExtUtils::Depends::get_deps) { use ExtUtils::MakeMaker; warn "ExtUtils::Depends is too old, need at " . "least version 0.2"; # this is so that CPAN builds will do the upgrade # properly. WriteMakefile( PREREQ_FATAL => 1, PREREQ_PM => { 'ExtUtils::Depends' => 0.2, }, ); exit 1; # not reached. } # continue with the excessive validation... croak "value of DEPENDS key must be an ExtUtils::Depends object" unless UNIVERSAL::isa $dep, 'ExtUtils::Depends'; croak "corrupt or invalid ExtUtils::Depends instance -- " . "the xs key is " .(exists ($dep->{xs}) ? "missing" : "broken")."!" unless exists $dep->{xs} and 'ARRAY' eq ref $dep->{xs}; # finally, *this* is what we wanted. @xs_files = @{$dep->{xs}}; # fetch doctypes files from the depends' dependencies. my %deps = $dep->get_deps; foreach my $d (keys %deps) { my $f = File::Spec->catfile ($deps{$d}{instpath}, 'doctypes'); #warn "looking for $f\n"; push @doctypes, $f if -f $f; } # the depends object conveniently knows the main module name. $name = $dep->{name}; } else { @xs_files = @{ $params{XS_FILES} }; } if ($params{COPYRIGHT}) { $copyright = $params{COPYRIGHT}; } elsif ($params{COPYRIGHT_FROM}) { open IN, $params{COPYRIGHT_FROM} or croak "can't open $params{COPYRIGHT_FROM} for reading: $!\n"; local $/ = undef; $copyright = ; close IN; } if ($copyright) { # this text has to be escaped for both make and the shell. $copyright =~ s/\n/\\n/gm; # collapse to one line. $copyright =~ s|/|\\/|g; # escape slashes for qq// $copyright = "Glib::GenPod::set_copyright(qq/$copyright/);"; } # the module name specified explicitly overrides the one in a # depends object. $name = $params{NAME} if $params{NAME}; # now sanitize if ($name) { # this is supposed to be a module name; names don't have # things in them that need escaping, so let's leave it alone. # that way, if there's a quoting error, the user will figure # it out real quick. $name = "Glib::GenPod::set_main_mod(qq($name));"; } #warn "".scalar(@doctypes)." doctype files\n"; #warn "".scalar(@xs_files)." xs files\n"; if (@doctypes) { $add_types = 'add_types (' . join(', ', map {'qq(' . quotemeta ($_) . ')'} @doctypes) . '); ' } my $docgen_code = '' . $add_types . ' ' . $copyright . ' ' . $name . ' $(POD_SET) ' . 'xsdoc2pod(q(build/doc.pl), q($(INST_LIB)), q(build/podindex));'; #warn "docgen_code: $docgen_code\n"; # BLIB_DONE should be set to something we can depend on that will # ensure that we are safe to link against an up to date module out # of blib. basically what we need to wait on is the static/dynamic # lib file to be created. the following trick is intended to handle # both of those cases without causing the other to happen. return <<"__EOM__"; BLIB_DONE=build/blib_done_\$(LINKTYPE) build/blib_done_dynamic :: \$(INST_DYNAMIC) \$(NOECHO) \$(TOUCH) \$@ build/blib_done_static :: \$(INST_STATIC) \$(NOECHO) \$(TOUCH) \$@ build/blib_done_ :: build/blib_done_dynamic \$(NOECHO) \$(TOUCH) \$@ # documentation stuff \$(INST_LIB)/Glib/GenPod.pm \$(INST_LIB)/Glib/ParseXSDoc.pm: pm_to_blib build/doc.pl :: Makefile @xs_files \$(NOECHO) \$(ECHO) Parsing XS files... \$(NOECHO) \$(FULLPERLRUN) -I \$(INST_LIB) -I \$(INST_ARCHLIB) -MGlib::ParseXSDoc \\ -e "xsdocparse (qw(@xs_files))" > \$@ # passing all of these files through the single podindex file, which is # created at the same time, prevents problems with -j4 where xsdoc2pod would # have multiple instances @gend_pods :: build/podindex build/podindex :: \$(BLIB_DONE) Makefile build/doc.pl \$(POD_DEPENDS) \$(NOECHO) \$(ECHO) Generating POD... \$(NOECHO) \$(FULLPERLRUN) -I \$(INST_LIB) -I \$(INST_ARCHLIB) -MGlib::GenPod -M\$(NAME) \\ -e "$docgen_code" \$(INST_LIB)/\$(FULLEXT)/: \$(FULLPERLRUN) -MExtUtils::Command -e mkpath \$@ \$(INST_LIB)/\$(FULLEXT)/index.pod :: \$(INST_LIB)/\$(FULLEXT)/ build/podindex \$(NOECHO) \$(ECHO) Creating POD index... \$(NOECHO) \$(FULLPERLRUN) -e "print qq(\\n=head1 NAME\\n\\n\$(NAME) \\\\- API Reference Pod Index\\n\\n=head1 PAGES\\n\\n=over\\n\\n)" \\ > \$(INST_LIB)/\$(FULLEXT)/index.pod \$(NOECHO) \$(FULLPERLRUN) -ne "print q(=item L<) . (split q( ))[1] . qq(>\\n\\n);" < build/podindex >> \$(INST_LIB)/\$(FULLEXT)/index.pod \$(NOECHO) \$(FULLPERLRUN) -e "print qq(=back\\n\\n);" >> \$(INST_LIB)/\$(FULLEXT)/index.pod __EOM__ } =item string = Glib::MakeHelper->postamble_rpms (HASH) Create and return the text of Makefile rules to manage building RPMs. You'd put this in your Makefile.PL's MY::postamble. I is a set of search and replace keys for the spec file. All occurences of @I@ in the spec file template perl-$(DISTNAME).spec.in will be replaced with I. 'VERSION' and 'SOURCE' are supplied for you. For example: Glib::MakeHelper->postamble_rpms ( MYLIB => 2.0.0, # we can work with anything from this up MYLIB_RUN => 2.3.1, # we are actually compiled against this one PERL_GLIB => 1.01, # you must have this version of Glib ); will replace @MYLIB@, @MYLIB_RUN@, and @PERL_GLIB@ in spec file. See the build setups for Glib and Gtk2 for examples. Note: This function just returns an empty string on Win32. =cut sub postamble_rpms { shift; # package name return '' unless $ENV{GPERL_BUILD_RPMS}; my @dirs = qw{$(RPMS_DIR) $(RPMS_DIR)/BUILD $(RPMS_DIR)/RPMS $(RPMS_DIR)/SOURCES $(RPMS_DIR)/SPECS $(RPMS_DIR)/SRPMS}; my $cwd = getcwd(); chomp (my $date = `date +"%a %b %d %Y"`); my %subs = ( 'VERSION' => '$(VERSION)', 'SOURCE' => '$(DISTNAME)-$(VERSION).tar.gz', 'DATE' => $date, @_, ); my $substitute = '$(PERL) -npe \''.join('; ', map { "s/\\\@$_\\\@/$subs{$_}/g"; } keys %subs).'\''; " RPMS_DIR=\$(HOME)/rpms \$(RPMS_DIR)/: -mkdir @dirs SUBSTITUTE=$substitute perl-\$(DISTNAME).spec :: perl-\$(DISTNAME).spec.in \$(VERSION_FROM) Makefile \$(SUBSTITUTE) \$< > \$@ dist-rpms :: Makefile dist perl-\$(DISTNAME).spec \$(RPMS_DIR)/ cp \$(DISTNAME)-\$(VERSION).tar.gz \$(RPMS_DIR)/SOURCES/ rpmbuild -ba --define \"_topdir \$(RPMS_DIR)\" perl-\$(DISTNAME).spec dist-srpms :: Makefile dist perl-\$(DISTNAME).spec \$(RPMS_DIR)/ cp \$(DISTNAME)-\$(VERSION).tar.gz \$(RPMS_DIR)/SOURCES/ rpmbuild -bs --nodeps --define \"_topdir \$(RPMS_DIR)\" perl-\$(DISTNAME).spec "; } =item string = Glib::MakeHelper->postamble_precompiled_headers (@headers) Create and return the text of Makefile rules for a 'precompiled-headers' target that precompiles I<@headers>. If you call this before you call C, all temporary files will be removed by the 'realclean' target. =cut sub postamble_precompiled_headers { shift; # package name my @headers = @_; my @precompiled_headers = (); my $rules = ""; foreach my $header (@headers) { my $output = $header . '.gch'; push @precompiled_headers, $output; push @ADDITIONAL_FILES_TO_CLEAN, $output; $rules .= <SUPER::const_cccmd (@_); return '' unless $inherited; require Config; # a more sophisticated match may be necessary, but this works for me. if ($Config::Config{cc} eq "cl") { $inherited .= ' /Fo$@'; } else { $inherited .= ' -o $@'; } $inherited; } # # And, some black magick to help make learn to shut the hell up. # sub quiet_rule { my $cmds = shift; my @lines = split /\n/, $cmds; foreach (@lines) { if (/NOECHO/) { # already quiet } elsif (/XSUBPP/) { s/^\t/\t\$(NOECHO) \$(ECHO) [ XS \$< ]\n\t\$(NOECHO) /; } elsif (/CCCMD/) { s/^\t/\t\$(NOECHO) \$(ECHO) [ CC \$< ]\n\t\$(NOECHO) /; } elsif (/\bLD\b/) { s/^\t/\t\$(NOECHO) \$(ECHO) [ LD \$@ ]\n\t\$(NOECHO) /; } elsif (/[_\b]AR\b/) { s/^\t/\t\$(NOECHO) \$(ECHO) [ AR \$@ ]\n\t\$(NOECHO) /; } } return join "\n", @lines; } sub c_o { return quiet_rule (shift->SUPER::c_o (@_)); } sub xs_o { return quiet_rule (shift->SUPER::xs_o (@_)); } sub xs_c { return quiet_rule (shift->SUPER::xs_c (@_)); } sub dynamic_lib { return quiet_rule (shift->SUPER::dynamic_lib (@_)); } sub static_lib { return quiet_rule (shift->SUPER::static_lib (@_)); } 1; =head1 AUTHOR Ross McFarland Erwmcfa1 at neces dot comE hacked up and documented by muppet. =head1 COPYRIGHT AND LICENSE Copyright 2003-2004, 2012 by the gtk2-perl team 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-1.320/lib/Glib/Object/000755 001750 000024 00000000000 12636025764 016333 5ustar00bdmanningstaff000000 000000 Glib-1.320/lib/Glib/ParseXSDoc.pm000644 001750 000024 00000055035 12636024737 017445 0ustar00bdmanningstaff000000 000000 package Glib::ParseXSDoc; # vim: set ts=4 : use strict; use Data::Dumper; use Storable qw(store_fd); use Exporter; use Carp; our @ISA = qw(Exporter); our @EXPORT = qw( xsdocparse ); our $VERSION = '1.320'; our $NOISY = $ENV{NOISYDOC}; =head1 NAME Glib::ParseXSDoc - Parse POD and XSub declarations from XS files. =head1 DESCRIPTION This is the heart of an automatic API reference documentation system for XS-based Perl modules. FIXME more info here!! FIXME document recognized POD directives and the output data structures =head1 FUNCTIONS =over =item xsdocparse (@filenames) Parse xs files for xsub signatures and pod. Writes to standard output a data structure suitable for eval'ing in another Perl script, describing all the stuff found. The output contains three variables: =over =item $xspods = ARRAYREF array of pods found in the verbatim C portion of the XS file, listed in the order found. These are assumed to pertain to the XS/C api, not the Perl api. Any C<=for apidoc> paragraphs following an C<=object> paragraphs in the verbatim sections are stripped (as are the C<=object> paragraphs), and will appear instead in C<< $data->{$package}{pods} >>. =item $data = HASHREF big hash keyed by package name (as found in the MODULE line), containing under each key a hash with all the xsubs and pods in that package, in the order found. Packages are consolidated across multiple files. =back FYI, this creates a new parser and calls C on it for each input filename; then calls C to ensure that any C<=for apidoc name> pods are matched up with their target xsubs; and finally calls Data::Dumper to write the data to stdout. So, if you want to get finer control over how the output is created, or keep all the data in-process, now you know how. :-) =cut sub xsdocparse { my @filenames = @_; my $parser = Glib::ParseXSDoc->new; foreach my $filename (@filenames) { $parser->parse_file ($filename); } $parser->canonicalize_xsubs; $parser->swizzle_pods; $parser->preprocess_pods; $parser->clean_out_empty_pods; print "# THIS FILE IS AUTOMATICALLY GENERATED - ANY CHANGES WILL BE LOST\n"; print "# generated by $0 ".scalar (localtime)."\n"; print "# input files:\n"; map { print "# $_\n" } @filenames; print "#\n\n"; # Data::Dumper converts the whole output to a string, and consequently # uses an obscene amount of ram on Gtk2's nearly 200 xs files. Use # Storable unless the user really really wants to force us to fall back # to Data::Dumper. Storable doesn't seem to work well on win32, so # always use Data::Dumper there. my $use_dd = $ENV{FORCE_DATA_DUMPER} || $^O eq 'MSWin32'; if ($use_dd) { $Data::Dumper::Purity = 1; print Data::Dumper->Dump([$parser->{xspods}, $parser->{data}], [qw($xspods $data)]); print "\n1;\n"; } else { print "use Storable qw(fd_retrieve);\n"; print "\$xspods = fd_retrieve \\*DATA;\n"; print "\$data = fd_retrieve \\*DATA;\n"; print "\n1;\n"; print "__DATA__\n"; # NOTE: don't assume STDOUT, because other code may have select'd # a different file handle. store_fd $parser->{xspods}, select; store_fd $parser->{data}, select; } return [ keys %{$parser->{data}} ]; } =back =cut # ========================================================================= =head1 METHODS =over =item $Glib::ParseXSDoc::verbose If true, this causes the parser to be verbose. =cut our $verbose = undef; =item $parser = Glib::ParseXSDoc->new Create a new xsub parser. =cut sub new { my $class = shift; return bless { # state module => undef, package => undef, prefix => undef, # data xspods => [], #pods for the exported xs interface, e.g. the C stuff data => {}, # all the shizzle, by package name }, $class; } =item string = $parser->package Get the current package name. Falls back to the module name. Will be undef if the parser hasn't reached the first MODULE line. =cut sub package { my $self = shift; return ($self->{package} || $self->{module}) } =item HASHREF = $parser->pkgdata The data hash corresponding to the current package, honoring the most recently encountered C<=for object> directive. Ensures that it exists. Returns a reference to the member of the main data structure, so modifications are permanent and useful. =cut sub pkgdata { my $self = shift; my $pkg = $self->{object} || $self->package; my $pkgdata = $self->{data}{$pkg}; if (not defined $pkgdata) { $pkgdata = {}; $self->{data}{$pkg} = $pkgdata; } return $pkgdata; } =item $parser->parse_file (filename) Parse one xs file. Stores all the collected data in I<$parser>'s internal data structures. =cut sub parse_file { my $self = shift; my $filename = shift; local *IN; open IN, $filename or die "can't open $filename: $!\n"; print STDERR "scanning $filename\n" if $verbose; $self->{filehandle} = \*IN; $self->{filename} = $filename; # there was once a single state machine to parse an entire # file, but it turned into a bi-level state machine because # of the two-part nature of XS files. that's silly, so i've # broken it into two loops: the part that scans up to the # first MODULE line, and the part that scans the rest of the # file. my $lastpod = undef; # most recently-read pod (for next xsub) my @thesepackages = (); # packages seen in this file # In the verbatim C portion of the file: # seek the first MODULE line *outside* comments. # collect any pod we encounter; only certain ones are # precious to us... my... preciousssss... ahem. $self->{module} = undef; $self->{package} = undef; $self->{prefix} = undef; $self->{object} = undef; while () { chomp; # in the verbatim C section before the first MODULE line, # we need to be on the lookout for a few things... # we need the first MODULE line, of course... if ($self->is_module_line ($_)) { last; # go to the next state machine. # mostly we want pods. } elsif (/^=/) { my $thispod = $self->slurp_pod_paragraph ($_); # we're only interested in certain pod directives here. if (/^=for\s+(apidoc|object)\b/) { my $which = $1; warn "$filename:".($.-@{$thispod->{lines}}+1).":" . " =for $which found before " . "MODULE directive\n"; } push @{ $self->{xspods} }, $thispod; ## # we also need to track whether we're in a C comment, because ## # MODULE directives are ignore in multiline comments. ## } elsif (m{/\*}) { ## # there was an open comment marker on this line. ## # see if it's alone. ## s{/\*.*\*/}{}g; ## if (m{/\*}) { ## # look for the end... ## while () { ## } ## } } } # preprocessor conditionals my @cond; $lastpod = undef; while () { # # we're seeking xsubs and pods to document the Perl interface. # if ($self->is_module_line ($_)) { # xsubs cannot steal pods across MODULE lines. $lastpod = undef; } elsif (/^\s*$/) { # ignore blank lines; but a blank line after a pod # means it can't be associated with an xsub. $lastpod = undef; } elsif (/^\s*#\s*(if|ifdef|ifndef)\s*(\s.*)$/) { #warn "conditional $1 $2\n"; push @cond, $2; #print Dumper(\@cond); } elsif (/^\s*#\s*else\s*(\s.*)?$/) { #warn "else $cond[-1]\n"; if (exists $cond[$#cond]) { $cond[$#cond] = '!' . $cond[$#cond]; } } elsif (/^\s*#\s*endif\s*(\s.*)?$/) { #warn "endif $cond[-1]\n"; pop @cond; } elsif (/^\s*#/) { # ignore comments. we've already determined that # this isn't a preprocessor directive (or at least # not one in which we're interested). } elsif (/^(BOOT|PROTOTYPES)/) { # ignore keyword lines in which we aren't interested } elsif (/^=/) { # slurp in pod, up to and including the next =cut. # put it in $lastpod so that the next-discovered # xsub can claim it. $lastpod = $self->slurp_pod_paragraph ($_); # we're interested in certain pod directives at # this point... if (/^=for\s+object(?:\s+([\w\:]*))?(.*)/) { $self->{object} = $1; if ($2) { $self->pkgdata->{blurb} = $2; $self->pkgdata->{blurb} =~ s/^\s*-\s*//; # If the line has the special form # "=for object Foo (Bar)", we take this # to mean: document the object Bar in # the file Foo. if ($self->pkgdata->{blurb} =~ s/\s*\((.*)\)//) { print STDERR "Documenting object $1 in file " .$self->{object}."\n"; $self->pkgdata->{object} = $1; if ('' eq $self->pkgdata->{blurb}) { delete $self->pkgdata->{blurb}; } } } } elsif (/^=for\s+(enum|flags)\s+([\w:]+)/) { push @{ $self->pkgdata->{enums} }, { type => $1, name => $2, pod => $lastpod, }; # claim this pod now! $lastpod = undef; } elsif (/^=for\s+see_also\s+(.+)$/) { push @{ $self->pkgdata->{see_alsos} }, $1; # claim this pod now! $lastpod = undef; } elsif (/^=for\s+deprecated_by\s+([\w:]+)$/) { push @{ $self->pkgdata->{deprecated_bys} }, $1; $lastpod = undef; } push @{ $self->pkgdata->{pods} }, $lastpod if defined $lastpod; } elsif (/^\w+/) { # there's something at the beginning of the line! # we've ruled out everything else, so this must be # an xsub. slurp in everything up to the next # blank line (or end of file). i know that's not # *really* an entire XSUB body, but we don't care # -- we only need the return value, name, arg types, # and body type, and there aren't supposed to be # blank lines in all of that. my @thisxsub = ($_); while () { chomp; last if /^\s*$/; push @thisxsub, $_; } my $xsub = $self->parse_xsub (\@thisxsub); if ($lastpod) { # aha! we'll lay claim to that... pop @{ $self->pkgdata->{pods} }; $xsub->{pod} = $lastpod; $lastpod = undef; } $xsub->{preprocessor_conditionals} = [ @cond ]; push @{ $self->pkgdata->{xsubs} }, $xsub; } else { # this is probably xsub function body, comment, or # some other stuff we don't care about. } } # that's it for this file... close IN; delete $self->{filehandle}; delete $self->{filename}; } =item $parser->swizzle_pods Match C<=for apidoc> pods to xsubs. =cut sub swizzle_pods { my $self = shift; foreach my $package (keys %{$self->{data}}) { my $pkgdata = $self->{data}{$package}; next unless $pkgdata->{pods}; next unless $pkgdata->{xsubs}; my $pods = $pkgdata->{pods}; for (my $i = @$pods-1 ; $i >= 0 ; $i--) { my $firstline = $pods->[$i]{lines}[0]; next unless $firstline =~ /=for\s+apidoc\s+([:\w]+)\s*/; my $name = $1; foreach my $xsub (@{ $pkgdata->{xsubs} }) { if ($name eq $xsub->{symname}) { $xsub->{pod} = $pods->[$i]; splice @$pods, $i, 1; last; } } } } } =item $parser->preprocess_pods Honor the C<__hide__> and C<__function__> directives in C<=for apidoc> lines. We look for the strings anywhere, but you'll typically have it at the end of the line, e.g.: =for apidoc symname __hide__ for detached blocks =for apidoc __hide__ for attached blocks =for apidoc symname __function__ for functions rather than methods =for apidoc __function__ for functions rather than methods =cut sub preprocess_pods { my $self = shift; foreach my $package (keys %{$self->{data}}) { my $pkgdata = $self->{data}{$package}; foreach (@{$pkgdata->{pods}}) { my $firstline = $_->{lines}[0]; if ($firstline) { $_->{position} = $1 if ($firstline =~ /=for\s+position\s+(\w+)/); } } next unless $pkgdata->{xsubs}; # look for magic keywords in the =for apidoc foreach (@{$pkgdata->{xsubs}}) { my $firstline = $_->{pod}{lines}[0]; if ($firstline) { $_->{function} = ($firstline =~ /__function__/); $_->{hidden} = ($firstline =~ /__hide__/); $_->{deprecated} = ($firstline =~ /__deprecated__/); $_->{gerror} = ($firstline =~ /__gerror__/); } } } } # =============================================================== =item bool = $parser->is_module_line ($line) Analyze I<$line> to see if it contains an XS MODULE directive. If so, returns true after setting the I<$parser>'s I, I, and I accordingly. =cut sub is_module_line { my $self = shift; my $l = shift; if ($l =~ /^MODULE\s*=\s*([:\w]+) (?:\s+PACKAGE\s*=\s*([:\w]+) (?:\s+PREFIX\s*=\s*([:\w]+))?)? /x) { $self->{module} = $1; $self->{package} = $2 || $self->{module}; $self->{prefix} = $3; $self->{object} = undef; return 1; } else { return 0; } } =item $pod = $parser->slurp_pod_paragraph ($firstline, $term_regex=/^=cut\s*/) Slurp up POD lines from I<$filehandle> from here to the next I<$term_regex> or EOF. Since you probably already read a line to determine that we needed to start a pod, you can pass that first line to be included. =cut sub slurp_pod_paragraph { my $parser = shift; my $firstline = shift; my $term_regex = shift || qr/^=cut\s*/o; my $filehandle = $parser->{filehandle}; # just in case. chomp $firstline; my @lines = $firstline ? ($firstline) : (); while (my $line = <$filehandle>) { chomp $line; push @lines, $line; last if $line =~ m/$term_regex/; } return { filename => $parser->{filename}, line => $. - @lines, lines => \@lines, }; } =item $xsub = $parser->parse_xsub (\@lines) =item $xsub = $parser->parse_xsub (@lines) Parse an xsub header, in the form of a list of lines, into a data structure describing the xsub. That includes pulling out the argument types, aliases, and code type. Without artificial intelligence, we cannot reliably determine anything about the types or number of parameters returned from xsubs with PPCODE bodies. OUTLIST parameters are pulled from the args list and put into an "outlist" key. IN_OUTLIST parameters are put into both. Data type names are not mangled at all. Note that the method can take either a list of lines or a reference to a list of lines. The flat list form is provided for compatibility; the reference form is preferred, to avoid duplicating a potentially large list of strings. =cut sub parse_xsub { my ($self, @thisxsub) = @_; # allow for pass-by-reference. @thisxsub = @{ $thisxsub[0] } if @thisxsub == 1 && 'ARRAY' eq ref $thisxsub[0]; map { s/#.*$// } @thisxsub; my $filename = $self->{filename}; my $oldwarn = $SIG{__WARN__}; #$SIG{__WARN__} = sub { # warn "$self->{filename}:$.: " # . join(" / ", $self->{module}||"", $self->{package}||"") # . "\n $_[0]\n ".Dumper(\@thisxsub) #}; my $lineno = $. - @thisxsub; my %xsub = ( 'filename' => $filename, 'line' => ($.-@thisxsub), 'module' => $self->{module}, 'package' => $self->package, # to be overwritten as needed ); my $args; #warn Dumper(\@thisxsub); # merge continuation lines. xsubpp allows continuation lines in the # xsub arguments list and barfs on them in other spots, but with xsubpp # providing such validation, we'll just cheat and merge any that we find. # this will bork the line counting logic we have below, but i don't see # a fix for it without major tearup of the code here. my @foo = @thisxsub; @thisxsub = shift @foo; while (my $s = shift @foo) { if ($thisxsub[$#thisxsub] =~ s/\\$//) { chomp $thisxsub[$#thisxsub]; $thisxsub[$#thisxsub] .= $s; } else { push @thisxsub, $s; } } if ($thisxsub[0] =~ /^([^(]+\s+\*?) # return type, possibly with a * \b([:\w]+)\s* # symbol name \( # open paren (.*) # whatever's inside, if anything \) # close paren, maybe with space \s*;?\s*$/x) { # and maybe other junk at the end # all on one line $xsub{symname} = $2; $args = $3; my $r = $1; $xsub{return_type} = [$r] unless $r =~ /^void\s*$/; shift @thisxsub; $lineno++; } elsif ($thisxsub[1] =~ /^(\S+)\s*\((.*)\);?\s*$/) { # multiple lines $xsub{symname} = $1; $args = $2; # return type is on line 0 $thisxsub[0] =~ s/\s*$//; $xsub{return_type} = [$thisxsub[0]] unless $thisxsub[0] =~ /^void\s*$/; shift @thisxsub; $lineno++; shift @thisxsub; $lineno++; } # eat padding spaces from the arg string. i tried several ways of # building this into the regexen above, but found nothing that still # allowed the arg string to be empty, which we'll have for functions # (not methods) without resorting to extremely arcane negatory # lookbeside assertiveness operators. $args =~ s/^\s*//; $args =~ s/\s*$//; # we can get empty arg strings on non-methods. #warn "$filename:$lineno: WTF : args string is empty\n" # if not defined $args; my %args = (); my @argstr = split /\s*,\s*/, $args; #warn Dumper([$args, \%args, \@argstr]); for (my $i = 0 ; $i < @argstr ; $i++) { # the last one can be an ellipsis, let's handle that specially if ($i == $#argstr and $argstr[$i] eq '...') { $args{'...'} = { name => '...', }; push @{ $xsub{args} }, $args{'...'}; last; } if ($argstr[$i] =~ /^(?:(IN_OUTLIST|OUTLIST)\s+)? # OUTLIST would be 1st ([^=]+(?:\b|\s))? # arg type is optional, too (\w+) # arg name (?:\s*=\s*(.+))? # possibly a default value $/x) { if (defined $1) { push @{ $xsub{outlist} }, { type => $2, name => $3, }; if ($1 eq 'IN_OUTLIST') { # also an arg $args{$3} = { type => $2, name => $3, }; $args{$3}{default} = $4 if defined $4; push @{ $xsub{args} }, $args{$3}; } } else { $args{$3} = { type => $2, name => $3, }; $args{$3}{default} = $4 if defined $4; push @{ $xsub{args} }, $args{$3}; } } elsif ($argstr[$i] =~ /^g?int\s+length\((\w+)\)$/) { #warn " ******* $i is string length of $1 *****\n"; } else { warn "$filename:$lineno: ($xsub{symname}) don't know how to" . " parse arg $i, '$argstr[$i]'\n"; } } my $xstate = 'args'; while ($_ = shift @thisxsub) { if (/^\s*ALIAS:/) { $xstate = 'alias'; } elsif (/\s*(PREINIT|CLEANUP|OUTPUT|C_ARGS):/) { $xstate = 'code'; } elsif (/\s*(PPCODE|CODE):/) { $xsub{codetype} = $1; last; } elsif ($xstate eq 'alias') { /^\s*([:\w]+)\s*=\s*(\d+)\s*$/; if (defined $2) { $xsub{alias}{$1} = $2; } else { warn "$filename:$lineno: WTF : seeking alias on line $_\n"; } } elsif ($xstate eq 'args') { if (/^\s* (.+(?:\b|\s)) # datatype (\w+) # arg name ;? # optional trailing semicolon \s*$/x) { if (exists $args{$2}) { $args{$2}{type} = $1 } else { warn "$filename:$lineno: unused arg $2\n"; warn " line was '$_'\n"; } } elsif (/^\s*/) { # must've stripped a comment. } else { warn "$filename:$lineno: WTF : seeking args on line $_\n"; } } $lineno++; } # mangle the symbol name from an xsub into its actual perl name. $xsub{original_name} = $xsub{symname}; if (defined $self->{prefix}) { my $pkg = $self->package; $xsub{symname} =~ s/^($self->{prefix})?/$pkg\::/; } else { $xsub{symname} = ($self->package)."::".$xsub{symname}; } # sanitize all the C type declarations, which we have # collected in the arguments, outlist, and return types. if ($xsub{args}) { foreach my $a (@{ $xsub{args} }) { $a->{type} = sanitize_type ($a->{type}) if defined $a->{type}; } } if ($xsub{outlist}) { foreach my $a (@{ $xsub{outlist} }) { $a->{type} = sanitize_type ($a->{type}) if defined $a->{type}; } } if ($xsub{return_type}) { for (my $i = 0 ; $i < @{ $xsub{return_type} } ; $i++) { $xsub{return_type}[$i] = sanitize_type ($xsub{return_type}[$i]); } } $SIG{__WARN__} = $oldwarn; return \%xsub; } sub sanitize_type { local $_ = shift; s/\s+/ /g; # squash all whitespace s/^\s//; # zap leading space s/\s$//; # zap trailing space s/(?<=\S)\*$/ */; # stars may not be glued to the name return $_; } sub canonicalize_xsubs { my $self = shift; return undef unless 'HASH' eq ref $self->{data}; # make sure that each package contains an xsub hash for each # xsub, whether an alias or not. foreach my $package (keys %{$self->{data}}) { my $pkgdata = $self->{data}{$package}; next unless $pkgdata or $pkgdata->{xsubs}; my $xsubs = $pkgdata->{xsubs}; @$xsubs = map { split_aliases ($_) } @$xsubs; } } sub split_aliases { my $xsub = shift; return $xsub unless exists $xsub->{alias}; return $xsub unless 'HASH' eq ref $xsub->{alias}; my %aliases = %{ $xsub->{alias} }; my @xsubs = (); my %seen = (); foreach my $a (sort { $aliases{$a} <=> $aliases{$b} } keys %aliases) { push @xsubs, { %$xsub, symname => $a, pod => undef, # we do a deep copy on the args, so that changes to one do not # affect another. in particular, adding docs or hiding an arg # in one xsub shouldn't affect another. args => deep_copy_ref ($xsub->{args}), }; $seen{ $aliases{$a} }++; } if (! $seen{0}) { unshift @xsubs, $xsub; } return @xsubs; } sub deep_copy_ref { my $ref = shift; return undef if not $ref; my $reftype = ref $ref; if ('ARRAY' eq $reftype) { my @newary = map { deep_copy_ref ($_) } @$ref; return \@newary; } elsif ('HASH' eq $reftype) { my %newhash = map { $_, deep_copy_ref ($ref->{$_}) } keys %$ref; return \%newhash; } else { return $ref; } } =item $parser->clean_out_empty_pods Looks through the data member of the parser and removes any keys (and associated values) when no pod, enums, and xsubs exist for the package. =cut sub clean_out_empty_pods { my $data = shift; return unless (exists ($data->{data})); $data = $data->{data}; my $pod; my $xsub; foreach (keys %$data) { $pod = $data->{$_}; next if ((exists $pod->{pods} and scalar @{$pod->{pods}}) or exists $pod->{enums} or scalar (grep (!/DESTROY/, map { $_->{hidden} ? () : $_->{symname} } @{$pod->{xsubs}}))); #print STDERR "Deleting $_ from doc.pl's \$data\n"; delete $data->{$_}; } } 1; __END__ =back =head1 AUTHOR muppet Escott at asofyet dot orgE =head1 COPYRIGHT AND LICENSE Copyright (C) 2003, 2004 by muppet This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. =cut Glib-1.320/lib/Glib/Object/Subclass.pm000644 001750 000024 00000035070 12636024715 020450 0ustar00bdmanningstaff000000 000000 # Copyright (C) 2003-2004, 2010 by the gtk2-perl team (see the file AUTHORS for # the full list) # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # # $Id$ # package Glib::Object::Subclass; our $VERSION = '1.320'; use Glib; =head1 NAME Glib::Object::Subclass - register a perl class as a GObject class =head1 SYNOPSIS use Glib::Object::Subclass Some::Base::Class::, # parent class, derived from Glib::Object signals => { something_changed => { class_closure => sub { do_something_fun () }, flags => [qw(run-first)], return_type => undef, param_types => [], }, some_existing_signal => \&class_closure_override, }, properties => [ Glib::ParamSpec->string ( 'some_string', 'Some String Property', 'This property is a string that is used as an example', 'default value', [qw/readable writable/] ), ]; =head1 DESCRIPTION This module allows you to create your own GObject classes, which is useful to e.g. implement your own Gtk2 widgets. It doesn't "export" anything into your namespace, but acts more like a pragmatic module that modifies your class to make it work as a GObject class. You may be wondering why you can't just bless a Glib::Object into a different package and add some subs. Well, if you aren't interested in object parameters, signals, or having your new class interoperate transparently with other GObject-based modules (e.g., Gtk2 and friends), then you can just re-bless. However, a GObject's signals, properties, virtual functions, and GInterface implementations are specific to its GObjectClass. If you want to create a new GObject which was a derivative of GtkDrawingArea, but adds a new signal, you must create a new GObjectClass to which to add the new signal. If you don't, then I of the GtkDrawingAreas in your application will get that new signal! Thus, the only way to create a new signal or object property in the Perl bindings for Glib is to register a new subclass with the GLib type system via Glib::Type::register_object(). The Glib::Object::Subclass module is a Perl-developer-friendly interface to this bit of paradigm mismatch. =head2 USAGE This module works similar to the C pragma in that it registers the current package as a subclass of some other class (which must be a GObjectClass implemented either in C or some other language). The pragma requires at least one argument, the parent class name. The remaining arguments are key/value pairs, in any order, all optional: =over =item - properties => [] Add object properties; see L. =item - signals => {} Add or override signals; see L and L. =item - interfaces => [] Add GInterfaces to your class; see L. =back (Actually, these parameters are all passed straight through to Glib::Type::register_object(), adding __PACKAGE__ (the current package name) as the name of the new child class.) =head2 OBJECT METHODS AND FUNCTIONS The following methods are either added to your class on request (not yet implemented), or by default unless your own class implements them itself. This means that all these methods and functions will get sensible default implementations unless explicitly overwritten by you (by defining your own version). Except for C, all of the following are I and no I. That means that you should I call the superclass method. Instead, the GObject system will call these functions per class as required, emulating normal inheritance. =over 4 =item $class->new (attr => value, ...) The default constructor just calls C, which allows you to set properties on the newly created object. This is done because many C methods inherited by Gtk2 or other libraries don't have C methods suitable for subclassing. =item INIT_INSTANCE $self [not a method] C is called on each class in the hierarchy as the object is being created (i.e., from C or our default C). Use this function to initialize any member data. The default implementation will leave the object untouched. =cut =item GET_PROPERTY $self, $pspec [not a method] =item SET_PROPERTY $self, $pspec, $newval [not a method] C and C are called whenever somebody does C<< $object->get ($propname) >> or C<< $object->set ($propname => $newval) >> (from other languages, too). The default implementations hold property values in the object hash, equivalent to sub GET_PROPERTY { my ($self, $pspec) = @_; my $pname = $pspec->get_name; return (exists $self->{$pname} ? $self->{$pname} : $pspec->get_default_value); # until set } sub SET_PROPERTY { my ($self, $pspec, $newval) = @_; $self->{$pspec->get_name} = $newval; } Because C<< $pspec->get_name >> converts hyphens to underscores, a property C<"line-style"> is in the hash as C. These methods let you store/fetch properties in any way you need to. They don't have to be in the hash, you can calculate something, read a file, whatever. Most often you'll write your own C so you can take action when a property changes, like redraw or resize a widget. Eg. sub SET_PROPERTY { my ($self, $pspec, $newval) = @_; my $pname = $pspec->get_name $self->{$pname} = $newval; # ready for default GET_PROPERTY if ($pname eq 'line_style') { $self->queue_draw; # redraw with new lines } } Care must be taken with boxed non-reference-counted types such as C. In C the C<$newval> is generally good only for the duration of the call. Use C or similar if keeping it longer (see L). In C the returned memory must last long enough to reach the caller, which generally means returning a field, not a newly created object (which is destroyed with the scalar holding it). C is different from a C get_property method in that the perl method returns the retrieved value. For symmetry, the C<$newval> and C<$pspec> args on C are swapped from the C usage. =item FINALIZE_INSTANCE $self [not a method] C is called as the GObject is being finalized, that is, as it is being really destroyed. This is independent of the more common DESTROY on the perl object; in fact, you must I override C (it's not useful to you, in any case, as it is being called multiple times!). Use this hook to release anything you have to clean up manually. FINALIZE_INSTANCE will be called for each perl instance, in reverse order of construction. The default finalizer does nothing. =item $object->DESTROY [DO NOT OVERWRITE] Don't I overwrite C, use C instead. The DESTROY method of all perl classes derived from GTypes is implemented in the Glib module and (ab-)used for its own internal purposes. Overwriting it is not useful as it will be called I times, and often long before the object actually gets destroyed. Overwriting might be very harmful to your program, so I do that. Especially watch out for other classes in your ISA tree. =back =cut *new = \&Glib::Object::new; sub import { shift; # $self # we seem to be imported by classes using classes which use us. # ignore anything that doesn't look like a registration attempt. return unless @_; my $superclass = shift; my $class = caller; Glib::Type->register_object( $superclass, $class, @_, ); # ensure that we have a perlish new(). the old version of this # code used a CHECK block to put a new() in if we didn't already # have one in the package, but it may be too late to run a CHECK # block when we get here. so, we use the old-fashioned way... unshift @{ $class."::ISA" }, __PACKAGE__; } 1; =head1 PROPERTIES To create gobject properties, supply a list of Glib::ParamSpec objects as the value for the key 'properties'. There are lots of different paramspec constructors, documented in the C API reference's Parameters and Values page, as well as L. As of Glib 1.060, you can also specify explicit getters and setters for your properties at creation time. The default values in your properties are also honored if you don't set anything else. See Glib::Type::register_object in L for an example. =head1 SIGNALS Creating new signals for your new object is easy. Just provide a hash of signal names and signal descriptions under the key 'signals'. Each signal description is also a hash, with a few expected keys. All the keys are allowed to default. =over =item flags => GSignalFlags If not present, assumed to be 'run-first'. =item param_types => reference to a list of package names If not present, assumed to be empty (no parameters). =item class_closure => reference to a subroutine to call as the class closure. may also be a string interpreted as the name of a subroutine to call, but you should be very very very careful about that. If not present, the library will attempt to call the method named "do_signal_name" for the signal "signal_name" (uses underscores). You'll want to be careful not to let this handler method be a publically callable method, or one that has the name name as something that emits the signal. Due to the funky ways in which Glib is different from Perl, the class closures I inherit through normal perl inheritance. =item return_type => package name for return value. If undefined or not present, the signal expects no return value. if defined, the signal is expected to return a value; flags must be set such that the signal does not run only first (at least use 'run-last'). =item accumulator => signal return value accumulator quoting the Glib manual: "The signal accumulator is a special callback function that can be used to collect return values of the various callbacks that are called during a signal emission." If not specified, the default accumulator is used, and you just get the return value of the last handler to run. Accumulators are not really documented very much in the C reference, and the perl interface here is slightly different, so here's an inordinate amount of detail for this arcane feature: The accumulator function is called for every handler as ($cont, $acc) = &$func ($invocation_hint, $acc, $ret) $invocation_hint is an anonymous hash (including the signal name); $acc is the current accumulated return value; $ret is the value from the most recent handler. The two return values are a boolean C<$cont> for whether signal emission should continue (false to stop); and a new C<$acc> accumulated return value. (This is different from the C version, which writes through a return_accu.) =back =head1 OVERRIDING BASE METHODS GLib pulls some fancy tricks with function pointers to implement methods in C. This is not very language-binding-friendly, as you might guess. However, as described above, every signal allows a "class closure"; you may override thie class closure with your own function, and you can chain from the overridden method to the original. This serves to implement virtual overrides for language bindings. So, to override a method, you supply a subroutine reference instead of a signal description hash as the value for the name of the existing signal in the "signals" hash described in L. # override some important widget methods: use Glib::Object::Subclass Gtk2::Widget::, signals => { expose_event => \&expose_event, configure_event => \&configure_event, button_press_event => \&button_press_event, button_release_event => \&button_release_event, motion_notify_event => \&motion_notify_event, # note the choice of names here... see the discussion. size_request => \&do_size_request, } It's important to note that the handlers you supply for these are class-specific, and that normal perl method inheritance rules are not followed to invoke them from within the library. However, perl code can still find them! Therefore it's rather important that you choose your handlers' names carefully, avoiding any public interfaces that you might call from perl. Case in point, since size_request is a widget method, i chose do_size_request as the override handler. =head1 INTERFACES GObject supports only single inheritance; in place of multiple inheritance, GObject uses GInterfaces. In the Perl bindings we have mostly masqueraded this with multiple inheritance (that is, simply adding the GInterface class to the @ISA of the implementing class), but in deriving new objects the facade breaks and the magic leaks out. In order to derive an object that implements a GInterface, you have to tell the GLib type system you want your class to include a GInterface. To do this, simply pass a list of package names through the "interfaces" key; this will add these packages to your @ISA, and cause perl to invoke methods that you must provide. package Mup::MultilineEntry; use Glib::Object::Subclass 'Gtk2::TextView', interfaces => [ 'Gtk2::CellEditable' ], ; # perl will now invoke these methods, which are part of the # GtkCellEditable GInterface, when somebody invokes the # corresponding lower-case methods on your objects. sub START_EDITING { warn "start editing\n"; } sub EDITING_DONE { warn "editing done\n"; } sub REMOVE_WIDGET { warn "remove widget\n"; } =head1 SEE ALSO GObject - http://developer.gnome.org/doc/API/2.0/gobject/ =head1 AUTHORS Marc Lehmann Eschmorp@schmorp.deE, muppet Escott at asofyet dot orgE =head1 COPYRIGHT AND LICENSE Copyright 2003-2004, 2010 by muppet and the gtk2-perl team 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