D/BUS IDL compiler ... #2 ...

Michael Meeks michael at ximian.com
Thu Mar 25 09:07:16 PST 2004


Hi there,

On Wed, 2004-03-10 at 09:20 -0500, Havoc Pennington wrote:
> Rather than IDL seems sensible for the _installed_ interface
> descriptions if any to be the Introspect() format, for reasons just
> discussed in my other mail. Installed descriptions should be used only
> at compile time though I think to generate headers; i.e. be considered
> part of the -devel package. At runtime it seems appropriate to me for a
> binding to call Introspect() instead.

	Right; well - since I loathe writing raw XML, and I don't believe life
is made altogether easier by the use of it. I hacked the IDL compiler
such that it now generates XML; since I think we all agree this is best.
Ultimately though the junk for parsing XML in (eg. perl, C, ...) throws
in a spanner of extra dependencies - so I'd still prefer to generate C
code bindings from the IDL directly[1]; leaving the XML as simply an
output medium [ perhaps some pre-defined strings to be compiled in to
make introspection faster ].

	Anyhow - after some poking, I discovered that the specification for
this XML format does not exist, nor is there anything at client or
server side really fully implementing it; which raises a number of
issues:

	From my IDL:

module org.freedesktop {
  interface TestSuite {
    oneway void Echo (string arg);
    oneway void EmitFoo ();

    attribute int32   Size;
    attribute string Name readonly;
    attribute string Comment writeonly;

    signal Foo(double length);
    signal SomethingChanged(string whatChanged, int32 size);
  };
};

	I generate some XML [1]:

<node>
        <interface name="org.freedesktop.TestSuite">
                <method name="Echo" oneway="true"/>
                        <arg name="arg" type="string"/>
                </method>
                <method name="EmitFoo" oneway="true"/>
                <signal name="Foo"/>
                        <arg name="length" type="double"/>
                </signal>
                <signal name="SomethingChanged"/>
                        <arg name="whatChanged" type="string"/>
                        <arg name="size" type="int32"/>
                </signal>
                <attribute name="Size" access="rw"/>
                <attribute name="Name" access="ro"/>
                <attribute name="Comment" access="wo"/>
        </interface>
</node>

	Now - there are a number of obvious problems / questions here ( code
attached incidentally ).

	* What should the 'name' of a return value be ? or nothing ?

	* Is 'oneway="true"' a sensible thing for oneways, and
	  is it acceptable to not emit oneway="false" ? - I never
	  much fancied XML attributes & booleans.

	* Is it an acceptable constraint to demand that any 'out'
	  values [ which currently I don't support ] be a
	  contiguous block of arguments at the end of a method call ?

	* For recursive / more powerful types [ ie. map(Foo, Baa) ] does
	  it seem  resonable to demand a preceeding 'typedef' and a
	  by-name reference ? then I guess we can add semantic richness,
	  and stronger typing to many backends:

		+ that would involve a type definition node perhaps:
	
	 <typedef name="org.openoffice.foobaa.NameAccount" type="map">
		<field type="string" name="Name"/>
		<field type="string" name="Account"/>
	 </typedef>

	  This of course allows a dynamic binding to instantiate that
	 type, and do foo->name = "jim", foo->account = "nn132", instead
	 of something more opaque. [ we do this for the CORBA binding
	 with some nice effect ].

	* attributes / properties

	    + I see the code in dbus-object.c(handle_introspect)
	    throws away the 'property' semantic; mapping it to
	    a 'get_' / 'set_', this is IMHO a mistake. Many languages
	    have a nice attribute mapping that would suck much more
	    to use methods everywhere
	
	    + a language binding for a no-attributes object system
	    can trivially convert to methods in the mapping.

	    + CORBA does something similar, but uses '_get' on the
	    wire - ie. a magic (not usable by other methods) '_'
	    prefix for this internal foo.

	* is 'access' a good name for the 'a11y' of the attribue ;-)
	  how about the suggested values - lots of different ways to
	  do that.


	I think that's about it really; If (at last) this is actually something
