src/xbt_log_extract_hierarchy

   1 #! /usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 my $debug = 0;
   7
   8
   9 # Search for calls to macros defining new channels, and prepare the tree representation
  10 my %ancestor;
  11 my %desc;
  12 # $ancestor{"toto"} is the ancestor of the toto channel
  13 # $desc{"toto"} is its description
  14
  15 sub parse_file {
  16     my $filename = shift;
  17
  18     my $data = "";
  19
  20     print "Parse $filename\n" if $debug;
  21     open IN, "$filename" || die "Cannot read $filename: $!\n";
  22     while (<IN>) {
  23         $data .= $_;
  24     }
  25     close IN;
  26
  27     # Purge $data from C comments
  28     $data =~ s|/\*.*?\*/||sg;
  29
  30     # C++ comments are forbiden in SG for portability reasons, but deal with it anyway
  31     $data =~ s|//.*$||mg;
  32
  33     while ($data =~ s/^.*?XBT_LOG_NEW(_DEFAULT)?_(SUB)?CATEGORY\(//s) {
  34         $data =~ s/([^"]*"[^"]*")\)//s || die "unparsable macro: $data"; # ]]);
  35         my $ctn = $1;
  36
  37         # cleanup the content
  38         $ctn =~ s/ *\n//gs;
  39         $ctn =~ s/,\s*"/,"/gs;
  40         $ctn =~ s/"\s*$/"/gs;
  41         $ctn =~ s/,\s*/,/gs;
  42         my @elms_tmp=split (/,/,$ctn);
  43         my @elms;
  44         print "ctn=$ctn\n" if $debug > 1;
  45         # There may be some ',' in the description. Remerge the stuff like: "description, really"
  46         while (1) {
  47             my $acc = shift @elms_tmp;
  48             last unless defined $acc;
  49             if ($acc =~ /^"/) { # ") {
  50                 while (shift @elms_tmp) {
  51                    $acc .= $_;
  52                 }
  53                 die "Unparsable content: $ctn\n"
  54                    unless ($acc =~ s/^"(.*)"$/$1/);
  55             }
  56             print "  seen $acc\n" if $debug > 1;
  57             push @elms, $acc;
  58         }
  59
  60         my ($name,$anc,$desc);
  61         # build the tree, checking for name conflict
  62         if (scalar(@elms) eq 3) {
  63            $name = $elms[0];
  64            $anc  = $elms[1];
  65            $desc = $elms[2];
  66         } elsif (scalar(@elms) eq 2) {
  67            $name = $elms[0];
  68            $anc  = "XBT_LOG_ROOT_CAT";
  69            $desc = $elms[1];
  70         } else {
  71            my $l = scalar(@elms);
  72            my $s = "";
  73            map {$s .= $_;} @elms;
  74            die "Unparsable content: $ctn (length=$l) (content=$s)\n";
  75         }
  76         $name =~ s/^\s*(\S*)\s*$/$1/; # trim
  77         $anc  =~ s/^\s*(\S*)\s*$/$1/; # trim
  78         die "ERROR: Category name conflict: $name used several times\n"
  79            if defined ($ancestor{$name}) && $ancestor{$name} ne $anc &&
  80               defined ($desc{$name}) && $desc{$name} ne $desc;
  81        $ancestor{$name}=$anc;
  82        $desc{$name}=$desc;
  83
  84        print " $name -> $anc\n" if $debug;
  85    }
  86 }
  87 # Retrieve all the file names, and add their content to $data
  88 my $data;
  89 open FILES, "find -name '*.c'|" || die "Cannot search for the source file names; $!\n";
  90 while (my $file=<FILES>) {
  91     chomp $file;
  92     parse_file($file);
  93 }
  94 close FILES;
  95
  96 # Display the tree, looking for disconnected elems
  97 my %used;
  98
  99 sub display_subtree {
 100     my $name=shift;
 101     my $indent=shift;
 102
 103     $used{$name} = 1;
 104     unless ($name eq "XBT_LOG_ROOT_CAT") { # do not display the root
 105         print "$indent - $name: ".($desc{$name}|| "(undocumented)")."\n";
 106     }
 107     foreach my $cat (grep {$ancestor{$_} eq $name} sort keys %ancestor) {
 108         display_subtree($cat,"$indent  ");
 109     }
 110 }
 111
 112 display_subtree("XBT_LOG_ROOT_CAT","");
 113
 114 map {warn "Category $_ does not seem to be connected to the root (anc=$ancestor{$_})\n";} grep {!defined $used{$_}} sort keys %ancestor;