Re: gtk priority constants

[Torsten Schoenfeld <kaffeetisch gmx de>]

On Wed, 2008-01-16 at 20:40 +0100, Torsten Schoenfeld wrote:

> Another way might be to put all GTK_, GDK_, and PANGO_ constants we want
> right into the Gtk2 namespace and make them importable from there.  The
> attached patch is a stab at this approach.

Here's another iteration, automating the binding and making exportable
of constants.  The patch puts the new stuff into Gtk2::CodeGen due to
laziness, but if incorporated, I think it should go into Glib::CodeGen.

This approach would make it easy to bind each and every gtk+, gdk, and
pango constant.  But do we want that?  What do we do with constants that
are already wrapped in some way?  Do we create new wrappers anyway and
deprecate the old ones?

-- 
Bye,
-Torsten

Index: CodeGen.pm
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/CodeGen.pm,v
retrieving revision 1.24
diff -u -d -p -r1.24 CodeGen.pm
--- CodeGen.pm	7 Jan 2008 19:54:48 -0000	1.24
+++ CodeGen.pm	20 Jan 2008 15:05:03 -0000
@@ -228,6 +228,99 @@ gperl_register_object ($typemacro, \"$pa
 }
 
 
+sub generate_constants_wrappers {
+    my $class = shift @_;
+
+    require File::Spec;
+    my %options = (
+        prefix => 'Glib',
+        lists => ['constants'],
+        xs_file => File::Spec->catfile ('build', 'constants.xs'),
+        header => 'gperl.h',
+        export_tag => 'constants',
+        @_,
+    );
+
+    my $xsub_code = '';
+    my @constants = ();
+    foreach my $list (@{ $options{lists} }) {
+        open my $list_fh, '<', $list
+            or croak "Unable to open `$list´ for reading: $!";
+
+        DESCRIPTION:
+        while (my $description = <$list_fh>) {
+            chomp $description;
+
+            # skip comments and blanks
+            next DESCRIPTION if $description =~ m/\A#|\A\s*\z/;
+
+            my ($constant, $type) = split "\t", $description;
+            push @constants, $constant;
+            $xsub_code .= <<"__EOD__";
+$type
+$constant ()
+    CODE:
+	RETVAL = $constant;
+    OUTPUT:
+	RETVAL
+
+__EOD__
+        }
+
+        close $list_fh
+            or croak "Unable to close `$list´: $!";
+    }
+
+    my $boot_code = <<"__EOD__";
+{
+	HV *tags_hv = get_hv ("$options{prefix}::EXPORT_TAGS", 1);
+	AV *constants_av = NULL;
+	SV *constants_ref_sv = NULL;
+	SV **constants_svp = hv_fetch (tags_hv, "$options{export_tag}", strlen ("$options{export_tag}"), 0);
+	if (constants_svp && gperl_sv_is_array_ref (*constants_svp)) {
+		constants_av = (AV *) SvRV (*constants_svp);
+		constants_ref_sv = *constants_svp;
+	} else {
+		constants_av = newAV ();
+		constants_ref_sv = newRV_noinc ((SV *) constants_av);
+	}
+__EOD__
+
+    foreach my $constant (@constants) {
+        $boot_code .= <<"__EOD__";
+	av_push (constants_av, newSVpv ("$constant", PL_na));
+__EOD__
+    }
+
+    $boot_code .= <<"__EOD__";
+	hv_store (tags_hv, "$options{export_tag}", strlen ("$options{export_tag}"), constants_ref_sv, 0);
+}
+__EOD__
+
+    open my $xs_fh, '>', $options{xs_file}
+        or croak "Unable to open `$options{xs_file}´ for writing: $!";
+
+    print $xs_fh <<"__EOD__";
+/**
+ * This is a generated file.  Do not edit.
+ */
+
+#include "$options{header}"
+
+MODULE = $options{prefix}::Constants	PACKAGE = $options{prefix}
+
+BOOT:
+$boot_code
+
+$xsub_code
+
+__EOD__
+
+    close $xs_fh
+        or croak "Unable to close `$options{xs_file}´: $!";
+}
+
+
 1;
 __END__
 
Index: Gtk2.pm
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/Gtk2.pm,v
retrieving revision 1.116
diff -u -d -p -r1.116 Gtk2.pm
--- Gtk2.pm	9 Jan 2008 21:55:05 -0000	1.116
+++ Gtk2.pm	20 Jan 2008 15:05:03 -0000
@@ -34,11 +34,33 @@ use Glib;
 # gtk+ and pango.
 eval "use Cairo;";
 
+use Exporter;
 require DynaLoader;
 
 our $VERSION = '1.172';
 
