package Gtk2::CodeGen;
#
# Copyright (c) 2003 by the gtk2-perl team (see the file AUTHORS)
#
# 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 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., 59 Temple Place - Suite 330, 
# Boston, MA  02111-1307  USA.
#
# $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/CodeGen.pm,v 1.3 2003/05/22 14:23:21 muppetman Exp $

use strict;
use warnings;
use Carp;
use IO::File;

=item Gtk2::CodeGen->write_boot (FILENAME, GREP_FILE_ARG)

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.

This function looks for a "MODULE = ..." line (matching the grep pattern
"^MODULE") in each of the files specified by GREP_FILE_ARG.  Each unique
name is added to a list of names to be mangled into boot code symbols.  The
function then writes an XS include file which calls each of those boot symbols
via GPERL_CALL_BOOT.  If FILENAME is not specified, 'build/boot.xsh' will be
used.


If GREP_FILE_ARG is not defined, the glob 'xs/*.xs' is used.  GREP_FILE_ARG is
passed directly to grep (the shell command), so you may have to experiment if
you want to do something out of the ordinary.


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, some 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 code for the toplevel module.

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.



xsubpp 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 toplevel 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 includes the file we are creating here.

=cut
sub write_boot {
	my $class = shift;
	my $filename = shift || 'build/boot.xsh';
	my $glob = shift || 'xs/*.xs';

	my $file = IO::File->new (">$filename")
		or carp "Cannot write $filename: $!"; 

	print $file "\n\n/* This file is automatically generated, any changes made here will be lost! */\n\n";

	my %boot=();
	foreach (`grep ^MODULE $glob`) {
		my @F = split;
		# the toplevel module is the only one without :'s in its name.
		if ($F[2] =~ s/:/_/g) {
			my $sym = "boot_$F[2]";
			print $file "GPERL_CALL_BOOT ($sym);\n"
				unless $boot{$sym};
			$boot{$sym}++;
		}
	}

	close $file;
}


# guh... communication with the helper functions.
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;

	open IN, "< $props{input}"
		or die "can't open $props{input} for reading: $!\n";

	my %seen = ();

	@header = ();
	@typemap = ();
	@input = ();
	@output = ();
	@boot = ();

	while (<IN>) {
		chomp;
		s/#.*//;
		my ($typemacro, $classname, $base, $package) = split;
		next unless defined $package;
		if ($base eq 'GEnum') {
			gen_enum_stuff ($typemacro, $classname);
			$seen{$base}++;
		
		} elsif ($base eq 'GFlags') {
			gen_flags_stuff ($typemacro, $classname);
			$seen{$base}++;
		
		} elsif ($base eq 'GBoxed') {
			gen_boxed_stuff ($typemacro, $classname, $package);
			$seen{$base}++;
		
#		} elsif ($base eq 'GObject' or $base eq 'GtkObject') {
		} elsif ($base eq 'GObject' or $base eq 'GtkObject'
		         or $base eq 'GInterface') {
			gen_object_stuff ($typemacro, $classname, $base, $package);
			$seen{$base}++;

#		} elsif ($base eq 'GInterface') {
#			# what do we do with interfaces?
#			#gen_interface_stuff ($typemacro, $classname, $base, $package);
#			warn "$classname is a $base -- what do we do with interfaces?\n";
#			$seen{$base}++;

		} else {
			warn "unhandled type $typemacro $classname $base $package\n";
			$seen{unhandled}++;
		}
	}

	close IN;

	# create output

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

#
# generator subs
#

sub gen_enum_stuff {
	my ($typemacro, $classname) = @_;
	push @header, "#ifdef $typemacro
  /* GEnum $classname */
# define Sv$classname(sv)	(gperl_convert_enum ($typemacro, sv))
# define newSV$classname(val)	(gperl_convert_back_enum ($typemacro, val))
#endif /* $typemacro */
";
	push @typemap, "$classname	T_$typemacro";
	push @input, "T_$typemacro
	\$var = Sv$classname(\$arg);
";
	push @output, "T_$typemacro
	\$arg = newSV$classname(\$var);
";
}

