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