useful :-) I'm happy to commit to CVS, although still concerned by the
ongoing, and deepening license uncertainty.

	Thanks,

		Michael.

[1] - what programmer would prefer to read an interface contract as this
blob of XML (and this for a hyper-simple interface) than the IDL
fragment ?
-- 
 michael at ximian.com  <><, Pseudo Engineer, itinerant idiot
-------------- next part --------------
:
eval 'exec perl -w -S $0 ${1+"$@"}'
    if 0;

use strict;

#
# --- Globals
#
my @include_path = ( "." );

#
# ------------------- simple pre-processor -------------------
#


my $NameRegexp = '\w[\w\d]*';

# Some types:
#
# state:
#   int	                line
#   string              fname
#   hash<string,string> defines
#   list<boolean>       expr_stack
#
# stack:
#   list<state>		state
#   <file>              OutPipe

sub process_macro($$$)
{
    my $stack = shift;
    my $state = shift;
    my $macro = shift;
   

    chomp ($macro);

    if      ($macro =~ /^\#define\s+($NameRegexp)\s*(.*)$/) {
	$state->{'defines'}->{$1} = $2;

    } elsif ($macro =~ /^\#undef\s+($NameRegexp)/) {
	delete $state->{'defines'}->{$1};

    } elsif ($macro =~ /^\#ifdef\s+($NameRegexp)/) {
	unshift @{$state->{'expr_stack'}}, defined $state->{'defines'}->{$1};

    } elsif ($macro =~ /^\#else/) {
	my $invert = !(shift @{$state->{'expr_stack'}});
	unshift @{$state->{'expr_stack'}}, $invert;

    } elsif ($macro =~ /^\#endif/) {
	shift @{$state->{'expr_stack'}};

    } elsif ($macro =~ /^\#include\s+\<(.*)\>/) {
	pre_process ($stack, $1);

    } elsif ($macro =~ /^\# / || $macro eq '#') {
	# api doc comment.

    } else {
	print "Unknown macro '$macro'\n";
    }
}

sub pre_process($$)
{
    my $stack = shift;
    my $file = shift;
    my $InFile;
    my %state_hash;
    my $state = \%state_hash;
    my @expr_stack = (1);
    my %defines;
    my $line_out = 1;
    my $OutPipe = $stack->{'OutPipe'};

# FIXME: use include path
    open ($InFile, $file) || die "Failed to open $file: $!";

    push @{$stack->{'state'}}, $state;
    $state->{'line'} = 0;
    $state->{'fname'} = $file;
    $state->{'defines'} = \%defines;
    $state->{'expr_stack'} = \@expr_stack;

    while (<$InFile>) {
	$state->{'line'}++;

	s/\/\/.*//; # C++ style comments

	if (/^\s*\#(.*)/) { # '#'macro
	    my $macroline = "#$1";
	    my $macro = '';

	    while ($macroline =~ s/\\(\s*)$/$1/) { # continuation
		$macro .= $macroline;
		$macroline = <$InFile>;
		$state->{'line'}++;
	    }
	    $macro .= $macroline;
	    process_macro ($stack, $state, $macro);
	    $line_out = 1;

	} elsif ($state->{expr_stack}[0]) { # normal line

	    if ($line_out) { # easily parsed line no. data
		print $OutPipe "#" . $state->{'fname'} . ":" . $state->{'line'} . "\n";
		$line_out = 0;
	    }
	    print $OutPipe " $_";

	} else { # conditional non-outpu
	    $line_out = 1;
#	    chomp ($_);
#	    print "!: '$_'\n";
	}
    }
    print $OutPipe "\n"; # help the parser

    close ($InFile);
}

#
# ------------------- IDL compiler -------------------
#

sub output($$)
{
    my ($state, $string) = @_;
    my $OutFile = $state->{'output'};

    print $OutFile $string;
}

# state:
#   <file>		file
#   string		line		- incoming string of tokens
#   string		location	- for error messages
#   bool		done		- tokens all gone
#   hash<string,string> types		- type names

