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