Changeset 1253

Show
Ignore:
Timestamp:
11/26/06 22:00:20
Author:
pvanhoof
Message:

Improvements by mupped

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/tools/gtypeinterface-h-files-to-c-file.pl

    r1252 r1253  
    1 #! /usr/bin/perl 
    2  
    3 # 
    4 # Usage: cat hfiles | ./gtypeinterface-h-files-to-c-file.pl MyTypeName 
     1#! /usr/bin/perl -w 
     2 
     3# 
     4# Usage: ./gtypeinterface-h-files-to-c-file.pl MyTypeName hfiles 
    55# For example:  
    6 # cat ../libtinymailui/tny-mime-part-view.h ../libtinymailui/tny-mime-part-saver.h | ./gtypeinterface-h-files-to-c-file.pl MyMimePartComponent 
    7 # 
    8  
    9 my $typename = $ARGV[0]; 
    10 my %interfaces = (); 
    11 my $tel=0; 
    12 my $itel=0; 
     6# ./gtypeinterface-h-files-to-c-file.pl MyMimePartComponent ../libtinymailui/tny-mime-part-view.h ../libtinymailui/tny-mime-part-saver.h 
     7# 
     8 
     9use strict; 
     10 
     11my $typename = shift @ARGV; 
     12 
     13die "usage: $0 TypeName iface1.h iface2.h ... > newiface.c\n" 
     14        unless defined $typename; 
     15 
     16my @interfaces = (); 
    1317 
    1418sub max     { $_[0] > $_[1] ? $_[0] : $_[1]; } 
    15 sub isupper { ord($_[0]) >= ord('A') && ord($_[0]) <= ord('Z'); } 
    16 sub islower { ord($_[0]) >= ord('a') && ord($_[0]) <= ord('z'); } 
    17 sub toupper { &islower ? pack('c', ord($_[0])-ord('a')+ord('A')) : $_[0];} 
    18 sub tolower { &isupper ? pack('c', ord($_[0])-ord('A')+ord('a')) : $_[0];} 
    1919 
    2020sub uncamel_low 
    2121{ 
    2222        my $line = shift; 
    23         my $char; 
    24         my $c; 
    25         my $out; 
    26         my $i=0; 
    27          
    28         for ($i=0; $i < length ($line); $i++) 
    29         { 
    30                 $char = substr ($line, $i, 1); 
    31  
    32                 if ($char =~ /[A-Z]/) { 
    33                         if ($i == 0) { 
    34                                 $c = ""; 
    35                         } else { 
    36                                 $c = "_"; 
    37                         } 
    38                         $c .= tolower (substr ($char, 0, 1)); 
    39                         $out .= $c; 
    40                 } else { 
    41                         $out .= substr ($char, 0, 1); 
    42                 } 
    43         } 
     23 
     24        my $out = lcfirst $line; 
     25        $out =~ s/([a-z0-9_])([A-Z])/$1."_".lcfirst($2)/ge; 
    4426 
    4527        return $out; 
    …… 
    4931{ 
    5032        my $line = shift; 
    51         my $char; 
    52         my $c; 
    53         my $out; 
    54         my $i=0;         
    55          
    56         for ($i=0; $i < length ($line); $i++) 
    57         { 
    58                 $char = substr ($line, $i, 1); 
    59  
    60                 if ($char =~ /[A-Z]/) { 
    61                         if ($i == 0) { 
    62                                 $c = ""; 
    63                         } else { 
    64                                 $c = "-"; 
    65                         } 
    66                         $c .= tolower (substr ($char, 0, 1)); 
    67                         $out .= $c; 
    68                 } else { 
    69                         $out .= substr ($char, 0, 1); 
    70                 } 
    71         } 
     33 
     34        my $out = lcfirst $line; 
     35        $out =~ s/([a-z0-9_])([A-Z])/$1."-".lcfirst($2)/ge; 
    7236 
    7337        return $out; 
    7438} 
     39 
    7540sub uncamel_up 
    7641{ 
    7742        my $line = shift; 
    78         my $char; 
    79         my $c; 
    80         my $out; 
    81         my $i=0; 
    82          
    83         for ($i=0; $i < length ($line); $i++) 
    84         { 
    85                 $char = substr ($line, $i, 1); 
    86  
    87                 if ($char =~ /[A-Z]/) { 
    88                         if ($i == 0) { 
    89                                 $c = ""; 
    90                         } else { 
    91                                 $c = "_"; 
    92                         } 
    93                         $c .= $char; 
    94                         $out .= $c; 
    95                 } else { 
    96                         $out .= toupper (substr ($char, 0, 1)); 
    97                 } 
    98         } 
    99  
    100         return $out; 
     43 
     44        my $out = $line; 
     45        $out =~ s/([a-z0-9_])([A-Z])/$1\_$2/g; 
     46 
     47        return uc $out; 
    10148} 
    10249 
    …… 
    10552        my $line = shift; 
    10653 
    107         $line =~ s/\*//g; 
     54        $line =~ s/\s*\*//g; 
    10855 
    10956        return $line; 
    11057} 
    11158 
    112 my $ifaisopen = 0; 
    113  
    114 while ($line = <STDIN>) 
    115 { 
    116  
    117         if ($line =~ /struct\s_(.*)Iface[\s|\s\{|\s\{\s]$/) 
    118         { 
    119                 $itel++; 
    120                 $interfaces{$itel}{"name"} = $1; 
    121                 $ifaisopen = $itel; 
    122                 $tel = 0; 
    123         } 
    124  
    125         if ($line =~ /^\}\;$/) 
    126         { 
    127                 $ifaisopen = 0; 
    128         } 
    129  
    130         if ($ifaisopen != 0) 
    131         { 
    132                 if ($line =~ /^\s(.*)[\s|]\(\*(.*)_func\)\s(.*)\;$/) 
    133                 { 
    134                         $interfaces{$ifaisopen}{"methods"}{$tel}{"return_type"} = $1; 
    135                         $interfaces{$ifaisopen}{"methods"}{$tel}{"func_name"} = $2; 
    136                         $interfaces{$ifaisopen}{"methods"}{$tel}{"params"} = $3; 
    137                         $tel++; 
    138                 } 
    139         } 
    140  
    141 } 
     59 
     60# 
     61# Slurp everything in as one big line.  Since C code can have arbitrary 
     62# formatting, we can't just parse by lines. 
     63# 
     64$/ = undef; 
     65my $intext = join "", <>; 
     66 
     67# 
     68# strip comments.  note that this is straight from the perlop manpage, and 
     69# doesn't deal with all the nasty special cases you can get in C comments... 
     70# 
     71$intext =~ s{/\*    # open 
     72             .*?    # minimal internal match 
     73             \*/    # close 
     74             }{}gsx; 
     75 
     76# 
     77# Now look for all the structure definitions... 
     78# 
     79while ($intext =~ m/\bstruct            # struct keword. 
     80                    \s+                 # separator. 
     81                    (\w+)               # struct tag name. 
     82                    \s*                 # maybe whitespace. 
     83                    {                   # open structure definition block. 
     84                        ([^}]*)         # body; NOTE, we're not allowing 
     85                                        #       nested blocks with this. 
     86                    }                   # close structure definition block. 
     87                    \s*                 # maybe whitespace. 
     88                   /xsg) 
     89{ 
     90        my $iface = $1; 
     91        my $body = $2; 
     92 
     93        # Remove any decorators from the structure name: 
     94        $iface =~ s/^_//;       # leading underscore 
     95        $iface =~ s/Iface$//;   # trailing "Iface" 
     96 
     97        my @methods; 
     98 
     99        # Handle the body one statement at a time. 
     100        foreach my $statement (split /;/, $body) { 
     101                $statement =~ y{\n}{ }; 
     102                $statement =~ s/^\s*//; 
     103                $statement =~ s/\s*$//; 
     104 
     105                if ($statement =~ /^ 
     106                     (.*)               # any leading stuff, return spec 
     107                     \(                 # open paren for funcptr member 
     108                       \s* 
     109                       \*               # an asterisk 
     110                       \s* 
     111                       (\w+)            # the symbol name 
     112                       \s* 
     113                     \)                 # close paren for member name 
     114                     \s* 
     115                     \(                 # open paren for parameter list 
     116                        (.*)            # parameter specs 
     117                     \)                 # close paren for parameter list 
     118                    $/xs) { 
     119                        my $retspec = $1; 
     120                        my $func_name = $2; 
     121                        my $params = $3; 
     122 
     123                        # Another version without any _func suffixes, as they 
     124                        # tend to be a bit redundant.  ;-) 
     125                        (my $clean_sym = $func_name) =~ s/_func$//; 
     126 
     127                        # Clean up the return type specifier. 
     128                        $retspec =~ s/\s*$//; 
     129 
     130                        # And the parameter spec. 
     131                        $params =~ s/^\s*//; 
     132                        $params =~ s/\s*$//; 
     133 
     134                        push @methods, { 
     135                                func_full_name => $func_name, 
     136                                func_name      => $clean_sym, 
     137                                return_type    => $retspec, 
     138                                params         => $params, 
     139                        }; 
     140                } 
     141        } 
     142 
     143        push @interfaces, { 
     144                name => $iface, 
     145                methods => \@methods, 
     146        }; 
     147} 
     148 
     149warn "Found ".scalar(@interfaces)." interfaces\n"; 
     150use Data::Dumper; 
     151warn Dumper(\@interfaces); 
     152 
    142153 
    143154 
    …… 
    150161print ("static GObjectClass *parent_class = NULL;\n\n"); 
    151162 
    152 for my $key (keys %interfaces) 
    153 { 
    154   for my $mkey (keys % { $interfaces{$key}{"methods"} } ) 
    155   { 
    156         print ("static "); 
    157         print ($interfaces{$key}{"methods"}{$mkey}{"return_type"}."\n"); 
    158         print (uncamel_low($typename)."_"); 
    159         print ($interfaces{$key}{"methods"}{$mkey}{"func_name"}." "); 
    160         print ($interfaces{$key}{"methods"}{$mkey}{"params"}); 
    161         print ("\n{\n"); 
    162         if ($interfaces{$key}{"methods"}{$mkey}{"return_type"} eq "void") 
    163         { 
    164                 print ("\treturn;"); 
    165         } else { 
    166                 print ("\treturn ".uncamel_low(unpointer($interfaces{$key}{"methods"}{$mkey}{"return_type"}))."_new ()"); 
     163foreach my $iface (@interfaces) 
     164{ 
     165    foreach my $method (@{ $iface->{methods} }) 
     166    { 
     167        print "static ".$method->{return_type}."\n"; 
     168        print uncamel_low($typename)."_".$method->{func_name}." "; 
     169        print "(".$method->{params}.")"; 
     170        print "\n{\n"; 
     171        print "\treturn ".uncamel_low(unpointer($method->{return_type}))."_new ()\n" 
     172                if $method->{return_type} ne "void"; 
     173        print "}\n\n"; 
     174    } 
     175} 
     176 
     177print "static void\n"; 
     178print uncamel_low($typename)."_finalize (GObject *object)\n"; 
     179print "{\n\tparent_class->finalize (object);\n}\n"; 
     180 
     181foreach my $iface (@interfaces) 
     182{ 
     183        print ("\nstatic void\n"); 
     184        print (uncamel_low ($iface->{name})."_init (".$iface->{name}."Iface *klass)\n{\n"); 
     185 
     186 
     187        foreach my $method (@{ $iface->{methods} }) 
     188        { 
     189                print ("\tklass->".$method->{func_full_name}." = "); 
     190                print (uncamel_low($typename)."_"); 
     191                print ($method->{func_name}.";\n"); 
    167192        } 
    168         print ("\n}\n\n"); 
    169   } 
    170 } 
    171  
    172 print ("static void\n"); 
    173 print (uncamel_low($typename)."_finalize (GObject *object)\n"); 
    174 print ("{\n\t(*parent_class->finalize) (object);\n\treturn;\n}\n"); 
    175  
    176 for my $key (keys(%interfaces)) 
    177 { 
    178         print ("\nstatic void\n"); 
    179         print (uncamel_low ($interfaces{$key}{"name"})."_init (".$interfaces{$key}{"name"}."Iface *klass)\n{\n"); 
    180  
    181  
    182         for my $mkey (keys % { $interfaces{$key}{"methods"} } ) 
    183         { 
    184                 print ("\tklass->".$interfaces{$key}{"methods"}{$mkey}{"func_name"}."_func = "); 
    185                 print (uncamel_low($typename)."_"); 
    186                 print ($interfaces{$key}{"methods"}{$mkey}{"func_name"}.";\n"); 
    187         } 
    188  
    189         print ("\n\treturn;\n}\n\n"); 
     193 
     194        print ("}\n\n"); 
    190195 
    191196} 
    …… 
    196201print ("\tparent_class = g_type_class_peek_parent (klass);\n"); 
    197202print ("\tobject_class = (GObjectClass*) klass;\n"); 
    198 print ("\tobject_class->finalize = ".uncamel_low ($typename)."_finalize;\n\n"); 
    199 print ("\treturn;\n}\n"); 
     203print ("\tobject_class->finalize = ".uncamel_low ($typename)."_finalize;\n"); 
     204print ("}\n"); 
    200205 
    201206print ("GType\n"); 
    …… 
    215220print ("\t\t\tNULL\n\t\t};\n\n\n"); 
    216221 
    217 for my $key (keys(%interfaces)) 
    218 { 
    219         print ("\t\tstatic const GInterfaceInfo ".uncamel_low ($interfaces{$key}{"name"})."_info = \n\t\t{\n"); 
    220         print ("\t\t\t(GInterfaceInitFunc) ".uncamel_low ($interfaces{$key}{"name"})."_init, /* interface_init */\n"); 
     222foreach my $iface (@interfaces) 
     223{ 
     224        my $iface_low = uncamel_low ($iface->{name}); 
     225        print ("\t\tstatic const GInterfaceInfo ".$iface_low."_info = \n\t\t{\n"); 
     226        print ("\t\t\t(GInterfaceInitFunc) ".$iface_low."_init, /* interface_init */\n"); 
    221227        print ("\t\t\tNULL,         /* interface_finalize */\n"); 
    222228        print ("\t\t\tNULL          /* interface_data */\n\t\t}\n\n"); 
    …… 
    224230 
    225231 
    226 print ("\t\ttype = g_type_register_static (G_TYPE_OBJECT,\n"); 
    227 print ("\t\t\t\"".$typename."\",\n"); 
    228 print ("\t\t\t&info, 0);\n\n"); 
    229  
    230 for my $key (keys(%interfaces)) 
    231 { 
    232         print ("\t\tg_type_add_interface_static (type, ".uncamel_up ($interfaces{$key}{"name"}).",\n");  
    233         print ("\t\t\t&".uncamel_low ($interfaces{$key}{"name"})."_info\n\n"); 
    234 } 
    235 print ("\t}\n\treturn type;\n}\n"); 
    236  
     232print "\t\ttype = g_type_register_static (G_TYPE_OBJECT,\n"; 
     233print "\t\t\t\"".$typename."\",\n"; 
     234print "\t\t\t&info, 0);\n\n"; 
     235 
     236foreach my $iface (@interfaces) 
     237{ 
     238        my $iface_up = uncamel_up ($iface->{name}); 
     239        my $iface_low = uncamel_low ($iface->{name}); 
     240        print "\t\tg_type_add_interface_static (type, $iface_up,\n"; 
     241        print "\t\t\t&".$iface_low."_info\n\n"; 
     242} 
     243print "\t}\n\treturn type;\n}\n"; 
     244