
package CORBA::XPIDL::HeaderVisitor;

use strict;
use warnings;

our $VERSION = '0.20';

use File::Basename;

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = {};
    bless $self, $class;
    my ($parser, $base_includes) = @_;
    $self->{srcname} = $parser->YYData->{srcname};
    $self->{symbtab} = $parser->YYData->{symbtab};
    $self->{base_includes} = $base_includes;
    my $filename;
    if ($parser->YYData->{opt_e}) {
        $filename = $parser->YYData->{opt_e};
    }
    else {
        if ($parser->YYData->{opt_o}) {
            $filename = $parser->YYData->{opt_o} . '.h';
        }
        else {
            $filename = basename($self->{srcname}, '.idl') . '.h';
        }
    }
    $self->open_stream($filename);
    $self->{num_key} = 'num_header_xp';
    return $self;
}

sub open_stream {
    my $self = shift;
    my ($filename) = @_;
    open $self->{out}, '>', $filename
            or die "can't open $filename ($!).\n";
    $self->{filename} = $filename;
}

sub _get_defn {
    my $self = shift;
    my ($defn) = @_;
    if (ref $defn) {
        return $defn;
    }
    else {
        return $self->{symbtab}->Lookup($defn);
    }
}

sub _is_dipper {
    my $self = shift;
    my ($node) = @_;    # type
    return     $node->hasProperty('domstring')
            || $node->hasProperty('utf8string')
            || $node->hasProperty('cstring')
            || $node->hasProperty('astring');
}

sub _classname_iid {
    my $self = shift;
    my ($node) = @_;
    my $idf = $node->{idf};
    $idf =~ s/^ns/NS_/;     # backcompat naming styles
    my $classname = uc $idf;
    $classname .= '_IID';
    return $classname;
}

sub _doc_comments {
    my $self = shift;
    my ($node) = @_;
    return q{} unless ($node->{doc});
    my $FH = $self->{out};
    my @doc = split /\n/, $node->{doc};
    shift @doc if ($doc[0] =~ /^\s*$/);
    pop @doc if ($doc[-1] =~ /^\s*$/);
    print $FH "/**\n";
    foreach (@doc) {
        print $FH " *",$_,"\n";
    }
    print $FH " */\n";
}

#
#   3.5     OMG IDL Specification
#

sub visitSpecification {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};

    my $basename = basename($self->{srcname}, '.idl');
    print $FH "/*\n";
    print $FH " * DO NOT EDIT.  THIS FILE IS GENERATED FROM ",$self->{srcname},"\n";
    print $FH " */\n";
    print $FH "\n";
    print $FH "#ifndef __gen_",$basename,"_h__\n";
    print $FH "#define __gen_",$basename,"_h__\n";

    if (scalar @{$self->{base_includes}}) {
        print $FH "\n";
        foreach (@{$self->{base_includes}}) {
            my $basename = basename($_, '.idl') ;
            print $FH "\n";
            print $FH "#ifndef __gen_",$basename,"_h__\n";
            print $FH "#include \"",$basename,".h\"\n";
            print $FH "#endif\n";
        }
        print $FH "\n";
    }
    if (exists $node->{list_import}) {
        print $FH "\n";
        foreach (@{$node->{list_import}}) {
            my $basename = $_->{value};
            $basename =~ s/^:://;
            $basename =~ s/::/_/g;
            print $FH "\n";
            print $FH "#ifndef __gen_",$basename,"_h__\n";
            print $FH "#include \"",$basename,".h\"\n";
            print $FH "#endif\n";
        }
        print $FH "\n";
    }
    # Support IDL files that don't include a root IDL file that defines
    # NS_NO_VTABLE.
    print $FH "/* For IDL files that don't want to include root IDL files. */\n";
    print $FH "#ifndef NS_NO_VTABLE\n";
    print $FH "#define NS_NO_VTABLE\n";
    print $FH "#endif\n";

    foreach (@{$node->{list_decl}}) {
        $self->_get_defn($_)->visit($self);
    }

    print $FH "\n";
    print $FH "#endif /* __gen_",$basename,"_h__ */\n";
    close $FH;
}

#
#   3.7     Module Declaration
#

