#
# this is all hacky etc. it works so it's gonna stay for now. it is not and
# should not be installed.
#
# $Id$
#

package MakeHelper;

use strict;
use warnings;
use IO::File;
use File::Spec;

our $autogen_dir = '.';

# --------------------------------------------------------------------------- #

# copied/borrowed from Gtk2-Perl's CodeGen
sub write_boot
{
	my %opts = (
		ignore => '^[^:]+$',	# ignore package with no colons in it
		filename => File::Spec->catdir ($autogen_dir,
						'cairo-perl-boot.xsh'),
		'glob' => File::Spec->catfile ('xs', '*.xs'),
		@_,
	);
	my $ignore = $opts{ignore};

	my $file = IO::File->new (">$opts{filename}")
		or die "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 "CAIRO_PERL_CALL_BOOT ($sym);\n"
				unless $boot{$sym};
			$boot{$sym}++;
		}

		close $in;
	}

	close $file;
}

# --------------------------------------------------------------------------- #

sub name
{
	$_[0] =~ /cairo_(\w+)_t/;
	return $1;
}

sub do_typemaps
{
	my %objects = %{shift ()};
	my %structs = %{shift ()};
	my %enums = %{shift ()};
	my %flags = %{shift ()};
	my %object_guards = %{shift ()};
	my %struct_guards = %{shift ()};
	my %enum_guards = %{shift ()};
	my %flag_guards = %{shift ()};

	my $cairo_perl = File::Spec->catfile ($autogen_dir,
					      'cairo-perl-auto.typemap');
	open TYPEMAP, '>', $cairo_perl
		or die "unable to open ($cairo_perl) for output";

	print TYPEMAP <<EOS;
#
# This file was automatically generated.  Do not edit.
#

TYPEMAP

EOS

	sub type_id
	{
		my $ret = shift;
		$ret =~ s/ \*//;
		uc ($ret);
	}

	sub func_name
	{
		$_[0] =~ /cairo_(\w+)_t/;
		$1;
	}

	foreach (sort(keys %objects, keys %structs, keys %enums, keys %flags))
	{
		print TYPEMAP "$_\tT_CAIROPERL_GENERIC_WRAPPER\n";
	}

	foreach (sort(keys %objects, keys %structs))
	{
		my $trunk = $_;
		$trunk =~ s/ \*//;

		print TYPEMAP "const $_\tT_CAIROPERL_GENERIC_WRAPPER\n";
		print TYPEMAP "${trunk}_ornull *\tT_CAIROPERL_GENERIC_WRAPPER\n";
		print TYPEMAP "const ${trunk}_ornull *\tT_CAIROPERL_GENERIC_WRAPPER\n";
	}

	foreach (sort(keys %objects))
	{
		my $trunk = $_;
		$trunk =~ s/ \*//;

		print TYPEMAP "${trunk}_noinc *\tT_CAIROPERL_GENERIC_WRAPPER\n";
	}

	my $conversion_code = ';
	  (my $ntype = $type) =~ s/(?:const\s+)?([:\w]+)(?:\s*\*)$/$1/x;
	  my $result = $type;
	  if ($ntype =~ m/(.+)_t(_.+)?/) {
	    my ($name, $options) = ($1, $2);
	    $name =~ s/([^_]+)/ucfirst $1/ge;
	    $name =~ s/_//g;
	    $result = $name;
	    $result .= $options if defined $options;
	  }
	  \$result';

        print TYPEMAP <<"EOS";

INPUT

T_CAIROPERL_GENERIC_WRAPPER
	\$var = Sv\${$conversion_code} (\$arg);

OUTPUT

T_CAIROPERL_GENERIC_WRAPPER
	\$arg = newSV\${$conversion_code} (\$var);
EOS

	close TYPEMAP;

	# ------------------------------------------------------------------- #

	my $header = File::Spec->catfile ($autogen_dir,
					  'cairo-perl-auto.h');
	open HEADER, '>', $header
		or die "unable to open ($header) for output";

	print HEADER <<EOS;
/*
 * This file was automatically generated.  Do not edit.
 */

#include <cairo.h>
EOS

	sub mangle
	{
		my $mangled = shift;
		$mangled =~ s/_t$//;
		$mangled =~ s/([^_]+)/ucfirst $1/ge;
		$mangled =~ s/_//g;
		return $mangled;
	}

	sub reference
	{
		my $ref = shift;
		$ref =~ s/_t$//;
		$ref .= '_reference';
		return $ref;
	}

	# ------------------------------------------------------------------- #

	print HEADER "\n/* objects */\n\n";

	foreach (sort(keys %objects))
	{
		/^(.+) \*/;
		my $type = $1;
		my $mangled = mangle ($type);
		my $ref = reference ($type);

		if (exists $object_guards{$type}) {
			print HEADER "$object_guards{$type}\n";
		}

		print HEADER <<"EOS";
typedef $type ${type}_noinc;
typedef $type ${type}_ornull;
#define Sv$mangled(sv)			(($type *) cairo_object_from_sv (sv, "$objects{$_}"))
#define Sv${mangled}_ornull(sv)		(((sv) && SvOK (sv)) ? Sv$mangled(sv) : NULL)
#define newSV$mangled(object)		(cairo_object_to_sv (($type *) $ref (object), "$objects{$_}"))
#define newSV${mangled}_noinc(object)	(cairo_object_to_sv (($type *) object, "$objects{$_}"))
#define newSV${mangled}_ornull(object)	(((object) == NULL) ? &PL_sv_undef : newSV$mangled(object))
EOS

		if (exists $object_guards{$type}) {
			print HEADER "#endif /* $object_guards{$type} */\n";
		}
	}

	# ------------------------------------------------------------------- #

	print HEADER "\n/* structs */\n\n";

	foreach (sort(keys %structs))
	{
		/^(.+) \*/;
		my $type = $1;
		my $mangled = mangle ($type);

		if (exists $struct_guards{$type}) {
			print HEADER "$struct_guards{$type}\n";
		}

		print HEADER <<"EOS";
typedef $type ${type}_ornull;
#define Sv$mangled(sv)			(($type *) cairo_struct_from_sv (sv, "$structs{$_}"))
#define Sv${mangled}_ornull(sv)		(((sv) && SvOK (sv)) ? Sv$mangled(sv) : NULL)
#define newSV$mangled(struct_)		(cairo_struct_to_sv (($type *) struct_, "$structs{$_}"))
#define newSV${mangled}_ornull(struct_)	(((struct_) == NULL) ? &PL_sv_undef : newSV$mangled(struct_))
EOS

		if (exists $struct_guards{$type}) {
			print HEADER "#endif /* $struct_guards{$type} */\n";
		}
	}

	# ------------------------------------------------------------------- #

	print HEADER "\n/* enums */\n\n";

	foreach my $type (sort(keys %enums))
	{
		my $mangled = mangle ($type);
		my $name = name ($type);

		next unless @{$enums{$type}};

		if (exists $enum_guards{$type}) {
			print HEADER "$enum_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 $enum_guards{$type}) {
			print HEADER "#endif /* $enum_guards{$type} */\n";
		}
	}

	# ------------------------------------------------------------------- #

	print HEADER "\n/* flags */\n\n";

	foreach my $type (sort(keys %flags))
	{
		my $mangled = mangle ($type);
		my $name = name ($type);

		next unless @{$flags{$type}};

		if (exists $flag_guards{$type}) {
			print HEADER "$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);
}

# --------------------------------------------------------------------------- #

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 ()};
        my %guards = %{shift ()};

	my $cairo_enums = 'cairo-perl-enums.c';
	open ENUMS, '>', $cairo_enums
		or die "unable to open ($cairo_enums) for output";

	print ENUMS <<'EOS';
/*
 * This file was automatically generated.  Do not edit.
 */

#include <cairo-perl.h>

EOS

	foreach my $type (sort(keys %enums))
	{
		my $name = name($type);
		my @enum_values = @{$enums{$type}};

		next unless @enum_values;

		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);

		if (exists $guards{$type}) {
			print ENUMS "$guards{$type}\n\n";
		}

		print ENUMS <<"EOS";
$type
cairo_${name}_from_sv (SV * $name)
{
	char * str = SvPV_nolen ($name);

	$tree_from
	croak ("`%s' is not a valid $type value; valid values are: $value_list", str);

	return 0;
}

SV *
cairo_${name}_to_sv ($type val)
{
	$tree_to
	warn ("unknown $type value %d encountered", val);
	return &PL_sv_undef;
}

EOS

		if (exists $guards{$type}) {
			print ENUMS "#endif /* $guards{$type} */\n";
		}
	}

	close ENUMS;
}

# --------------------------------------------------------------------------- #

sub flag_if_tree_from
{
	my ($prefix, @flags) = @_;
	my $str = '';

	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;
}

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
	}

	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 (sort(keys %flags))
	{
		my $name = name($type);
		my @flag_values = @{$flags{$type}};

		next unless @flag_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 FLAGS "$guards{$type}\n\n";
		}

		print FLAGS <<"EOS";
static $type
cairo_${name}_from_sv_part (const char *str)
{
	$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
	return newRV_noinc ((SV *) flags);
}

EOS

		if (exists $guards{$type}) {
			print FLAGS "#endif /* $guards{$type} */\n";
		}
	}

	close FLAGS;
}

1;