-our @ISA = qw(DynaLoader);
+our @ISA = qw(DynaLoader Exporter);
+
+# this is critical -- tell dynaloader to load the module so that its
+# symbols are available to all other modules.  without this, nobody
+# else can use important functions like gtk2perl_new_object!
+#
+# hrm.  win32 doesn't really use this, because we have to link the whole
+# thing at compile time to ensure all the symbols are defined.
+#
+# on darwin, at least with the particular 5.8.0 binary i'm using, perl
+# complains "Can't make loaded symbols global on this platform" when this
+# is set to 0x01, but goes on to work fine.  returning 0 here avoids the
+# warning and doesn't appear to break anything.
+sub dl_load_flags { $^O eq 'darwin' ? 0x00 : 0x01 }
+
+# now load the XS code.
+Gtk2->bootstrap ($VERSION);
+
+# %Gtk2::EXPORT_TAGS is filled from the constants-x.y files by the generated XS
+# code in build/constants.xs
+our @EXPORT_OK = map { @$_ } values %Gtk2::EXPORT_TAGS;
+$Gtk2::EXPORT_TAGS{all} = \ EXPORT_OK;
 
 sub import {
 	my $class = shift;
@@ -50,35 +72,24 @@ sub import {
 	my $init = 0;
 	my $threads_init = 0;
 
+	my @unknown_args = ($class);
 	foreach (@_) {
 		if (/^-?init$/) {
 			$init = 1;
 		} elsif (/-?threads-init$/) {
 			$threads_init = 1;
 		} else {
-			$class->VERSION ($_);
+			push @unknown_args, $_;
 		}
 	}
 
 	Gtk2::Gdk::Threads->init if ($threads_init);
 	Gtk2->init if ($init);
-}
 
-# this is critical -- tell dynaloader to load the module so that its
-# symbols are available to all other modules.  without this, nobody
-# else can use important functions like gtk2perl_new_object!
-#
-# hrm.  win32 doesn't really use this, because we have to link the whole
-# thing at compile time to ensure all the symbols are defined.
-#
-# on darwin, at least with the particular 5.8.0 binary i'm using, perl
-# complains "Can't make loaded symbols global on this platform" when this
-# is set to 0x01, but goes on to work fine.  returning 0 here avoids the
-# warning and doesn't appear to break anything.
-sub dl_load_flags { $^O eq 'darwin' ? 0x00 : 0x01 }
-
-# now load the XS code.
-Gtk2->bootstrap ($VERSION);
+	# call into Exporter for the unrecognized arguments; handles exporting
+	# and version checking
+	Gtk2->export_to_level (1, @unknown_args);
+}
 
 # Preloaded methods go here.
 
@@ -270,6 +281,22 @@ called, if done by "use Gtk2 -init -thre
 
 =back
 
+=head1 EXPORTS
+
+Gtk2 exports nothing by default, but some constants are available upon request.
+
+=over
+
+=item Tag: constants
+
+  GTK_PRIORITY_RESIZE
+  GDK_PRIORITY_EVENTS
+  GDK_PRIORITY_REDRAW
+
+=back
+
+See L<Glib> for other standard priority levels.
+
 =head1 SEE ALSO
 
 L<perl>(1), L<Glib>(3pm).
Index: Makefile.PL
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/Makefile.PL,v
retrieving revision 1.141
diff -u -d -p -r1.141 Makefile.PL
--- Makefile.PL	9 Jan 2008 21:55:07 -0000	1.141
+++ Makefile.PL	20 Jan 2008 15:05:03 -0000
@@ -109,6 +109,20 @@ if (($gtk_version[0] > 2 || ($gtk_versio
 }
 
 #
+# generate the constants wrappers
+#
+my @gtk_constants_lists =
+	Glib::MakeHelper->select_files_by_version ('constants', @gtk_version);
+my $gtk_constants_file = File::Spec->catfile ('build', 'constants.xs');
+Gtk2::CodeGen->generate_constants_wrappers (
+	prefix => 'Gtk2',
+	lists => \ gtk_constants_lists,
+	xs_file => $gtk_constants_file,
+	header => 'gtk2perl.h',
+        export_tag => 'constants');
+push @xs_files, $gtk_constants_file;
+
+#
 # create version macros for pango and atk
 #
 ExtUtils::PkgConfig->write_version_macros(
Index: constants-2.0
===================================================================
RCS file: constants-2.0
diff -N constants-2.0
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ constants-2.0	20 Jan 2008 15:05:03 -0000
@@ -0,0 +1,4 @@
+GDK_PRIORITY_EVENTS	gint
+GDK_PRIORITY_REDRAW	gint
+
+GTK_PRIORITY_RESIZE	gint
Index: t/00.Gtk2.t
===================================================================
RCS file: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/t/00.Gtk2.t,v
retrieving revision 1.21
diff -u -d -p -r1.21 00.Gtk2.t
--- t/00.Gtk2.t	14 May 2006 10:57:07 -0000	1.21
+++ t/00.Gtk2.t	20 Jan 2008 15:05:04 -0000
@@ -14,8 +14,8 @@ use warnings;
 
 # NOTE: this is the bootstrap test -- no Gtk2::TestHelper here!
 
-use Test::More tests => 35;
-BEGIN { use_ok('Gtk2') };
+use Test::More tests => 41;
+BEGIN { use_ok('Gtk2', ':constants') };
 
 #########################
 
@@ -43,6 +43,14 @@ is (@version, 3, 'version info is three 
 ok (Gtk2::Pango->CHECK_VERSION(0,0,0), 'CHECK_VERSION pass');
 ok (!Gtk2::Pango->CHECK_VERSION(50,0,0), 'CHECK_VERSION fail');
 
+my $number = qr/^\d+$/;
+like (Gtk2::GTK_PRIORITY_RESIZE, $number);
+like (Gtk2::GDK_PRIORITY_EVENTS, $number);
+like (Gtk2::GDK_PRIORITY_REDRAW, $number);
+like (GTK_PRIORITY_RESIZE, $number);
+like (GDK_PRIORITY_EVENTS, $number);
+like (GDK_PRIORITY_REDRAW, $number);
+
 SKIP:
 {
 	Gtk2->disable_setlocale;
Index: t/version-checks.t
===================================================================
RCS file: t/version-checks.t
diff -N t/version-checks.t
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ t/version-checks.t	20 Jan 2008 15:05:04 -0000
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+eval "use Gtk2 ':constants', 1.00;";
+is ($@, '');
+
+eval "use Gtk2 -init, 10.00;";
+like ($@, qr/this is only version/);
+
+__END__
+
+Copyright (C) 2008 by the gtk2-perl team (see the file AUTHORS for the
+full list).  See LICENSE for more information.