← Back to branch summary

~zulcss/samba/server-dailies-3.4

« back to all changes in this revision

Viewing changes to pidl/lib/Parse/Pidl/Samba4/COM/Header.pm

  • Committer: Chuck Short
  • Date: 2010-09-28 20:38:39 UTC
  • Revision ID: zulcss@ubuntu.com-20100928203839-pgjulytsi9ue63x1
Initial version

Show diffs side-by-side

added added

removed removed

Lines of Context:
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 OBJREF obj;
 
92
        struct com_context *ctx;
 
93
        struct $if->{NAME}_vtable *vtable;
 
94
        void *object_data;
 
95
};\n\n";
 
96
 
 
97
        $res.=HeaderVTable($if);
 
98
 
 
99
        foreach my $d (@{$if->{DATA}}) {
 
100
                next if ($d->{TYPE} ne "FUNCTION");
 
101
 
 
102
                $res .= "#define $if->{NAME}_$d->{NAME}(interface, mem_ctx" . GetArgumentList($d) . ") ";
 
103
 
 
104
                $res .= "((interface)->vtable->$d->{NAME}(interface, mem_ctx" . GetArgumentList($d) . "))";
 
105
 
 
106
                $res .="\n";
 
107
        }
 
108
 
 
109
        $res .= "#endif\n";
 
110
 
 
111
        return $res;
 
112
}
 
113
 
 
114
sub ParseCoClass($)
 
115
{
 
116
        my ($c) = @_;
 
117
        my $res = "";
 
118
        $res .= "#define CLSID_" . uc($c->{NAME}) . " $c->{PROPERTIES}->{uuid}\n";
 
119
        if (has_property($c, "progid")) {
 
120
                $res .= "#define PROGID_" . uc($c->{NAME}) . " $c->{PROPERTIES}->{progid}\n";
 
121
        }
 
122
        $res .= "\n";
 
123
        return $res;
 
124
}
 
125
 
 
126
sub Parse($$)
 
127
{
 
128
        my ($idl,$ndr_header) = @_;
 
129
        my $res = "";
 
130
        my $has_obj = 0;
 
131
 
 
132
        $res .= "#include \"librpc/gen_ndr/orpc.h\"\n" . 
 
133
                        "#include \"$ndr_header\"\n\n";
 
134
 
 
135
        foreach (@{$idl})
 
136
        {
 
137
                if ($_->{TYPE} eq "INTERFACE" && has_property($_, "object")) {
 
138
                        $res .="struct $_->{NAME};\n";
 
139
                        $has_obj = 1;
 
140
                }
 
141
        }
 
142
 
 
143
        foreach (@{$idl})
 
144
        {
 
145
                if ($_->{TYPE} eq "INTERFACE" && has_property($_, "object")) {
 
146
                        $res.=ParseInterface($_);
 
147
                        $has_obj = 1;
 
148
                } 
 
149
 
 
150
                if ($_->{TYPE} eq "COCLASS") {
 
151
                        $res.=ParseCoClass($_);
 
152
                        $has_obj = 1;
 
153
                }
 
154
        }
 
155
 
 
156
        return $res if ($has_obj);
 
157
        return undef;
 
158
}
 
159
 
 
160
1;