pidl/lib/Parse/Pidl/Dump.pm

   1 ###################################################
   2 # dump function for IDL structures
   3 # Copyright tridge@samba.org 2000
   4 # Copyright jelmer@samba.org 2005
   5 # released under the GNU GPL
   6
   7 =pod
   8
   9 =head1 NAME
  10
  11 Parse::Pidl::Dump - Dump support
  12
  13 =head1 DESCRIPTION
  14
  15 This module provides functions that can generate IDL code from
  16 internal pidl data structures.
  17
  18 =cut
  19
  20 package Parse::Pidl::Dump;
  21
  22 use Exporter;
  23
  24 use vars qw($VERSION);
  25 $VERSION = '0.01';
  26 @ISA = qw(Exporter);
  27 @EXPORT_OK = qw(DumpType DumpTypedef DumpStruct DumpEnum DumpBitmap DumpUnion DumpFunction);
  28
  29 use strict;
  30 use Parse::Pidl::Util qw(has_property);
  31
  32 my($res);
  33
  34 #####################################################################
  35 # dump a properties list
  36 sub DumpProperties($)
  37 {
  38     my($props) = shift;
  39     my $res = "";
  40
  41     foreach my $d ($props) {
  42         foreach my $k (keys %{$d}) {
  43             if ($k eq "in") {
  44                 $res .= "[in] ";
  45                 next;
  46             }
  47             if ($k eq "out") {
  48                 $res .= "[out] ";
  49                 next;
  50             }
  51             if ($k eq "ref") {
  52                 $res .= "[ref] ";
  53                 next;
  54             }
  55             $res .= "[$k($d->{$k})] ";
  56         }
  57     }
  58     return $res;
  59 }
  60
  61 #####################################################################
  62 # dump a structure element
  63 sub DumpElement($)
  64 {
  65     my($element) = shift;
  66     my $res = "";
  67
  68     (defined $element->{PROPERTIES}) &&
  69         ($res .= DumpProperties($element->{PROPERTIES}));
  70     $res .= DumpType($element->{TYPE});
  71     $res .= " ";
  72         for my $i (1..$element->{POINTERS}) {
  73             $res .= "*";
  74     }
  75     $res .= "$element->{NAME}";
  76         foreach (@{$element->{ARRAY_LEN}}) {
  77                 $res .= "[$_]";
  78         }
  79
  80     return $res;
  81 }
  82
  83 #####################################################################
  84 # dump a struct
  85 sub DumpStruct($)
  86 {
  87     my($struct) = shift;
  88     my($res);
  89
  90     $res .= "struct ";
  91         if ($struct->{NAME}) {
  92                 $res.="$struct->{NAME} ";
  93         }
  94
  95         $res.="{\n";
  96     if (defined $struct->{ELEMENTS}) {
  97                 foreach (@{$struct->{ELEMENTS}}) {
  98                     $res .= "\t" . DumpElement($_) . ";\n";
  99                 }
 100     }
 101     $res .= "}";
 102
 103     return $res;
 104 }
 105
 106
 107 #####################################################################
 108 # dump a struct
 109 sub DumpEnum($)
 110 {
 111     my($enum) = shift;
 112     my($res);
 113
 114     $res .= "enum {\n";
 115
 116     foreach (@{$enum->{ELEMENTS}}) {
 117         if (/^([A-Za-z0-9_]+)[ \t]*\((.*)\)$/) {
 118                 $res .= "\t$1 = $2,\n";
 119         } else {
 120                 $res .= "\t$_,\n";
 121         }
 122     }
 123
 124     $res.= "}";
 125
 126     return $res;
 127 }
 128
 129 #####################################################################
 130 # dump a struct
 131 sub DumpBitmap($)
 132 {
 133     my($bitmap) = shift;
 134     my($res);
 135
 136     $res .= "bitmap {\n";
 137
 138     foreach (@{$bitmap->{ELEMENTS}}) {
 139         if (/^([A-Za-z0-9_]+)[ \t]*\((.*)\)$/) {
 140                 $res .= "\t$1 = $2,\n";
 141         } else {
 142                 die ("Bitmap $bitmap->{NAME} has field $_ without proper value");
 143         }
 144     }
 145
 146     $res.= "}";
 147
 148     return $res;
 149 }
 150
 151
 152 #####################################################################
 153 # dump a union element
 154 sub DumpUnionElement($)
 155 {
 156     my($element) = shift;
 157     my($res);
 158
 159     if (has_property($element, "default")) {
 160         $res .= "[default] ;\n";
 161     } else {
 162         $res .= "[case($element->{PROPERTIES}->{case})] ";
 163         $res .= DumpElement($element), if defined($element);
 164         $res .= ";\n";
 165     }
 166
 167     return $res;
 168 }
 169
 170 #####################################################################
 171 # dump a union
 172 sub DumpUnion($)
 173 {
 174     my($union) = shift;
 175     my($res);
 176
 177     (defined $union->{PROPERTIES}) &&
 178         ($res .= DumpProperties($union->{PROPERTIES}));
 179     $res .= "union {\n";
 180     foreach my $e (@{$union->{ELEMENTS}}) {
 181         $res .= DumpUnionElement($e);
 182     }
 183     $res .= "}";
 184
 185     return $res;
 186 }
 187
 188 #####################################################################
 189 # dump a type
 190 sub DumpType($)
 191 {
 192     my($data) = shift;
 193
 194     if (ref($data) eq "HASH") {
 195                 return DumpStruct($data) if ($data->{TYPE} eq "STRUCT");
 196                 return DumpUnion($data) if ($data->{TYPE} eq "UNION");
 197                 return DumpEnum($data) if ($data->{TYPE} eq "ENUM");
 198                 return DumpBitmap($data) if ($data->{TYPE} eq "BITMAP");
 199     } else {
 200                 return $data;
 201     }
 202 }
 203
 204 #####################################################################
 205 # dump a typedef
 206 sub DumpTypedef($)
 207 {
 208     my($typedef) = shift;
 209     my($res);
 210
 211     $res .= "typedef ";
 212     $res .= DumpType($typedef->{DATA});
 213     $res .= " $typedef->{NAME};\n\n";
 214
 215     return $res;
 216 }
 217
 218 #####################################################################
 219 # dump a typedef
 220 sub DumpFunction($)
 221 {
 222     my($function) = shift;
 223     my($first) = 1;
 224     my($res);
 225
 226     $res .= DumpType($function->{RETURN_TYPE});
 227     $res .= " $function->{NAME}(\n";
 228     for my $d (@{$function->{ELEMENTS}}) {
 229                 unless ($first) { $res .= ",\n"; } $first = 0;
 230                 $res .= DumpElement($d);
 231     }
 232     $res .= "\n);\n\n";
 233
 234     return $res;
 235 }
 236
 237 #####################################################################
 238 # dump a module header
 239 sub DumpInterfaceProperties($)
 240 {
 241     my($header) = shift;
 242     my($data) = $header->{DATA};
 243     my($first) = 1;
 244     my($res);
 245
 246     $res .= "[\n";
 247     foreach my $k (keys %{$data}) {
 248             $first || ($res .= ",\n"); $first = 0;
 249             $res .= "$k($data->{$k})";
 250     }
 251     $res .= "\n]\n";
 252
 253     return $res;
 254 }
 255
 256 #####################################################################
 257 # dump the interface definitions
 258 sub DumpInterface($)
 259 {
 260     my($interface) = shift;
 261     my($data) = $interface->{DATA};
 262     my($res);
 263
 264         $res .= DumpInterfaceProperties($interface->{PROPERTIES});
 265
 266     $res .= "interface $interface->{NAME}\n{\n";
 267     foreach my $d (@{$data}) {
 268         ($d->{TYPE} eq "TYPEDEF") &&
 269             ($res .= DumpTypedef($d));
 270         ($d->{TYPE} eq "FUNCTION") &&
 271             ($res .= DumpFunction($d));
 272     }
 273     $res .= "}\n";
 274
 275     return $res;
 276 }
 277
 278
 279 #####################################################################
 280 # dump a parsed IDL structure back into an IDL file
 281 sub Dump($)
 282 {
 283     my($idl) = shift;
 284     my($res);
 285
 286     $res = "/* Dumped by pidl */\n\n";
 287     foreach my $x (@{$idl}) {
 288         ($x->{TYPE} eq "INTERFACE") &&
 289             ($res .= DumpInterface($x));
 290     }
 291     return $res;
 292 }
 293
 294 1;