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