source/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 mapType scalar_is_reference expandAlias);
  11 use vars qw($VERSION);
  12 $VERSION = '0.01';
  13
  14 use Parse::Pidl::Util qw(has_property);
  15 use strict;
  16
  17 my %typedefs = ();
  18
  19 my @reference_scalars = (
  20         "string", "string_array", "nbt_string",
  21         "wrepl_nbt_name", "ipv4address"
  22 );
  23
  24 # a list of known scalar types
  25 my %scalars = (
  26         "void"          => "void",
  27         "char"          => "char",
  28         "int8"          => "int8_t",
  29         "uint8"         => "uint8_t",
  30         "int16"         => "int16_t",
  31         "uint16"        => "uint16_t",
  32         "int32"         => "int32_t",
  33         "uint32"        => "uint32_t",
  34         "hyper"         => "uint64_t",
  35         "dlong"         => "int64_t",
  36         "udlong"        => "uint64_t",
  37         "udlongr"       => "uint64_t",
  38         "pointer"       => "void*",
  39         "DATA_BLOB"     => "DATA_BLOB",
  40         "string"        => "const char *",
  41         "string_array"  => "const char **",
  42         "time_t"        => "time_t",
  43         "NTTIME"        => "NTTIME",
  44         "NTTIME_1sec"   => "NTTIME",
  45         "NTTIME_hyper"  => "NTTIME",
  46         "WERROR"        => "WERROR",
  47         "NTSTATUS"      => "NTSTATUS",
  48         "COMRESULT" => "COMRESULT",
  49         "nbt_string"    => "const char *",
  50         "wrepl_nbt_name"=> "struct nbt_name *",
  51         "ipv4address"   => "const char *",
  52 );
  53
  54 my %aliases = (
  55         "error_status_t" => "uint32",
  56         "boolean8" => "uint8",
  57         "boolean32" => "uint32",
  58         "DWORD" => "uint32",
  59         "int" => "int32",
  60         "WORD" => "uint16",
  61         "char" => "uint8",
  62         "long" => "int32",
  63         "short" => "int16",
  64         "HYPER_T" => "hyper",
  65         "HRESULT" => "COMRESULT",
  66 );
  67
  68 sub expandAlias($)
  69 {
  70         my $name = shift;
  71
  72         return $aliases{$name} if defined($aliases{$name});
  73
  74         return $name;
  75 }
  76
  77 # map from a IDL type to a C header type
  78 sub mapScalarType($)
  79 {
  80         my $name = shift;
  81
  82         # it's a bug when a type is not in the list
  83         # of known scalars or has no mapping
  84         return $scalars{$name} if defined($scalars{$name});
  85
  86         die("Unknown scalar type $name");
  87 }
  88
  89 sub addType($)
  90 {
  91         my $t = shift;
  92         $typedefs{$t->{NAME}} = $t;
  93 }
  94
  95 sub getType($)
  96 {
  97         my $t = shift;
  98         return undef if not hasType($t);
  99         return $typedefs{$t};
 100 }
 101
 102 sub typeIs($$)
 103 {
 104         my ($t,$tt) = @_;
 105
 106         return 1 if (hasType($t) and getType($t)->{DATA}->{TYPE} eq $tt);
 107         return 0;
 108 }
 109
 110 sub hasType($)
 111 {
 112         my $t = shift;
 113         return 1 if defined($typedefs{$t});
 114         return 0;
 115 }
 116
 117 sub is_scalar($)
 118 {
 119         my $type = shift;
 120
 121         return 0 unless(hasType($type));
 122
 123         if (my $dt = getType($type)->{DATA}->{TYPE}) {
 124                 return 1 if ($dt eq "SCALAR" or $dt eq "ENUM" or $dt eq "BITMAP");
 125         }
 126
 127         return 0;
 128 }
 129
 130 sub scalar_is_reference($)
 131 {
 132         my $name = shift;
 133
 134         return 1 if (grep(/^$name$/, @reference_scalars));
 135         return 0;
 136 }
 137
 138 sub RegisterScalars()
 139 {
 140         foreach (keys %scalars) {
 141                 addType({
 142                         NAME => $_,
 143                         TYPE => "TYPEDEF",
 144                         DATA => {
 145                                 TYPE => "SCALAR",
 146                                 NAME => $_
 147                         }
 148                 }
 149                 );
 150         }
 151 }
 152
 153 sub enum_type_fn($)
 154 {
 155         my $enum = shift;
 156         $enum->{TYPE} eq "ENUM" or die("not an enum");
 157         if (has_property($enum->{PARENT}, "enum8bit")) {
 158                 return "uint8";
 159         } elsif (has_property($enum->{PARENT}, "v1_enum")) {
 160                 return "uint32";
 161         }
 162         return "uint16";
 163 }
 164
 165 sub bitmap_type_fn($)
 166 {
 167         my $bitmap = shift;
 168
 169         $bitmap->{TYPE} eq "BITMAP" or die("not an enum");
 170
 171         if (has_property($bitmap, "bitmap8bit")) {
 172                 return "uint8";
 173         } elsif (has_property($bitmap, "bitmap16bit")) {
 174                 return "uint16";
 175         } elsif (has_property($bitmap, "bitmap64bit")) {
 176                 return "hyper";
 177         }
 178         return "uint32";
 179 }
 180
 181 sub mapType($)
 182 {
 183         my $t = shift;
 184         return "void" unless defined($t);
 185         my $dt;
 186         $t = expandAlias($t);
 187
 188         unless ($dt or ($dt = getType($t))) {
 189                 # Best guess
 190                 return "struct $t";
 191         }
 192         return mapScalarType($t) if ($dt->{DATA}->{TYPE} eq "SCALAR");
 193         return "enum $dt->{NAME}" if ($dt->{DATA}->{TYPE} eq "ENUM");
 194         return "struct $dt->{NAME}" if ($dt->{DATA}->{TYPE} eq "STRUCT");
 195         return "struct $dt->{NAME}" if ($dt->{DATA}->{TYPE} eq "INTERFACE");
 196         return "union $dt->{NAME}" if ($dt->{DATA}->{TYPE} eq "UNION");
 197
 198         if ($dt->{DATA}->{TYPE} eq "BITMAP") {
 199                 return mapScalarType(bitmap_type_fn($dt->{DATA}));
 200         }
 201
 202         die("Unknown type $dt->{DATA}->{TYPE}");
 203 }
 204
 205 sub LoadIdl($)
 206 {
 207         my $idl = shift;
 208
 209         foreach my $x (@{$idl}) {
 210                 next if $x->{TYPE} ne "INTERFACE";
 211
 212                 # DCOM interfaces can be types as well
 213                 addType({
 214                         NAME => $x->{NAME},
 215                         TYPE => "TYPEDEF",
 216                         DATA => $x
 217                         }) if (has_property($x, "object"));
 218
 219                 foreach my $y (@{$x->{DATA}}) {
 220                         addType($y) if (
 221                                 $y->{TYPE} eq "TYPEDEF"
 222                              or $y->{TYPE} eq "DECLARE");
 223                 }
 224         }
 225 }
 226
 227 RegisterScalars();
 228
 229 1;