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