# returns 0 on error, 1 on success
sub read_tok($$)
{
    my $state = shift;
    my $retval = shift;
    my $InFile = $state->{'file'};
    my $line;

    $state->{'done'} && return 0;

    $line = $state->{'line'};
    while (1) {

	# read next line of text
	if ($line eq '') {
	    if ($line = <$InFile>) {
		$state->{'lineno'}++;
		chomp $line;
	    } else {
		$state->{'done'} = 1;
		return 0;
	    }
	}
	
	if ($line =~ s/^\#(.*):(\d+)//) {
	    $state->{'location'} = $1;
	    $state->{'lineno'} = $2;
	    next;
	}

	$line =~s/^\s+//;
	$line eq '' && next;
	
	if ($line =~ s/^($NameRegexp)//) {		# name / type
	    $$retval = $1;

	} elsif ($line =~ s/^([\(\)\{\}\,\;\.])//) {	# brace / comma
	    $$retval = $1;

	} else {
	    print "Unknown token '$line' at " .
		$state->{'location'} . ':' . $state->{'lineno'} . "\n";
	    $$retval = '';
	    $line = '';
	}
	$state->{'line'} = $line;

#	print "Tok '$$retval' [ '$line' ]\n";

	return 1;
    }
}

sub parse_error(@)
{
    my $state = shift;
    my $err;
    $err = "Parse error" if (!($err = shift));
    die "$err at " . $state->{'location'} . ':' . $state->{'lineno'} . "\n";

    return 0;
}

sub push_tok($$)
{
    my $state = shift;
    my $tok = shift;

    $state->{'line'} = $tok . " " . $state->{'line'};
}

sub next_tok_is($$)
{
    my $state = shift;
    my $query = shift;
    my $tok;
    
    read_tok ($state, \$tok) || return 1;
    if ($tok eq $query) {
	return 1;
    } else {
	push_tok ($state, $tok);
	return 0;
    }
}

sub last_tok($)
{
    my $state = shift;
    my $tok;
    if (!read_tok ($state, \$tok)) {
	return 1;
    } else {
	push_tok ($state, $tok);
	return 0;
    }
}

sub read_this_tok($$)
{
    my $state = shift;
    my $result = shift;
    my $tok;

    read_tok ($state, \$tok) || return parse_error ($state, "reading $tok");

    $tok eq $result || return parse_error ($state, "Expecting '$result' but found '$tok'");

    return 1;
}

#
# Type:
#   'name' - the name
#   'type' - immediate type name
#     'subtype' - sub / value type
#     'keytype' - key type if available
#
my %basic_types = ( 'void'    => 'v',
		    'byte'    => 'y',
		    'bool'    => 'b',
		    'int32'   => 'i',
		    'uint32'  => 'u',
		    'int64'   => 'x',
		    'uint64'  => 't',
		    'double'  => 'd',
		    'string'  => 's',
		    'custom'  => 'c',
		    'array'   => 'a',
		    'map'     => 'm', # dict
		    'object'  => 'o',
		    # extended types
		    'any'     => 'A',
		    'struct'  => 'S',
		    'alias'   => 'L',
		    'method'  => 'M',
		    'signal'  => 'I',
		    'attribute' => 'T'
		    );

sub create_basic_type($$)
{
    my $type_name = shift;
    my %type;
    
    $type{'name'} = shift;
    $type{'type'} = $basic_types{$type_name};

    return \%{%type};
}

sub read_type ($$);
sub read_type ($$)
{
    my ($state, $type) = @_;
    my $tok;

    $type->{'name'} = '';
    delete $type->{'subtype'};
    delete $type->{'subtypes'};
    delete $type->{'keytype'};

    read_tok ($state, \$tok) || return parse_error ($state);

    if (defined $basic_types{$tok}) {
	$type->{'type'} = $basic_types{$tok};

    } elsif (defined $state->{'types'}->{$tok}) {
	$type = $state->{'types'}->{$tok};

    } else {
	return parse_error ($state, "unknown type $tok");
    }

    if ($tok eq 'array') {
	read_this_tok ($state, '{') || return 0;
	read_type ($state, \%{$state->{'subtype'}}) || return parse_error ($state, "Error on type");
	read_this_tok ($state, '}') || return 0;

    } elsif ($tok eq 'map') {
	read_this_tok ($state, '{') || return 0;
	read_type ($state, \%{$state->{'keytype'}}) || return parse_error ($state, "Error with map key type");
	read_this_tok ($state, ',') || return 0;
	read_type ($state, \%{$state->{'subtype'}}) || return parse_error ($state, "Error with map value type");
	read_this_tok ($state, '}') || return 0;
    }

    return 1;
}

