diff options
author | Mageia SVN-Git Migration <svn-git-migration@mageia.org> | 2007-04-25 15:16:21 +0000 |
---|---|---|
committer | Mageia SVN-Git Migration <svn-git-migration@mageia.org> | 2007-04-25 15:16:21 +0000 |
commit | be4fff49f0164e606d4b2f76f64d4d108895f236 (patch) | |
tree | a46bc8c23de0b885f8a2962a9069930b48836fd9 /fake_packages/gen.pl | |
parent | 4746e8e79a5b3cdf3f72400a5a5d6742f6a76a8c (diff) | |
download | perl_checker-be4fff49f0164e606d4b2f76f64d4d108895f236.tar perl_checker-be4fff49f0164e606d4b2f76f64d4d108895f236.tar.gz perl_checker-be4fff49f0164e606d4b2f76f64d4d108895f236.tar.bz2 perl_checker-be4fff49f0164e606d4b2f76f64d4d108895f236.tar.xz perl_checker-be4fff49f0164e606d4b2f76f64d4d108895f236.zip |
Rename folder to match history.
This is a Synthesized commit to combine perl-MDK-Common and perl_checker repository
history.
Diffstat (limited to 'fake_packages/gen.pl')
-rwxr-xr-x | fake_packages/gen.pl | 108 |
1 files changed, 108 insertions, 0 deletions
diff --git a/fake_packages/gen.pl b/fake_packages/gen.pl new file mode 100755 index 0000000..6ca4c21 --- /dev/null +++ b/fake_packages/gen.pl @@ -0,0 +1,108 @@ +#!/usr/bin/perl -w + +use strict; +use MDK::Common; + +my ($current_package, $current_prefix, $current_name); + +my %l; +sub get_paras { + my ($name, $para) = @_; + $name =~ s/\Q$current_prefix//; + $current_name = $name; + $l{$current_package}{$name} = [ map { + if (/\Q.../) { + '@_more_paras'; + } else { + my ($optional) = s/=(.*)//; + my $s = /.*\W(\w+)/ ? $1 : $_; + '$_' . ($optional ? 'o_' : '') . $s; + } + } grep { !/OUTLIST/ } split(',', $para) ]; +} + +sub parse_xs { + my ($file) = @_; + warn "parse_xs $file\n"; + my $state = 'waiting_for_type'; + ($current_package, $current_prefix) = ('', ''); + my $multi_line; + my $c; + foreach (cat_($file)) { + $c++; + next if /^=/ ... /^=cut/; + chomp; + my $orig_line = $_; + + if (/^\s*#/ || (m!^\s*/\*! .. m!\*/!)) { + # forget it + } elsif ($state eq 'multi_line') { + if (/(.*)\)/) { + get_paras($current_name, $multi_line . $1); + $state = 'waiting_for_end'; + } else { + $multi_line .= $_; + } +# } elsif (/^\s*gperl_set_isa\s*\("(.*)", ".*"\)\s*;/) { + } elsif (/MODULE\s*=\s*\S+\s+PACKAGE\s*=\s*(\S+)\s+PREFIX\s*=\s*(\S+)/) { + ($current_package, $current_prefix) = ($1, $2); + } elsif (/MODULE\s*=\s*\S+\s+PACKAGE\s*=\s*(\S+)/) { + ($current_package, $current_prefix) = ($1, ''); + } elsif (!$current_package) { + # waiting for the MODULE line + } elsif (/^\s*$/) { + $state = 'waiting_for_type'; + } elsif (/^\w[^\(]*$/ && $state eq 'waiting_for_type') { + $state = 'waiting_for_function' if !/^BOOT:/ && !/;/; + } elsif (/^\s*ALIAS:\s*$/) { + $state = 'alias'; + } elsif ($state eq 'alias') { + if (my ($f) = /^\s*(\S+)\s*=\s*\d+\s*$/) { + my $pkg = $f =~ s/(.*)::// ? $1 : $current_package; + $l{$pkg}{$f} ||= $l{$current_package}{$current_name}; + } else { + warn "bad line #$c $orig_line (state: $state)\n" if !/^\s*\w+:\s*$/ && !/^\s*$/; + $state = 'waiting_for_end'; + } + } elsif ($state eq 'waiting_for_type' && s/^(const\s*)?\w+\s*(\*\s*)?// || + $state eq 'waiting_for_function' && /^\w+/) { + if (my ($name, $para) = /^(\S+)\s*\((.*)\)\s*;?\s*$/) { + get_paras($name, $para); + $state = 'waiting_for_end'; + } elsif (($name, $para) = /^(\S+)\s*\((.*)$/) { + $multi_line = $para; + $current_name = $name; + $state = 'multi_line'; + } else { + warn "bad line #$c $orig_line (state: $state)\n"; + } + } else { + warn "bad line #$c $orig_line (state: $state)\n" if + !(($state eq 'waiting_for_end' || $state eq 'waiting_for_type') && + (/^\s/ || /^[{}]\s*$/ || /^(CODE|OUTPUT):\s*$/)); + } + } +} + + +my ($pkg_name, $dir) = @ARGV; +my @xs_files = chomp_(`find $dir -name "*.xs"`); +@ARGV == 2 && @xs_files or die "usage: gen.pl <Gtk2 or Glib> <dir where Gtk2's or Glib's *.xs are>\n"; + +parse_xs($_) foreach @xs_files; + +print "package $pkg_name;\nuse Glib;\n" if $pkg_name eq 'Gtk2'; + +foreach my $pkg (sort keys %l) { + print "\npackage $pkg;\n"; + print "our \@ISA = qw();\n"; + foreach my $name (sort keys %{$l{$pkg}}) { + my $para = $l{$pkg}{$name}; + $name = $pkg . '::' . $name if $name =~ /^(eq|foreach|format|ge|length|sub|x|xor|y)$/; + if (@$para) { + print "sub $name { my (", join(", ", @$para), ") = \@_ }\n"; + } else { + print "sub $name() {}\n"; + } + } +} |