sub visitModules {
    my $self = shift;
    my ($node) = @_;
    unless (exists $node->{$self->{num_key}}) {
        $node->{$self->{num_key}} = 0;
    }
    my $module = ${$node->{list_decl}}[$node->{$self->{num_key}}];
    $module->visit($self);
    $node->{$self->{num_key}} ++;
}

sub visitModule {
    my $self = shift;
    my ($node) = @_;
    if ($self->{srcname} eq $node->{filename}) {
        foreach (@{$node->{list_decl}}) {
            $self->_get_defn($_)->visit($self);
        }
    }
}

#
#   3.8     Interface Declaration
#

sub visitRegularInterface {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};
    if ($self->{srcname} eq $node->{filename}) {
        my $classname = $node->{idf};
        my $indent = q{ } x 2;
        print $FH "\n";
        print $FH "/* starting interface:    ",$classname," */\n";
        my $name_space = $node->getProperty('namespace');
        if (defined $name_space) {
            print $FH "/* namespace:             ",$name_space," */\n";
            print $FH "/* fully qualified name:  ",$name_space,".",$classname," */\n";
        }
        my $iid = lc $node->getProperty('uuid');
        my $classname_iid = $self->_classname_iid($node);
        print $FH "#define ",$classname_iid,"_STR \"",$iid,"\"\n";
        print $FH "\n";
        print $FH "#define ",$classname_iid," \\\n";
        print $FH "  {0x",substr($iid,0,8),", 0x",substr($iid,9,4),", ";
        print $FH "0x",substr($iid,14,4),", \\\n";
        print $FH "    { 0x",substr($iid,19,2),", 0x",substr($iid,21,2),", ";
        print $FH "0x",substr($iid,24,2),", 0x",substr($iid,26,2),", ";
        print $FH "0x",substr($iid,28,2),", 0x",substr($iid,30,2),", ";
        print $FH "0x",substr($iid,32,2),", 0x",substr($iid,34,2)," }}\n";
        print $FH "\n";

        $self->_doc_comments($node) if (exists $node->{doc});

        # NS_NO_VTABLE is defined in nsISupportsUtils.h, and defined on windows
        # to __declspec(novtable) on windows.  This optimization is safe
        # whenever the constructor calls no virtual methods.  Writing in IDL
        # almost guarantees this, except for the case when a %{C++ block occurs in
        # the interface.  We detect that case, and emit a macro call that disables
        # the optimization.
        my $keepvtable;
        foreach (@{$node->{list_decl}}) {
            my $defn = $self->_get_defn($_);
            $keepvtable = 1 if ($defn->isa('CodeFragment'));
        }

        # The interface declaration itself.
        print $FH "class ",($keepvtable ? q{} : "NS_NO_VTABLE "),$classname;
        if (exists $node->{inheritance}) {
            print $FH " : ";
            my $base = $self->_get_defn(${$node->{inheritance}->{list_interface}}[0]);
            print $FH "public ",$base->{idf};
        }
        print $FH " {\n";
        print $FH " public: \n";
        print $FH "\n";
        print $FH "  NS_DEFINE_STATIC_IID_ACCESSOR(",$classname_iid,")\n";
        print $FH "\n";
        foreach (@{$node->{list_decl}}) {
            $self->_get_defn($_)->visit($self);
        }
        print $FH "};\n";
        print $FH "\n";

        my @attribute_operation = ();
        foreach (@{$node->{list_decl}}) {
            my $defn = $self->_get_defn($_);
            if    ($defn->isa('Operation')) {
                push @attribute_operation, $defn;
            }
            elsif ($defn->isa('Attributes')) {
                foreach (@{$defn->{list_decl}}) {
                    my $defn = $self->_get_defn($_);
                    push @attribute_operation, $defn;
                }
            }
        }
        # #define NS_DECL_NSIFOO - create method prototypes that can be used in
        # class definitions that support this interface.
        #
        # Walk the tree explicitly to prototype a reworking of xpidl to get rid of
        # the callback mechanism.
        print $FH "/* Use this macro when declaring classes that implement this interface. */\n";
        print $FH "#define NS_DECL_",uc($classname)," \\\n";
        if (scalar @attribute_operation) {
            my $first = 1;
            foreach my $defn (@attribute_operation) {
                print $FH "; \\\n" unless ($first);
                if ($defn->isa('Operation')) {
                    print $FH $indent;
                    $self->_method($defn, 'AS_DECL', q{});
                }
                else {
                    print $FH $indent;
                    $self->_attr_getter($defn, 'AS_DECL', q{});
                    unless (exists $defn->{modifier}) { # readonly
                        print $FH "; \\\n";
                        print $FH $indent;
                        $self->_attr_setter($defn, 'AS_DECL', q{});
                    }
                }
                $first = 0;
            }
            print $FH ";\n";
        }
        else {
            print $FH "/* no methods! */\n";
        }
        print $FH "\n";

        # XXX abstract above and below into one function?
        #
        # #define NS_FORWARD_NSIFOO - create forwarding methods that can delegate
        # behavior from in implementation to another object.  As generated by
        # idlc.
        print $FH "/* Use this macro to declare functions that forward the behavior of this interface to another object. */\n";
        print $FH "#define NS_FORWARD_",uc($classname),"(_to) \\\n";
        if (scalar @attribute_operation) {
            my $first = 1;
            foreach my $defn (@attribute_operation) {
                print $FH "; } \\\n" unless ($first);
                if ($defn->isa('Operation')) {
                    print $FH $indent;
                    $self->_method($defn, 'AS_DECL', q{});
                    print $FH " { return _to ";
                    $self->_method($defn, 'AS_CALL', q{});
                }
                else {
                    print $FH $indent;
                    $self->_attr_getter($defn, 'AS_DECL', q{});
                    print $FH " { return _to ";
                    $self->_attr_getter($defn, 'AS_CALL', q{});
                    unless (exists $defn->{modifier}) { # readonly
                        print $FH "; } \\\n";
                        print $FH $indent;
                        $self->_attr_setter($defn, 'AS_DECL', q{});
                        print $FH " { return _to ";
                        $self->_attr_setter($defn, 'AS_CALL', q{});
                    }
                }
                $first = 0;
            }
            print $FH "; }\n";
        }
        else {
            print $FH "/* no methods! */\n";
        }
        print $FH "\n";

        # XXX abstract above and below into one function?
        #
        # #define NS_FORWARD_SAFE_NSIFOO - create forwarding methods that can delegate
        # behavior from in implementation to another object.  As generated by
        # idlc.
        print $FH "/* Use this macro to declare functions that forward the behavior of this interface to another object in a safe way. */\n";
        print $FH "#define NS_FORWARD_SAFE_",uc($classname),"(_to) \\\n";
        if (scalar @attribute_operation) {
            my $first = 1;
            foreach my $defn (@attribute_operation) {
                print $FH "; } \\\n" unless ($first);
                if ($defn->isa('Operation')) {
                    print $FH $indent;
                    $self->_method($defn, 'AS_DECL', q{});
                    print $FH " { return !_to ? NS_ERROR_NULL_POINTER : _to->";
                    $self->_method($defn, 'AS_CALL', q{});
                }
                else {
                    print $FH $indent;
                    $self->_attr_getter($defn, 'AS_DECL', q{});
                    print $FH " { return !_to ? NS_ERROR_NULL_POINTER : _to->";
                    $self->_attr_getter($defn, 'AS_CALL', q{});
                    unless (exists $defn->{modifier}) { # readonly
                        print $FH "; } \\\n";
                        print $FH $indent;
                        $self->_attr_setter($defn, 'AS_DECL', q{});
                        print $FH " { return !_to ? NS_ERROR_NULL_POINTER : _to->";
                        $self->_attr_setter($defn, 'AS_CALL', q{});
                    }
                }
                $first = 0;
            }
            print $FH "; }\n";
        }
        else {
            print $FH "/* no methods! */\n";
        }
        print $FH "\n";

        # Build a sample implementation template.
        my $classNameImpl;
        if ($classname =~ /^..I/) {
            $classNameImpl = substr($classname, 0, 2) . substr($classname, 3);
        }
        else {
            $classNameImpl = '_MYCLASS_';
        }
        print $FH "#if 0\n";
        print $FH "/* Use the code below as a template for the implementation class for this interface. */\n";
        print $FH "\n";
        print $FH "/* Header file */\n";
        print $FH "class ",$classNameImpl," : public ",$classname,"\n";
        print $FH "{\n";
        print $FH "public:\n";
        print $FH $indent,"NS_DECL_ISUPPORTS\n";
        print $FH $indent,"NS_DECL_",uc($classname),"\n";
        print $FH "\n";
        print $FH $indent,$classNameImpl,"();\n";
        print $FH $indent,"virtual ~",$classNameImpl,"();\n";
        print $FH $indent,"/* additional members */\n";
        print $FH "};\n";
        print $FH "\n";
        print $FH "/* Implementation file */\n";
        print $FH "NS_IMPL_ISUPPORTS1(",$classNameImpl,", ",$classname,")\n";
        print $FH "\n";
        print $FH $classNameImpl,"::",$classNameImpl,"()\n";
        print $FH "{\n";
        print $FH $indent,"/* member initializers and constructor code */\n";
        print $FH "}\n";
        print $FH "\n";
        print $FH $classNameImpl,"::~",$classNameImpl,"()\n";
        print $FH "{\n";
        print $FH $indent,"/* destructor code */\n";
        print $FH "}\n";
        print $FH "\n";
        foreach my $defn (@attribute_operation) {
            if ($defn->isa('Operation')) {
                $self->_doc_comments($defn);
                $self->_method($defn, 'AS_IMPL', $classNameImpl);
                print $FH "\n";
                print $FH "{\n";
                print $FH $indent,$indent,"return NS_ERROR_NOT_IMPLEMENTED;\n";
                print $FH "}\n";
                print $FH "\n";
            }
            else {
                $self->_doc_comments($defn);
                $self->_attr_getter($defn, 'AS_IMPL', $classNameImpl);
                print $FH "\n";
                print $FH "{\n";
                print $FH $indent,$indent,"return NS_ERROR_NOT_IMPLEMENTED;\n";
                print $FH "}\n";
                unless (exists $defn->{modifier}) { # readonly
                    $self->_attr_setter($defn, 'AS_IMPL', $classNameImpl);
                    print $FH "\n";
                    print $FH "{\n";
                    print $FH $indent,$indent,"return NS_ERROR_NOT_IMPLEMENTED;\n";
                    print $FH "}\n";
                }
                print $FH "\n";
            }
        }
        print $FH "/* End of implementation class template. */\n";
        print $FH "#endif\n";
        print $FH "\n";
    }
}