sub read_name ($$)
{
    my ($state, $tok) = @_;

    read_tok ($state, $tok);
    
    $$tok =~ /^$NameRegexp$/ && return 1;

    return parse_error ($state, "Invalid name '$$tok'");
}

sub read_method_decl($$)
{
    my ($state, $interface) = @_;
    my $type;
    my %ret_type;
    my $arg = 0;

    $type = create_basic_type ('', '');
    $type->{'oneway'} = next_tok_is ($state, 'oneway');
    if (next_tok_is ($state, 'signal')) {
	$type->{'type'} = $basic_types{'signal'};
	$type->{'retval'} = create_basic_type ('void', '');
    } else {
	$type->{'type'} = $basic_types{'method'};
	read_type ($state, \%{$type->{'retval'}}) || return 0;
    }
    read_name ($state, \$type->{'name'}) || return 0;
    read_this_tok ($state, '(') || return 0;

#    print "Method '". $type->{'name'} . "'\n";
    while (!next_tok_is ($state, ')')) {
	my %arg_type;

	if ($arg++) {
	    read_this_tok ($state, ',') || return parse_error ("expecting comma");
	}
	read_type ($state, \%arg_type) || return 0;
	read_name ($state, \$arg_type{'name'}) || return 0;
	push @{$type->{'subtypes'}}, \%arg_type;
    }

    read_this_tok ($state, ';') ||
	return parse_error( $state, "expect ';' after method");

    push @{$interface->{'methods'}}, $type;

    return 1;
}

sub read_attribute_decl($$)
{
    my ($state, $interface) = @_;
    my (%type, $name);

    read_type ($state, \%type) || return 0;
    read_name ($state, \$type{'name'}) || return 0;
    $type{'access'} = 'rw';
    if (next_tok_is ($state, 'readonly')) {
	$type{'access'} = 'ro';
    } elsif (next_tok_is ($state, 'writeonly')) {
	$type{'access'} = 'wo';
    }
    next_tok_is ($state, ';') ||
	return parse_error ($state, "Expect ';' after attribute");

    push @{$interface->{'attributes'}}, \%type;
    
    return 1;
}

sub add_type($$)
{
    my ($state, $type) = @_;
    my $name = $type->{'name'};

#    print "Type '$name'\n";
    
    if (defined $state->{'types'}->{$name}) {
	parse_error ($state, "$name already defined");
    }
    
    $state->{'types'}->{$name} = $type;
}

sub read_interface($)
{
    my $state = shift;
    my ($tok, $name, $interface);

    read_name ($state, \$name) || return 0;
    $interface = create_basic_type ('object', $name);
    add_type ($state, $interface);

    push @{$state->{'namespace'}}, $name;

    @{$interface->{'namespace'}} = @{$state->{'namespace'}};

    if (next_tok_is ($state, '{')) {
	while (!next_tok_is ($state, '}')) {
	    if (next_tok_is ($state, 'attribute')) {
		read_attribute_decl ($state, $interface);
	    } else {
		read_method_decl ($state, $interface);
	    }
	};
    }
    next_tok_is ($state, ';');

    pop @{$state->{'namespace'}};

    return 1;
}

