Attached is the script to generate the ECMAScript source code in <http://lists.w3.org/Archives/Public/www-archive/2005Mar/0021.html>. The CORBA::IDL module is available from CPAN, in order to use it the IDL pre-processor and the IDL input document need to be configured. Originally http://lists.w3.org/Archives/Public/www-archive/2005Mar/0028.html

idl2attributes.pl

#!perl -w
#
# Generates ECMAScript code from an IDL interface description
# that annotates a DOM tree with information from objects im-
# plementing the defined interfaces. For example, in an SVG
# document { 'http://www.w3.org/2000/svg', 'text' } like
#
#   <text transform="translate(100,100)" font-size="20" id="x"/>
# 
# would have an object that implements the SVGTextElement in-
# terface which provides various attributes and methods that
# would be encoded like
#
#   <text
#     transform="translate(100,100)"
#     id="x"
#     font-size="20"
#     startOffset="0"
#     x:getBBox.x="1.6198731660842895"
#     x:getBBox.y="-14.319764137268066"
#     x:getBBox.width="99.91486358642578"
#     x:getBBox.height="14.539490699768066"
#     x:getCTM.a="1"
#     x:getCTM.d="1"
#     x:getCTM.e="100"
#     x:getCTM.f="100"
#     x:getScreenCTM.a="1"
#     x:getScreenCTM.d="1"
#     x:getScreenCTM.e="100"
#     x:getScreenCTM.f="100"
#     x:id="x"
#     x:getNumberOfChars="11"
#     x:getComputedTextLength="102.99805450439453"
#   ...
#

#
# Copyright (c) 2005 Bjoern Hoehrmann <[email protected]>.
# This script is licensed under the same terms as Perl itself.
#

use strict;
use warnings;
use CORBA::IDL::symbtab;
use CORBA::IDL::node;
use CORBA::IDL::parser30;

#
# resolve various types like ::svg::Element to ::dom::Element
# and IIRC ::dom::DOMTimeStamp to unsigned long long, etc.
#
sub resolve_type_decls
{
    my $data = shift;
    my $type = shift;
    
    while ($type =~ /::/)
    {
        # resolve indirectly defined type
        my $def = $data->Lookup($type);
        last unless UNIVERSAL::isa($def, 'TypeDeclarator');
        $type = $def->{type};
        
        # for IntegerType objects...
        $type = $type->{value} if ref $type;
    }
     
    return $type;
}

#
# class x ISA class y?
#
sub IsaClass
{
    my $data = shift;
    my $item = shift;
    my $clss = shift;
    
    return 1 if $item eq $clss;
    return 0 unless $item =~ /::/;

    $item = resolve_type_decls($data, $item);
    
    my $entr = $data->Lookup($item);
    
    do { return 1 if IsaClass($data, $_, $clss) }
      foreach @{$entr->{inheritance}{list_interface}};
    
    return $entr->{inheritance}{hash_interface}{$clss} ? 1 : 0;
}

#
# Helper function for more consistent output
#
sub ObjectToAttributes
{
    sprintf "ObjectToAttributes(%s %-50s %-50s %s);",
      shift() . ',', shift() . ',', shift() . ',', shift();
}

#
# MAIN ----------------------------------------------------------------
#

my $parser = new Parser;
$parser->YYData->{symbtab} = CORBA::IDL::Symbtab->new($parser);

# IDL pre-processor @@CHANGEME@@
$parser->YYData->{preprocessor} = 'vsvars32 > nul & CL /E /nologo';

# IDL to process
$parser->Run('w3cidl.idl');

#my $hash = retrieve "file";
#my $data = $hash->{symbtab};

my $data = $parser->YYData->{symbtab};

my $else = "";
my %types;

#
# print function header
#

