source/pidl/lib/Parse/Pidl/Samba3/Types.pm

   1 ###################################################
   2 # Samba3 type-specific declarations / initialization / marshalling
   3 # Copyright jelmer@samba.org 2005
   4 # released under the GNU GPL
   5
   6 package Parse::Pidl::Samba3::Types;
   7
   8 require Exporter;
   9 @ISA = qw(Exporter);
  10 @EXPORT_OK = qw(DeclShort DeclLong InitType DissectType AddType);
  11
  12 use strict;
  13 use Parse::Pidl::Util qw(has_property ParseExpr);
  14 use Parse::Pidl::NDR qw(GetPrevLevel GetNextLevel ContainsDeferred);
  15
  16 use vars qw($VERSION);
  17 $VERSION = '0.01';
  18
  19 # TODO: Find external types somehow?
  20
  21 sub warning($$) { my ($e,$s) = @_; print STDERR "$e->{FILE}:$e->{LINE}: $s\n"; }
  22
  23 sub init_scalar($$$$)
  24 {
  25         my ($e,$l,$n,$v) = @_;
  26
  27         return "$n = $v;";
  28 }
  29
  30 sub dissect_scalar($$$)
  31 {
  32         my ($e,$l,$n) = @_;
  33
  34         my $t = lc($e->{TYPE});
  35
  36         return "prs_$t(\"$e->{NAME}\", ps, depth, &$n)";
  37 }
  38
  39 sub decl_string($)
  40 {
  41         my $e = shift;
  42
  43         # FIXME: More intelligent code here - select between UNISTR2 and other
  44         # variants
  45         return "UNISTR2";
  46 }
  47
  48 sub init_string($$$$)
  49 {
  50         my ($e,$l,$n,$v) = @_;
  51
  52         return "init_unistr2(&$n, $v, UNI_FLAGS_NONE);";
  53 }
  54
  55 sub dissect_string($$$)
  56 {
  57         my ($e,$l,$n) = @_;
  58
  59         return "prs_unistr2(True, \"$e->{NAME}\", ps, depth, &n)";
  60 }
  61
  62 sub init_uuid($$$$)
  63 {
  64         my ($e,$l,$n,$v) = @_;
  65
  66         return "";
  67 }
  68
  69 sub dissect_uuid($$$)
  70 {
  71         my ($e,$l,$n) = @_;
  72
  73         return "smb_io_uuid(\"$e->{NAME}\", &$n, ps, depth)";
  74 }
  75
  76 my $known_types =
  77 {
  78         uint8 =>
  79         {
  80                 DECL => "uint8",
  81                 INIT => \&init_scalar,
  82                 DISSECT => \&dissect_scalar,
  83         },
  84         uint16 =>
  85         {
  86                 DECL => "uint16",
  87                 INIT => \&init_scalar,
  88                 DISSECT => \&dissect_scalar,
  89         },
  90         uint32 =>
  91         {
  92                 DECL => "uint32",
  93                 INIT => \&init_scalar,
  94                 DISSECT => \&dissect_scalar,
  95         },
  96         string =>
  97         {
  98                 DECL => \&decl_string,
  99                 INIT => \&init_string,
 100                 DISSECT => \&dissect_string,
 101         },
 102         NTSTATUS =>
 103         {
 104                 DECL => "NTSTATUS",
 105                 INIT => \&init_scalar,
 106                 DISSECT => \&dissect_scalar,
 107         },
 108         WERROR =>
 109         {
 110                 DECL => "WERROR",
 111                 INIT => \&init_scalar,
 112                 DISSECT => \&dissect_scalar,
 113         },
 114         GUID =>
 115         {
 116                 DECL => "struct uuid",
 117                 INIT => \&init_uuid,
 118                 DISSECT => \&dissect_uuid,
 119         }
 120 };
 121
 122 sub AddType($$)
 123 {
 124         my ($t,$d) = @_;
 125
 126         warn("Reregistering type $t") if (defined($known_types->{$t}));
 127
 128         $known_types->{$t} = $d;
 129 }
 130
 131 sub GetType($)
 132 {
 133         my $e = shift;
 134
 135         my $t = $known_types->{$e->{TYPE}};
 136
 137         if (not $t) {
 138                 warning($e, "Can't declare unknown type $e->{TYPE}");
 139                 return undef;
 140         }
 141
 142         # DECL can be a function
 143         if (ref($t->{DECL}) eq "CODE") {
 144                 return $t->{DECL}->($e);
 145         } else {
 146                 return $t->{DECL};
 147         }
 148 }
 149
 150 # Return type without special stuff, as used in
 151 # struct declarations
 152 sub DeclShort($)
 153 {
 154         my $e = shift;
 155
 156         my $t = GetType($e);
 157         return undef if not $t;
 158
 159         return "$t $e->{NAME}";
 160 }
 161
 162 sub DeclLong($)
 163 {
 164         my $e = shift;
 165
 166         my $t = GetType($e);
 167
 168         return undef if not $t;
 169
 170         my $ptrs = "";
 171
 172         foreach my $l (@{$e->{LEVELS}}) {
 173                 ($ptrs.="*") if ($l->{TYPE} eq "POINTER");
 174         }
 175
 176         return "$t $ptrs$e->{NAME}";
 177 }
 178
 179 sub InitType($$$$)
 180 {
 181         my ($e, $l, $varname, $value) = @_;
 182
 183         my $t = $known_types->{$l->{DATA_TYPE}};
 184
 185         if (not $t) {
 186                 warning($e, "Don't know how to initialize type $l->{DATA_TYPE}");
 187                 return undef;
 188         }
 189
 190         # INIT can be a function
 191         if (ref($t->{INIT}) eq "CODE") {
 192                 return $t->{INIT}->($e, $l, $varname, $value);
 193         } else {
 194                 return $t->{INIT};
 195         }
 196 }
 197
 198 sub DissectType($$$)
 199 {
 200         my ($e, $l, $varname) = @_;
 201
 202         my $t = $known_types->{$l->{DATA_TYPE}};
 203
 204         if (not $t) {
 205                 warning($e, "Don't know how to dissect type $l->{DATA_TYPE}");
 206                 return undef;
 207         }
 208
 209         # DISSECT can be a function
 210         if (ref($t->{DISSECT}) eq "CODE") {
 211                 return $t->{DISSECT}->($e, $l, $varname);
 212         } else {
 213                 return $t->{DISSECT};
 214         }
 215 }
 216
 217 sub LoadTypes($)
 218 {
 219         my $ndr = shift;
 220         foreach my $if (@{$ndr}) {
 221                 next unless ($if->{TYPE} eq "INTERFACE");
 222
 223                 foreach my $td (@{$if->{TYPEDEFS}}) {
 224                         AddType($td->{NAME}, {
 225                                 DECL => uc("$if->{NAME}_$td->{NAME}"),
 226                                 INIT => sub {
 227                                         my ($e,$l,$n,$v) = @_;
 228                                         return "init_$td->{NAME}(&$n/*FIXME:OTHER ARGS*/);";
 229                                 },
 230                                 DISSECT => sub {
 231                                         my ($e,$l,$n) = @_;
 232
 233                                         return "$if->{NAME}_io_$td->{NAME}(\"$e->{NAME}\", &$n, ps, depth)";
 234                                 }
 235                         });
 236                 }
 237         }
 238 }
 239
 240 1;