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