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