Logo AND Algorithmique Numérique Distribuée

Public GIT Repository
mv include/xbt/context.h src/include/xbt/context.h since users shouldn't mess with it
[simgrid.git] / 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;