status/mono-stats

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use XML::Parser;
   5 #use Data::Dumper;
   6
   7 # command line arguments: shell globs for the files containing the info
   8 # for the ms assemblyes and mono's
   9 my $msglob = shift || 'ms*.xml';
  10 my $monoglob = shift || 'mono*.xml';
  11 # maintainers file
  12 my $mfile = 'maintainers.xml';
  13 my $curfile;
  14
  15 # positions in array refs
  16 use constant MNAME => 0;
  17 use constant MASSEMBLY => 1;
  18 use constant MCLASS => 2;
  19
  20 use constant MAINTAINER => 0;
  21 use constant PERCENT => 1;
  22 use constant HASH => 2;
  23 # we store all the data in some global hash tables
  24 # $email => [$name, \%assembly, \%class]
  25 my %maintainer;
  26
  27 # $name => [$maintainer, $percent, \%classes];
  28 my %assembly;
  29
  30 # $name => [$maintainer, $percent, \%methods]
  31 my %class;
  32
  33 # my parsing state machine
  34 my @status;
  35 # current maintainer, class and assembly pointers
  36 my ($curm, $curc, $cura);
  37 my $mono = 0;
  38 my $namespace = '';
  39 my %status_action = (
  40         MAINTAINERS => sub {
  41                 my ($elem, %attrs) = @_;
  42                 malformed ($mfile, $elem, 'maintainers', \@status);
  43                 push @status, 'DUDE';
  44         },
  45         DUDE => sub {
  46                 my ($elem, %attrs) = @_;
  47                 malformed ($mfile, $elem, 'person', \@status);
  48                 foreach(qw(email name)) {die "$_ not included in person\n" unless defined $attrs{$_}}
  49                 $curm = $maintainer{$attrs{email}} = [$attrs{name}, {}, {}];
  50                 push @status, 'DUDE_CONTENT';
  51         },
  52         DUDE_CONTENT => sub {
  53                 my ($elem, %attrs) = @_;
  54                 malformed ($mfile, $elem, 'class|assembly', \@status);
  55                 if ($elem eq 'class') {
  56                         $curm->[MCLASS]->{$attrs{name}} = '';
  57                 } elsif ($elem eq 'assembly') {
  58                         $curm->[MASSEMBLY]->{$attrs{name}} = '';
  59                 }
  60                 push @status, 'DUDE_CONTENT';
  61         },
  62         ASSEMBLY => sub {
  63                 my ($elem, %attrs) = @_;
  64                 malformed ($curfile, $elem, 'assembly', \@status);
  65                 $namespace = '';
  66                 $cura = $assembly{$attrs{name}} = ['', 0, {}];
  67                 push @status, 'NAMESPACE';
  68         },
  69         NAMESPACE => sub {
  70                 my ($elem, %attrs) = @_;
  71                 malformed ($curfile, $elem, 'namespace', \@status);
  72                 $namespace = $attrs{name};
  73                 push @status, 'CLASS';
  74         },
  75         CLASS => sub {
  76                 my ($elem, %attrs) = @_;
  77                 malformed ($curfile, $elem, 'class|valueType|interface', \@status);
  78                 if ($elem eq 'class') {
  79                         my $name = $namespace ? $namespace.".".$attrs{name} : $attrs{name};
  80                         if ($mono) {
  81                                 warn "mono implements non exisistent class $name\n"
  82                                         if (!exists $class{$name});
  83                                 $curc = $class{$name};
  84                         } else {
  85                                 $curc = $class{$name} = ['', 0, {}];
  86                         }
  87                         $cura->[HASH]->{$name} = $mono;
  88                         push @status, 'METHOD';
  89                 } else {
  90                         push @status, 'METHOD';
  91                 }
  92         },
  93         METHOD => sub {
  94                 my ($elem, %attrs) = @_;
  95                 malformed ($curfile, $elem, 'method|field|valueType', \@status);
  96                 if ($elem eq 'method') {
  97                         my $name = $attrs{signature};
  98                         if ($mono) {
  99                                 warn "mono implements non exisistent method $name\n"
 100                                         if (!exists $curc->[HASH]->{$name});
 101                         }
 102                         $curc->[HASH]->{$name} = $mono;
 103                         push @status, 'METHOD';
 104                 } else {
 105                         push @status, 'METHOD';
 106                 }
 107         },
 108 );
 109
 110
 111 my $parser = new XML::Parser (Handlers => {Start => \&handle_tag, End => \&end_tag});
 112
 113 # parse the maintainers info
 114 if ($mfile) {
 115         @status = 'MAINTAINERS';
 116         $parser->parsefile($mfile);
 117         #print Dumper(\%maintainer);
 118 }
 119
 120 foreach (glob($msglob)) {
 121         $curfile = $_;
 122         @status = 'ASSEMBLY';
 123         $mono = 0;
 124         $parser->parsefile($_);
 125 }
 126
 127 foreach (glob($monoglob)) {
 128         $curfile = $_;
 129         @status = 'ASSEMBLY';
 130         $mono = 1;
 131         $parser->parsefile($_);
 132 }
 133
 134 create_stats();
 135 create_html();
 136 #print Dumper(\%assembly);
 137 #print Dumper(\%class);
 138 exit(0);
 139
 140 sub malformed {
 141         my ($file, $elem, $match, $data) = @_;
 142         unless ($elem =~ /^$match$/) {
 143                 $data = Dumper($data) if defined $data;
 144                 die "file $file malformed ($elem instead of $match) $data\n"
 145         }
 146 }
 147
 148 sub handle_tag {
 149         my $parser = shift @_;
 150         my $status = $status[-1];
 151         die "status $status unknown" unless exists $status_action{$status};
 152         $status_action{$status}->(@_);
 153 }
 154
 155 sub end_tag {
 156         my $last = pop @status;
 157         # print STDERR "done with $last\n";
 158 }
 159
 160 sub assign_maintainer {
 161         my ($m, $from, $to, $type) = @_;
 162         foreach (keys %$from) {
 163                 if (!exists $to->{$_}) {
 164                         warn "$m maintains unknown $type $_\n";
 165                         # fixup to avoid warnings
 166                         $to->{$_}->[MAINTAINER] = $m;
 167                         $to->{$_}->[PERCENT] = 0;
 168                         $to->{$_}->[HASH] = {};
 169                 } else {
 170                         warn "$to->{$_}->[MAINTAINER] already maintains $_ (now $m)\n" if $to->{$_}->[MAINTAINER];
 171                         $to->{$_}->[MAINTAINER] = $m;
 172                 }
 173         }
 174 }
 175
 176 sub completeness {
 177         my $hash = shift @_;
 178         my $total = keys %$hash;
 179         my $done = 0;
 180         map {$done += $_} values %$hash;
 181         return 0 unless $total;
 182         return int($done*100/$total);
 183 }
 184
 185 sub create_stats {
 186         # set maintainer field in assembly and class hashes
 187         foreach my $m (sort keys %maintainer) {
 188                 assign_maintainer ($m, $maintainer{$m}->[MASSEMBLY], \%assembly, 'assembly');
 189                 assign_maintainer ($m, $maintainer{$m}->[MCLASS], \%class, 'class');
 190         }
 191         # assign completeness percent
 192         foreach my $ass (values %assembly) {
 193                 $ass->[PERCENT] = completeness ($ass->[HASH]);
 194         }
 195         foreach my $class (values %class) {
 196                 $class->[PERCENT] = completeness ($class->[HASH]);
 197         }
 198 }
 199
 200 sub html_header {
 201         my ($title) = @_;
 202 return <<"EOF";
 203 <html><head><title>$title</title></head><body bgcolor="#ffffff">
 204 <h1 ALIGN=center>$title</H1>
 205 EOF
 206
 207 }
 208
 209 sub unimplemented ($) {
 210         my ($c) = @_;
 211         my $id = $c;
 212         $id =~ tr/./-/;
 213         return "<A HREF='per-unimplemented.html#$id'>$c</A>";
 214 }
 215
 216 sub create_html {
 217
 218         open(F, ">per-assembly.html") || die "Cannot open file: $!";
 219         print F html_header("Mono - per-assembly stats");
 220         print F "<TABLE BORDER=1><TR><TH>Assembly<TH>Maintainer<TH>Completion\n";
 221         foreach my $ass (sort keys %assembly) {
 222                 print F "\t<TR><TD>", join('<TD>', $ass, $assembly{$ass}->[MAINTAINER], $assembly{$ass}->[PERCENT]), "\n";
 223         }
 224         print F "</TABLE>\n";
 225         print F "</body></html>\n";
 226         close(F);
 227
 228         # per maintainer info
 229         open(F, ">per-maintainer.html") || die "Cannot open file: $!";
 230         print F html_header("Mono - per-maintainer stats");
 231         print F "<TABLE BORDER=1><TR><TH>Maintainer<TH>Class<TH>Completion\n";
 232         foreach my $m (sort keys %maintainer) {
 233                 my @classes = sort keys %{$maintainer{$m}->[MCLASS]};
 234                 my $count = @classes;
 235                 foreach my $c (@classes) {
 236                         my $start = $count?"\t<TR><TD ROWSPAN=$count>$m<TD>":"\t<TR><TD>";
 237                         $count = 0;
 238                         print F $start, join('<TD>', $c, $class{$c}->[PERCENT]), "\n";
 239                 }
 240         }
 241         my @unmantained = sort grep {!$class{$_}->[MAINTAINER]} keys %class;
 242         my $count = @unmantained;
 243         foreach my $c (@unmantained) {
 244                 my $start = $count?"\t<TR><TD ROWSPAN=$count>Unmantained<TD>":"\t<TR><TD>";
 245                 $count = 0;
 246                 print F $start, join('<TD>', $c, $class{$c}->[PERCENT]), "\n";
 247         }
 248         print F "</TABLE>\n";
 249         print F "</body></html>\n";
 250         close(F);
 251
 252         # per-completion info
 253         open(F, ">per-completion.html") || die "Cannot open file: $!";
 254         print F html_header("Mono - per-completion stats");
 255         print F "<TABLE BORDER=1><TR><TH>Completion<TH>Class<TH>Maintainer\n";
 256         foreach my $c (sort {$class{$b}->[PERCENT] <=> $class{$a}->[PERCENT]} keys %class) {
 257                 print F "\t<TR><TD>", join('<TD>', $class{$c}->[PERCENT], unimplemented($c), $class{$c}->[MAINTAINER]), "\n";
 258         }
 259         print F "</TABLE>\n";
 260         print F "</body></html>\n";
 261         close(F);
 262
 263         # unimplemented methods
 264         # FIXME: this can create a very big file, split on assembly name
 265         # and fix also the unimplemented() sub
 266         open(F, ">per-unimplemented.html") || die "Cannot open file: $!";
 267         print F html_header("Mono - unimplemented methods stats");
 268         print F "<TABLE BORDER=1><TR><TH>Class<TH>Method\n";
 269         foreach my $c (sort grep {$class{$_}->[PERCENT] != 100} keys %class) {
 270                 my @methods = sort grep {!$class{$c}->[HASH]->{$_}} keys %{$class{$c}->[HASH]};
 271                 my $count = @methods;
 272                 my $aname = '';
 273                 if ($count) {
 274                         my $id = $c;
 275                         $id =~ tr/./-/;
 276                         $aname = "<A NAME='$id'></A>";
 277                 }
 278                 foreach my $m (@methods) {
 279                         my $start = $count?"\t<TR><TD ROWSPAN=$count>$aname$c<TD>":"\t<TR><TD>";
 280                         $count = 0;
 281                         print F $start, join('<TD>', $m), "\n";
 282                 }
 283         }
 284         print F "</TABLE>\n";
 285         print F "</body></html>\n";
 286         close(F);
 287
 288 }
 289