pidl/lib/Parse/Pidl/Typelist.pm

   1 ###################################################
   2 # Samba4 parser generator for IDL structures
   3 # Copyright jelmer@samba.org 2005
   4 # released under the GNU GPL
   5
   6 package Parse::Pidl::Typelist;
   7
   8 require Exporter;
   9 @ISA = qw(Exporter);
  10 @EXPORT_OK = qw(hasType getType resolveType mapTypeName scalar_is_reference expandAlias
  11                             mapScalarType addType typeIs is_signed is_scalar enum_type_fn
  12                                 bitmap_type_fn mapType typeHasBody
  13 );
  14 use vars qw($VERSION);
  15 $VERSION = '0.01';
  16
  17 use Parse::Pidl::Util qw(has_property);
  18 use strict;
  19
  20 my %types = ();
  21
  22 my @reference_scalars = (
  23         "string", "string_array", "nbt_string",
  24         "wrepl_nbt_name", "ipv4address"
  25 );
  26
  27 # a list of known scalar types
  28 my %scalars = (
  29         "void"          => "void",
  30         "char"          => "char",
  31         "int8"          => "int8_t",
  32         "uint8"         => "uint8_t",
  33         "int16"         => "int16_t",
  34         "uint16"        => "uint16_t",
  35         "int1632"       => "int16_t",
  36         "uint1632"      => "uint16_t",
  37         "int32"         => "int32_t",
  38         "uint32"        => "uint32_t",
  39         "int3264"       => "int32_t",
  40         "uint3264"      => "uint32_t",
  41         "hyper"         => "uint64_t",
  42         "dlong"         => "int64_t",
  43         "udlong"        => "uint64_t",
  44         "udlongr"       => "uint64_t",
  45         "double"        => "double",
  46         "pointer"       => "void*",
  47         "DATA_BLOB"     => "DATA_BLOB",
  48         "string"        => "const char *",
  49         "string_array"  => "const char **",
  50         "time_t"        => "time_t",
  51         "NTTIME"        => "NTTIME",
  52         "NTTIME_1sec"   => "NTTIME",
  53         "NTTIME_hyper"  => "NTTIME",
  54         "WERROR"        => "WERROR",
  55         "NTSTATUS"      => "NTSTATUS",
  56         "COMRESULT" => "COMRESULT",
  57         "nbt_string"    => "const char *",
  58         "wrepl_nbt_name"=> "struct nbt_name *",
  59         "ipv4address"   => "const char *",
  60         "dnsp_name"     => "const char *",
  61 );
  62
  63 my %aliases = (
  64         "error_status_t" => "uint32",
  65         "boolean8" => "uint8",
  66         "boolean32" => "uint32",
  67         "DWORD" => "uint32",
  68         "uint" => "uint32",
  69         "int" => "int32",
  70         "WORD" => "uint16",
  71         "char" => "uint8",
  72         "long" => "int32",
  73         "short" => "int16",
  74         "HYPER_T" => "hyper",
  75         "HRESULT" => "COMRESULT",
  76 );
  77
  78 sub expandAlias($)
  79 {
  80         my $name = shift;
  81
  82         return $aliases{$name} if defined($aliases{$name});
  83
  84         return $name;
  85 }
  86
  87 # map from a IDL type to a C header type
  88 sub mapScalarType($)
  89 {
  90         my $name = shift;
  91
  92         # it's a bug when a type is not in the list
  93         # of known scalars or has no mapping
  94         return $scalars{$name} if defined($scalars{$name});
  95
  96         die("Unknown scalar type $name");
  97 }
  98
  99 sub addType($)
 100 {
 101         my $t = shift;
 102         $types{$t->{NAME}} = $t;
 103 }
 104
 105 sub resolveType($)
 106 {
 107         my ($ctype) = @_;
 108
 109         if (not hasType($ctype)) {
 110                 # assume struct typedef
 111                 return { TYPE => "TYPEDEF", NAME => $ctype, DATA => { TYPE => "STRUCT" } };
 112         } else {
 113                 return getType($ctype);
 114         }
 115
 116         return $ctype;
 117 }
 118
 119 sub getType($)
 120 {
 121         my $t = shift;
 122         return ($t) if (ref($t) eq "HASH" and not defined($t->{NAME}));
 123         return undef if not hasType($t);
 124         return $types{$t->{NAME}} if (ref($t) eq "HASH");
 125         return $types{$t};
 126 }
 127
 128 sub typeIs($$)
 129 {
 130         my ($t,$tt) = @_;
 131
 132         if (ref($t) eq "HASH") {
 133                 return 1 if ($t->{TYPE} eq $tt);
 134                 return 0;
 135         }
 136         return 1 if (hasType($t) and getType($t)->{TYPE} eq "TYPEDEF" and
 137                          getType($t)->{DATA}->{TYPE} eq $tt);
 138         return 0;
 139 }
 140
 141 sub hasType($)
 142 {
 143         my $t = shift;
 144         if (ref($t) eq "HASH") {
 145                 return 1 if (not defined($t->{NAME}));
 146                 return 1 if (defined($types{$t->{NAME}}) and
 147                         $types{$t->{NAME}}->{TYPE} eq $t->{TYPE});
 148                 return 0;
 149         }
 150         return 1 if defined($types{$t});
 151         return 0;
 152 }
 153
 154 sub is_signed($)
 155 {
 156     my $t = shift;
 157
 158     return ($t eq "int8"
 159             or $t eq "int16"
 160             or $t eq "int32"
 161             or $t eq "dlong"
 162             or $t eq "int"
 163             or $t eq "long"
 164             or $t eq "short");
 165 }
 166
 167 sub is_scalar($)
 168 {
 169         sub is_scalar($);
 170         my $type = shift;
 171
 172         return 1 if (ref($type) eq "HASH" and
 173                 ($type->{TYPE} eq "SCALAR" or $type->{TYPE} eq "ENUM" or
 174                  $type->{TYPE} eq "BITMAP"));
 175
 176         if (my $dt = getType($type)) {
 177                 return is_scalar($dt->{DATA}) if ($dt->{TYPE} eq "TYPEDEF");
 178                 return 1 if ($dt->{TYPE} eq "SCALAR" or $dt->{TYPE} eq "ENUM" or
 179                                  $dt->{TYPE} eq "BITMAP");
 180         }
 181
 182         return 0;
 183 }
 184
 185 sub scalar_is_reference($)
 186 {
 187         my $name = shift;
 188
 189         return 1 if (grep(/^$name$/, @reference_scalars));
 190         return 0;
 191 }
 192
 193 sub RegisterScalars()
 194 {
 195         foreach (keys %scalars) {
 196                 addType({
 197                         NAME => $_,
 198                         TYPE => "TYPEDEF",
 199                         BASEFILE => "<builtin>",
 200                         DATA => {
 201                                 TYPE => "SCALAR",
 202                                 NAME => $_
 203                         }
 204                 }
 205                 );
 206         }
 207 }
 208
 209 sub enum_type_fn($)
 210 {
 211         my $enum = shift;
 212         $enum->{TYPE} eq "ENUM" or die("not an enum");
 213
 214         # for typedef enum { } we need to check $enum->{PARENT}
 215         if (has_property($enum, "enum8bit")) {
 216                 return "uint8";
 217         } elsif (has_property($enum, "enum16bit")) {
 218                 return "uint16";
 219         } elsif (has_property($enum, "v1_enum")) {
 220                 return "uint32";
 221         } elsif (has_property($enum->{PARENT}, "enum8bit")) {
 222                 return "uint8";
 223         } elsif (has_property($enum->{PARENT}, "enum16bit")) {
 224                 return "uint16";
 225         } elsif (has_property($enum->{PARENT}, "v1_enum")) {
 226                 return "uint32";
 227         }
 228         return "uint1632";
 229 }
 230
 231 sub bitmap_type_fn($)
 232 {
 233         my $bitmap = shift;
 234
 235         $bitmap->{TYPE} eq "BITMAP" or die("not a bitmap");
 236
 237         if (has_property($bitmap, "bitmap8bit")) {
 238                 return "uint8";
 239         } elsif (has_property($bitmap, "bitmap16bit")) {
 240                 return "uint16";
 241         } elsif (has_property($bitmap, "bitmap64bit")) {
 242                 return "hyper";
 243         }
 244         return "uint32";
 245 }
 246
 247 sub typeHasBody($)
 248 {
 249         sub typeHasBody($);
 250         my ($e) = @_;
 251
 252         if ($e->{TYPE} eq "TYPEDEF") {
 253                 return 0 unless(defined($e->{DATA}));
 254                 return typeHasBody($e->{DATA});
 255         }
 256
 257         return defined($e->{ELEMENTS});
 258 }
 259
 260 sub mapType($$)
 261 {
 262         sub mapType($$);
 263         my ($t, $n) = @_;
 264
 265         return mapType($t->{DATA}, $n) if ($t->{TYPE} eq "TYPEDEF");
 266         return mapScalarType($n) if ($t->{TYPE} eq "SCALAR");
 267         return "enum $n" if ($t->{TYPE} eq "ENUM");
 268         return "struct $n" if ($t->{TYPE} eq "STRUCT" or $t->{TYPE} eq "INTERFACE");
 269         return "union $n" if ($t->{TYPE} eq "UNION");
 270         return mapScalarType(bitmap_type_fn($t)) if ($t->{TYPE} eq "BITMAP");
 271         die("Unknown type $t->{TYPE}");
 272 }
 273
 274 sub mapTypeName($)
 275 {
 276         my $t = shift;
 277         return "void" unless defined($t);
 278         my $dt;
 279         $t = expandAlias($t);
 280
 281         if ($dt = getType($t)) {
 282                 return mapType($dt, $dt->{NAME});
 283         } elsif (ref($t) eq "HASH" and defined($t->{NAME})) {
 284                 return mapType($t, $t->{NAME});
 285         } else {
 286                 # Best guess
 287                 return "struct $t";
 288         }
 289
 290 }
 291
 292 sub LoadIdl($;$)
 293 {
 294         my $idl = shift;
 295         my $basename = shift;
 296
 297         foreach my $x (@{$idl}) {
 298                 next if $x->{TYPE} ne "INTERFACE";
 299
 300                 # DCOM interfaces can be types as well
 301                 addType({
 302                         NAME => $x->{NAME},
 303                         TYPE => "TYPEDEF",
 304                         DATA => $x,
 305                         BASEFILE => $basename,
 306                         }) if (has_property($x, "object"));
 307
 308                 foreach my $y (@{$x->{DATA}}) {
 309                         if ($y->{TYPE} eq "TYPEDEF"
 310                                 or $y->{TYPE} eq "UNION"
 311                                 or $y->{TYPE} eq "STRUCT"
 312                         or $y->{TYPE} eq "ENUM"
 313                         or $y->{TYPE} eq "BITMAP") {
 314                                 $y->{BASEFILE} = $basename;
 315                                 addType($y);
 316                         }
 317                 }
 318         }
 319 }
 320
 321 sub GenerateTypeLib()
 322 {
 323         return Parse::Pidl::Util::MyDumper(\%types);
 324 }
 325
 326 RegisterScalars();
 327
 328 1;