sub gen_flags_stuff {
	my ($typemacro, $classname) = @_;
	push @header, "#ifdef $typemacro
  /* GFlags $classname */
# define Sv$classname(sv)	(gperl_convert_flags ($typemacro, sv))
# define newSV$classname(val)	(gperl_convert_back_flags ($typemacro, val))
#endif /* $typemacro */
";
	push @typemap, "$classname	T_$typemacro";
	push @input, "T_$typemacro
	\$var = Sv$classname(\$arg);
";
	push @output, "T_$typemacro
	\$arg = newSV$classname(\$var);
";
}



sub gen_boxed_stuff {
	my ($typemacro, $classname, $package) = @_;
	push @header, "#ifdef $typemacro
  /* GBoxed $classname */
  typedef $classname $classname\_ornull;
# define Sv$classname(sv)	(gperl_get_boxed_check ((sv), $typemacro))
# define Sv$classname\_ornull(sv)	(((sv) && SvTRUE (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 ((val), $typemacro, FALSE))
# define newSV$classname\_own(val)	(gperl_new_boxed ((val), $typemacro, TRUE))
# define newSV$classname\_copy(val)	(gperl_new_boxed_copy ((val), $typemacro))
# define newSV$classname\_own_ornull(val)	((val) ? newSV$classname\_own(val) : &PL_sv_undef)
#endif /* $typemacro */
";
	push @typemap, "$classname *	T_$typemacro";
	push @typemap, "$classname\_ornull *	T_$typemacro\_ORNULL";
	push @typemap, "$classname\_own *	T_$typemacro\_OWN";
	push @typemap, "$classname\_copy *	T_$typemacro\_COPY";
	push @typemap, "$classname\_own_ornull *	T_$typemacro\_OWN_ORNULL";
	push @input, "T_$typemacro
	\$var = Sv$classname(\$arg);
T_$typemacro\_ORNULL
	\$var = Sv$classname\_ornull(\$arg);
";
	push @output, "T_$typemacro
	\$arg = newSV$classname(\$var);
T_$typemacro\_OWN
	\$arg = newSV$classname\_own(\$var);
T_$typemacro\_COPY
	\$arg = newSV$classname\_copy(\$var);
T_$typemacro\_OWN_ORNULL
	\$arg = newSV$classname\_own_ornull(\$var);
";
	push @boot, "#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 = $root eq 'GtkObject' 
		? 'gtk2perl_new_gtkobject (GTK_OBJECT (val))' 
		: 'gperl_new_object (G_OBJECT (val), FALSE)';
	push @header, "#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)	(((sv) && SvTRUE (sv)) ? Sv$classname(sv) : NULL)
# define newSV$classname\_ornull(val)	(((val) == NULL) ? &PL_sv_undef : $get_wrapper)
";

	push @typemap, "$classname *	T_$typemacro";
	push @typemap, "$classname\_ornull *	T_$typemacro\_NULLOK";
	push @input, "T_$typemacro
	\$var = Sv$classname(\$arg);
T_$typemacro\_NULLOK
	\$var = Sv$classname\_ornull(\$arg);
";
	push @output, "T_$typemacro
	\$arg = newSV$classname(\$var);
T_$typemacro\_NULLOK
	\$arg = newSV$classname\_ornull(\$var);
";
	push @boot, "#ifdef $typemacro
gperl_register_object ($typemacro, \"$package\");
#endif /* $typemacro */";

	if ($root eq 'GObject') {
		# for GObjects, add a _noinc variant for returning GObjects
		# from constructors.
		$header[$#header] .= "typedef $classname $classname\_noinc;
#define newSV$classname\_noinc(val)	(gperl_new_object (G_OBJECT (val), TRUE))
";
		push @typemap, "$classname\_noinc *	T_$typemacro\_NOINC";
		$output[$#output] .= "T_$typemacro\_NOINC
	\$arg = newSV$classname\_noinc(\$var);
";
	}

	# close the header ifdef
	$header[$#header] .= "#endif /* $typemacro */\n";
}



1;