sub read_namespace($)
{
    my $state = shift;
    my ($tok, $name);
    my @spaces;

    do {
	read_tok ($state, \$tok) || return parse_error ($state, "expecting namespace");
	push @spaces, $tok;
    } until (!next_tok_is ($state, '.'));

    push @{$state->{'namespace'}}, @spaces;

    if (next_tok_is ($state, '{')) {
	while (!next_tok_is ($state, '}')) {
	    read_statement ($state);
	};
    }
    next_tok_is ($state, ';');

    for $tok (@spaces) {
	pop @{$state->{'namespace'}};
    }

    return 1;
}

sub read_statement($)
{
    my $state = shift;
    my $tok;

    read_tok ($state, \$tok) || return 0;

    if ($tok eq 'typedef') {
	my $name;
	my %new_type;

	read_type ($state, \%new_type) || return 0;
	read_name ($state, \$name) || return 0;
	$new_type{'name'} = $name;
	add_type ($state, \%new_type);
	read_this_tok ($state, ';') || return 0;

    } elsif ($tok eq 'interface') {
	read_interface ($state) || return 0;

    } elsif ($tok eq 'module' ||
	     $tok eq 'namespace') {
	read_namespace ($state) || return 0;

    } elsif ($tok eq 'struct') {
	
    } elsif ($tok eq 'using') {
	die "Really need namespacing";

    } else {
	parse_error ($state, "Unexpected token '$tok'");
    }
}

sub idl_compile($)
{
    my $state = shift;

    while (!last_tok ($state)) {
	read_statement ($state) || die "Error parsing at " . $state->{'location'} . "\n";
    }
}

#
# ------------------- GObject bindings output -------------------
#

sub output_name($$@)
{
    my $name = shift;
    my $separator = shift;
    my $namesp = join $separator, @_;
    
    if ($name ne '') {
	$namesp .= $separator . $name;
    }

    return $namesp;
}

sub output_type ($$)
{
    my ($state, $arg) = @_;

    output ($state, $arg->{'type'});
}

sub make_type_descr($)
{
    my $method = shift;
    my ($arg, $descr);

    $descr = '';
    for $arg (@{$method->{'subtypes'}}) {
	$descr .= $arg->{'type'};
    }
    $descr .= '_';
    if ($method->{'oneway'}) {
	$descr .= 'o';
    }
    $descr .= '_';
    $descr .= $method->{'retval'}->{'type'};

    return $descr;
}

my %basic_type_to_ctype = (
			   'v' => 'void',
			   'y' => 'dbus_bool_t',
			   'b' => 'unsigned char',
			   'i' => 'dbus_int32_t',
			   'u' => 'dbus_uint32_t',
			   'x' => 'dbus_int64_t',
			   't' => 'dbus_uint64_t',
			   'd' => 'double',
			   );
			    
sub get_ctype($$)
{
    my ($state, $type) = @_;
    my $ctype;
    
    $ctype = $basic_type_to_ctype{$type->{'type'}};
    if (!defined $ctype) {
# We can pass all these as pointers anyway:
#	'string', 'custom', 'array', 'map', 'object',
#	'any', 'struct', 'alias', 'method'
	$ctype = "void *";
    }
    return $ctype;
}

# there must be a good way to do this
sub pad_spaces($)
{
    my $space = '    ';
    my $count = 60 - length shift;
    for (; $count > 0; $count--) {
	$space .= ' ';
    }
    return $space; 
}

