[perl-Cairo] Add support for flag types

[Torsten Schönfeld <tsch src gnome org>]

commit 97788e474d94f45306cb24d91aa1cb2342d3158e
Author: Torsten Schönfeld <kaffeetisch gmx de>
Date:   Sun May 16 21:03:54 2010 +0200

    Add support for flag types
    
    This will be needed for cairo_text_cluster_flags_t.
    
    The refactoring during this change also fixes an off-by-one error in the enum
    value conversion.

 .gitignore        |    1 +
 Makefile.PL       |   14 ++-
 inc/MakeHelper.pm |  291 ++++++++++++++++++++++++++++++++++++++++-------------
 3 files changed, 230 insertions(+), 76 deletions(-)
---
diff --git a/.gitignore b/.gitignore
index b3a78f6..ac375d8 100644
--- a/.gitignore
+++ b/.gitignore
@@ -5,4 +5,5 @@ Makefile
 blib
 build
 cairo-perl-enums.*
+cairo-perl-flags.*
 pm_to_blib
diff --git a/Makefile.PL b/Makefile.PL
index 760f11d..335e751 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -215,6 +215,8 @@ my %enums = (
 	/],
 );
 
+my %flags = ();
+
 # --------------------------------------------------------------------------- #
 
 my $have_cairo_1_2 = ExtUtils::PkgConfig->atleast_version("cairo", "1.2.0");
@@ -319,9 +321,11 @@ if ($have_cairo_1_6) {
 my %enum_guards = (
 	cairo_svg_version_t => $backend_guards{cairo_svg_surface_t},
 );
-
 MakeHelper::do_enums (\%enums, \%enum_guards);
 
+my %flag_guards = ();
+MakeHelper::do_flags (\%flags, \%flag_guards);
+
 my @xs_files = qw(
 	Cairo.xs
 	CairoFont.xs
@@ -345,15 +349,17 @@ MakeHelper::write_boot (
 	ignore => '^Cairo$',
 );
 
-my @typemaps = MakeHelper::do_typemaps (\%objects, \%structs, \%enums,
-                                        \%backend_guards, \%enum_guards);
+my @typemaps = MakeHelper::do_typemaps (\%objects, \%structs, \%enums, \%flags,
+                                        \%backend_guards,
+                                        \%enum_guards,
+                                        \%flag_guards);
 push @typemaps, 'cairo-perl.typemap';
 
 my $dep = ExtUtils::Depends->new ('Cairo');
 $dep->set_inc ('-I. -I'.$autogen_dir.' '.$cairo_cfg{cflags});
 $dep->set_libs ($cairo_cfg{libs});
 $dep->add_xs (@xs_files);
-$dep->add_c ('cairo-perl-enums.c');
+$dep->add_c (qw/cairo-perl-enums.c cairo-perl-flags.c/);
 $dep->add_pm ('lib/Cairo.pm' => '$(INST_LIBDIR)/Cairo.pm');
 $dep->add_typemaps (@typemaps);
 
diff --git a/inc/MakeHelper.pm b/inc/MakeHelper.pm
index 568ba1f..3daa129 100644
--- a/inc/MakeHelper.pm
+++ b/inc/MakeHelper.pm
@@ -66,13 +66,21 @@ sub write_boot
 
 # --------------------------------------------------------------------------- #
 
+sub name
+{
+	$_[0] =~ /cairo_(\w+)_t/;
+	return $1;
+}
+
 sub do_typemaps
 {
 	my %objects = %{shift ()};
 	my %structs = %{shift ()};
 	my %enums = %{shift ()};
+	my %flags = %{shift ()};
 	my %backend_guards = %{shift ()};
 	my %enum_guards = %{shift ()};
+	my %flag_guards = %{shift ()};
 
 	my $cairo_perl = File::Spec->catfile ($autogen_dir,
 					      'cairo-perl-auto.typemap');
@@ -101,7 +109,7 @@ EOS
 		$1;
 	}
 
-	foreach (keys %objects, keys %structs, keys %enums)
+	foreach (keys %objects, keys %structs, keys %enums, keys %flags)
 	{
 		print TYPEMAP "$_\tT_CAIROPERL_GENERIC_WRAPPER\n";
 	}
@@ -182,12 +190,6 @@ EOS
 		return $ref;
 	}
 
-	sub name
-	{
-		$_[0] =~ /cairo_(\w+)_t/;
-		return $1;
-	}
-
 	# ------------------------------------------------------------------- #
 
 	print HEADER "\n/* objects */\n\n";
@@ -264,6 +266,33 @@ EOS
 		}
 	}
 
