source/build/pidl/Parse/Pidl/Samba/COM/Header.pm

   1 # COM Header generation
   2 # (C) 2005 Jelmer Vernooij <jelmer@samba.org>
   3
   4 package Parse::Pidl::Samba::COM::Header;
   5
   6 use Parse::Pidl::Typelist;
   7 use Parse::Pidl::Util qw(has_property);
   8
   9 use strict;
  10
  11 sub GetArgumentProtoList($)
  12 {
  13         my $f = shift;
  14         my $res = "";
  15
  16         foreach my $a (@{$f->{ELEMENTS}}) {
  17
  18                 $res .= ", " . Parse::Pidl::Typelist::mapType($a->{TYPE}) . " ";
  19
  20                 my $l = $a->{POINTERS};
  21                 $l-- if (Parse::Pidl::Typelist::scalar_is_reference($a->{TYPE}));
  22                 foreach my $i (1..$l) {
  23                         $res .= "*";
  24                 }
  25
  26                 if (defined $a->{ARRAY_LEN}[0] &&
  27                 !Parse::Pidl::Util::is_constant($a->{ARRAY_LEN}[0]) &&
  28                 !$a->{POINTERS}) {
  29                         $res .= "*";
  30                 }
  31                 $res .= $a->{NAME};
  32                 if (defined $a->{ARRAY_LEN}[0] && Parse::Pidl::Util::is_constant($a->{ARRAY_LEN}[0])) {
  33                         $res .= "[$a->{ARRAY_LEN}[0]]";
  34                 }
  35         }
  36
  37         return $res;
  38 }
  39
  40 sub GetArgumentList($)
  41 {
  42         my $f = shift;
  43         my $res = "";
  44
  45         foreach my $a (@{$f->{ELEMENTS}}) {
  46                 $res .= ", $a->{NAME}";
  47         }
  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" . Parse::Pidl::Typelist::mapType($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\n/* $if->{NAME} */\n";
  82
  83         $res .="#define COM_" . uc($if->{NAME}) . "_UUID $if->{PROPERTIES}->{uuid}\n\n";
  84
  85         $res .="struct $if->{NAME}_vtable;\n\n";
  86
  87         $res .="struct $if->{NAME} {
  88         struct com_context *ctx;
  89         struct $if->{NAME}_vtable *vtable;
  90         void *object_data;
  91 };\n\n";
  92
  93         $res.=HeaderVTable($if);
  94
  95         foreach my $d (@{$if->{DATA}}) {
  96                 next if ($d->{TYPE} ne "FUNCTION");
  97
  98                 $res .= "#define $if->{NAME}_$d->{NAME}(interface, mem_ctx" . GetArgumentList($d) . ") ";
  99
 100                 $res .= "((interface)->vtable->$d->{NAME}(interface, mem_ctx" . GetArgumentList($d) . "))";
 101
 102                 $res .="\n";
 103         }
 104
 105         return $res;
 106 }
 107
 108 sub ParseCoClass($)
 109 {
 110         my $c = shift;
 111         my $res = "";
 112         $res .= "#define CLSID_" . uc($c->{NAME}) . " $c->{PROPERTIES}->{uuid}\n";
 113         if (has_property($c, "progid")) {
 114                 $res .= "#define PROGID_" . uc($c->{NAME}) . " $c->{PROPERTIES}->{progid}\n";
 115         }
 116         $res .= "\n";
 117         return $res;
 118 }
 119
 120 sub Parse($)
 121 {
 122         my $idl = shift;
 123         my $res = "";
 124
 125         foreach my $x (@{$idl})
 126         {
 127                 if ($x->{TYPE} eq "INTERFACE" && has_property($x, "object")) {
 128                         $res.=ParseInterface($x);
 129                 }
 130
 131                 if ($x->{TYPE} eq "COCLASS") {
 132                         $res.=ParseCoClass($x);
 133                 }
 134         }
 135
 136         return $res;
 137 }
 138
 139 1;