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