r5674: - Re-enable DCOM support.
[samba.git] / source4 / build / pidl / dcom_proxy.pm
1 ###################################################
2 # DCOM parser for Samba
3 # Basically the glue between COM and DCE/RPC with NDR
4 # Copyright jelmer@samba.org 2003-2005
5 # released under the GNU GPL
6
7 package DCOMProxy;
8
9 use com_header;
10
11 use strict;
12
13 my($res);
14
15 sub ParseVTable($$)
16 {
17         my $interface = shift;
18         my $name = shift;
19
20         # Generate the vtable
21         $res .="\tstruct $interface->{NAME}_vtable $name = {";
22
23         if (defined($interface->{BASE})) {
24                 $res .= "\n\t\t{},";
25         }
26
27         my $data = $interface->{DATA};
28
29         foreach my $d (@{$data}) {
30                 if ($d->{TYPE} eq "FUNCTION") {
31                     $res .= "\n\t\tdcom_proxy_$interface->{NAME}_$d->{NAME}";
32                         $res .= ",";
33                 }
34         }
35
36         $res .= "\n\t};\n\n";
37 }
38
39 sub ParseRegFunc($)
40 {
41         my $interface = shift;
42
43         $res .= "static NTSTATUS dcom_proxy_$interface->{NAME}_init(void)
44 {
45         struct GUID base_iid;
46         struct $interface->{NAME}_vtable *proxy_vtable = talloc(talloc_autofree_context(), struct $interface->{NAME}_vtable);
47 ";
48
49         if (defined($interface->{BASE})) {
50                 $res.= "
51         const void *base_vtable;
52
53         GUID_from_string(DCERPC_" . (uc $interface->{BASE}) . "_UUID, &base_iid);
54
55         base_vtable = dcom_proxy_vtable_by_iid(&base_iid);
56         if (base_vtable == NULL) {
57                 DEBUG(0, (\"No proxy registered for base interface '$interface->{BASE}'\\n\"));
58                 return NT_STATUS_FOOBAR;
59         }
60         
61         memcpy(&proxy_vtable, base_vtable, sizeof(struct $interface->{BASE}_vtable));
62
63 ";
64         }
65         foreach my $x (@{$interface->{DATA}}) {
66                 next unless ($x->{TYPE} eq "FUNCTION");
67
68                 $res .= "\tproxy_vtable.$x->{NAME} = dcom_proxy_$interface->{NAME}_$x->{NAME};\n";
69         }
70
71         $res.= "
72         GUID_from_string(DCERPC_" . (uc $interface->{NAME}) . "_UUID, &proxy_vtable.iid);
73
74         return dcom_register_proxy(&proxy_vtable);
75 }\n\n";
76 }
77
78 #####################################################################
79 # parse a function
80 sub ParseFunction($$)
81 {
82         my $interface = shift;
83         my $fn = shift;
84         my $name = $fn->{NAME};
85         my $uname = uc $name;
86
87         $res.="
88 static $fn->{RETURN_TYPE} dcom_proxy_$interface->{NAME}_$name(struct $interface->{NAME} *d, TALLOC_CTX *mem_ctx" . COMHeader::GetArgumentProtoList($fn) . ")
89 {
90         struct dcerpc_pipe *p;
91         NTSTATUS status = dcom_get_pipe(d, &p);
92         struct $name r;
93         struct rpc_request *req;
94
95         if (NT_STATUS_IS_ERR(status)) {
96                 return status;
97         }
98
99         ZERO_STRUCT(r.in.ORPCthis);
100         r.in.ORPCthis.version.MajorVersion = COM_MAJOR_VERSION;
101         r.in.ORPCthis.version.MinorVersion = COM_MINOR_VERSION;
102 ";
103         
104         # Put arguments into r
105         foreach my $a (@{$fn->{ELEMENTS}}) {
106                 next unless (util::has_property($a, "in"));
107                 if (typelist::typeIs($a->{TYPE}, "INTERFACE")) {
108                         $res .="\tNDR_CHECK(dcom_OBJREF_from_IUnknown(&r.in.$a->{NAME}.obj, $a->{NAME}));\n";
109                 } else {
110                         $res .= "\tr.in.$a->{NAME} = $a->{NAME};\n";
111                 }
112         }
113
114         $res .="
115         if (p->conn->flags & DCERPC_DEBUG_PRINT_IN) {
116                 NDR_PRINT_IN_DEBUG($name, &r);          
117         }
118
119         status = dcerpc_ndr_request(p, &d->ipid, &dcerpc_table_$interface->{NAME}, DCERPC_$uname, mem_ctx, &r);
120
121         if (NT_STATUS_IS_OK(status) && (p->conn->flags & DCERPC_DEBUG_PRINT_OUT)) {
122                 NDR_PRINT_OUT_DEBUG($name, r);          
123         }
124
125 ";
126
127         # Put r info back into arguments
128         foreach my $a (@{$fn->{ELEMENTS}}) {
129                 next unless (util::has_property($a, "out"));
130
131                 if (typelist::typeIs($a->{TYPE}, "INTERFACE")) {
132                         $res .="\tNDR_CHECK(dcom_IUnknown_from_OBJREF(d->ctx, &$a->{NAME}, r.out.$a->{NAME}.obj));\n";
133                 } else {
134                         $res .= "\t*$a->{NAME} = r.out.$a->{NAME};\n";
135                 }
136
137         }
138         
139         if ($fn->{RETURN_TYPE} eq "NTSTATUS") {
140                 $res .= "\tif (NT_STATUS_IS_OK(status)) status = r.out.result;\n";
141         }
142
143         $res .= 
144         "
145         return r.out.result;
146 }\n\n";
147 }
148
149 #####################################################################
150 # parse the interface definitions
151 sub ParseInterface($)
152 {
153         my($interface) = shift;
154         my($data) = $interface->{DATA};
155         $res = "/* DCOM proxy for $interface->{NAME} generated by pidl */\n\n";
156         foreach my $d (@{$data}) {
157                 ($d->{TYPE} eq "FUNCTION") && 
158                 ParseFunction($interface, $d);
159         }
160
161         ParseRegFunc($interface);
162 }
163
164 sub RegistrationFunction($$)
165 {
166         my $idl = shift;
167         my $basename = shift;
168
169         my $res = "\n\nNTSTATUS dcom_$basename\_init(void)\n";
170         $res .= "{\n";
171         $res .="\tNTSTATUS status = NT_STATUS_OK;\n";
172         foreach my $interface (@{$idl}) {
173                 next if $interface->{TYPE} ne "INTERFACE";
174                 next if not util::has_property($interface, "object");
175
176                 my $data = $interface->{INHERITED_DATA};
177                 my $count = 0;
178                 foreach my $d (@{$data}) {
179                         if ($d->{TYPE} eq "FUNCTION") { $count++; }
180                 }
181
182                 next if ($count == 0);
183
184                 $res .= "\tstatus = dcom_$interface->{NAME}_init();\n";
185                 $res .= "\tif (NT_STATUS_IS_ERR(status)) {\n";
186                 $res .= "\t\treturn status;\n";
187                 $res .= "\t}\n\n";
188         }
189         $res .= "\treturn status;\n";
190         $res .= "}\n\n";
191
192         return $res;
193 }
194
195 sub Parse($)
196 {
197         my $pidl = shift;
198         my $res = "";
199
200         foreach my $x (@{$pidl}) {
201                 next if ($x->{TYPE} ne "INTERFACE");
202                 next if util::has_property($x, "local");
203                 next unless util::has_property($x, "object");
204
205                 $res .= ParseInterface($x);
206         }
207
208         return $res;
209 }
210
211 1;