sub output_gobject_interface($$)
{
    my ($state, $type) = @_;
    my $method;

    if (!defined $type->{'methods'}) { # empty interface
	return;
    }

    my $iface_name = output_name ('', '.', @{$type->{'namespace'}});
    my $guard_name = uc (output_name ('', '_', @{$type->{'namespace'}}) . "_0_defined");
    
    output ($state, "#ifndef $guard_name\n");
    output ($state, "#define $guard_name\n");

    for $method (@{$type->{'methods'}}) {
	my $mname = output_name ($method->{'name'}, '_', @{$type->{'namespace'}});

# to please Owen - uncomment the lc line
# [ cf. existing HAL VB naming convention ]
#    $mname = lc ($mname);

#	print "Method: " . $method->{'name'} . "\n";
	output ($state, "#  define " . $mname . "_0_type" . pad_spaces ($mname) . '"');
	output ($state, make_type_descr ($method));
	output ($state, "_");
	output ($state, $method->{'name'});
	output ($state, "\"\n");
    }

  if (0) {
    for $method (@{$type->{'methods'}}) {
	my $mname = output_name ($method->{'name'}, '_', @{$type->{'namespace'}});

	output ($state, "#define " . $mname . "_0_skel \\\n");

	output ($state, "\tstatic void dbus_skel_" . make_type_descr ($method));
	output ($state, "(void *fn, void **args, void *retval)\\\n");
	output ($state, "\t\t{ ");
	{ # Output signal definitions ?
	    my $ret_type = get_ctype ($state, $method->{'retval'});
	    if ($ret_type ne 'void') {
		output ($state, " *(" . $ret_type . " *)retval = ");
	    }
	    output ($state, "(($ret_type(*)(");
	    my $arg;
	    my $i = 0;
	    my $arg_casts = '';
	    for $arg (@{$method->{'subtypes'}}) {
		my $ctype = get_ctype ($state, $arg);

		output ($state, ",") if $i;
		output ($state, $ctype);
		$arg_casts .= "," if $i;
		$arg_casts .= "*($ctype *)args[$i]",
		$i++;
	    }
	    output ($state, "))fn) ($arg_casts);");
	}
	output ($state, " }\n");
    }

    for $method (@{$type->{'methods'}}) {
	my $mname = output_name ($method->{'name'}, '_', @{$type->{'namespace'}});

	output ($state, "#define " . $mname . "_0_define(fn) \\\n");
	output ($state, "\t" . $mname . "_0_type, " . $mname . "_0_skel, (fn)\n");
    }
  }

    for $method (@{$type->{'methods'}}) {
	my $mname = output_name ($method->{'name'}, '_', @{$type->{'namespace'}});
	my $arg_string = '';

	for my $arg (@{$method->{'subtypes'}}) {
	    $arg_string .= ", _" . $arg->{'name'};
	}
	if ($method->{'retval'}->{'type'} ne 'v') {
	    $arg_string .= ", _retval";
	}

	output ($state, "#define $mname(_cnx, _service, _path " . $arg_string . ", _ev) \\\n");
	output ($state, "\t" . 'tbus_invoke (_cnx, _service, _path, "' . $iface_name . '", _ev, ' . "\\\n" .
		"\t             $mname". "_0_type $arg_string)\n");
    }

    output ($state, "#endif /* $guard_name */\n\n");
}

sub output_gobject($)
{
    my $state = shift;
    my $name;

    output ($state, "/* Auto-generated file */\n");
    output ($state, "#include <tbus.h>\n\n");
    for $name (sort keys %{$state->{'types'}}) {
	my $type = $state->{'types'}->{$name};
	
#	print "Type: '" . $type->{'name'} . " : " . $type->{'type'} . "\n";
	if ($type->{'type'} eq 'o') {
	    output_gobject_interface ($state, $type);
	}
    }
}

#
# ------------------- XML output -------------------
#

my %xml_typenames = ( 'v' => 'void',
		      'y' => 'byte',
		      'b' => 'bool',
		      'i' => 'int32',
		      'u' => 'uint32',
		      'x' => 'int64',
		      't' => 'uint64',
		      'd' => 'double',
		      's' => 'string',
		      'c' => 'custom',
		      'o' => 'object',
		      'A' => 'any'
		      );

sub output_xml_type_name($)
{
    my $type = shift;
    if( defined $xml_typenames{$type->{'type'}} ) {
	return $xml_typenames{$type->{'type'}};
    }
    print "Complex type\n";
    return $type->{'name'};
}

sub output_xml_arg($$$$)
{
    my ($state, $name, $arg, $direction) = @_;
    
    output ($state, "\t\t\t<arg name=\"$name\" ");
    output ($state, "type=\"" . output_xml_type_name ($arg) . "\"/>\n");
}

