More improvements.
[sfrench/samba-autobuild/.git] / source4 / pidl / lib / Parse / Pidl / Samba4 / COM / Header.pm
1 # COM Header generation
2 # (C) 2005 Jelmer Vernooij <jelmer@samba.org>
3
4 package Parse::Pidl::Samba4::COM::Header;
5
6 use Parse::Pidl::Typelist qw(mapTypeName);
7 use Parse::Pidl::Util qw(has_property is_constant);
8
9 use vars qw($VERSION);
10 $VERSION = '0.01';
11
12 use strict;
13
14 sub GetArgumentProtoList($)
15 {
16         my $f = shift;
17         my $res = "";
18
19         foreach my $a (@{$f->{ELEMENTS}}) {
20
21                 $res .= ", " . mapTypeName($a->{TYPE}) . " ";
22
23                 my $l = $a->{POINTERS};
24                 $l-- if (Parse::Pidl::Typelist::scalar_is_reference($a->{TYPE}));
25                 foreach my $i (1..$l) {
26                         $res .= "*";
27                 }
28
29                 if (defined $a->{ARRAY_LEN}[0] && !is_constant($a->{ARRAY_LEN}[0]) &&
30                 !$a->{POINTERS}) {
31                         $res .= "*";
32                 }
33                 $res .= $a->{NAME};
34                 if (defined $a->{ARRAY_LEN}[0] && is_constant($a->{ARRAY_LEN}[0])) {
35                         $res .= "[$a->{ARRAY_LEN}[0]]";
36                 }
37         }
38
39         return $res;
40 }
41
42 sub GetArgumentList($)
43 {
44         my $f = shift;
45         my $res = "";
46
47         foreach (@{$f->{ELEMENTS}}) { $res .= ", $_->{NAME}"; }
48
49         return $res;
50 }
51
52 #####################################################################
53 # generate vtable structure for COM interface
54 sub HeaderVTable($)
55 {
56         my $interface = shift;
57         my $res;
58         $res .= "#define " . uc($interface->{NAME}) . "_METHODS \\\n";
59         if (defined($interface->{BASE})) {
60                 $res .= "\t" . uc($interface->{BASE} . "_METHODS") . "\\\n";
61         }
62
63         my $data = $interface->{DATA};
64         foreach my $d (@{$data}) {
65                 $res .= "\t" . mapTypeName($d->{RETURN_TYPE}) . " (*$d->{NAME}) (struct $interface->{NAME} *d, TALLOC_CTX *mem_ctx" . GetArgumentProtoList($d) . ");\\\n" if ($d->{TYPE} eq "FUNCTION");
66         }
67         $res .= "\n";
68         $res .= "struct $interface->{NAME}_vtable {\n";
69         $res .= "\tstruct GUID iid;\n";
70         $res .= "\t" . uc($interface->{NAME}) . "_METHODS\n";
71         $res .= "};\n\n";
72
73         return $res;
74 }
75
76 sub ParseInterface($)
77 {
78         my $if = shift;
79         my $res;
80
81         $res .= "\n#ifndef _$if->{NAME}_\n";
82         $res .= "#define _$if->{NAME}_\n";
83
84         $res .="\n\n/* $if->{NAME} */\n";
85
86         $res .="#define COM_" . uc($if->{NAME}) . "_UUID $if->{PROPERTIES}->{uuid}\n\n";
87
88         $res .="struct $if->{NAME}_vtable;\n\n";
89
90         $res .="struct $if->{NAME} {
91         struct com_context *ctx;
92         struct $if->{NAME}_vtable *vtable;
93         void *object_data;
94 };\n\n";
95
96         $res.=HeaderVTable($if);
97
98         foreach my $d (@{$if->{DATA}}) {
99                 next if ($d->{TYPE} ne "FUNCTION");
100
101                 $res .= "#define $if->{NAME}_$d->{NAME}(interface, mem_ctx" . GetArgumentList($d) . ") ";
102
103                 $res .= "((interface)->vtable->$d->{NAME}(interface, mem_ctx" . GetArgumentList($d) . "))";
104
105                 $res .="\n";
106         }
107
108         $res .= "#endif\n";
109
110         return $res;
111 }
112
113 sub ParseCoClass($)
114 {
115         my ($c) = @_;
116         my $res = "";
117         $res .= "#define CLSID_" . uc($c->{NAME}) . " $c->{PROPERTIES}->{uuid}\n";
118         if (has_property($c, "progid")) {
119                 $res .= "#define PROGID_" . uc($c->{NAME}) . " $c->{PROPERTIES}->{progid}\n";
120         }
121         $res .= "\n";
122         return $res;
123 }
124
125 sub Parse($$)
126 {
127         my ($idl,$ndr_header) = @_;
128         my $res = "";
129
130         $res .= "#include \"librpc/gen_ndr/orpc.h\"\n" . 
131                         "#include \"$ndr_header\"\n\n";
132
133         foreach (@{$idl})
134         {
135                 if ($_->{TYPE} eq "INTERFACE" && has_property($_, "object")) {
136                         $res .="struct $_->{NAME};\n";
137                 }
138         }
139
140         foreach (@{$idl})
141         {
142                 if ($_->{TYPE} eq "INTERFACE" && has_property($_, "object")) {
143                         $res.=ParseInterface($_);
144                 } 
145
146                 if ($_->{TYPE} eq "COCLASS") {
147                         $res.=ParseCoClass($_);
148                 }
149         }
150
151         return $res;
152 }
153
154 1;