sub visitForwardRegularInterface {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};
    if ($self->{srcname} eq $node->{filename}) {
        $self->_doc_comments($node);
        print $FH "class ",$node->{idf},"; /* forward declaration */\n";
        print $FH "\n";
    }
}

sub visitBaseInterface {
    # empty
}

sub visitForwardBaseInterface {
    # empty
}

#
#   3.10    Constant Declaration
#

sub visitConstant {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};
    $self->_doc_comments($node);
    my $indent = q{ } x 2;
    my $value = $node->{value}->{value};
    my $type = $self->_get_defn($node->{type});
    while ($type->isa('TypeDeclarator')) {
        $type = $self->_get_defn($type->{type});
    }
    $value .= 'U' if (exists $type->{value} and $type->{value} =~ /^unsigned/);
    print $FH $indent,"enum { ",$node->{idf}," = ",$value," };\n";
    print $FH "\n";
}

#
#   3.11    Type Declaration
#

sub visitTypeDeclarators {
    my $self = shift;
    my ($node) = @_;
    my $type = $self->_get_defn($node->{type});
    return if ($type->isa('SequenceType'));

    my $FH = $self->{out};
    if ($self->{srcname} eq $node->{filename}) {
        $self->_doc_comments($node);
        foreach (@{$node->{list_decl}}) {
            $self->_get_defn($_)->visit($self);
        }
        print $FH "\n";
    }
}

