source4/pidl/lib/Parse/Pidl/Samba4/COM/Header.pm

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