d7df5fa0ca
* codegen/get-props-from-source.pl : Temporary (possibly) defs generator for props. Will probably kill this when the official defs support props. * codegen/defs-parse.pl : Added object-based aggregation of defs. Generate the class shells, methods, and props. * codegen/gdk-types.defs : ripped from pygtk. * codegen/gtk.defs : ripped from pygtk. * codegen/gtk-props.defs : some props defs. * codegen/makefile : add the new defs files. svn path=/trunk/gtk-sharp/; revision=1203
144 lines
3 KiB
Perl
Executable file
144 lines
3 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
open (SRCFILE, $ARGV[0]) || die "Could open $ARGV[0]";
|
|
|
|
@lines = <SRCFILE>;
|
|
$linenum = 0;
|
|
|
|
while ($linenum < @lines) {
|
|
|
|
$line = $lines[$linenum];
|
|
|
|
if ($line =~ /^(\w+)_class_init/) {
|
|
$typename = StudCaps($1);
|
|
$fstr = "";
|
|
|
|
do {
|
|
$fstr .= $lines[$linenum++];
|
|
} until ($lines[$linenum] =~ /^}/);
|
|
|
|
parse_init_func ($typename, $fstr);
|
|
}
|
|
|
|
$linenum++;
|
|
}
|
|
|
|
sub parse_init_func
|
|
{
|
|
my ($class, $func) = @_;
|
|
my @init_lines = split (/\n/, $func);
|
|
|
|
my $linenum = 0;
|
|
while ($linenum < @init_lines) {
|
|
|
|
my $line = $init_lines[$linenum];
|
|
|
|
while ($linenum < @init_lines) {
|
|
$line = $init_lines[$linenum];
|
|
if ($line =~ /g_object_class_install_prop/) {
|
|
my $prop = $line;
|
|
do {
|
|
$prop .= $init_lines[++$linenum];
|
|
} until ($init_lines[$linenum] =~ /;/);
|
|
print_prop ($prop, $class);
|
|
} elsif ($line =~ /g_signal_new/) {
|
|
my $sig = $line;
|
|
do {
|
|
$sig .= $init_lines[++$linenum];
|
|
} until ($init_lines[$linenum] =~ /;/);
|
|
print_signal ($sig, $class);
|
|
}
|
|
$linenum++;
|
|
}
|
|
|
|
$linenum++;
|
|
}
|
|
}
|
|
|
|
sub print_signal
|
|
{
|
|
my ($spec, $class) = @_;
|
|
$spec =~ s/\n\s*//g;
|
|
|
|
$spec =~ /\((.*)\);/;
|
|
my @args = split (/,\s*/, $1);
|
|
|
|
$args[0] =~ /\w+/;
|
|
my $name = $&;
|
|
|
|
my $ret = $args[8];
|
|
if ($ret =~ /G_TYPE_(\w+)/) {
|
|
$ret = lc ($1);
|
|
}
|
|
|
|
my $param_cnt = $args[9];
|
|
|
|
my $pstr = "\t<signal name=\"$name\">\n";
|
|
$pstr .= "\t\t<return> $ret </return>\n";
|
|
if ($param_cnt) {
|
|
$pstr .= "\t\t<parameters>\n";
|
|
for ($i=0; $i < $param_cnt; $i++) {
|
|
if ($args[$i+10] =~ /G_TYPE_(\w+)/) {
|
|
$args[$i+10] = lc ($1);
|
|
}
|
|
$pstr .= "\t\t\t<param> $args[$i+10] </param>\n";
|
|
}
|
|
$pstr .= "\t\t</parameters>\n";
|
|
}
|
|
$pstr .= "\t</signal>\n\n";
|
|
|
|
$signals{$name} = $pstr;
|
|
}
|
|
|
|
sub print_prop
|
|
{
|
|
my ($spec, $class) = @_;
|
|
|
|
$spec =~ /g_param_spec_(\w+)\s*\((.*)/;
|
|
$type = $1;
|
|
$params = $2;
|
|
|
|
if ($type =~ /boolean|^u*int|pointer/) {
|
|
$params =~ /\"(.+)\",.+\".+\".+\"(.+)\".*(,\s*G_PARAM_\w+.*)\)\s*\)/;
|
|
$name = $1; $docs = $2; $mode = $3;
|
|
$type = "g$type";
|
|
} elsif ($type =~ /string/) {
|
|
$params =~ /\"(.+)\",.+\".+\".+\"(.+)\".*(,\s*G_PARAM_\w+.*)\)\s*\)/;
|
|
$name = $1; $docs = $2; $mode = $3;
|
|
$type = "gchar*";
|
|
} elsif ($type =~ /enum|flags/) {
|
|
$params =~ /\"(.+)\",.+,.+\"(.+)\".*,\s+(\w+),.*,(\s*G_PARAM_\w+.*)\)\s*\)/;
|
|
$name = $1; $docs = $2; $type = $3; $mode = $4;
|
|
$type =~ s/TYPE_//;
|
|
$type = StudCaps(lc($type));
|
|
} elsif ($type =~ /object/) {
|
|
$params =~ /\"(.+)\",.+,.+\"(.+)\".*,\s+(\w+),(\s*G_PARAM_\w+.*)\)\s*\)/;
|
|
$name = $1; $docs = $2; $type = $3; $mode = $4;
|
|
$type =~ s/TYPE_//;
|
|
$type = StudCaps(lc($type));
|
|
}
|
|
|
|
|
|
print "(define-property $name\n";
|
|
print " (of-object \"$class\")\n";
|
|
print " (prop-type \"$type\")\n";
|
|
print " (doc-string \"$docs\")\n";
|
|
|
|
if ($mode =~ /READ/) { print " (readable #t)\n"; }
|
|
if ($mode =~ /WRIT/) { print " (writeable #t)\n"; }
|
|
if ($mode =~ /CONS/) { print " (construct-only #t)\n"; }
|
|
|
|
print ")\n\n";
|
|
|
|
$props{$name} = $pstr;
|
|
}
|
|
|
|
sub StudCaps
|
|
{
|
|
my ($str) = @_;
|
|
|
|
$str =~ s/^(\w)/\u\1/;
|
|
$str =~ s/[_-]([a-z])/\u\1/g;
|
|
$str =~ s/[_-](\d)/\1/g;
|
|
return $str;
|
|
}
|