1a1b8de0642c2ee7bec4d5316b31fd0faca5649d
[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 GUID iid;
47         struct $interface->{NAME}_vtable proxy_vtable;";
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\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, &iid);
73
74         return dcom_register_proxy(&iid, &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->{DATA}}) {
106                 next if ($a->{NAME} eq "ORPCthis");
107                 next unless (util::has_property($a, "in"));
108                 $res .= "\tr.in.$a->{NAME} = $a->{NAME};\n";
109         }
110
111         $res .="
112         if (p->conn->flags & DCERPC_DEBUG_PRINT_IN) {
113                 NDR_PRINT_IN_DEBUG($name, &r);          
114         }
115
116         status = dcerpc_ndr_request(p, &d->ipid, &dcerpc_table_$interface->{NAME}, DCERPC_$uname, mem_ctx, &r);
117
118         if (NT_STATUS_IS_OK(status) && (p->conn->flags & DCERPC_DEBUG_PRINT_OUT)) {
119                 NDR_PRINT_OUT_DEBUG($name, r);          
120         }
121
122 ";
123
124         # Put r info back into arguments
125         foreach my $a (@{$fn->{DATA}}) {
126                 next if ($a->{NAME} eq "ORPCthat");
127                 next unless (util::has_property($a, "out"));
128                 $res .= "\t*$a->{NAME} = r.out.$a->{NAME};\n";
129         }
130         
131         if ($fn->{RETURN_TYPE} eq "NTSTATUS") {
132                 $res .= "\tif (NT_STATUS_IS_OK(status)) status = r.out.result;\n";
133         }
134
135         $res .= 
136         "
137         return r.out.result;
138 }\n\n";
139 }
140
141 #####################################################################
142 # parse the interface definitions
143 sub ParseInterface($)
144 {
145         my($interface) = shift;
146         my($data) = $interface->{DATA};
147         $res = "/* DCOM proxy for $interface->{NAME} generated by pidl */\n\n";
148         foreach my $d (@{$data}) {
149                 ($d->{TYPE} eq "FUNCTION") && 
150                 ParseFunction($interface, $d);
151         }
152
153         ParseRegFunc($interface);
154 }
155
156 sub RegistrationFunction($$)
157 {
158         my $idl = shift;
159         my $basename = shift;
160
161         my $res = "\n\nNTSTATUS dcom_$basename\_init(void)\n";
162         $res .= "{\n";
163         $res .="\tNTSTATUS status = NT_STATUS_OK;\n";
164         foreach my $interface (@{$idl}) {
165                 next if $interface->{TYPE} ne "INTERFACE";
166                 next if not util::has_property($interface, "object");
167
168                 my $data = $interface->{INHERITED_DATA};
169                 my $count = 0;
170                 foreach my $d (@{$data}) {
171                         if ($d->{TYPE} eq "FUNCTION") { $count++; }
172                 }
173
174                 next if ($count == 0);
175
176                 $res .= "\tstatus = dcom_$interface->{NAME}_init();\n";
177                 $res .= "\tif (NT_STATUS_IS_ERR(status)) {\n";
178                 $res .= "\t\treturn status;\n";
179                 $res .= "\t}\n\n";
180         }
181         $res .= "\treturn status;\n";
182         $res .= "}\n\n";
183
184         return $res;
185 }
186
187 sub Parse($)
188 {
189         my $pidl = shift;
190         my $res = "";
191
192         foreach my $x (@{$pidl}) {
193                 next if ($x->{TYPE} ne "INTERFACE");
194                 next if util::has_property($x, "local");
195                 next unless util::has_property($x, "object");
196
197                 $res .= ParseInterface($x);
198         }
199
200         return $res;
201 }
202
203 1;