#!/usr/bin/perl -w
#############################################################################
## Name: script/make_v_cback.pl
## Purpose: Create the v_cback_def.h include
## Author: Mattia Barbon
## Modified by:
## Created: 19/08/2007
## RCS-ID: $Id: make_v_cback.pl 2264 2007-11-05 23:23:35Z mbarbon $
## Copyright: (c) 2007 Mattia Barbon
## Licence: This program is free software; you can redistribute it and/or
## modify it under the same terms as Perl itself
#############################################################################
use strict;
use Data::Dumper;
my @macros =
qw(DEC_V_CBACK_BOOL__BOOL
DEF_V_CBACK_BOOL__BOOL
DEC_V_CBACK_BOOL__INT
DEF_V_CBACK_BOOL__INT
DEF_V_CBACK_BOOL__INT_pure
DEC_V_CBACK_BOOL__WXVARIANT_UINT_UINT
DEF_V_CBACK_BOOL__WXVARIANT_UINT_UINT_pure
DEC_V_CBACK_BOOL__SIZET
DEF_V_CBACK_BOOL__SIZET
DEF_V_CBACK_BOOL__SIZET_pure
DEC_V_CBACK_BOOL__SIZET_SIZET
DEF_V_CBACK_BOOL__SIZET_SIZET
DEF_V_CBACK_BOOL__SIZET_SIZET_pure
DEC_V_CBACK_BOOL__VOID
DEC_V_CBACK_BOOL__VOID_const
DEF_V_CBACK_BOOL__VOID
DEF_V_CBACK_BOOL__VOID_const
DEF_V_CBACK_BOOL__VOID_pure
DEC_V_CBACK_BOOL__INT_INT
DEC_V_CBACK_BOOL__INT_INT_const
DEF_V_CBACK_BOOL__INT_INT
DEF_V_CBACK_BOOL__INT_INT_pure
DEF_V_CBACK_BOOL__INT_INT_const
DEF_V_CBACK_BOOL__INT_INT_const_pure
DEC_V_CBACK_DOUBLE__INT_INT
DEC_V_CBACK_DOUBLE__INT_INT_const
DEF_V_CBACK_DOUBLE__INT_INT
DEF_V_CBACK_DOUBLE__INT_INT_pure
DEF_V_CBACK_DOUBLE__INT_INT_const
DEF_V_CBACK_DOUBLE__INT_INT_const_pure
DEC_V_CBACK_INT__LONG_LONG
DEC_V_CBACK_INT__LONG_LONG_const
DEF_V_CBACK_INT__LONG_LONG
DEF_V_CBACK_INT__LONG_LONG_pure
DEF_V_CBACK_INT__LONG_LONG_const
DEC_V_CBACK_INT__VOID
DEF_V_CBACK_INT__VOID
DEF_V_CBACK_INT__VOID_pure
DEC_V_CBACK_LONG__INT_INT
DEC_V_CBACK_LONG__INT_INT_const
DEF_V_CBACK_LONG__INT_INT
DEF_V_CBACK_LONG__INT_INT_pure
DEF_V_CBACK_LONG__INT_INT_const
DEF_V_CBACK_LONG__INT_INT_const_pure
DEC_V_CBACK_UINT__VOID
DEC_V_CBACK_UINT__VOID_const
DEF_V_CBACK_UINT__VOID
DEF_V_CBACK_UINT__VOID_const
DEF_V_CBACK_UINT__VOID_pure
DEF_V_CBACK_UINT__VOID_const_pure
DEC_V_CBACK_VOID__INT_INT_LONG
DEF_V_CBACK_VOID__INT_INT_LONG
DEF_V_CBACK_VOID__INT_INT_LONG_pure
DEC_V_CBACK_VOID__mWXVARIANT_UINT_UINT_const
DEF_V_CBACK_VOID__mWXVARIANT_UINT_UINT_const_pure
DEC_V_CBACK_VOID__SIZET_SIZET_const
DEF_V_CBACK_VOID__SIZET_SIZET_const
DEC_V_CBACK_WXCOORD__VOID_const
DEF_V_CBACK_WXCOORD__VOID_const
DEF_V_CBACK_WXCOORD__VOID_const_pure
DEC_V_CBACK_WXCOORD__SIZET
DEC_V_CBACK_WXCOORD__SIZET_const
DEF_V_CBACK_WXCOORD__SIZET
DEF_V_CBACK_WXCOORD__SIZET_const
DEF_V_CBACK_WXCOORD__SIZET_pure
DEF_V_CBACK_WXCOORD__SIZET_const_pure
DEC_V_CBACK_WXSTRING__WXSTRING
DEF_V_CBACK_WXSTRING__WXSTRING
DEC_V_CBACK_WXSTRING__UINT
DEC_V_CBACK_WXSTRING__UINT_const
DEF_V_CBACK_WXSTRING__UINT
DEF_V_CBACK_WXSTRING__UINT_const_pure
);
my %type_map =
( BOOL => [ 'bool', 'SvTRUE( ret )', 'return false',
'bool p%d', 'b', 'p%d', 'p%d' ],
SIZET => [ 'size_t', 'SvIV( ret )', 'return 0',
'size_t p%d', 'L', 'p%d', 'p%d' ],
LONG => [ 'long', 'SvIV( ret )', 'return 0',
'long p%d', 'l', 'p%d', 'p%d' ],
INT => [ 'int', 'SvIV( ret )', 'return 0',
'int p%d', 'i', 'p%d', 'p%d' ],
UINT => [ 'unsigned int', 'SvUV( ret )', 'return 0',
'unsigned int p%d', 'I', 'p%d', 'p%d' ],
WXCOORD => [ 'wxCoord', 'SvIV( ret )', 'return 0',
'wxCoord p%d', 'l', 'p%d', 'p%d' ],
DOUBLE => [ 'double', 'SvNV( ret )', 'return 0.0', ],
VOID => [ 'void', ';', , 'return',
],
WXSTRING=> [ 'wxString','wxPli_sv_2_wxString( aTHX_ ret )', 'return wxEmptyString',
'const wxString& p%d', 'P', '&p%d', 'p%d' ],
WXVARIANT=> [ 'wxVariant','wxPli_sv_2_wxvariant( aTHX_ ret )', 'return wxVariant()',
'const wxVariant& p%d', 'q', '&p%d, "Wx::Variant"', 'p%d' ],
mWXVARIANT=> [ 'wxVariant','wxPli_sv_2_wxvariant( aTHX_ ret )', 'return wxVariant()',
'wxVariant& p%d', 'q', '&p%d, "Wx::Variant"', 'p%d' ],
);
my %const_map =
( 0 => 'wxPli_NOCONST',
1 => 'wxPli_CONST',
);
my %emitted;
my @todo = map [ parse_macro( $_, \%type_map ) ], @macros;
print <<'EOT';
// GENERATED FILE, DO NOT EDIT
#ifndef _WXPERL_V_CBACK_DEF_H
#define _WXPERL_V_CBACK_DEF_H
EOT
foreach my $todo ( @todo ) {
my $args = join '_', @{$todo->[2]};
my( $c_args, $p_args, $b_args, $tymap ) = macro_call_args( $todo );
if( $todo->[0] eq 'DEC' && $todo->[1] eq 'VOID' ) {
my $name = sprintf 'DEC_V_CBACK_VOID__%s_', $args;
next if $emitted{$name};
$emitted{$name} = 1;
printf <<'EOT',
#define %s( RET, METHOD, CONST ) \
void METHOD(%s) CONST
EOT
$name, $c_args;
} elsif( $todo->[0] eq 'DEC' ) {
my $name = sprintf 'DEC_V_CBACK_ANY__%s_', $args;
next if $emitted{$name};
$emitted{$name} = 1;
printf <<'EOT',
#define %s( RET, METHOD, CONST ) \
RET METHOD(%s) CONST
EOT
$name, $c_args;
} elsif( $todo->[0] eq 'DEF' && $todo->[1] eq 'VOID' ) {
my $name = sprintf 'DEF_V_CBACK_VOID__%s_', $args;
next if $emitted{$name};
$emitted{$name} = 1;
printf <<'EOT',
#define %s( RET, CVT, CLASS, CALLBASE, METHOD, CONST ) \
void CLASS::METHOD(%s) CONST \
{ \
dTHX; \
if( wxPliFCback( aTHX_ &m_callback, #METHOD ) ) \
{ \
wxPliCCback( aTHX_ &m_callback, G_SCALAR|G_DISCARD, \
%s%s ); \
} \
else \
CALLBASE; \
}
EOT
$name, $c_args, $tymap, ( $p_args ? ", $p_args" : '' );
} elsif( $todo->[0] eq 'DEF' ) {
my $name = sprintf 'DEF_V_CBACK_ANY__%s_', $args;
next if $emitted{$name};
$emitted{$name} = 1;
printf <<'EOT',
#define %s( RET, CVT, CLASS, CALLBASE, METHOD, CONST ) \
RET CLASS::METHOD(%s) CONST \
{ \
dTHX; \
if( wxPliFCback( aTHX_ &m_callback, #METHOD ) ) \
{ \
wxAutoSV ret( aTHX_ wxPliCCback( aTHX_ &m_callback, G_SCALAR, \
%s%s ) ); \
return CVT; \
} \
else \
CALLBASE; \
}
EOT
$name, $c_args, $tymap, ( $p_args ? ", $p_args" : '' );
}
}
foreach my $todo ( @todo ) {
my $args = join '_', @{$todo->[2]};
my( $c_args, $p_args, $b_args, $tymap ) = macro_call_args( $todo );
my $const = $todo->[3]->{const} ? '_const' : '';
my $pure = $todo->[3]->{pure} ? '_pure' : '';
die 'No type name for ', $todo->[1]
unless $type_map{$todo->[1]}[0];
die 'No type conversion for ', $todo->[1]
unless $type_map{$todo->[1]}[1];
if( $todo->[0] eq 'DEC' && $todo->[1] eq 'VOID' ) {
printf <<'EOT',
#define DEC_V_CBACK_VOID__%s%s( METHOD ) \
DEC_V_CBACK_VOID__%s_( %s, METHOD, %s )
EOT
$args, $const, $args, $type_map{$todo->[1]}[0],
$const_map{$todo->[3]->{const}};
} elsif( $todo->[0] eq 'DEC' ) {
printf <<'EOT',
#define DEC_V_CBACK_%s__%s%s( METHOD ) \
DEC_V_CBACK_ANY__%s_( %s, METHOD, %s )
EOT
$todo->[1], $args, $const, $args, $type_map{$todo->[1]}[0],
$const_map{$todo->[3]->{const}};
} elsif( $todo->[0] eq 'DEF' && $todo->[1] eq 'VOID' ) {
my $callbase = sprintf 'BASE::METHOD(%s)', $b_args;
die 'No default value for pure function ', $todo->[1]
if $todo->[3]{pure} && !$type_map{$todo->[1]}[2];
printf <<'EOT',
#define DEF_V_CBACK_VOID__%s%s%s( CLASS, BASE, METHOD ) \
DEF_V_CBACK_VOID__%s_( %s, %s, CLASS, %s, METHOD, %s )
EOT
$args, $const, $pure, $args, $type_map{$todo->[1]}[0],
$type_map{$todo->[1]}[1],
( $todo->[3]{pure} ? $type_map{$todo->[1]}[2] : $callbase ),
$const_map{$todo->[3]->{const}};
} elsif( $todo->[0] eq 'DEF' ) {
my $callbase = sprintf 'return BASE::METHOD(%s)', $b_args;
die 'No default value for pure function ', $todo->[1]
if $todo->[3]{pure} && !$type_map{$todo->[1]}[2];
printf <<'EOT',
#define DEF_V_CBACK_%s__%s%s%s( CLASS, BASE, METHOD ) \
DEF_V_CBACK_ANY__%s_( %s, %s, CLASS, %s, METHOD, %s )
EOT
$todo->[1], $args, $const, $pure, $args, $type_map{$todo->[1]}[0],
$type_map{$todo->[1]}[1],
( $todo->[3]{pure} ? $type_map{$todo->[1]}[2] : $callbase ),
$const_map{$todo->[3]->{const}};
}
}
print <<'EOT';
#endif
EOT
sub parse_macro {
my( $macro, $types ) = @_;
my( $type, $ret, @args, %flags );
$flags{$_} = 0 foreach qw(const pure);
my $tmp = $macro;
$tmp =~ s/_const// and $flags{const} = 1;
$tmp =~ s/_pure// and $flags{pure} = 1;
$tmp =~ s/^DE([CF])_V_CBACK// and $type = 'DE' . $1;
$tmp =~ s/^_([A-Za-z]+)__// and $ret = $1;
@args = split '_', $tmp;
die "Unable to parse '$macro'" unless @args && $ret;
$types->{$_} or die "invalid type $_ in '$macro'" foreach $ret, @args;
return ( $type, $ret, \@args, \%flags );
}
sub macro_call_args {
my( $todo ) = @_;
my( $c_args, $p_args, $b_args, $tymap );
if( $todo->[2][0] eq 'VOID' ) {
$c_args = $p_args = $b_args = '';
$tymap = 'NULL';
} else {
my $c = 0;
my( @cargs, @pargs, @bargs );
foreach my $idx ( 0 .. $#{$todo->[2]} ) {
my $type = $todo->[2][$idx];
die 'Incomplete type definition for ', $type
unless $type_map{$type}[3]
&& $type_map{$type}[4]
&& $type_map{$type}[5];
$cargs[$idx] = sprintf $type_map{$type}[3], $idx + 1;
$tymap .= $type_map{$type}[4];
$pargs[$idx] = sprintf $type_map{$type}[5], $idx + 1;
$bargs[$idx] = sprintf $type_map{$type}[6], $idx + 1;
}
$c_args = ' ' . join( ', ', @cargs ) . ' ';
$p_args = join( ', ', @pargs );
$b_args = join( ', ', @bargs );
$tymap = qq{"$tymap"};
}
return ( $c_args, $p_args, $b_args, $tymap );
}