[prev in list] [next in list] [prev in thread] [next in thread]
List: kde-bindings
Subject: Re: [Kde-bindings] The code!
From: Ashley Winters <jahqueel () yahoo ! com>
Date: 2003-03-07 4:30:53
[Download RAW message or body]
Okay, new version.
Fixed in this release:
* Virtual functions are declared according to spec. Virtual methods
inherited from parent classes are indicated with origin="QBase" instead
of whatever I originally proposed
* Fields work. Member variables and static variables in a class are now
output as field tags.
* Works better. Every class I've thrown at it works beautifully.
QString, template classes, deeply nested virtual hierarchies. I can't
find anything wrong.
* Enums work better. Previously, it was only printing out enums
actually used at arguments to a function. Now it prints out all enums.
Missing features:
* Signal/slot tags. I need to integrate slotnames.cpp into the xml
generator.
Give it a try. See if there's a class it doesn't work right on. I've
been throwing lots of classes at it... The fact that QString and
QPointArray (aka. QMemArray<QPoint>) will be fully available to the C
binding scares me! :)
Ashley Winters
__________________________________________________
Do you Yahoo!?
Yahoo! Tax Center - forms, calculators, tips, more
http://taxes.yahoo.com/
["genxml.pl" (application/octet-stream)]
#!/usr/bin/perl -w
use Getopt::Std;
$db = 0; # debug flag
getopt("c", \%opts);
$output = $opts{c} || "QWidget"; # what class to spit out
my %enums;
my %dumped; # only dump a class once
my %ops = (
'new' => "new",
vecnew => "new[]",
'delete' => "delete",
vecdelete => "delete[]",
'pos' => "+",
neg => "-",
addr => "&",
deref => "*",
'not' => "~",
lnot => "!",
preinc => "++",
predec => "--",
plus => "+",
plusassign => "+=",
minus => "-",
minusassign => "-=",
mult => "*",
multassign => "*=",
div => "/",
divassign => "/=",
mod => "%",
modassign => "%=",
'and' => "&",
andassign => "&=",
'or' => "|",
orassign => "|=",
'xor' => "^",
xorassign => "^=",
lshift => "<<",
lshiftassign => "<<=",
rshift => ">>",
rshiftassign => ">>=",
'eq' => "==",
'ne' => "!=",
'lt' => "<",
'gt' => ">",
'le' => "<=",
'ge' => ">=",
land => "&&",
lor => "||",
compound => ",",
memref => "->*",
'ref' => "->",
subs => "[]",
postinc => "++",
postdec => "--",
call => "()",
assign => "="
);
my $cur = 0;
while(<>) {
if(/^\@(\d+)\s+(\w+)/gc) {
# @123 foo_decl
$cur = $1;
$tu[$cur] ||= { ident => $cur };
bless $tu[$cur], "GCC::$2";
warn "Read $cur\n" unless $cur % 1000;
}
while(1) {
if(/\G\s+(\S.{3}): \@(\d+)/gc) {
# fooz: @123
my $key = $1;
my $i = $2;
$key =~ s/\s+$//;
$tu[$i] ||= { ident => $i };
if($key eq 'base' && ref($tu[$cur]) ne 'GCC::binfo') { # baseclasses are odd
# unfortunately, base can have 'virtual' and 'protected'
# after it
my $super = { super => $tu[$i] };
while(/\G\s+(public|private|protected|virtual)\b|\G\s*$/gc) {
unless(defined $1) {
$_ = <>;
next;
}
if($1 eq 'virtual') {
$super->{virtual} = 1;
print "inheriting \@$super->{super}{ident} virtual\n" if $db;
} else {
$super->{access} = $1;
print "inheriting \@$super->{super}{ident} $1\n" if $db;
}
}
push @{$tu[$cur]{base}}, $super;
} else {
$tu[$cur]{$key} = $tu[$i];
print "tu[$cur]{$key} = tu[$i]\n" if $db;
}
} elsif(/\G\s+strg: (.+?)\s+(?=\S.{3}: )/gc ||
/\G\s+strg: (.+?)\s*$/gc) {
$tu[$cur]{strg} = $1;
print "tu[$cur]{strg} = q($1)\n" if $db;
} elsif(/\G\s+srcp: (.+?)(?=\s{2,})|\G\s+srcp: (.+?)\s*$/gc) {
$tu[$cur]{srcp} = $1;
print "tu[$cur]{srcp} = q($1)\n" if $db;
} elsif(/\G\s+(\S.{3}): (\S*)/gc) {
# Plain string, I hope
my $key = $1;
my $val = $2;
$key =~ s/\s*$//;
$tu[$cur]{$key} = $val;
print "tu[$cur]{$key} = $val\n" if $db;
} elsif(/\G\s+(\S+)/gc) {
# it's a flag
if($tu[$cur]{operator} && $ops{$1}) {
$tu[$cur]{operator} = $1;
print "operator $ops{$1}\n" if $db;
} else {
$tu[$cur]{$1} = 1;
print "tu[$cur]{$1} = TRUE\n" if $db;
}
} else {
last; # breaks inner loop
}
}
}
package GCC::integer_cst;
sub low { shift->{low} } # value, usually
sub high { shift->{high} }
sub type { shift->{type} }
package GCC::void_type;
sub name { shift->{name}->name }
sub type { shift->{name} }
sub typename { shift->name }
sub qualname { shift->typename }
package GCC::record_type;
sub typename {
return "class " . shift->name;
}
sub qualname {
my $self = shift;
return ($self->{unql} && !$self->{qual}) ? $self->{name}->qualname : \
$self->typename; }
sub name {
my $self = shift;
return $self->{name}->name unless $self->{unql};
my $ret = $self->{unql}->name;
if($self->{qual}) {
if($self->{qual} =~ /c/) {
$ret .= " const";
}
if($self->{qual} =~ /v/) {
$ret .= " volatile";
}
}
return $ret;
}
sub type { shift->{name} }
sub unql { shift->{unql} }
sub base { shift->{base} }
package GCC::union_type;
sub name { shift->{name}->name }
sub type { shift->{name} }
sub typename { return "union " . shift->name }
sub qualname { return shift->typename }
package GCC::enumeral_type;
sub typename {
return "enum " . shift->name;
}
sub qualname { shift->typename }
sub name {
my $self = shift;
my $name = $self->{name}->name;
$enums{$name} = $self;
return $name;
}
sub type { shift->{name} }
sub constants {
my $self = shift;
my $enum = $self->{csts};
my %enumeration;
while($enum) {
$enumeration{$enum->enum} = $enum->value;
$enum = $enum->chain;
}
return \%enumeration;
}
package GCC::boolean_type;
sub name { shift->{name}->name }
sub type { shift->{name} }
sub typename { shift->name }
sub qualname { shift->typename }
package GCC::real_type;
sub name { shift->{name}->name }
sub typename { shift->name }
sub qualname { shift->typename }
package GCC::integer_type;
sub qualname {
my $self = shift;
return ($self->{unql} && !$self->{qual}) ? $self->{name}->name : $self->typename;
}
sub name {
my $self = shift;
return $self->{name}->name unless $self->{unql};
my $ret = $self->{unql}->name;
if($self->{qual}) {
if($self->{qual} =~ /c/) {
$ret .= " const";
}
if($self->{qual} =~ /v/) {
$ret .= " volatile";
}
}
return $ret;
}
sub type { shift->{name} }
sub typename { shift->name }
package GCC::reference_type;
sub name { shift->{refd}->name . '&' }
sub typename { shift->{refd}->typename . '&' }
sub qualname { shift->{refd}->qualname . '&' }
package GCC::pointer_type;
sub qualname {
my $self = shift;
return ($self->{unql} && !$self->{qual}) ? $self->{ptd}->qualname . '*' : \
$self->typename; }
sub name {
my $self = shift;
return $self->{ptd}->name . "*" unless $self->{unql};
my $ret = $self->{unql}{ptd}->name . "*";
if($self->{qual}) {
if($self->{qual} =~ /c/) {
$ret .= " const";
}
if($self->{qual} =~ /v/) {
$ret .= " volatile";
}
}
return $ret;
}
sub typename {
my $self = shift;
return $self->{ptd}->typename . "*" unless $self->{unql};
my $ret = $self->{unql}{ptd}->typename . "*";
if($self->{qual}) {
if($self->{qual} =~ /c/) {
$ret .= " const";
}
if($self->{qual} =~ /v/) {
$ret .= " volatile";
}
}
return $ret;
}
package GCC::field_decl;
sub name { shift->{name}{strg} }
sub chain { shift->{chan} }
sub public { shift->{public} }
sub protected { shift->{protected} }
sub private { shift->{private} }
package GCC::const_decl;
sub name { shift->{name}{strg} }
sub chain { shift->{chan} }
package GCC::var_decl;
sub name { shift->{name}{strg} }
sub chain { shift->{chan} }
sub public { shift->{public} }
sub protected { shift->{protected} }
sub private { shift->{private} }
package GCC::type_decl;
sub chain { shift->{chan} }
sub scope { shift->{scpe} }
sub name {
my $self = shift;
my $ret = "";
if($self->scope and $self->scope->name) {
# enums within classes have scope, so we qualify the name
$ret .= $self->scope->name . "::";
}
$ret .= $self->{name}{strg};
return $ret;
}
sub qualname { shift->name }
package GCC::namespace_decl;
sub name { shift->{type}{strg} }
package GCC::parm_decl;
sub name { shift->{type}->name }
sub chain { shift->{chan} }
sub arg {
my $self = shift;
return $self->{name} ? $self->{name}{strg} : ""
}
package GCC::tree_list;
sub value { shift->{valu} }
sub default { shift->{purp} }
sub enum { shift->{purp}{strg} }
sub chain { shift->{chan} }
sub name { shift->{valu}->name }
sub c_name {
my $self = shift;
my $name = $self->value->name;
if($name =~ /[*&]$/) {
return "void*";
} elsif($name =~ /\b(int|float|double)\b/) {
return "$name";
} elsif($name =~ /\b(bool|char)\b/) { # Java don't like char, Perl don't like \
bool return "int";
} elsif(ref $self->value eq 'GCC::enumeral_type') {
return "long";
} elsif(ref $self->value eq 'GCC::record_type') {
return "void*";
} else {
return "WHATIS @{[ ref $self ]} @{[ ref $self->value ]} $name?";
}
}
sub c_cast {
my $self = shift;
my $name = $self->value->name;
if($name =~ s/[&]$// or ref $self->value eq 'GCC::record_type') {
return "*($name*)";
} else {
return "($name)";
}
}
package GCC::function_decl;
sub c_ret {
my $self = shift;
my $ret = $self->ret;
if($ret =~ /[*&]$/) {
return "void*";
} elsif($ret eq 'void' || $ret =~ /\b(int|float|double)\b/) {
return $ret;
} elsif($ret =~ /\b(bool|char)\b/) {
return "int";
} elsif(ref $self->{type}{retn} eq 'GCC::enumeral_type') {
return "long";
} elsif(ref $self->{type}{retn} eq 'GCC::record_type') {
return "void*";
} else {
return "WHATIS $ret?";
}
}
sub operator { shift->{operator} }
sub conversion { shift->{conversion} }
sub name {
my $self = shift;
if($self->operator) {
if($self->conversion) {
return "operator " . $self->ret;
} else {
return "operator $ops{$self->operator}";
}
}
return $self->{name}{strg};
}
sub chain { shift->{chan} }
sub ret { shift->{type}{retn}->typename }
sub static { shift->{static} }
sub virtual { shift->{virtual} }
sub public { shift->{public} }
sub protected { shift->{protected} }
sub constructor { shift->{constructor} }
sub destructor { shift->{destructor} }
sub private { shift->{private} }
sub parms { shift->{type}{prms} } # tree_list
sub args { shift->{args} }
sub arglist {
my $self = shift;
# okay, lets return some arguments
my $parm = $self->parms;
my $arg = $self->args;
my @args;
while($arg) {
# the parm list terminates with 'void'
# last if ref $arg->value eq 'GCC::void_type' and not $arg->chain;
$parm->{argname} = $arg->arg;
push @args, $parm;
$arg = $arg->chain;
$parm = $parm->chain;
}
return \@args; # unless $arg;
}
package TranslationUnitClass;
sub name { shift->{c} }
sub base { shift->{r}->base || [] }
sub new {
my($p, $tu, $class) = @_;
my $record;
for my $u (@$tu) {
if(ref $u eq 'GCC::record_type' && !$u->unql) { # class/struct/union
if($u->name eq $class) {
$record = $u;
last;
}
}
}
die "No such class `$class'" unless $record;
my $self = bless {
c => $class,
r => $record
}, $p;
}
sub methods {
my $self = shift;
my $func = $self->{r}{fncs};
my @methods;
while($func) {
if($func->name) {
push @methods, $func;
} else {
die "Unknown function: @{[ keys %$func ]}";
}
$func = $func->chain;
}
return \@methods;
}
sub fields {
my $self = shift;
my $field = $self->{r}{flds};
my @fields;
while($field) {
if($field->name) {
push @fields, $field;
} else {
die "Unknown field: @{[ keys %$field ]}";
}
$field = $field->chain;
}
return \@fields;
}
package main;
use XML::Simple;
my $c = TranslationUnitClass->new(\@tu, $output);
my %XMLCLASS;
$xml = {
name => 'Qt',
class => [ dumpxml($c) ] # err, $c->dumpxml?
};
print XMLout($xml, rootname => 'api');
sub baseclasses {
my $xml = shift;
my $list = shift || [];
# okay, start munging through baseclasses
for my $base (@{ $xml->{base} || [] }) {
push @$list, $XMLCLASS{$base->{name}};
baseclasses($XMLCLASS{$base->{name}}, $list);
}
return @$list;
}
sub dumpxml {
my $class = shift;
my %virtual;
my $xml = { name => $class->name, -virtual => \%virtual };
$XMLCLASS{$xml->{name}} = $xml;
my @xmlmethods;
my $methods = $class->methods;
for my $m (@$methods) {
next if $m->name =~ /^__/;
my $protection = $m->public ? "public" :
$m->protected ? "protected" :
$m->private ? "private" :
"UNKNOWN";
my %xmlmethod = (
name => $m->name,
access => $protection,
);
$xmlmethod{call} = 'virtual' if $m->virtual;
$xmlmethod{call} = 'static' if $m->static;
$xmlmethod{call} = 'static' if ref $m->{type} eq 'GCC::function_type';
$xmlmethod{call} = 'constructor' if $m->constructor;
$xmlmethod{call} = 'destructor' if $m->destructor;
$xmlmethod{call} = 'operator' if $xmlmethod{name} =~ s/^operator //;
if($m->ret ne 'void') {
$xmlmethod{type} = $m->ret;
my $typedef = $m->{type}{retn}->qualname;
$xmlmethod{typedef} = $typedef if $typedef ne $xmlmethod{type};
}
my @args;
my $arglist = $m->arglist;
my $this;
$this = shift @$arglist if !$xmlmethod{call} or $xmlmethod{call} !~ /^(?:static)$/;
if($this and $this->value->name =~ /\b(const|volatile)\*$/) {
$xmlmethod{this} = $1;
}
my $argX = 0;
for my $arg (@$arglist) {
if($arg->default) {
my $xmlmethod = { %xmlmethod };
$xmlmethod->{argument} = [ @args ] if @args;
push @xmlmethods, $xmlmethod;
}
$argX++;
my $xmlarg = {
name => $arg->{argname} || "arg$argX",
type => $arg->value->typename
};
my $typedef = $arg->value->qualname;
$xmlarg->{typedef} = $typedef if $typedef ne $xmlarg->{type};
push @args, $xmlarg;
}
my $xmlmethod = { %xmlmethod };
$xmlmethod->{argument} = [ @args ] if @args and not $m->destructor;
# handle virtual methods
local($") = ",";
my $call = $xmlmethod->{call} || "";
$call = "method" unless length $call;
my $sig = "$call $xmlmethod->{name}\(@{[ map { $_->{type} } @args ]})";
#$xmlmethod->{sig} = $sig;
$virtual{$sig} = $xmlmethod if $call eq 'virtual';
push @xmlmethods, $xmlmethod;
}
$xml->{method} = \@xmlmethods;
my @xmlbase;
for my $base (@{ $class->base }) {
my $xmlbase = {
name => $base->{super}->name,
access => $base->{access}
};
$xmlbase->{this} = 'virtual' if $base->{virtual};
push @xmlbase, $xmlbase;
unless(exists $XMLCLASS{$xmlbase->{name}}) {
# also dump out ALL superclasses!
my $bc = TranslationUnitClass->new(\@tu, $xmlbase->{name});
dumpxml($bc); # this gets virtual method info!
}
}
$xml->{base} = [ @xmlbase ] if @xmlbase;
my @xmlfield;
for my $field (@{ $class->fields }) {
my $ref = ref $field;
my $name = $field->name; # declare enum
next if $field->{artificial};
#next unless $field->can('public');
my $access;
$access = $field->public ? "public" :
$field->protected ? "protected" :
$field->private ? "private" : "UNKNOWN" if $field->can('public');
my $xmlfield = {
name => $name,
type => $field->{type}->typename,
access => $access,
};
my $typedef = $field->{type}->qualname;
$xmlfield->{typedef} = $typedef if $typedef ne $xmlfield->{type};
$xmlfield->{this} = "static" if $ref eq 'GCC::var_decl';
$xmlfield->{this} = "mutable" if $field->{mutable};
push @xmlfield, $xmlfield if $field->can('public') and $ref eq 'GCC::var_decl' or \
$ref eq 'GCC::field_decl'; }
$xml->{field} = [ @xmlfield ] if @xmlfield;
my @xmlenum;
for my $enum (sort keys %enums) {
my $e = $enums{$enum};
next unless $enum =~ s/^$xml->{name}\:://;
my @constants;
my $csts = $e->{csts};
my %enumeration;
while($csts) {
push @constants, {
name => $csts->enum,
value => $csts->value->low
};
$csts = $csts->chain;
}
push @xmlenum, { name => $enum, constant => [ @constants ] };
}
$xml->{enum} = \@xmlenum if @xmlenum;
my %vtbl;
for my $base (baseclasses($xml)) {
for my $v (keys %{ $base->{-virtual} }) {
unless(exists $virtual{$v} || exists $vtbl{$v}) {
$vtbl{$v} = { %{$base->{-virtual}{$v}}, origin => $base->{name} };
}
}
}
for my $v (keys %vtbl) {
if($vtbl{$v}{origin}) {
push @{ $xml->{method} }, $vtbl{$v};
}
}
return $xml;
}
exit;
_______________________________________________
Kde-bindings mailing list
Kde-bindings@mail.kde.org
http://mail.kde.org/mailman/listinfo/kde-bindings
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic