git.maemo.org Git - pkg-perl/blob - deb-src/libwx-perl/libwx-perl-0.96/debian/libwx-perl/usr/lib/perl5/Wx/Overload/Driver.pm

   1 #############################################################################
   2 ## Name:        build/Wx/Overload/Driver.pm
   3 ## Purpose:     builds overload constants
   4 ## Author:      Mattia Barbon
   5 ## Modified by:
   6 ## Created:     17/08/2001
   7 ## RCS-ID:      $Id: Driver.pm 2500 2008-11-05 22:17:53Z mbarbon $
   8 ## Copyright:   (c) 2001-2003, 2005-2008 Mattia Barbon
   9 ## Licence:     This program is free software; you can redistribute it and/or
  10 ##              modify it under the same terms as Perl itself
  11 #############################################################################
  12
  13 package Wx::Overload::Driver;
  14
  15 use strict;
  16
  17 use Symbol qw(gensym);
  18
  19 use Wx::Overload::Handle;
  20
  21 my %_name2type =
  22   (
  23    wimg => 'Wx::Image',
  24    wbmp => 'Wx::Bitmap',
  25    wico => 'Wx::Icon',
  26    wmen => 'Wx::Menu',
  27    wmit => 'Wx::MenuItem',
  28    wrec => 'Wx::Rect',
  29    wreg => 'Wx::Region',
  30    wszr => 'Wx::Sizer',
  31    wtip => 'Wx::ToolTip',
  32    wwin => 'Wx::Window',
  33    wcol => 'Wx::Colour',
  34    wlci => 'Wx::ListItem',
  35    wgco => 'Wx::GridCellCoords',
  36    wdat => 'Wx::DataObject',
  37    wcur => 'Wx::Cursor',
  38    wehd => 'Wx::EvtHandler',
  39    wfon => 'Wx::Font',
  40    wdc  => 'Wx::DC',
  41    wfrm => 'Wx::Frame',
  42    wsiz => 1,
  43    wpoi => 1,
  44    wist => 1,
  45    wost => 1,
  46    num  => 1,
  47    str  => 1,
  48    bool => 1,
  49    arr  => 1,
  50    wpos => 1,
  51    zzz  => 1,
  52    );
  53
  54 my %name2type = %_name2type;
  55 my %constants;
  56
  57 sub new {
  58   my( $class, %args ) = @_;
  59   my $self = bless \%args, $class;
  60
  61   return $self;
  62 }
  63
  64 sub process {
  65   my( $self ) = @_;
  66
  67   $self->_parse;
  68   $self->_write;
  69 }
  70
  71 sub _parse {
  72   my( $self ) = @_;
  73
  74   foreach my $i ( $self->files ) {
  75     my %namedecl = %_name2type;
  76     open my $fh, '<', $i or die "open '$i': $!";
  77
  78     while( <$fh> ) {
  79       if( m/DECLARE_OVERLOAD\(\s*(\w+)\s*,\s*(\S+)\s*\)/ ) {
  80         $namedecl{$1} = $2;
  81         next if exists $name2type{$1} && $name2type{$1} eq $2;
  82         die "Clashing type: '$1' was '$name2type{$1}', redeclared as '$2'"
  83           if exists $name2type{$1};
  84         $name2type{$1} = $2;
  85       }
  86       if( m/Wx::_match\(\s*\@_\s*,\s*\$Wx::_(\w+)\s*\,/ ||
  87           m/wxPliOvl_(\w+)/ ) {
  88         my $const = $1;
  89         my @const = split /_/, $const;
  90         foreach my $j ( @const ) {
  91           $j = 'num' if $j eq 'n';
  92           $j = 'str' if $j eq 's';
  93           $j = 'bool' if $j eq 'b';
  94
  95           die "unrecognized type '$j' in file '$i'"
  96             unless $namedecl{$j};
  97           $constants{$const} = \@const;
  98         }
  99       }
 100     }
 101   }
 102 }
 103
 104 sub _write {
 105   my( $self ) = @_;
 106
 107   my @keys = ( ( sort grep { $name2type{$_} eq '1' } keys %name2type ),
 108                ( sort grep { $name2type{$_} ne '1' } keys %name2type ) );
 109
 110   my $vars_comma = join ", ",
 111                    map  "\$$_",
 112                         @keys;
 113   my $vars = $vars_comma; $vars =~ s/,//g;
 114   my $types = join ", ",
 115               map  "'$name2type{$_}'",
 116               grep $name2type{$_} ne '1',
 117                    @keys;
 118   my $cpp_types = $types; $cpp_types =~ s/\'/\"/g;
 119
 120   # header
 121   {
 122     my $out = gensym;
 123     tie *$out, 'Wx::Overload::Handle', $self->header;
 124
 125     my $enum = join ",\n",
 126                map  "    wxPliOvl$_",
 127                     @keys;
 128
 129     print $out <<EOT;
 130 // GENERATED FILE, DO NOT EDIT
 131
 132 #ifndef _CPP_OVERLOAD_H
 133 #define _CPP_OVERLOAD_H
 134
 135 enum
 136 {
 137     wxPliOvl\_Dummy = 0,
 138 $enum
 139 };
 140
 141 #endif
 142
 143 EOT
 144
 145     foreach my $i ( sort keys %constants ) {
 146       print $out "extern const wxPliPrototype wxPliOvl_${i};\n";
 147     }
 148
 149     close $out;
 150   }
 151
 152   # write source
 153   {
 154     my $out = gensym;
 155     tie *$out, 'Wx::Overload::Handle', $self->source;
 156
 157     print $out <<EOT;
 158 // GENERATED FILE, DO NOT EDIT
 159
 160 const char* wxPliOvl\_tnames[] = { 0,
 161 $cpp_types
 162 };
 163
 164 extern void wxPli_set_ovl_constant( const char* name,
 165                                     const wxPliPrototype* value );
 166 EOT
 167
 168     print $out <<EOT;
 169
 170 #ifndef WXPL_EXT
 171
 172 void SetOvlConstants()
 173 {
 174     dTHX;
 175 EOT
 176
 177     foreach my $i ( sort keys %constants ) {
 178       print $out <<EOT
 179     wxPli_set_ovl_constant( \"$i\", &wxPliOvl_${i} );
 180 EOT
 181     }
 182
 183     print $out <<EOT;
 184 }
 185
 186 #endif // WXPL_EXT
 187
 188 EOT
 189
 190     foreach my $i ( sort keys %constants ) {
 191       my $count = scalar @{$constants{$i}};
 192       print $out "const unsigned char wxPliOvl_${i}_datadef\[\] = { ";
 193       print $out join ", ", map { "wxPliOvl$_" } @{$constants{$i}};
 194       print $out " };\n";
 195       print $out <<EOT;
 196 const wxPliPrototype wxPliOvl_${i}
 197     ( wxPliOvl\_tnames, wxPliOvl_${i}_datadef, $count );
 198 EOT
 199     }
 200
 201     close $out;
 202   }
 203 }
 204
 205 sub source { $_[0]->{source} }
 206 sub header { $_[0]->{header} }
 207 sub files  { @{$_[0]->{files}} }
 208
 209 1;