1 files changed, 140 insertions, 0 deletions
diff --git a/perl_checker_fake_packages/gen.pl b/perl_checker_fake_packages/gen.pl
new file mode 100755
index 0000000..35be8f4
--- /dev/null
+++ b/perl_checker_fake_packages/gen.pl
@@ -0,0 +1,140 @@
+#!/usr/bin/perl
+
+use MDK::Common;
+
+sub gtk2 {
+    my (@files) = @_;
+
+    my @subroutines;
+    my $add = sub {
+        push @subroutines, [ $_[0], $_[1] ];
+    };
+    
+    my $pm_file = sub {
+        my ($file) = @_;
+        my @contents = cat_($file);
+        each_index {
+            if (/^\s*sub\s+(\w+)/) {
+                my $fun = $1;
+                #- one liner constants
+                #-   sub EXPOSURE_MASK { 'exposure-mask' }
+                /^\s*sub\s+(\w+)\s*{\s*('[^']+')|("[^"]+")\s*}/ and $add->($fun, '() { }');
+                #-   sub Sym_Hangul_J_Phieuf { 0xeed }
+                /^\s*sub\s+(\w+)\s*{\s*0\S+\s*}/                and $add->($fun, '() { }');
+
+                #- explore first line of subroutine definition
+                local $_ = $contents[$::i+1];
+                #- methods with no argument
+                #-   my $values = shift->_get_size_request;
+                if (/shift->\w+\s*;/) {
+                    $add->($fun, ' { my ($_self) = @_ }');
+                }
+                #- methods with variable list of arguments (which branch to different XS functions)
+                #-   Gtk2::_Helpers::check_usage(\@_, [ 'Gtk2::GSList group' ], [ 'Gtk2::GSList group', 'string label' ]);
+                if (/Gtk2::_Helpers::check_usage\(\\\@_, (.*)\);/) {
+                    my $subroutine = ' { my (';
+                    my @various = split /\]\s*,/, $1;
+                    s/[\[\]]//g foreach @various;
+                    my @mandatory = split /,/, $various[0];
+                    my $proto2varname = sub { $_[0] =~ /\s*'\s*\S+\s+(.*)\s*'/; $1 };
+                    $subroutine .= join(', ', map { '$_'.$proto2varname->($_) } @mandatory);
+                    @mandatory and $subroutine .= ', ';
+                    my @optional = split /,/, $various[-1];
+                    @optional = splice @optional, @mandatory;
+                    $subroutine .= join(', ', map { '$o_'.$proto2varname->($_) } @optional);
+                    $add->($fun, "$subroutine) = \@_ }");
+                }
+
+            }
+
+        } @contents;
+    };
+
+    my $c_file = sub {
+        my ($file) = @_;
+        my @contents = cat_($file);
+        my $comment;
+        each_index {
+            m|/\*| and $comment = 1;
+            m|\*/| and $comment = 0;
+            s|/\*.*\*/||;
+            s|//.*||;
+            $comment and goto next_;
+            /^#/ and goto next_;
+            /^\s*static/ and goto next_;
+            if (/^\S.*\s(\w+)\s*\((.*)/) {
+                my $fun = $1;
+                #- skip "internal" functions
+                $fun =~ /__/ and goto next_;
+                my $args = $2;
+                
+                #- guess function name
+                $fun =~ s/^.*perl_//;
+                
+                my ($trimlast) = $file =~ /([A-Z]\w+)\.c$/;
+                while ($trimlast =~ s/([a-z])([A-Z])/$1_$2/) {}
+                $trimlast =~ s/^G([A-Z])/$1/; #- glib case
+                $file =~ m|Gdk/Event/src| and $trimlast = "event_$trimlast"; #- gdkevent case
+                $trimlast = lc($trimlast);
+                #- skip functions that will not be exported anyway because don't follow the naming scheme
+                $fun =~ s/^\Q$trimlast\_// or goto next_;
+
+                #- explore following lines if prototype was not complete
+                my $line = $::i;
+                while ($args !~ /\)/) {
+                    $line++;
+                    $args .= $contents[$line];
+                }
+                $args =~ s/\s+/ /g;
+                $args =~ s/\).*//;
+
+                my $proto2varname = sub { $_[0] =~ /(\w+)\s*$/; $1 };
+                my @args = split /,/, $args;
+
+                $add->($fun, ' { my (' . join(', ', map { '$_'.$proto2varname->($_) } @args) . ') = @_ }');
+            }
+          next_:
+        } @contents;
+    };
+
+    foreach (@files) {
+        /\.pm$/ and $pm_file->($_);
+        /\.c$/ and $c_file->($_);
+    }
+
+
+    print
+"package Gtk2;
+
+our \@ISA = qw();
+
+";
+    @subroutines = sort { $a->[0] cmp $b->[0] } @subroutines;
+    my @ok;
+    foreach my $fun (uniq(map { $_->[0] } @subroutines)) {
+        my @multiples = grep { $_->[0] eq $fun } @subroutines;
+        if (@multiples != 1) {
+            my $args = -1;
+            foreach (@multiples) {
+                my $a = split /,/, $_->[1];
+                $args == -1 and $args = $a;
+                #- skip multiply defined functions that have different numbers of arguments
+                $args != $a and goto skip_it;
+            }
+            my $i;
+            $multiples[0][1] =~ s/\$_(\w+)/'$_DUMMY'.$i++/ge;
+            push @ok, @multiples[0];
+        } else {
+            push @ok, @multiples;
+        }
+      skip_it:
+    }
+
+    print "sub Gtk2::$_->[0]$_->[1]\n" foreach @ok;
+}
+
+
+if ($ARGV[0] =~ /gtk2/) {
+    shift @ARGV;
+    gtk2(@ARGV);
+}