sub output_xml_interface($$)
{
    my ($state, $type) = @_;

    if (!defined $type->{'methods'}) { # empty interface
	return;
    }

    my $iface_name = output_name ('', '.', @{$type->{'namespace'}});

    output ($state, "\t<interface name=\"$iface_name\">\n");

    for my $method (@{$type->{'methods'}}) {
	my $type_name = "method";
	my $returns_void = ($method->{'retval'}->{'type'} eq 'v');
	if ($method->{'type'} eq $basic_types{'signal'}) {
	    $type_name = 'signal';
	}

	my $decl = "\t\t<$type_name name=\"" . $method->{'name'} . '"';

	if ($method->{'oneway'}) {
	    $decl .= ' oneway="true"';
	}
	
	if (!defined $method->{'subtypes'} && $returns_void) {
	    $decl .= "/>\n";
	    output ($state, $decl);

	} else {
	    $decl .= "/>\n";
	    output ($state, $decl);

	    for my $arg (@{$method->{'subtypes'}}) {
		output_xml_arg ($state, $arg->{'name'}, $arg, 0);
	    }

	    if (!$returns_void) {
		output_xml_arg ($state, "retval", $method->{'retval'}, 1);
	    }

	    output ($state, "\t\t</$type_name>\n");
	}
    }

    for my $attribute (@{$type->{'attributes'}}) {
	output ($state, "\t\t<attribute name=\"" . $attribute->{'name'} . "\" ");
	output ($state, "access=\"" . $attribute->{'access'} . "\"/>\n");
    }

    output ($state, "\t</interface>\n");
}

sub output_xml($)
{
    my $state = shift;
    my $name;

# FIXME: what about recursive type definitions !?

    output ($state, "<node>\n");

    for $name (sort keys %{$state->{'types'}}) {
	my $type = $state->{'types'}->{$name};
	
#	print "Type: '" . $type->{'name'} . " : " . $type->{'type'} . "\n";
	if ($type->{'type'} eq 'o') {
	    output_xml_interface ($state, $type);
	}
    }

    output ($state, "</node>\n");
}

sub main()
{
    my $arg;
    my $file;
    my $output_xml = 1;
    my $out_fname = ">-";

    for $arg (@ARGV) {
	if ($arg =~ /^-I(.*)/) {
	    push @include_path, $1;

	} elsif ($arg =~ /^-o(.*)/) {
	    $out_fname = ">$1";
	} elsif ($arg =~ /^--gobject/i) {
	    $output_xml = 0;
	} else {
	    $file = $arg;
	}
    }

    if( !defined $file ) {
	die "Syntax error: diddle <idl filename>\n";
    }
    
    my ($PreProcRead, $PreProcWrite);
    pipe ($PreProcRead, $PreProcWrite);
    
    defined (my $pid = fork ()) || die "Failed to fork: $!";
    
    if ($pid == 0) { # child
	close $PreProcRead;

	my @evaluate = ();
	my %stack = ( 'OutPipe' => $PreProcWrite,
		      'state'   => \@evaluate );
	pre_process (\%stack, $file);
	
	close $PreProcWrite;
	exit 0;
	
    } else { # parent
	my $OutFile;

	close $PreProcWrite;

#	pre-processor debug
#	while (<$PreProcRead>) { print $_; }

	open ($OutFile, $out_fname) || die "Can't open $out_fname: $!";

	my %types;
	my @namespace;
	my %state = ( 'file'      => $PreProcRead,
		      'output'    => $OutFile,
		      'line'      => '',
		      'location'  => '',
		      'lineno'    => '0',
		      'done'      => '0',
		      'namespace' => \@namespace,
		      'types'     => \%types );

	idl_compile (\%state);

	if (!$output_xml) {
	    output_gobject (\%state);
	} else {
	    output_xml (\%state);
	}
	
	close $PreProcRead;
	close $OutFile;
    }
}

main();
-------------- next part --------------
A non-text attachment was scrubbed...
Name: test.idl
Type: text/x-idl
Size: 340 bytes
Desc: not available
Url : http://freedesktop.org/pipermail/dbus/attachments/20040325/d212d6f2/test-0001.bin


More information about the dbus mailing list