7cac705547f79e2350b668269d1698ad81efcf85
[sip-router] / doc / scripts / cdefs2doc / dump_rpcs.pl
1 #!/usr/bin/perl
2
3 #
4 # Generate docs from ser/sip-router RPCs descriptions
5 # (run on files generated by gcc -fdump-translation-unit -c file.c, 
6 #  try -h for help)
7 # E.g.: dump_rpcs.pl --file cfg_core.c  --defs="-DUSE_SCTP ..."
8 #
9 # History:
10 # =======
11 #  2009-10-18  initial version (Andrei Pelinescu-Onciul <andrei@iptel.org>)
12 #
13
14 # Note: uses GCC::TranslationUnit (see cpan) with the following patch:
15 #@@ -251,6 +251,8 @@
16 #           $node->{vector}[$key] = $value;
17 #       } elsif($key =~ /^op (\d+)$/) {
18 #           $node->{operand}[$1] = $value;
19 #+      } elsif ($key eq "val") {
20 #+              push @{$node->{$key}}, ($value) ;
21 #       } else {
22 #           $node->{$key} = $value;
23 #       }
24
25 #
26 # Assumptions:
27 #  - the first array of type rpc_export_t with an initializer is the array
28 #    with the rpc definitions (name, doc, flags a.s.o.). Only
29 #    one rpc_export_t array per file is supported.
30 #  - all the documentation arrays referenced in the rpc export array are
31 #    defined and intialized in the same file.
32 #
33 # Output notes:
34 #  - doc strings are not printed if they cannot be found
35
36
37 use strict;
38 use warnings;
39 use Getopt::Long;
40 use File::Temp qw(:mktemp);
41 use File::Basename;
42 use lib "/home/andrei/perl/modules/share/perl/5.10.1";
43 use GCC::TranslationUnit;
44
45 # text printed if we discover that GCC::TranslationUnit is unpatched
46 my $patch_required="$0 requires a patched GCC:TranslationUnit, see the " .
47                                 "comments at the beginning of the file or try --patch\n";
48 # gcc name
49 my $gcc="gcc";
50 # default defines
51 my $c_defs="-D__CPU_i386 -D__OS_linux -DSER_VER=2099099 -DPKG_MALLOC -DSHM_MEM  -DSHM_MMAP -DDNS_IP_HACK -DUSE_IPV6 -DUSE_MCAST -DUSE_TCP -DUSE_DNS_CACHE -DUSE_DNS_FAILOVER -DUSE_DST_BLACKLIST -DUSE_NAPTR  -DUSE_TLS -DTLS_HOOKS -DFAST_LOCK   -DCC_GCC_LIKE_ASM -DHAVE_GETHOSTBYNAME2 -DHAVE_UNION_SEMUN -DHAVE_SCHED_YIELD -DHAVE_MSG_NOSIGNAL -DHAVE_MSGHDR_MSG_CONTROL -DHAVE_ALLOCA_H -DHAVE_SCHED_SETSCHEDULER -DHAVE_EPOLL -DUSE_SCTP -DNAME='\"ser\"' -DVERSION='\"2.99.99-pre3\"' -DARCH='\"i386\"' -DOS_QUOTED='\"linux\"' -DSER_MOD_INTERFACE";
52
53 # file with gcc syntax tree
54 my $file;
55 my $tmp_file;
56 my $src_fname;
57
58 # type to look for
59 my $var_type="rpc_export_t";
60
61 my $tu;
62 my $node;
63 my $i;
64 my @rpc_exports; # filled with rpc definitions (rpc_export_t)
65 my %rpc_docs; # hash containing rpc_doc_varname -> doc_string mappings
66 my ($rpc_grp_name, $rpc_var_name);
67
68 my ($opt_help, $opt_txt, $opt_is_tu, $dbg, $opt_grp_name, $opt_patch);
69 my $opt_force_grp_name;
70
71
72
73 sub show_patch
74 {
75 my $patch='
76 --- GCC/TranslationUnit.pm.orig 2009-10-16 17:57:51.275963053 +0200
77 +++ GCC/TranslationUnit.pm      2009-10-16 20:17:28.128455959 +0200
78 @@ -251,6 +251,8 @@
79             $node->{vector}[$key] = $value;
80         } elsif($key =~ /^op (\d+)$/) {
81             $node->{operand}[$1] = $value;
82 +       } elsif ($key eq "val") {
83 +               push @{$node->{$key}}, ($value) ;
84         } else {
85             $node->{$key} = $value;
86         }
87 ';
88
89 print $patch;
90 }
91
92
93 sub help
94 {
95         $~ = "USAGE";
96         write;
97
98 format USAGE =
99 Usage @*  -f filename | --file filename  [options...]
100       $0
101 Options:
102          -f        filename    - use filename for input (see also -T/--tu).
103          --file    filename    - same as -f.
104          -h | -? | --help      - this help message.
105          -D | --dbg | --debug  - enable debugging messages.
106          -d | --defs           - defines to be passed on gcc's command line
107                                  (e.g. --defs="-DUSE_SCTP -DUSE_TCP").
108          -g | --grp  name
109          --group     name      - rpc group name used if one cannot be
110                                  autodetected (e.g. no default value 
111                                  intializer present in the file).
112          -G | --force-grp name
113          --force-group    name - force using a rpc group name, even if one
114                                  is autodetected (see also -g).
115          --gcc     gcc_name    - run gcc_name instead of gcc.
116          -t | --txt            - text mode output.
117          -T | --tu             - the input file is in raw gcc translation
118                                  unit format (as produced by
119                                    gcc -fdump-translation-unit -c ). If not
120                                  present it's assumed that the file contains
121                                  C code.
122          -s | --src | --source - name of the source file, needed only if
123                                  the input file is in "raw" translation
124                                  unit format (--tu) and usefull to restrict
125                                  and speed-up the search.
126          --patch               - show patches needed for the
127                                  GCC::TranslationUnit package.
128 .
129
130 }
131
132 # eliminate casts and expressions.
133 # (always go on the first operand)
134 # params: node (GCC::Node)
135 # result: if node is an expression it will walk on operand(0) until first non
136 # expression element is found
137 sub expr_op0{
138         my $n=shift;
139         
140         while(($n->isa('GCC::Node::Expression') || $n->isa('GCC::Node::Unary')) &&
141                         defined $n->operand(0)) {
142                 $n=$n->operand(0);
143         }
144         return $n;
145 }
146
147
148
149 # read command line args
150 if ($#ARGV < 0 || ! GetOptions( 'help|h|?' => \$opt_help,
151                                                                 'file|f=s' => \$file,
152                                                                 'txt|t' => \$opt_txt,
153                                                                 'tu|T' => \$opt_is_tu,
154                                                                 'source|src|s=s' => \$src_fname,
155                                                                 'defs|d=s'=>\$c_defs,
156                                                                 'group|grp|g=s'=>\$opt_grp_name,
157                                                                 'force-group|force-grp|G=s' =>
158                                                                                                         \$opt_force_grp_name,
159                                                                 'dbg|debug|D'=>\$dbg,
160                                                                 'gcc=s' => \$gcc,
161                                                                 'patch' => \$opt_patch) ||
162                 defined $opt_help) {
163         do { show_patch(); exit 0; } if (defined $opt_patch);
164         select(STDERR) if ! defined $opt_help;
165         help();
166         exit((defined $opt_help)?0:1);
167 }
168
169 do { show_patch(); exit 0; } if (defined $opt_patch);
170 do { select(STDERR); help(); exit 1 } if (!defined $file);
171
172 if (! defined $opt_is_tu){
173         # file is not a gcc translation-unit dump
174         # => we have to create one
175         $src_fname=basename($file);
176         $tmp_file = "/tmp/" . mktemp ("dump_translation_unit_XXXXXX");
177         system("$gcc -fdump-translation-unit $c_defs -c $file -o $tmp_file && \
178                         mv \"$src_fname\".001t.tu  $tmp_file") == 0 or
179                 die "$gcc failed to generate a translation unit dump from $file";
180         $tu=GCC::TranslationUnit::Parser->parsefile($tmp_file);
181         print(STDERR "src name $src_fname\n") if $dbg;
182         unlink($tmp_file, "$tmp_file.o");
183 }else{
184         $tu=GCC::TranslationUnit::Parser->parsefile($file);
185 }
186
187 print(STDERR "Parsing file $file...\n") if $dbg;
188 #
189 # function_decl: name, type, srcp (source), chan?, body?, link (e.g. extern)
190 # parm_decl: name, type, scpe, srcp, chan, argt, size, algn, used
191 # field_decl: name, type, scpe (scope), srcp, size, algn, bpos (bit pos?)
192 #
193 # array_type: size, algn, elts (elements?), domn ?
194 #
195 #
196 # name as string $node->name->identifier
197 #
198 # E.g.: static cfg_def_t tcp_cfg_def[]= {...}
199 #                        ^^^^^^^^^^^
200 #
201 # @7695 var_decl:  name: @7705   type: @7706    srcp: tcp_options.c:51
202 #                  chan: @7707    init: @7708    size: @7709
203 #                  algn: 256      used: 1
204
205 # @7705 (var name)      identifier_node strg: tcp_cfg_def lngt 11
206 # @7706 (var type)      array_type: size:@7709 algn: 32 elts: @2265 domn: @7718
207 # @7707 (? next ?  )    function_decl: ....
208 # @7708 (intializer)    constructor: lngt: 25
209 #                                    idx : @20      val : @7723    [...]
210 # @7709                 interget_cst: type: @11 low: 5600
211 #
212 # @2265 (array type)    record_type: name: @2256    unql: @2255    size: @2002
213 #                                    algn: 32       tag : struct   flds: @2263
214 # @2256 (type)          type_decl: name: @2264    type: @2265    srcp: cfg.h:73
215 #                                  chan: @2266
216 # @2264 (name)                  identifier_node:  strg: cfg_def_t
217
218 print(STDERR "Searching...\n") if $dbg;
219 $i=0;
220 # iterate on the entire nodes array (returned by gcc), but skipping node 0
221 SEARCH: for $node (@{$tu}[1..$#{$tu}]) {
222         $i++;
223         while($node) {
224                 if (
225                         @rpc_exports == 0 &&  # parse it only once
226                         $node->isa('GCC::Node::var_decl') &&
227                         $node->type->isa('GCC::Node::array_type')  &&
228                         (! defined $src_fname || $src_fname eq "" ||
229                                 $node->source=~"$src_fname")
230                         ){
231                         # found a var decl. that it's an array
232                         # check if it's a valid array type
233                         next if (!(     $node->type->can('elements') &&
234                                                 defined $node->type->elements &&
235                                                 $node->type->elements->can('name') &&
236                                                 defined $node->type->elements->name &&
237                                                 $node->type->elements->name->can('name') &&
238                                                 defined $node->type->elements->name->name)
239                                         );
240                         my $type_name= $node->type->elements->name->name->identifier;
241                         if ($type_name eq $var_type) {
242                                 if ($node->can('initial') && defined $node->initial) {
243                                         my %c1=%{$node->initial};
244                                         $rpc_var_name=$node->name->identifier;
245                                         if (defined $c1{val}){
246                                                 my $c1_el;
247                                                 die $patch_required if (ref($c1{val}) ne "ARRAY");
248                                                 # iterate on array elem., level 1( top {} )
249                                                 # each element is a constructor.
250                                                 #    { name, callback, doc_var, flags }
251                                                 for $c1_el (@{$c1{val}}) {
252                                                         # finally we are a the lower {} initializer:
253                                                         #    { name, callback, doc_var, flags }
254                                                         my %c2=%{$c1_el};
255                                                         my @el=@{$c2{val}};
256                                                         my ($name_n, $callback_n, $docvar_n, $flags_n)=@el;
257                                                         my ($name, $docvar, $flags);
258                                                         if ($name_n->isa('GCC::Node::integer_cst')){
259                                                                 printf(" ERROR: integer non-0 name (%d)\n",
260                                                                                 $name_n->low) if ($name_n->low!=0);
261                                                                 last SEARCH;
262                                                         }
263                                                         $name_n=expr_op0($name_n);
264                                                         $name= $name_n->string;
265                                                         $flags=$flags_n->low;
266                                                         # eliminate casts and expressions
267                                                         # (always go on the first operand)
268                                                         $docvar_n=expr_op0($docvar_n);
269                                                         $docvar=$docvar_n->name->identifier;
270                                                         push @rpc_exports, [$name, $docvar, $flags];
271                                                 }
272                                         }
273                                 }
274                         }
275                 }
276         } continue {
277                 if ($node->can('chain')){
278                         $node = $node->chain;
279                 }else{
280                         last;
281                 }
282         }
283 }
284
285
286 print(STDERR "Searching doc vars...\n") if $dbg;
287 # look for docvars
288 # re-iterate on the entire nodes array (returned by gcc), but skipping node 0
289 DOC: for $node (@{$tu}[1..$#{$tu}]) {
290         while(@rpc_exports>0 && $node) {
291                 if (
292                         $node->isa('GCC::Node::var_decl') &&
293                         $node->type->isa('GCC::Node::array_type')  &&
294                         (! defined $src_fname || $src_fname eq "" ||
295                                 $node->source=~"$src_fname") &&
296                         # var name is among the one we look for
297                         grep(${$_}[1] eq $node->name->identifier, @rpc_exports) > 0
298                         ){
299                         print(STDERR "found a candidate:", $node->name->identifier, "\n")
300                                 if $dbg;
301                         # found a var decl. that it's an array
302                         # check if it's a valid array type
303                         next if (!(     $node->type->can('elements') &&
304                                                 defined $node->type->elements)
305                                         );
306                         if ($node->can('initial') && defined $node->initial){
307                                 my %c1=%{$node->initial};
308                                 my $doc_n = ${$c1{val}}[0];
309                                 if (defined $doc_n){
310                                         my $doc=expr_op0($doc_n)->string;
311                                         $rpc_docs{$node->name->identifier}=$doc;
312                                         last DOC if ( @rpc_exports == keys %rpc_docs );
313                                 }
314                         }
315                 }
316         } continue {
317                 if ($node->can('chain')){
318                         $node = $node->chain;
319                 }else{
320                         last;
321                 }
322         }
323 }
324
325
326 print(STDERR "Done.\n") if $dbg;
327
328 my ($name, $flags, $desc);
329 my $extra_txt;
330
331 if (@rpc_exports > 0){
332         my $l;
333         $i=0;
334         if (@rpc_exports != keys %rpc_docs){
335                 print STDERR "Warning: missing ", @rpc_exports - keys %rpc_docs,
336                         " doc variables definitions\n";
337         }
338         # dump the configuration in txt mode
339         if (defined $opt_force_grp_name) {
340                 $rpc_grp_name=$opt_force_grp_name;
341         }elsif (!defined $rpc_grp_name && defined $opt_grp_name) {
342                 $rpc_grp_name=$opt_grp_name;
343         }
344         $~ = "HEADER"; write;
345         $~ = "RPCLINE" ;
346         for $l (@rpc_exports){
347                 ($name, $desc, $flags)=@{$l};
348                 $extra_txt="";
349                 $desc=(defined $rpc_docs{$desc} && $rpc_docs{$desc} ne "")?
350                                 $rpc_docs{$desc}:
351                                 "Documentation missing ($desc).";
352                 $i++;
353                 $extra_txt.="Returns an array." if ($flags & 1 );
354                 # generate txt description
355                 write;
356         }
357 }else{
358         die "no rpc exports found in $file\n";
359 }
360
361
362 sub valid_grp_name
363 {
364         my $name=shift;
365         return defined $name && $name ne "";
366 }
367
368
369 format HEADER =
370 RPC Exports@*
371 (valid_grp_name $rpc_grp_name) ? " for " . $rpc_grp_name : ""
372 ===========@*
373 "=" x length((valid_grp_name $rpc_grp_name)?" for " . $rpc_grp_name : "")
374
375 @||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
376 "[ this file is autogenerated, do not edit ]"
377
378
379 .
380
381 format RPCLINE =
382 @>. @*
383 $i, $name
384 ~~      ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
385         $desc
386 ~~      ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
387         $extra_txt
388
389 .