git.maemo.org Git - pkg-perl/blob - deb-src/libwx-perl/libwx-perl-0.96/script/make_v_cback.pl

   1 #!/usr/bin/perl -w
   2 #############################################################################
   3 ## Name:        script/make_v_cback.pl
   4 ## Purpose:     Create the v_cback_def.h include
   5 ## Author:      Mattia Barbon
   6 ## Modified by:
   7 ## Created:     19/08/2007
   8 ## RCS-ID:      $Id: make_v_cback.pl 2264 2007-11-05 23:23:35Z mbarbon $
   9 ## Copyright:   (c) 2007 Mattia Barbon
  10 ## Licence:     This program is free software; you can redistribute it and/or
  11 ##              modify it under the same terms as Perl itself
  12 #############################################################################
  13
  14 use strict;
  15 use Data::Dumper;
  16
  17 my @macros =
  18   qw(DEC_V_CBACK_BOOL__BOOL
  19      DEF_V_CBACK_BOOL__BOOL
  20
  21      DEC_V_CBACK_BOOL__INT
  22      DEF_V_CBACK_BOOL__INT
  23      DEF_V_CBACK_BOOL__INT_pure
  24
  25      DEC_V_CBACK_BOOL__WXVARIANT_UINT_UINT
  26      DEF_V_CBACK_BOOL__WXVARIANT_UINT_UINT_pure
  27
  28      DEC_V_CBACK_BOOL__SIZET
  29      DEF_V_CBACK_BOOL__SIZET
  30      DEF_V_CBACK_BOOL__SIZET_pure
  31
  32      DEC_V_CBACK_BOOL__SIZET_SIZET
  33      DEF_V_CBACK_BOOL__SIZET_SIZET
  34      DEF_V_CBACK_BOOL__SIZET_SIZET_pure
  35
  36      DEC_V_CBACK_BOOL__VOID
  37      DEC_V_CBACK_BOOL__VOID_const
  38      DEF_V_CBACK_BOOL__VOID
  39      DEF_V_CBACK_BOOL__VOID_const
  40      DEF_V_CBACK_BOOL__VOID_pure
  41
  42      DEC_V_CBACK_BOOL__INT_INT
  43      DEC_V_CBACK_BOOL__INT_INT_const
  44      DEF_V_CBACK_BOOL__INT_INT
  45      DEF_V_CBACK_BOOL__INT_INT_pure
  46      DEF_V_CBACK_BOOL__INT_INT_const
  47      DEF_V_CBACK_BOOL__INT_INT_const_pure
  48
  49      DEC_V_CBACK_DOUBLE__INT_INT
  50      DEC_V_CBACK_DOUBLE__INT_INT_const
  51      DEF_V_CBACK_DOUBLE__INT_INT
  52      DEF_V_CBACK_DOUBLE__INT_INT_pure
  53      DEF_V_CBACK_DOUBLE__INT_INT_const
  54      DEF_V_CBACK_DOUBLE__INT_INT_const_pure
  55
  56      DEC_V_CBACK_INT__LONG_LONG
  57      DEC_V_CBACK_INT__LONG_LONG_const
  58      DEF_V_CBACK_INT__LONG_LONG
  59      DEF_V_CBACK_INT__LONG_LONG_pure
  60      DEF_V_CBACK_INT__LONG_LONG_const
  61
  62      DEC_V_CBACK_INT__VOID
  63      DEF_V_CBACK_INT__VOID
  64      DEF_V_CBACK_INT__VOID_pure
  65
  66      DEC_V_CBACK_LONG__INT_INT
  67      DEC_V_CBACK_LONG__INT_INT_const
  68      DEF_V_CBACK_LONG__INT_INT
  69      DEF_V_CBACK_LONG__INT_INT_pure
  70      DEF_V_CBACK_LONG__INT_INT_const
  71      DEF_V_CBACK_LONG__INT_INT_const_pure
  72
  73      DEC_V_CBACK_UINT__VOID
  74      DEC_V_CBACK_UINT__VOID_const
  75      DEF_V_CBACK_UINT__VOID
  76      DEF_V_CBACK_UINT__VOID_const
  77      DEF_V_CBACK_UINT__VOID_pure
  78      DEF_V_CBACK_UINT__VOID_const_pure
  79
  80      DEC_V_CBACK_VOID__INT_INT_LONG
  81      DEF_V_CBACK_VOID__INT_INT_LONG
  82      DEF_V_CBACK_VOID__INT_INT_LONG_pure
  83
  84      DEC_V_CBACK_VOID__mWXVARIANT_UINT_UINT_const
  85      DEF_V_CBACK_VOID__mWXVARIANT_UINT_UINT_const_pure
  86
  87      DEC_V_CBACK_VOID__SIZET_SIZET_const
  88      DEF_V_CBACK_VOID__SIZET_SIZET_const
  89
  90      DEC_V_CBACK_WXCOORD__VOID_const
  91      DEF_V_CBACK_WXCOORD__VOID_const
  92      DEF_V_CBACK_WXCOORD__VOID_const_pure
  93
  94      DEC_V_CBACK_WXCOORD__SIZET
  95      DEC_V_CBACK_WXCOORD__SIZET_const
  96      DEF_V_CBACK_WXCOORD__SIZET
  97      DEF_V_CBACK_WXCOORD__SIZET_const
  98      DEF_V_CBACK_WXCOORD__SIZET_pure
  99      DEF_V_CBACK_WXCOORD__SIZET_const_pure
 100
 101      DEC_V_CBACK_WXSTRING__WXSTRING
 102      DEF_V_CBACK_WXSTRING__WXSTRING
 103
 104      DEC_V_CBACK_WXSTRING__UINT
 105      DEC_V_CBACK_WXSTRING__UINT_const
 106      DEF_V_CBACK_WXSTRING__UINT
 107      DEF_V_CBACK_WXSTRING__UINT_const_pure
 108      );
 109 my %type_map =
 110   ( BOOL    => [ 'bool',    'SvTRUE( ret )', 'return false',
 111                  'bool p%d', 'b', 'p%d', 'p%d' ],
 112     SIZET   => [ 'size_t',  'SvIV( ret )', 'return 0',
 113                  'size_t p%d', 'L', 'p%d', 'p%d' ],
 114     LONG    => [ 'long',    'SvIV( ret )', 'return 0',
 115                  'long p%d', 'l', 'p%d', 'p%d' ],
 116     INT     => [ 'int',     'SvIV( ret )', 'return 0',
 117                  'int p%d', 'i', 'p%d', 'p%d' ],
 118     UINT    => [ 'unsigned int', 'SvUV( ret )', 'return 0',
 119                  'unsigned int p%d', 'I', 'p%d', 'p%d' ],
 120     WXCOORD => [ 'wxCoord', 'SvIV( ret )', 'return 0',
 121                  'wxCoord p%d', 'l', 'p%d', 'p%d' ],
 122     DOUBLE  => [ 'double',  'SvNV( ret )', 'return 0.0', ],
 123     VOID    => [ 'void',    ';',         , 'return',
 124                  ],
 125     WXSTRING=> [ 'wxString','wxPli_sv_2_wxString( aTHX_ ret )', 'return wxEmptyString',
 126                  'const wxString& p%d', 'P', '&p%d', 'p%d' ],
 127     WXVARIANT=> [ 'wxVariant','wxPli_sv_2_wxvariant( aTHX_ ret )', 'return wxVariant()',
 128                  'const wxVariant& p%d', 'q', '&p%d, "Wx::Variant"', 'p%d' ],
 129     mWXVARIANT=> [ 'wxVariant','wxPli_sv_2_wxvariant( aTHX_ ret )', 'return wxVariant()',
 130                  'wxVariant& p%d', 'q', '&p%d, "Wx::Variant"', 'p%d' ],
 131     );
 132 my %const_map =
 133   ( 0       => 'wxPli_NOCONST',
 134     1       => 'wxPli_CONST',
 135     );
 136
 137 my %emitted;
 138 my @todo = map [ parse_macro( $_, \%type_map ) ], @macros;
 139
 140 print <<'EOT';
 141 // GENERATED FILE, DO NOT EDIT
 142
 143 #ifndef _WXPERL_V_CBACK_DEF_H
 144 #define _WXPERL_V_CBACK_DEF_H
 145
 146 EOT
 147
 148 foreach my $todo ( @todo ) {
 149     my $args = join '_', @{$todo->[2]};
 150     my( $c_args, $p_args, $b_args, $tymap ) = macro_call_args( $todo );
 151
 152     if( $todo->[0] eq 'DEC' && $todo->[1] eq 'VOID' ) {
 153         my $name = sprintf 'DEC_V_CBACK_VOID__%s_', $args;
 154         next if $emitted{$name};
 155         $emitted{$name} = 1;
 156
 157         printf <<'EOT',
 158 #define %s( RET, METHOD, CONST ) \
 159     void METHOD(%s) CONST
 160
 161 EOT
 162         $name, $c_args;
 163     } elsif( $todo->[0] eq 'DEC' ) {
 164         my $name = sprintf 'DEC_V_CBACK_ANY__%s_', $args;
 165         next if $emitted{$name};
 166         $emitted{$name} = 1;
 167
 168         printf <<'EOT',
 169 #define %s( RET, METHOD, CONST ) \
 170     RET METHOD(%s) CONST
 171
 172 EOT
 173         $name, $c_args;
 174     } elsif( $todo->[0] eq 'DEF' && $todo->[1] eq 'VOID' ) {
 175         my $name = sprintf 'DEF_V_CBACK_VOID__%s_', $args;
 176         next if $emitted{$name};
 177         $emitted{$name} = 1;
 178
 179         printf <<'EOT',
 180 #define %s( RET, CVT, CLASS, CALLBASE, METHOD, CONST ) \
 181     void CLASS::METHOD(%s) CONST \
 182     {                                                                         \
 183         dTHX;                                                                 \
 184         if( wxPliFCback( aTHX_ &m_callback, #METHOD ) )                       \
 185         {                                                                     \
 186             wxPliCCback( aTHX_ &m_callback, G_SCALAR|G_DISCARD,               \
 187                          %s%s );                              \
 188         }                                                                     \
 189         else                                                                  \
 190             CALLBASE;                                                         \
 191     }
 192
 193 EOT
 194             $name, $c_args, $tymap, ( $p_args ? ", $p_args" : '' );
 195     } elsif( $todo->[0] eq 'DEF' ) {
 196         my $name = sprintf 'DEF_V_CBACK_ANY__%s_', $args;
 197         next if $emitted{$name};
 198         $emitted{$name} = 1;
 199
 200         printf <<'EOT',
 201 #define %s( RET, CVT, CLASS, CALLBASE, METHOD, CONST ) \
 202     RET CLASS::METHOD(%s) CONST                           \
 203     {                                                                         \
 204         dTHX;                                                                 \
 205         if( wxPliFCback( aTHX_ &m_callback, #METHOD ) )                       \
 206         {                                                                     \
 207             wxAutoSV ret( aTHX_ wxPliCCback( aTHX_ &m_callback, G_SCALAR,     \
 208                                              %s%s ) );                      \
 209             return CVT;                                                       \
 210         }                                                                     \
 211         else                                                                  \
 212             CALLBASE;                                                         \
 213     }
 214
 215 EOT
 216             $name, $c_args, $tymap, ( $p_args ? ", $p_args" : '' );
 217     }
 218 }
 219
 220 foreach my $todo ( @todo ) {
 221     my $args = join '_', @{$todo->[2]};
 222     my( $c_args, $p_args, $b_args, $tymap ) = macro_call_args( $todo );
 223
 224     my $const = $todo->[3]->{const} ? '_const' : '';
 225     my $pure = $todo->[3]->{pure} ? '_pure' : '';
 226
 227     die 'No type name for ', $todo->[1]
 228         unless $type_map{$todo->[1]}[0];
 229     die 'No type conversion for ', $todo->[1]
 230         unless $type_map{$todo->[1]}[1];
 231
 232     if( $todo->[0] eq 'DEC' && $todo->[1] eq 'VOID' ) {
 233         printf <<'EOT',
 234 #define DEC_V_CBACK_VOID__%s%s( METHOD ) \
 235     DEC_V_CBACK_VOID__%s_( %s, METHOD, %s )
 236
 237 EOT
 238             $args, $const, $args, $type_map{$todo->[1]}[0],
 239             $const_map{$todo->[3]->{const}};
 240     } elsif( $todo->[0] eq 'DEC' ) {
 241         printf <<'EOT',
 242 #define DEC_V_CBACK_%s__%s%s( METHOD ) \
 243     DEC_V_CBACK_ANY__%s_( %s, METHOD, %s )
 244
 245 EOT
 246             $todo->[1], $args, $const, $args, $type_map{$todo->[1]}[0],
 247             $const_map{$todo->[3]->{const}};
 248     } elsif( $todo->[0] eq 'DEF' && $todo->[1] eq 'VOID' ) {
 249         my $callbase = sprintf 'BASE::METHOD(%s)', $b_args;
 250         die 'No default value for pure function ', $todo->[1]
 251             if $todo->[3]{pure} && !$type_map{$todo->[1]}[2];
 252
 253         printf <<'EOT',
 254 #define DEF_V_CBACK_VOID__%s%s%s( CLASS, BASE, METHOD ) \
 255     DEF_V_CBACK_VOID__%s_( %s, %s, CLASS, %s, METHOD, %s )
 256
 257 EOT
 258             $args, $const, $pure, $args, $type_map{$todo->[1]}[0],
 259             $type_map{$todo->[1]}[1],
 260             ( $todo->[3]{pure} ? $type_map{$todo->[1]}[2] : $callbase ),
 261             $const_map{$todo->[3]->{const}};
 262     } elsif( $todo->[0] eq 'DEF' ) {
 263         my $callbase = sprintf 'return BASE::METHOD(%s)', $b_args;
 264         die 'No default value for pure function ', $todo->[1]
 265             if $todo->[3]{pure} && !$type_map{$todo->[1]}[2];
 266
 267         printf <<'EOT',
 268 #define DEF_V_CBACK_%s__%s%s%s( CLASS, BASE, METHOD ) \
 269     DEF_V_CBACK_ANY__%s_( %s, %s, CLASS, %s, METHOD, %s )
 270
 271 EOT
 272             $todo->[1], $args, $const, $pure, $args, $type_map{$todo->[1]}[0],
 273             $type_map{$todo->[1]}[1],
 274             ( $todo->[3]{pure} ? $type_map{$todo->[1]}[2] : $callbase ),
 275             $const_map{$todo->[3]->{const}};
 276     }
 277 }
 278
 279 print <<'EOT';
 280
 281 #endif
 282
 283 EOT
 284
 285 sub parse_macro {
 286     my( $macro, $types ) = @_;
 287     my( $type, $ret, @args, %flags );
 288
 289     $flags{$_} = 0 foreach qw(const pure);
 290
 291     my $tmp = $macro;
 292     $tmp =~ s/_const// and $flags{const} = 1;
 293     $tmp =~ s/_pure//  and $flags{pure} = 1;
 294
 295     $tmp =~ s/^DE([CF])_V_CBACK// and $type = 'DE' . $1;
 296     $tmp =~ s/^_([A-Za-z]+)__//   and $ret = $1;
 297
 298     @args = split '_', $tmp;
 299
 300     die "Unable to parse '$macro'" unless @args && $ret;
 301     $types->{$_} or die "invalid type $_ in '$macro'" foreach $ret, @args;
 302
 303     return ( $type, $ret, \@args, \%flags );
 304 }
 305
 306 sub macro_call_args {
 307     my( $todo ) = @_;
 308
 309     my( $c_args, $p_args, $b_args, $tymap );
 310     if( $todo->[2][0] eq 'VOID' ) {
 311         $c_args = $p_args = $b_args = '';
 312         $tymap = 'NULL';
 313     } else {
 314         my $c = 0;
 315         my( @cargs, @pargs, @bargs );
 316         foreach my $idx ( 0 .. $#{$todo->[2]} ) {
 317             my $type = $todo->[2][$idx];
 318             die 'Incomplete type definition for ', $type
 319               unless    $type_map{$type}[3]
 320                      && $type_map{$type}[4]
 321                      && $type_map{$type}[5];
 322             $cargs[$idx] = sprintf $type_map{$type}[3], $idx + 1;
 323             $tymap .= $type_map{$type}[4];
 324             $pargs[$idx] = sprintf $type_map{$type}[5], $idx + 1;
 325             $bargs[$idx] = sprintf $type_map{$type}[6], $idx + 1;
 326         }
 327         $c_args = ' ' . join( ', ', @cargs ) . ' ';
 328         $p_args = join( ', ', @pargs );
 329         $b_args = join( ', ', @bargs );
 330         $tymap  = qq{"$tymap"};
 331     }
 332
 333     return ( $c_args, $p_args, $b_args, $tymap );
 334 }