+	# ------------------------------------------------------------------- #
+
+	print HEADER "\n/* flags */\n\n";
+
+	foreach my $type (keys %flags)
+	{
+		my $mangled = mangle ($type);
+		my $name = name ($type);
+
+		next unless @{$flags{$type}};
+
+		if (exists $flag_guards{$type}) {
+			print HEADER "#ifdef $flag_guards{$type}\n";
+		}
+
+		print HEADER <<"EOS";
+$type cairo_${name}_from_sv (SV * $name);
+SV * cairo_${name}_to_sv ($type val);
+#define Sv$mangled(sv)		(cairo_${name}_from_sv (sv))
+#define newSV$mangled(val)	(cairo_${name}_to_sv (val))
+EOS
+
+		if (exists $flag_guards{$type}) {
+			print HEADER "#endif /* $flag_guards{$type} */\n";
+		}
+	}
+
 	close HEADER;
 
 	return ($cairo_perl);
@@ -271,6 +300,58 @@ EOS
 
 # --------------------------------------------------------------------------- #
 
+sub canonicalize_enum_name
+{
+	my ($name, $prefix) = @_;
+	$name =~ s/$prefix//;
+	$name =~ tr/_/-/;
+	$name = lc ($name);
+	return $name;
+}
+
+sub enum_if_tree_from
+{
+	my ($prefix, @enums) = @_;
+	my $str = '';
+
+	my $is_first = 1;
+	foreach my $full (@enums)
+	{
+		my $name = canonicalize_enum_name($full, $prefix);
+		# +1 so that strncmp also looks at the trailing \0, and
+		# discerns 'color' and 'color-alpha', for example.
+		my $len = length ($name) + 1;
+		my $conditional = $is_first ? 'if' : 'else if';
+		$str .= <<"EOS";
+	$conditional (strncmp (str, "$name", $len) == 0)
+		return $full;
+EOS
+		$is_first = 0;
+	}
+
+	return $str;
+}
+
+sub enum_if_tree_to
+{
+	my ($prefix, @enums) = @_;
+	my $str = '';
+
+	my $is_first = 1;
+	foreach my $full (@enums)
+	{
+		my $name = canonicalize_enum_name($full, $prefix);
+		my $conditional = $is_first ? 'if' : 'else if';
+		$str .= <<"EOS";
+	$conditional (val == $full)
+		return newSVpv ("$name", 0);
+EOS
+		$is_first = 0;
+	}
+
+	return $str;
+}
+
 sub do_enums
 {
 	my %enums = %{shift ()};
@@ -280,124 +361,190 @@ sub do_enums
 	open ENUMS, '>', $cairo_enums
 		or die "unable to open ($cairo_enums) for output";
 
-	print ENUMS "
+	print ENUMS <<'EOS';
 /*
  * This file was automatically generated.  Do not edit.
  */
 
 #include <cairo-perl.h>
 
-";
+EOS
 
-	sub canonicalize
+	foreach my $type (keys %enums)
 	{
-		my ($name, $prefix) = @_;
-		$name =~ s/$prefix//;
-		$name =~ tr/_/-/;
-		$name = lc ($name);
-		return $name;
-	}
+		my $name = name($type);
+		my @enum_values = @{$enums{$type}};
 
-	sub if_tree_from
-	{
-		my @enums = @_;
+		next unless @enum_values;
 
-		my $prefix = shift @enums;
+		my $value_list =
+			join ", ", map {
+				canonicalize_enum_name($_, $enum_values[0])
+			} @enum_values[1..$#enum_values];
+		my $tree_from = enum_if_tree_from (@enum_values);
+		my $tree_to = enum_if_tree_to (@enum_values);
 
-		my $full = shift @enums;
-		my $name = canonicalize($full, $prefix);
+		if (exists $guards{$type}) {
+			print ENUMS "#ifdef $guards{$type}\n\n";
+		}
 
-		# +1 so that strncmp also looks at the trailing \0, and discerns
-		# 'color' and 'color-alpha', for example.
-		my $len = length ($name) + 1;
+		print ENUMS <<"EOS";
+$type
+cairo_${name}_from_sv (SV * $name)
+{
+	char * str = SvPV_nolen ($name);
 
-		my $str = <<"EOS";
-	if (strncmp (str, "$name", $len) == 0)
-		return $full;
-EOS
+	$tree_from
+	croak ("`%s' is not a valid $type value; valid values are: $value_list", str);
 
-		foreach $full (@enums)
-		{
-			my $name = canonicalize($full, $prefix);
-			$len = length ($name);
+	return 0;
+}
+
+SV *
+cairo_${name}_to_sv ($type val)
+{
+	$tree_to
+	warn ("unknown $type value %d encountered", val);
+	return &PL_sv_undef;
+}
 
-			$str .= <<"EOS";
-	else if (strncmp (str, "$name", $len) == 0)
-		return $full;
 EOS
-		}
 
-		$str;
+		if (exists $guards{$type}) {
+			print ENUMS "#endif /* $guards{$type} */\n";
+		}
 	}
 
-	sub if_tree_to
-	{
-		my @enums = @_;
+	close ENUMS;
+}
 
-		my $prefix = shift @enums;
-		my $full = shift @enums;
-		my $name = canonicalize($full, $prefix);
+# --------------------------------------------------------------------------- #
 
-		my $str = <<"EOS";
-	if (val == $full)
-		return newSVpv ("$name", 0);
-EOS
+sub flag_if_tree_from
+{
+	my ($prefix, @flags) = @_;
+	my $str = '';
 
-		foreach $full (@enums)
-		{
-			my $name = canonicalize($full, $prefix);
-			$str .= <<"EOS";
-	else if (val == $full)
-		return newSVpv ("$name", 0);
+	my $is_first = 1;
+	foreach my $full (@flags)
+	{
+		my $name = canonicalize_enum_name($full, $prefix);
+		# +1 so that strncmp also looks at the trailing \0, and
+		# discerns 'color' and 'color-alpha', for example.
+		my $len = length ($name) + 1;
+		my $conditional = $is_first ? 'if' : 'else if';
+		$str .= <<"EOS";
+	$conditional (strncmp (str, "$name", $len) == 0) {
+		return $full;
+	}
 EOS
-		}
+		$is_first = 0;
+	}
+
+	return $str;
+}
 
-		$str;
+sub flag_if_tree_to
+{
+	my ($prefix, @flags) = @_;
+	my $str = '';
+
+	foreach my $full (@flags)
+	{
+		my $name = canonicalize_enum_name($full, $prefix);
+		$str .= <<"EOS";
+	if ((val & $full) == $full) {
+		val -= $full;
+		av_push (flags, newSVpv ("$name", 0));
+	}
+EOS
 	}
 
-	foreach my $type (keys %enums)
+	return $str;
+}
+
+sub do_flags
+{
+	my %flags = %{shift ()};
+        my %guards = %{shift ()};
+
+	my $cairo_flags = 'cairo-perl-flags.c';
+	open FLAGS, '>', $cairo_flags
+		or die "unable to open ($cairo_flags) for output";
+
+	print FLAGS <<'EOS';
+/*
+ * This file was automatically generated.  Do not edit.
+ */
+
+#include <cairo-perl.h>
+#include <cairo-perl-private.h>
+
+EOS
+
+	foreach my $type (keys %flags)
 	{
 		my $name = name($type);
-		my @enum_values = @{$enums{$type}};
+		my @flag_values = @{$flags{$type}};
 
-		next unless @enum_values;
+		next unless @flag_values;
 
-		my $value_list = join ", ", map { canonicalize($_, $enum_values[0]) } @enum_values[1..$#enum_values];
-		my $tree_from = if_tree_from (@enum_values);
-		my $tree_to = if_tree_to (@enum_values);
+		my $value_list =
+			join ", ", map {
+				canonicalize_enum_name($_, $flag_values[0])
+			} @flag_values[1..$#flag_values];
+		my $tree_from = flag_if_tree_from (@flag_values);
+		my $tree_to = flag_if_tree_to (@flag_values);
 
 		if (exists $guards{$type}) {
-			print ENUMS "#ifdef $guards{$type}\n\n";
+			print FLAGS "#ifdef $guards{$type}\n\n";
 		}
 
-		print ENUMS <<"EOS";
-$type
-cairo_${name}_from_sv (SV * $name)
+		print FLAGS <<"EOS";
+static $type
+cairo_${name}_from_sv_part (const char *str)
 {
-	char * str = SvPV_nolen ($name);
-
 	$tree_from
 	croak ("`%s' is not a valid $type value; valid values are: $value_list", str);
+	return 0;
+}
 
+$type
+cairo_${name}_from_sv (SV * $name)
+{
+	if (cairo_perl_sv_is_array_ref ($name)) {
+		AV *vals = (AV *) SvRV ($name);
+		$type value = 0;
+		int i;
+		for (i=0; i<=av_len(vals); i++)
+			value |= cairo_${name}_from_sv_part (
+					SvPV_nolen (*av_fetch (vals, i, 0)));
+		return value;
+	}
+	if (SvPOK ($name))
+		return cairo_${name}_from_sv_part (SvPV_nolen ($name));
+	croak ("`%s' is not a valid $type value, expecting a string scalar "
+	       "or an arrayref of strings",
+	       SvPV_nolen ($name));
 	return 0;
 }
 
 SV *
 cairo_${name}_to_sv ($type val)
 {
+	AV *flags = newAV ();
 	$tree_to
-	warn ("unknown $type value %d encountered", val);
-	return &PL_sv_undef;
+	return newRV_noinc ((SV *) flags);
 }
 
 EOS
 
 		if (exists $guards{$type}) {
-			print ENUMS "#endif /* $guards{$type} */\n";
+			print FLAGS "#endif /* $guards{$type} */\n";
 		}
 	}
 
-	close ENUMS;
+	close FLAGS;
 }
 
 1;