sub visitTypeDeclarator {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};
    my $type = $self->_get_defn($node->{type});
    print $FH "typedef ",$type->{xp_name}," ",$node->{idf};
    if (exists $node->{array_size}) {   # usefull ?
        foreach (@{$node->{array_size}}) {
            print $FH "[",$_->{value},"]";
        }
    }
    print $FH ";\n";
}

sub visitNativeType {
    # empty
}

#
#   3.11.2  Constructed Types
#

sub visitStructType {
    # empty
}

sub visitUnionType {
    # empty
}

sub visitForwardStructType {
    # empty
}

sub visitForwardUnionType {
    # empty
}

sub visitEnumType {
    # empty
}

#
#   3.12    Exception Declaration
#

sub visitException {
    # empty
}

#
#   3.13    Operation Declaration
#

sub visitOperation {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};
    $self->_doc_comments($node);
    my $indent = q{ } x 2;
    print $FH $indent;
    $self->_method($node, 'AS_DECL', q{});
    print $FH " = 0;\n";
    print $FH "\n";
}

# Shared between the interface class declaration and the NS_DECL_IFOO macro
# provided to aid declaration of implementation classes.
# mode...
#  AS_DECL writes 'NS_IMETHOD foo(string bar, long sil)'
#  AS_IMPL writes 'NS_IMETHODIMP className::foo(string bar, long sil)'
#  AS_CALL writes 'foo(bar, sil)'
sub _method {
    my $self = shift;
    my ($node, $mode, $className) = @_;
    my $FH = $self->{out};
    my $type = $self->_get_defn($node->{type});
    my $op_notxpcom = $node->hasProperty('notxpcom');

    if     ($mode eq 'AS_DECL') {
        if ($op_notxpcom) {
            print $FH "NS_IMETHOD_(",$type->{xp_name},")";
        }
        else {
            print $FH 'NS_IMETHOD';
        }
        print $FH " ";
    }
    elsif ($mode eq 'AS_IMPL') {
        if ($op_notxpcom) {
            print $FH "NS_IMETHODIMP_(",$type->{xp_name},")";
        }
        else {
            print $FH "NS_IMETHODIMP";
        }
        print $FH " ";
    }

    if ($mode eq 'AS_IMPL') {
        print $FH $className,"::",ucfirst($node->{idf}),"(";
    }
    else {
        print $FH ucfirst($node->{idf}),"(";
    }

    my $first = 1;
    foreach (@{$node->{list_param}}) {
        next if ($_->isa('Ellipsis'));
        print $FH ", " unless ($first);
        if ($mode eq 'AS_DECL' or $mode eq 'AS_IMPL') {
            $self->_param($_);
        }
        else {
            print $FH $_->{idf};
        }
        $first = 0;
    }

    # make IDL return value into trailing out argument
    if ( !$type->isa('VoidType') and !$op_notxpcom ) {
        my $fake_param = _Build CORBA::IDL::Node (
                'attr'  => 'out',
                'type'  => $type,
                'idf'   => '_retval',
        );
        bless $fake_param, 'Parameter';
        print $FH ", " unless ($first);
        if ($mode eq 'AS_DECL' or $mode eq 'AS_IMPL') {
            $self->_param($fake_param);
        }
        else {
            print $FH "_retval";
        }
        $first = 0;
    }

    # varargs go last
    if (        scalar @{$node->{list_param}}
            and ${$node->{list_param}}[-1]->isa('Ellipsis') ) {
        print $FH ", " unless ($first);
        if ($mode eq 'AS_DECL' or $mode eq 'AS_IMPL') {
            print $FH "nsVarArgs *";
        }
        print $FH "_varargs";
        $first = 0;
    }

    # If generated method has no arguments, output 'void' to avoid C legacy
    # behavior of disabling type checking.
    if ($first and $mode eq 'AS_DECL') {
        print $FH "void";
    }

    print $FH ")";
}

