doc: dump_rpcs.pl: support for docbook output
[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, $opt_docbook);
70
71 # default output formats
72 my $output_format_header="HEADER";
73 my $output_format_footer="FOOTER";
74 my $output_format_rpcline="RPCLINE";
75
76
77 sub show_patch
78 {
79 my $patch='
80 --- GCC/TranslationUnit.pm.orig 2009-10-16 17:57:51.275963053 +0200
81 +++ GCC/TranslationUnit.pm      2009-10-16 20:17:28.128455959 +0200
82 @@ -251,6 +251,8 @@
83             $node->{vector}[$key] = $value;
84         } elsif($key =~ /^op (\d+)$/) {
85             $node->{operand}[$1] = $value;
86 +       } elsif ($key eq "val") {
87 +               push @{$node->{$key}}, ($value) ;
88         } else {
89             $node->{$key} = $value;
90         }
91 ';
92
93 print $patch;
94 }
95
96
97 sub help
98 {
99         $~ = "USAGE";
100         write;
101
102 format USAGE =
103 Usage @*  -f filename | --file filename  [options...]
104       $0
105 Options:
106          -f        filename    - use filename for input (see also -T/--tu).
107          --file    filename    - same as -f.
108          -h | -? | --help      - this help message.
109          -D | --dbg | --debug  - enable debugging messages.
110          -d | --defs           - defines to be passed on gcc's command line
111                                  (e.g. --defs="-DUSE_SCTP -DUSE_TCP").
112          -g | --grp  name
113          --group     name      - rpc group name used if one cannot be
114                                  autodetected (e.g. no default value 
115                                  intializer present in the file).
116          -G | --force-grp name
117          --force-group    name - force using a rpc group name, even if one
118                                  is autodetected (see also -g).
119          --gcc     gcc_name    - run gcc_name instead of gcc.
120          -t | --txt            - text mode output.
121          --docbook | --xml     - docbook output (xml).
122          -T | --tu             - the input file is in raw gcc translation
123                                  unit format (as produced by
124                                    gcc -fdump-translation-unit -c ). If not
125                                  present it's assumed that the file contains
126                                  C code.
127          -s | --src | --source - name of the source file, needed only if
128                                  the input file is in "raw" translation
129                                  unit format (--tu) and usefull to restrict
130                                  and speed-up the search.
131          --patch               - show patches needed for the
132                                  GCC::TranslationUnit package.
133 .
134
135 }
136
137
138
139 # escape a string for xml use
140 # params: string to be escaped
141 # return: escaped string
142 sub xml_escape{
143         my $s=shift;
144         my %escapes = (
145                 '"' => '&quot;',
146                 "'" => '&apos;',
147                 '&' => '&amp;',
148                 '<' => '&lt;',
149                 '>' => '&gt;'
150         );
151         
152         $s=~s/(["'&<>])/$escapes{$1}/g;
153         return $s;
154 }
155
156
157
158 # escape a string according with the output requirements
159 # params: string to be escaped
160 # return: escaped string
161 sub output_esc{
162         return xml_escape(shift) if defined $opt_docbook;
163         return shift;
164 }
165
166
167
168 # eliminate casts and expressions.
169 # (always go on the first operand)
170 # params: node (GCC::Node)
171 # result: if node is an expression it will walk on operand(0) until first non
172 # expression element is found
173 sub expr_op0{
174         my $n=shift;
175         
176         while(($n->isa('GCC::Node::Expression') || $n->isa('GCC::Node::Unary')) &&
177                         defined $n->operand(0)) {
178                 $n=$n->operand(0);
179         }
180         return $n;
181 }
182
183
184
185 # read command line args
186 if ($#ARGV < 0 || ! GetOptions( 'help|h|?' => \$opt_help,
187                                                                 'file|f=s' => \$file,
188                                                                 'txt|t' => \$opt_txt,
189                                                                 'docbook|xml' => \$opt_docbook,
190                                                                 'tu|T' => \$opt_is_tu,
191                                                                 'source|src|s=s' => \$src_fname,
192                                                                 'defs|d=s'=>\$c_defs,
193                                                                 'group|grp|g=s'=>\$opt_grp_name,
194                                                                 'force-group|force-grp|G=s' =>
195                                                                                                         \$opt_force_grp_name,
196                                                                 'dbg|debug|D'=>\$dbg,
197                                                                 'gcc=s' => \$gcc,
198                                                                 'patch' => \$opt_patch) ||
199                 defined $opt_help) {
200         do { show_patch(); exit 0; } if (defined $opt_patch);
201         select(STDERR) if ! defined $opt_help;
202         help();
203         exit((defined $opt_help)?0:1);
204 }
205
206 do { show_patch(); exit 0; } if (defined $opt_patch);
207 do { select(STDERR); help(); exit 1 } if (!defined $file);
208
209 if (defined $opt_txt){
210         $output_format_header="HEADER";
211         $output_format_footer="FOOTER";
212         $output_format_rpcline="RPCLINE";
213 }elsif (defined $opt_docbook){
214         $output_format_header="DOCBOOK_HEADER";
215         $output_format_footer="DOCBOOK_FOOTER";
216         $output_format_rpcline="DOCBOOK_RPCLINE";
217 }
218
219 if (! defined $opt_is_tu){
220         # file is not a gcc translation-unit dump
221         # => we have to create one
222         $src_fname=basename($file);
223         $tmp_file = "/tmp/" . mktemp ("dump_translation_unit_XXXXXX");
224         system("$gcc -fdump-translation-unit $c_defs -c $file -o $tmp_file && \
225                         mv \"$src_fname\".001t.tu  $tmp_file") == 0 or
226                 die "$gcc failed to generate a translation unit dump from $file";
227         $tu=GCC::TranslationUnit::Parser->parsefile($tmp_file);
228         print(STDERR "src name $src_fname\n") if $dbg;
229         unlink($tmp_file, "$tmp_file.o");
230 }else{
231         $tu=GCC::TranslationUnit::Parser->parsefile($file);
232 }
233
234 print(STDERR "Parsing file $file...\n") if $dbg;
235 #
236 # function_decl: name, type, srcp (source), chan?, body?, link (e.g. extern)
237 # parm_decl: name, type, scpe, srcp, chan, argt, size, algn, used
238 # field_decl: name, type, scpe (scope), srcp, size, algn, bpos (bit pos?)
239 #
240 # array_type: size, algn, elts (elements?), domn ?
241 #
242 #
243 # name as string $node->name->identifier
244 #
245 # E.g.: static cfg_def_t tcp_cfg_def[]= {...}
246 #                        ^^^^^^^^^^^
247 #
248 # @7695 var_decl:  name: @7705   type: @7706    srcp: tcp_options.c:51
249 #                  chan: @7707    init: @7708    size: @7709
250 #                  algn: 256      used: 1
251
252 # @7705 (var name)      identifier_node strg: tcp_cfg_def lngt 11
253 # @7706 (var type)      array_type: size:@7709 algn: 32 elts: @2265 domn: @7718
254 # @7707 (? next ?  )    function_decl: ....
255 # @7708 (intializer)    constructor: lngt: 25
256 #                                    idx : @20      val : @7723    [...]
257 # @7709                 interget_cst: type: @11 low: 5600
258 #
259 # @2265 (array type)    record_type: name: @2256    unql: @2255    size: @2002
260 #                                    algn: 32       tag : struct   flds: @2263
261 # @2256 (type)          type_decl: name: @2264    type: @2265    srcp: cfg.h:73
262 #                                  chan: @2266
263 # @2264 (name)                  identifier_node:  strg: cfg_def_t
264
265 print(STDERR "Searching...\n") if $dbg;
266 $i=0;
267 # iterate on the entire nodes array (returned by gcc), but skipping node 0
268 SEARCH: for $node (@{$tu}[1..$#{$tu}]) {
269         $i++;
270         while($node) {
271                 if (
272                         @rpc_exports == 0 &&  # parse it only once
273                         $node->isa('GCC::Node::var_decl') &&
274                         $node->type->isa('GCC::Node::array_type')  &&
275                         (! defined $src_fname || $src_fname eq "" ||
276                                 $node->source=~"$src_fname")
277                         ){
278                         # found a var decl. that it's an array
279                         # check if it's a valid array type
280                         next if (!(     $node->type->can('elements') &&
281                                                 defined $node->type->elements &&
282                                                 $node->type->elements->can('name') &&
283                                                 defined $node->type->elements->name &&
284                                                 $node->type->elements->name->can('name') &&
285                                                 defined $node->type->elements->name->name)
286                                         );
287                         my $type_name= $node->type->elements->name->name->identifier;
288                         if ($type_name eq $var_type) {
289                                 if ($node->can('initial') && defined $node->initial) {
290                                         my %c1=%{$node->initial};
291                                         $rpc_var_name=$node->name->identifier;
292                                         if (defined $c1{val}){
293                                                 my $c1_el;
294                                                 die $patch_required if (ref($c1{val}) ne "ARRAY");
295                                                 # iterate on array elem., level 1( top {} )
296                                                 # each element is a constructor.
297                                                 #    { name, callback, doc_var, flags }
298                                                 for $c1_el (@{$c1{val}}) {
299                                                         # finally we are a the lower {} initializer:
300                                                         #    { name, callback, doc_var, flags }
301                                                         my %c2=%{$c1_el};
302                                                         my @el=@{$c2{val}};
303                                                         my ($name_n, $callback_n, $docvar_n, $flags_n)=@el;
304                                                         my ($name, $docvar, $flags);
305                                                         if ($name_n->isa('GCC::Node::integer_cst')){
306                                                                 printf(" ERROR: integer non-0 name (%d)\n",
307                                                                                 $name_n->low) if ($name_n->low!=0);
308                                                                 last SEARCH;
309                                                         }
310                                                         $name_n=expr_op0($name_n);
311                                                         $name= $name_n->string;
312                                                         $flags=$flags_n->low;
313                                                         # eliminate casts and expressions
314                                                         # (always go on the first operand)
315                                                         $docvar_n=expr_op0($docvar_n);
316                                                         $docvar=$docvar_n->name->identifier;
317                                                         push @rpc_exports, [$name, $docvar, $flags];
318                                                 }
319                                         }
320                                 }
321                         }
322                 }
323         } continue {
324                 if ($node->can('chain')){
325                         $node = $node->chain;
326                 }else{
327                         last;
328                 }
329         }
330 }
331
332
333 print(STDERR "Searching doc vars...\n") if $dbg;
334 # look for docvars
335 # re-iterate on the entire nodes array (returned by gcc), but skipping node 0
336 DOC: for $node (@{$tu}[1..$#{$tu}]) {
337         while(@rpc_exports>0 && $node) {
338                 if (
339                         $node->isa('GCC::Node::var_decl') &&
340                         $node->type->isa('GCC::Node::array_type')  &&
341                         (! defined $src_fname || $src_fname eq "" ||
342                                 $node->source=~"$src_fname") &&
343                         # var name is among the one we look for
344                         grep(${$_}[1] eq $node->name->identifier, @rpc_exports) > 0
345                         ){
346                         print(STDERR "found a candidate:", $node->name->identifier, "\n")
347                                 if $dbg;
348                         # found a var decl. that it's an array
349                         # check if it's a valid array type
350                         next if (!(     $node->type->can('elements') &&
351                                                 defined $node->type->elements)
352                                         );
353                         if ($node->can('initial') && defined $node->initial){
354                                 my %c1=%{$node->initial};
355                                 my $doc_n = ${$c1{val}}[0];
356                                 if (defined $doc_n){
357                                         my $doc=expr_op0($doc_n)->string;
358                                         $rpc_docs{$node->name->identifier}=$doc;
359                                         last DOC if ( @rpc_exports == keys %rpc_docs );
360                                 }
361                         }
362                 }
363         } continue {
364                 if ($node->can('chain')){
365                         $node = $node->chain;
366                 }else{
367                         last;
368                 }
369         }
370 }
371
372
373 print(STDERR "Done.\n") if $dbg;
374
375 my ($name, $flags, $desc);
376 my $extra_txt;
377
378 if (@rpc_exports > 0){
379         my $l;
380         $i=0;
381         if (@rpc_exports != keys %rpc_docs){
382                 print STDERR "Warning: missing ", @rpc_exports - keys %rpc_docs,
383                         " doc variables definitions\n";
384         }
385         # dump the configuration in txt mode
386         if (defined $opt_force_grp_name) {
387                 $rpc_grp_name=output_esc($opt_force_grp_name);
388         }elsif (!defined $rpc_grp_name && defined $opt_grp_name) {
389                 $rpc_grp_name=output_esc($opt_grp_name);
390         }
391         $~ = $output_format_header; write;
392         $~ = $output_format_rpcline ;
393         for $l (@rpc_exports){
394                 ($name, $desc, $flags)=@{$l};
395                 $extra_txt="";
396                 $desc=(defined $rpc_docs{$desc} && $rpc_docs{$desc} ne "")?
397                                 output_esc($rpc_docs{$desc}):
398                                 output_esc("Documentation missing ($desc).");
399                 $i++;
400                 $extra_txt.=output_esc("Returns an array.") if ($flags & 1 );
401                 $name=output_esc($name);
402                 # generate txt description
403                 write;
404         }
405         $~ = $output_format_footer; write;
406 }else{
407         die "no rpc exports found in $file\n";
408 }
409
410
411 sub valid_grp_name
412 {
413         my $name=shift;
414         return defined $name && $name ne "";
415 }
416
417
418 format HEADER =
419 RPC Exports@*
420 (valid_grp_name $rpc_grp_name) ? " for " . $rpc_grp_name : ""
421 ===========@*
422 "=" x length((valid_grp_name $rpc_grp_name)?" for " . $rpc_grp_name : "")
423
424 @||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
425 "[ this file is autogenerated, do not edit ]"
426
427
428 .
429
430 format FOOTER =
431 .
432
433 format RPCLINE =
434 @>. @*
435 $i, $name
436 ~~      ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
437         $desc
438 ~~      ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
439         $extra_txt
440
441 .
442
443 format DOCBOOK_HEADER =
444 <?xml version="1.0" encoding="UTF-8"?>
445 <!-- this file is autogenerated, do not edit! -->
446 <!DOCTYPE section PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN"
447         "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd">
448 <chapter id="rpc_exports@*">
449 (valid_grp_name $rpc_grp_name) ? "." . $rpc_grp_name : ""
450         <title>
451 RPC Exports@*
452 (valid_grp_name $rpc_grp_name) ? " for " . $rpc_grp_name : ""
453         </title>
454
455
456 .
457
458 format DOCBOOK_FOOTER =
459 </chapter>
460 .
461
462
463 format DOCBOOK_RPCLINE =
464 <section id="@*"><title>@*</title>
465 $name, $name
466 <para>
467 ~~      ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
468         $desc
469 </para>
470 <para>
471 ~~      ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
472         $extra_txt
473 </para>
474 </section>
475
476 .