#!/usr/bin/perl -w
# Mark the 'no translate' arg types
@arghash{qw(double int)} = undef;

my ($module, $xs, $pm);
$module = shift;
$xs = shift;
$pm = shift;

open XS, "> $xs" or die "Can't open XS file! $!";
open PM, "> $pm" or die "Can't open PM file! $!";

print XS <<CONST_HEADER;
// **** WARNING ****
// This file is auto-generated by the process_description.pl script
// from the file $ARGV[0]. Edit that file instead of this one.
//

#import <Foundation/Foundation.h>
#import <AppKit/AppKit.h>

#ifndef GNUSTEP
#include <Carbon/Carbon.h>
#endif

#import "PerlImports.h"
#import "Conversions.h"
#import "Structs.h"

MODULE = $module		PACKAGE = $module

PROTOTYPES: ENABLE

CONST_HEADER

print PM <<CONST_HEADER;
# **** WARNING ****
# This file is auto-generated by the process_description.pl script
# from the file $ARGV[0]. Edit that file instead of this one.
#

package $module;

require 5.005_62;
use strict;
use warnings;

require Exporter;

our \@ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Foundation::Helper ':all';
# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );

our \@EXPORT = qw(
CONST_HEADER

while (<>) {
    chomp;
    next unless $_;

    # Skip comments
    next if /^\s*#/;

    @args = ();
    ($return, $function, @args) = split " ", $_;

    print PM $function, "\n";

    # First figure out the signature
    @newargs = @args;
    $argcount = 0;
    $vetting_code = "";
    # for each arg, see if we let xsubpp use a typemap or if we need
    # to extract it from an SV *
    foreach (@newargs) {
	$argcount++;
	if (exists $arghash{$_}) {
	    $_ = "$_ arg$argcount";
	} else {
	    s/(\*)//; # Strip off any leading stars
	    $vetting_code .= <<EOV;
if (!SvROK(arg$argcount) /*|| !sv_derived_from(arg$argcount,  "$_")*/) {
  croak("Arg $argcount isn't an $_");
}		
EOV
	    $_ = "SV *arg$argcount";
	}
    }

    # print out the XS header for the function
    print XS "SV *\n$function(", join(", ", @newargs), ")\nCODE:\n";
    
    # print some variables we might need
    print XS "double a_double;\nint an_int;\nvoid *a_pointer;\n";

    $argcount = 0;
    foreach (@args) {
	$argcount++;
	if (exists $arghash{$_}) {
	} else {
	    /^(\*?)(.*)$/;
	    if (defined $1 && $1) {
		print XS "$2 aFoo$argcount, *bFoo$argcount;\n";
	    } else {
		print XS "$2 *obj$argcount;\n";
	    }
	}
    }

    # Return type, if needed

    # Reset back to the beginning
    @newargs = @args;

    # Print the vetting code
    print XS $vetting_code;

    # Now, what sort of return value do we have?
  SWITCH:
    for ($return) {
	# No return value
	/^void$/ && do { print XS "$function(";
			 dump_args(@args);
			 print XS ");\nXSRETURN(1);\n";
			 $output = 0;
			 last SWITCH;
		     };

	# int
	/^int$/  && do {print XS "an_int = $function(";
			  dump_args(@args);
			  print XS ");\nRETVAL = newSViv(an_int);\n";
			  $output = 1;
			  last SWITCH;
		      };

	# double
	/^double$/ && do {print XS "a_double = $function(";
			  dump_args(@args);
			  print XS ");\nRETVAL = newSVnv(a_double);\n";
			  $output = 1;
			  last SWITCH;
		      };

	# A struct
	/^\*(.*)/ && do { print XS "{$1 thing;\nthing = $function(";
			  dump_args(@args);
			  print XS ");\n";
			  my $short1 = $1;
			  $short1 =~ s/NS//;
			  print XS "RETVAL = CB${short1}ToSV(thing);}\n";
			  $output = 1;
			  last SWITCH;
		      };

	# An object
	 do { print XS "{$return *obj;\nobj = $function(";
	      dump_args(@args);
	      print XS ");\n";
	      print XS "RETVAL=CBDerefIDtoSV(obj);}\n";
	      $output = 1;
	      last SWITCH;
	  };

    }

    # End
    print XS "OUTPUT:\n  RETVAL\n" if $output;
    print XS "\n";
}

close XS;

my $bootmod = $module;
$bootmod =~ s/::/__/g;

print PM <<CONST_FOOTER;
	
);
our \$VERSION = '0.01';

&boot_$bootmod();

# Preloaded methods go here.

1;
__END__

CONST_FOOTER

close PM;

sub dump_args {
    my @arglist;
    my $arg_count = 0;
    foreach my $foo ((@_)) {
		$arg_count++;
		# A base type?
		if (exists $arghash{$foo}) {
			push @arglist, "arg$arg_count";
			next;
		}
		# How about a pointer to something structish?
		if ($foo =~ /^\*(.*)$/) {
			my $real_arg = $1;
			$short1 = $1;
			$short1 =~ s/NS//;
			push @arglist, "CB${short1}FromSV(arg$arg_count)";
			next;
		}
		# Must be an object of some sort
		do {
			push @arglist, "CBDerefSVtoID(arg$arg_count)";
			next;
		}
    }

    print XS join(", ", @arglist);
    return;
}