# param generation:
# in string foo        -->     nsString *foo
# out string foo       -->     nsString **foo;
# inout string foo     -->     nsString **foo;
sub _param {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};
    my $type = $self->_get_defn($node->{type});

    # in string, wstring, nsid, domstring, utf8string, cstring and
    # astring any explicitly marked [const] are const
    if (        $node->{attr} eq 'in'
            and (  $type->isa('StringType')
                or $type->isa('WideStringType')
                or $node->hasProperty('const')
                or $type->hasProperty('nsid')
                or $type->hasProperty('domstring')
                or $type->hasProperty('utf8string')
                or $type->hasProperty('cstring')
                or $type->hasProperty('astring') ) ) {
        print $FH "const ";
    }
    elsif (   $node->{attr} eq 'out'
            and $node->hasProperty('shared') ) {
        print $FH "const ";
    }

    print $FH $type->{xp_name};

    # unless the type ended in a *, add a space
    unless (   $type->isa('StringType')
            or $type->isa('WideStringType')
            or $type->isa('Interface')
            or $type->isa('ForwardInterface') ) {
        print $FH " ";
    }

    # out and inout params get a bonus '*' (unless this is type that has a
    # 'dipper' class that is passed in to receive 'out' data)
    if (        $node->{attr} ne 'in'
            and !$self->_is_dipper($type) ) {
        print $FH "*";
    }

    # arrays get a bonus * too
    # XXX Should this be a leading '*' or a trailing "[]" ?
    if ($node->hasProperty('array')) {
        print $FH "*";
    }

    print $FH $node->{idf};
}

