Re: gtk priority constants
- From: Torsten Schoenfeld <kaffeetisch gmx de>
- To: gtk-perl-list gnome org
- Subject: Re: gtk priority constants
- Date: Sat, 31 May 2008 19:58:40 +0200
Kevin Ryde wrote:
+$type
+$constant ()
+ CODE:
+ RETVAL = $constant;
I guess the only downside there might be I think the value from an xs
sub like that isn't inlined the way a perl level one is.
True. So here's a third attempt, this time using newCONSTSUB which
should have the desired effect.
Unfortunately, this complicates the format of the constants-x.y files
slightly: instead of specifying the constants' type and letting typemaps
do the work, we now need to specify a converter explicitly.
To recapitulate: this patch extends Gtk2::CodeGen to generate xsub
wrappers for constants that are specified in files called
"constants-x.y". The xsubs are named like the constants they wrap and
they are put directly into the Gtk2 namespace. For example:
Gtk2::GDK_PRIORITY_EVENTS or Gtk2::GTK_PRIORITY_RESIZE. They are also
exportable via the usual Exporter machinery.
Commit?
--
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 31 May 2008 17:48:28 -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, $converter) = split "\t", $description;
+ push @constants, [$constant, $converter];
+ }
+
+ close $list_fh
+ or croak "Unable to close `$list´: $!";
+ }
+
+ my $boot_code = <<"__EOD__";
+{
+ HV *stash = gv_stashpv ("$options{prefix}", TRUE); /* create if needed */
+ 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 $pair (@constants) {
+ my ($constant, $converter) = @$pair;
+
+ my $conversion;
+ if ($converter =~ m/\$var/) {
+ ($conversion = $converter) =~ s/\$var/$constant/;
+ } else {
+ $conversion = "$converter ($constant)";
+ }
+
+ $boot_code .= <<"__EOD__";
+ newCONSTSUB (stash, "$constant", $conversion);
+ 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
+
+__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.121
diff -u -d -p -r1.121 Gtk2.pm
--- Gtk2.pm 22 May 2008 21:39:57 -0000 1.121
+++ Gtk2.pm 31 May 2008 17:48:28 -0000
@@ -34,11 +34,33 @@ use Glib;
# gtk+ and pango.
eval "use Cairo;";
+use Exporter;
require DynaLoader;
our $VERSION = '1.182';
-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.
@@ -271,6 +282,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.146
diff -u -d -p -r1.146 Makefile.PL
--- Makefile.PL 30 Mar 2008 19:27:35 -0000 1.146
+++ Makefile.PL 31 May 2008 17:48:29 -0000
@@ -119,6 +119,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 31 May 2008 17:48:29 -0000
@@ -0,0 +1,4 @@
+GDK_PRIORITY_EVENTS newSViv ($var)
+GDK_PRIORITY_REDRAW newSViv
+
+GTK_PRIORITY_RESIZE newSViv
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 31 May 2008 17:48:29 -0000
@@ -1,3 +1,4 @@
+#!/usr/bin/perl
#
# $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/t/00.Gtk2.t,v 1.21 2006/05/14 10:57:07 kaffeetisch Exp $
#
@@ -14,8 +15,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 +44,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 31 May 2008 17:48:29 -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.
[
Date Prev][
Date Next] [
Thread Prev][Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