print qq:
function ObjectToAttributes(node, type, obj, prefix)
{
  if (!node) return;
  if (!type) return;
  if (!obj)  return;
  
  // poor mans cycle detection ...
  if (prefix.split(/\\./).length > 10) return;
  
:;

# 
# print data
#
foreach (sort { $a cmp $b } keys %{$data->{scopes}})
{
    # not a interface
    next unless length;
    
    # lookup name
    my $this = $data->{scopes}->{$_};
    
    # skip everything but interfaces
    next unless $this->{class} eq "RegularInterface";
    
    # lookup interface
    my $iface = $data->Lookup($_);
    
    # ...
    printf "  %sif ('%s' == type)\n  {\n", $else, $iface->{full};
    $else = "else ";
    
    # mark this type as handled; this is needed in order to
    # output a list of unhandled types later in the process
    $types{$iface->{full}} = 0;
    
    #
    # Inherited interfaces
    #
    print "    // Inherited interfaces\n";
    foreach my $inherited (@{$iface->{inheritance}{list_interface}})
    {
        $inherited = resolve_type_decls($data, $inherited);

        print "    ";
        print ObjectToAttributes("node", "'$inherited'", "obj", "prefix"), "\n";
    }
    
    #
    # Attributes
    #
    print "\n    // Attributes\n";
    foreach my $attribute (@{$iface->{list_decl}})
    {
        next unless UNIVERSAL::isa($attribute, 'Attributes');
        $attribute = $attribute->{list_decl}->[0];
        
        # SVGColorProfileElement::_local trips up the IDL parser
        next unless defined $attribute;
        
        $attribute = $data->Lookup($attribute);

        # resolve type
        my $type = $attribute->{type};
        $type = $type->{value} if ref $type;
        $type = resolve_type_decls($data, $type);
        
        # remember this type for the unhandled type list
        $types{$type} = 1 unless defined $types{$type};

        # indentation
        print "    ";
        
        # comment out stuff that might yield in infinite loops
        # or really deep recursion; this is incomplete, but
        # catches most cases.
        print "// " if IsaClass($data, $type, $iface->{full});
        
        # ...
        print ObjectToAttributes("node", "'$type'", "obj.$attribute->{idf}", "prefix + '.' + '$attribute->{idf}'"), "\n";
    }
    
    #
    # Methods
    #
    print "\n    // Methods\n";
    my @methods;
    foreach my $operation (@{$iface->{list_decl}})
    {
        # skip unexpected stuff
        next if ref $operation;
        next unless defined $operation;
        
        # lookup method definition
        $operation = $data->Lookup($operation);
        
        # skip non-methods
        next unless UNIVERSAL::isa($operation, 'Operation');
        
        # resolve type
        my $type = $operation->{type};
        $type = $type->{value} if ref $type;
        $type = resolve_type_decls($data, $type);
        
        # remember type
        $types{$type} = 1 unless defined $types{$type};
        
        # count number of parameters
        my $num = scalar(@{$operation->{list_param}});
        
        # pseudo-parameter list, not really useful by
        # default as such methods get commented out
        my $params = join ", ", (('a'..'z')[0..$num-1]);
        
        # whether to include the method or comment it out
        my $include = 1;
        
        # skip stuff with parameters
        $include = 0 if $num;
        
        # void return type has typically side-effects or
        # does not really represent a useful value
        $include = 0 if $type eq "void";
        
        # setters tend to have side-effects
        $include = 0 if $operation->{idf} =~ /^set/;
        
        # no need to create anything
        $include = 0 if $operation->{idf} =~ /^create/;
        
        # avoid loops / deep recursion
        $include = 0 if IsaClass($data, $type, $iface->{full});
        
        # generate output. @@FIXME@@, looks horrible
        my $s = "";
        open F, '>', \$s;
        print F "    ";
        print F "// " if !$include;
        print F "try {      ";
        print F ObjectToAttributes("node", "'$type'", "obj.$operation->{idf}($params)", "prefix + '.' + '$operation->{idf}'");
        print F " }\n";
        print F "    ";
        print F "// " if !$include;
        print F "catch(e) { ";
        print F ObjectToAttributes("node", "'::dom::DOMString'", "'EXCEPTION'", "prefix + '.' + '$operation->{idf}'");
        print F " }";
        print F "\n";
        close F;
        
        # remember methods to group them
        push @methods, $s;
    }
    
    # print out uncommented methods
    print grep !m(//), @methods;
    
    # print out commented methods
    print grep m(//), @methods;
    
    # close me baby one more time...
    print "  }\n";
}

# handle unhandled types by assuming it's a native JS type...
printf qq<  else if (
    %s)
  {
    prefix = prefix.replace(/^\\./, "");
    node.setAttributeNS('example:', 'x:' + prefix, new String(obj));
  }
>,
  join " ||\n    ", map { sprintf "'%s' == type", $_ } grep { $types{$_} } keys %types;

print qq<
}
>;

#
# SVG Annotator -------------------------------------------------------
#

our @SVG_ELEMENTS =
qw/
  altGlyph altGlyphDef altGlyphItem animate animateColor animateMotion
  animateTransform circle clipPath color-profile cursor definition-src
  a defs desc ellipse feBlend feColorMatrix feComponentTransfer
  feComposite feConvolveMatrix feDiffuseLighting feDisplacementMap
  feDistantLight feFlood feFuncA feFuncB feFuncG feFuncR feGaussianBlur
  feImage feMerge feMergeNode feMorphology feOffset fePointLight
  feSpecularLighting feSpotLight feTile feTurbulence filter font
  font-face font-face-format font-face-name font-face-src font-face-uri
  foreignObject g glyph glyphRef hkern image line linearGradient marker
  mask metadata missing-glyph mpath path pattern polygon polyline
  radialGradient rect script set stop style svg switch symbol text
  textPath title tref tspan use view vkern
/;

#
# convert 'font-face-name' to '::svg::SVGFontFaceNameElement'
#
sub interface_from_element_name
{
    my $data = shift;
    local $_ = shift;

    s/svg/SVG/i;
    s/\s+//g;
    s/-(.)/\U$1/g;
    s/^(.)(.*)$/SVG\U$1\E$2Element/;
    
    $_ = "::svg::$_";
    
    # the above is insufficient for case changes, e.g.,
    # 'hkern' would be mapped to ::svg::SVGHkernElement
    # while it is to be mapped to ::svg::SVGHKernElement
    # CORBA::IDL does not seem to provide a good way to
    # do that, so we use a little workaround...
    
    my $capture = "";

    # save stdout
    open my $oldout, ">&STDOUT";

    # re-open stdout
    close STDOUT;

    # and re-direct to string
    open STDOUT, , ">", \$capture;

    # try probably wrong name
    $data->Lookup($_);

    # check error message for correct name
    $_ = "::svg::$1" if $capture =~ /collides with '(.+?)'/;

    # restore stdout
    open STDOUT, ">&", $oldout;
    
    return $_;
}

# generate { ns, local } => interface hash plus lookup function

print qq<
function AnnotateElement(node)
{
  if (!node)
    return;
    
  var itf = { 'http://www.w3.org/2000/svg' :
  {
>;

my $i = 0;

foreach my $element (sort { $a cmp $b } @SVG_ELEMENTS)
{
    my $iface = interface_from_element_name($data, $element);
    
    print ",\n" if $i++;
    printf "      %-30s : '%s'", "'$element'", $iface;
}

print qq<
  }}[node.namespaceURI][node.localName];

  if (!itf)
    return;
    
  ObjectToAttributes(node, itf, node, "");
}
>;