#
#   3.14    Attribute Declaration
#

sub visitAttributes {
    my $self = shift;
    my ($node) = @_;
    foreach (@{$node->{list_decl}}) {
        $self->_get_defn($_)->visit($self);
    }
}

sub visitAttribute {
    my $self = shift;
    my ($node) = @_;
    my $FH = $self->{out};
    $self->_doc_comments($node);
    my $indent = q{ } x 2;
    print $FH $indent;
    $self->_attr_getter($node, 'AS_DECL', q{});
    print $FH " = 0;\n";
    unless (exists $node->{modifier}) {     # readonly
        print $FH $indent;
        $self->_attr_setter($node, 'AS_DECL', q{});
        print $FH " = 0;\n";
    }
    print $FH "\n";
}

sub _attr_getter {
    my $self = shift;
    my ($node, $mode, $className) = @_;
    my $FH = $self->{out};
    if    ($mode eq 'AS_DECL') {
        print $FH "NS_IMETHOD ";
    }
    elsif ($mode eq 'AS_IMPL') {
        print $FH "NS_IMETHODIMP ",$className,"::";
    }
    print $FH "Get",ucfirst($node->{idf}),"(";
    if ($mode eq 'AS_DECL' or $mode eq 'AS_IMPL') {
        my $type = $self->_get_defn($node->{type});
        print $FH $type->{xp_name}," ";
        unless ($self->_is_dipper($type)) {
            print $FH "*";
        }
    }
    print $FH "a",ucfirst($node->{idf}),")";
}

sub _attr_setter {
    my $self = shift;
    my ($node, $mode, $className) = @_;
    my $FH = $self->{out};
    if    ($mode eq 'AS_DECL') {
        print $FH "NS_IMETHOD ";
    }
    elsif ($mode eq 'AS_IMPL') {
        print $FH "NS_IMETHODIMP ",$className,"::";
    }
    print $FH "Set",ucfirst($node->{idf}),"(";
    if ($mode eq 'AS_DECL' or $mode eq 'AS_IMPL') {
        my $type = $self->_get_defn($node->{type});
        # Setters for string, wstring, nsid, domstring, utf8string,
        # cstring and astring get const.
        if (       $type->isa('StringType')
                or $type->isa('WideStringType')
                or $type->hasProperty('nsid')
                or $type->hasProperty('domstring')
                or $type->hasProperty('utf8string')
                or $type->hasProperty('cstring')
                or $type->hasProperty('astring') ) {
            print $FH "const ";
        }
        print $FH $type->{xp_name}," ";
    }
    print $FH "a",ucfirst($node->{idf}),")";
}

#
#   3.15    Repository Identity Related Declarations
#

sub visitTypeId {
    # empty
}

sub visitTypePrefix {
    # empty
}

#
#   XPIDL
#

sub visitCodeFragment {
    my $self = shift;
    my ($node) = @_;
    if ($self->{srcname} eq $node->{filename}) {
        my @code = split /\n/, $node->{value};
        shift @code;
        my $FH = $self->{out};
        foreach (@code) {
            print $FH $_,"\n";
        }
    }
}

1;

