l4/mk/pkgdeps

   1 #! /usr/bin/perl -W
   2
   3 use strict;
   4
   5 my $controlfile       = 'Control';
   6 my $controlfile_local = 'Control.local';
   7 my %pkgs;
   8 my %requires;
   9 my %provided;
  10 my %maintainer;
  11 my %srcpkgs;
  12 my %aliases;
  13 my %disabled;
  14
  15 my $pcfiledir_for_aliases;
  16
  17 sub set_pcfiledir_for_aliases($)
  18 {
  19   $pcfiledir_for_aliases = shift;
  20 }
  21
  22 sub write_alias_pcfile($@)
  23 {
  24   my $alias = shift;
  25
  26   die "Path for pc-file not set, use '-P dir'"
  27     unless defined $pcfiledir_for_aliases;
  28
  29   open(U, ">$pcfiledir_for_aliases/$alias.pc")
  30     || die "Cannot create '$pcfiledir_for_aliases/$alias.pc': $!";
  31
  32   print U "Name: $alias\n".
  33           "Version: 0\n".
  34           "Description: Alias Dependency Package\n".
  35           "Requires: ".join(' ', @_)."\n";
  36
  37   close U;
  38 }
  39
  40 sub add_alias($$@)
  41 {
  42   my $alias = shift;
  43   my $do_write_pc_file = shift;
  44
  45   $requires{$alias} = [ @_ ];
  46   $provided{$alias} = $alias;
  47   $aliases{$alias} = 1;
  48
  49   write_alias_pcfile($alias, @_)
  50     if $do_write_pc_file;
  51 }
  52
  53 sub is_alias($)
  54 {
  55   my $a = shift;
  56   defined $aliases{$a};
  57 }
  58
  59 sub read_aliases_dir($$)
  60 {
  61   my $dir = shift;
  62   my $do_write_pc_file = shift;
  63
  64   opendir(A, $dir) || die "Cannot open directory '$dir': $!";
  65
  66   foreach my $file (sort readdir(A))
  67     {
  68       next if $file =~ /^\./;
  69       next if -d $file;
  70
  71       open(F, "$dir/$file") || die "Cannot open file '$dir/$file': $!";
  72       my $line = 0;
  73       while (<F>)
  74         {
  75           $line++;
  76           chomp;
  77           s/\#.*//;
  78           s/^\s+$//;
  79           next if /^$/;
  80           if (/^\s*(\S+)\s*:?=\s*(.+)/)
  81             {
  82               add_alias($1, $do_write_pc_file, split(/\s+/, $2));
  83             }
  84           else
  85             {
  86               die "Invalid syntax in $dir/$file:$line";
  87             }
  88         }
  89
  90       close F;
  91     }
  92
  93   closedir A;
  94 }
  95
  96 sub scan_for_provided_pkg_configs($$$)
  97 {
  98   my $path = shift;
  99   my $pkg = shift;
 100   my $scan_all = shift;
 101
 102   $disabled{$pkg} = 1 if -e "$path/broken" or -e "$path/obsolete";
 103
 104   return if not $scan_all and $disabled{$pkg};
 105
 106   foreach my $ctfn ($controlfile, $controlfile_local)
 107     {
 108       if (open(A, "$path/$ctfn"))
 109         {
 110           my $o;
 111           {
 112             undef local $/;
 113             $o = <A>;
 114           }
 115
 116           $o =~ s/#.*$//gm;
 117           $o =~ s/\n[ \t]+/ /smg;
 118
 119           while (1)
 120             {
 121               if ($o =~ /^requires:[ \t]*(.+)$/im)
 122                 {
 123                   push @{$requires{$pkg}}, split /\s+/, $1;
 124                 }
 125               elsif ($o =~ /^provides:[ \t]*(.+)$/im)
 126                 {
 127                   $provided{$_} = $pkg foreach (split /\s+/, $1);
 128                 }
 129               elsif ($o =~ /^source-pkg:[ \t]*(.+)$/im)
 130                 {
 131                   push @{$srcpkgs{$pkg}},  split /\s+/, $1;
 132                 }
 133               elsif ($o =~ /^maintainer:[ \t]*(.+)$/im)
 134                 {
 135                   push @{$maintainer{$pkg}}, split /[,\s]+/, $1;
 136                 }
 137               else
 138                 {
 139                   last;
 140                 }
 141               $o = $`."\n".$';
 142             }
 143
 144           close A;
 145       }
 146     }
 147 }
 148
 149 sub scan_files($$)
 150 {
 151   my $base_path = shift;
 152   my $scan_all = shift;
 153   my $dh;
 154   opendir($dh, $base_path) || die "Cannot readdir in '$base_path': $!";
 155
 156   foreach (readdir($dh)) {
 157     my $path = "$base_path/$_";
 158     $path = readlink $path if -l $path;
 159     next unless -d $path;
 160     next if /^\./ or /^CVS$/;
 161     $pkgs{$_} = 1;
 162     scan_for_provided_pkg_configs($path, $_, $scan_all);
 163   }
 164   closedir $dh;
 165 }
 166
 167 sub generate_dep_makefile($)
 168 {
 169   scan_files(shift, 0);
 170   my $error_count = 0;
 171
 172   print "# Automatically generated Makefile for dependencies\n";
 173   print "#\n";
 174   print "# ", `date`;
 175   print "#\n";
 176
 177   foreach my $a (sort keys %requires)
 178     {
 179       print "$a:";
 180       foreach (sort @{$requires{$a}})
 181         {
 182           if (defined $provided{$_})
 183             {
 184               print " $provided{$_}";
 185             }
 186           else
 187             {
 188               if ($disabled{$_})
 189                 {
 190                   print STDERR "ERROR: Package providing \"$_\" disabled and required by \"$a\".\n";
 191                   $error_count++;
 192                 }
 193               elsif (!is_alias($a))
 194                 {
 195                   print STDERR "ERROR: Package providing \"$_\" not found as required by \"$a\".\n";
 196                   $error_count++;
 197                 }
 198             }
 199         }
 200       print "\n";
 201     }
 202
 203   print "\n.PHONY: ".join(' ', sort keys %aliases)."\n" if %aliases;
 204
 205   if ($error_count)
 206     {
 207       print STDERR "PANIC: Detected $error_count dependency error(s).\n";
 208       exit(1);
 209     }
 210 }
 211
 212
 213
 214 sub figure_out_pkg_dependecies(@)
 215 {
 216   my %newpkgs;
 217   foreach (@_)
 218     {
 219       if (not defined $requires{$_})
 220         {
 221           if (not defined $provided{$_})
 222             {
 223               print STDERR "WARNING: '$_' does not exist.\n";
 224               next;
 225             }
 226           $newpkgs{$provided{$_}} = 1;
 227         }
 228       else
 229         {
 230           $newpkgs{$_} = 1;
 231         }
 232     }
 233
 234   my %pkgh;
 235   my $again;
 236   # get requires of package(s)
 237   do
 238     {
 239       foreach (keys %newpkgs)
 240         {
 241           $newpkgs{$_} = 1 foreach @{$srcpkgs{$_}};
 242         }
 243
 244       my %rdeps;
 245       $again = 0;
 246       foreach my $p (keys %newpkgs)
 247         {
 248           if ($requires{$p})
 249             {
 250               $rdeps{$_} = 1 foreach @{$requires{$p}};
 251             }
 252           $pkgh{$p} = 1;
 253         }
 254       %newpkgs = ();
 255       if (%rdeps)
 256         {
 257           # translate to packages providing those
 258           foreach (keys %rdeps)
 259             {
 260               my $p = $_;
 261               $p = $provided{$p} if defined $provided{$p};
 262               $newpkgs{$p} = 1 unless defined $pkgh{$p};
 263             }
 264           $again = 1;
 265         }
 266     }
 267   while ($again);
 268
 269   # remove aliases
 270   foreach my $p (keys %pkgh)
 271     {
 272       delete $pkgh{$p} if is_alias($p);
 273     }
 274
 275   keys %pkgh;
 276 }
 277
 278 # this sub figures out which packages depend on the given ones
 279 sub figure_out_dependant_pkgs(@)
 280 {
 281   my %h;
 282   my %r;
 283   $h{$_} = 1 foreach @_;
 284
 285   while (1)
 286     {
 287       my %tmp = %r;
 288       foreach my $a (keys %requires)
 289         {
 290           foreach (sort @{$requires{$a}})
 291             {
 292               my $p = $_;
 293               $p = $provided{$_} if defined $provided{$_};
 294               $tmp{$a} = 1 if defined $h{$p} or $tmp{$p};
 295             }
 296         }
 297
 298       last if scalar keys %r == scalar keys %tmp;
 299       %r = %tmp;
 300     }
 301
 302   # remove aliases
 303   foreach my $p (keys %r)
 304     {
 305       delete $r{$p} if is_alias($p);
 306     }
 307
 308   %r;
 309 }
 310
 311 sub generate_dot_file_all($$)
 312 {
 313   my $base_path = shift;
 314   my $output = shift;
 315   scan_files($base_path, 1) if defined $base_path;
 316   my $error_count = 0;
 317
 318   my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
 319     = localtime(time);
 320   $year += 1900;
 321   $mon++;
 322
 323   open O, $output or die "Cannot open '$output': $!";
 324
 325   print O "# Automatically generated\n";
 326   print O "#\n";
 327   print O "# ", `date`;
 328   print O "#\n";
 329   print O "digraph dep {\n";
 330   print O "  graph [ label = \"\\nSource based package dependency\\n",
 331           sprintf("%02d. %02d. %04d, %02d:%02d \"];\n", $mday, $mon, $year, $hour, $min);
 332
 333   my %disabled_because_of_deps = figure_out_dependant_pkgs(%disabled);
 334
 335   foreach my $a (sort keys %requires)
 336     {
 337       print O "  \"$a\" [shape=septagon]\n" if is_alias($a);
 338       foreach (sort @{$requires{$a}})
 339         {
 340           if (defined $provided{$_})
 341             {
 342               print O "  \"$a\" -> \"$provided{$_}\" [color=black];\n";
 343             }
 344           elsif (not defined $disabled{$a} and not is_alias($a))
 345             {
 346               print STDERR "ERROR: Package providing \"$_\" not found as required by \"$a\".\n";
 347               $error_count++;
 348             }
 349         }
 350       print O "\n";
 351     }
 352
 353   foreach my $a (sort keys %requires)
 354     {
 355       if (defined $disabled{$a})
 356         {
 357           print O "  \"$a\" [style=filled, fillcolor=red];\n";
 358         }
 359       elsif (defined $disabled_because_of_deps{$a})
 360         {
 361           print O "  \"$a\" [style=filled, fillcolor=sandybrown];\n";
 362         }
 363     }
 364
 365   print O "}\n";
 366
 367   close O;
 368
 369   if ($error_count)
 370     {
 371       print STDERR "PANIC: Detected $error_count dependency error(s).\n";
 372       exit(1);
 373     }
 374 }
 375
 376 sub generate_overview_set($$)
 377 {
 378   my $base_path = shift;
 379   my $output_dir = shift;
 380
 381   die "Output directory not given." unless defined $output_dir;
 382
 383   scan_files($base_path, 1);
 384   my $error_count = 0;
 385
 386   my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
 387     = localtime(time);
 388   $year += 1900;
 389   $mon++;
 390   my $datestring = sprintf("%02d. %02d. %04d, %02d:%02d",
 391                            $mday, $mon, $year, $hour, $min);
 392
 393   generate_dot_file_all(undef, "| tred | dot -Tsvg -o $output_dir/all.svg");
 394
 395   open INDEX, ">$output_dir/index.html" or die "Cannot create $output_dir/index.html: $!";
 396   print INDEX <<EOFOO;
 397 <html>
 398  <head>
 399  <title>TUD:OS package dependency overview</title>
 400  </head>
 401  <body>
 402   <h2>TUD:OS package dependency overview</h2>
 403   <p>Generated: $datestring</p>
 404   <p>
 405     Legend of overview graphs:
 406     <ul>
 407       <li>Red: Broken package</li>
 408       <li>Lightred: Package broken because it depends on broken package but is itself not broken</li>
 409     </ul>
 410     Legend of package graphs:
 411     <ul>
 412       <li>Blue: The package itself</li>
 413       <li>Green: Reverse dependency of package</li>
 414       <li>Yellow: Dependency of package</li>
 415     </ul>
 416   </p>
 417   <p><a href=\"all.svg\">General overview</a><br/></p>
 418   <table border=\"1\"><tr><td>Package</td><td>Maintainer(s)</td><td>Deps</td><td>Reverse Deps</td></tr>
 419 EOFOO
 420
 421   foreach my $pkg (sort keys %pkgs)
 422     {
 423       open F, "| tred | dot -Tsvg -o $output_dir/p_$pkg.svg" || die "Cannot open $output_dir/p_$pkg.svg: $!";
 424       #open F, ">$output_dir/pkg_$pkg.dot" || die "Cannot open pkg_$pkg.dot: $!";
 425
 426       print F "# Automatically generated\n";
 427       print F "#\n";
 428       print F "# ", `date`;
 429       print F "#\n";
 430       print F "digraph dep {\n";
 431       print F "  graph [ label = \"\\nSource based package dependency for package '$pkg'\\n",
 432               "$datestring\"];\n";
 433
 434       foreach my $a (sort keys %requires)
 435         {
 436           print F "  \"$a\" [shape=septagon]\n" if is_alias($a);
 437           foreach (sort @{$requires{$a}})
 438             {
 439               if (defined $provided{$_})
 440                 {
 441                   print F "  \"$a\" -> \"$provided{$_}\" [color=black];\n";
 442                 }
 443               elsif (not defined $disabled{$a} and not is_alias($a))
 444                 {
 445                   print STDERR "ERROR: Package providing \"$_\" not found as required by \"$a\".\n";
 446                   $error_count++;
 447                 }
 448             }
 449           print F "\n";
 450         }
 451
 452       my %rev_deps = figure_out_dependant_pkgs($pkg);
 453       my @deps     = figure_out_pkg_dependecies($pkg);
 454
 455       print F "  \"$_\" [style=filled, fillcolor=seagreen1];\n"
 456         foreach keys %rev_deps;
 457       print F "  \"$_\" [style=filled, fillcolor=yellow1];\n"
 458         foreach @deps;
 459
 460       print F "  \"$pkg\" [style=filled, fillcolor=dodgerblue];\n";
 461
 462       print F "}\n";
 463       close F;
 464
 465       # Generate HTML content
 466
 467       print INDEX "<tr><td><a href=\"p_$pkg.svg\">$pkg</a></td><td>\n";
 468       print INDEX defined $maintainer{$pkg}
 469                   ? (join " ", map { "<a href=\"mailto:$_\">$_</a>" } @{$maintainer{$pkg}}) : "none";
 470       print INDEX "</td><td>\n";
 471       foreach my $a (sort @deps)
 472         {
 473           print INDEX " <a href=\"p_$a.svg\">$a</a> ";
 474         }
 475       print INDEX "</td><td>\n";
 476       foreach my $a (sort keys %rev_deps)
 477         {
 478           print INDEX " <a href=\"p_$a.svg\">$a</a> ";
 479         }
 480       print INDEX "</td></tr>\n";
 481     }
 482
 483   print INDEX "</table>\n";
 484   print INDEX "</body>\n</html>\n";
 485   close INDEX;
 486
 487   if ($error_count)
 488     {
 489       print STDERR "PANIC: Detected $error_count dependency error(s).\n";
 490       exit(1);
 491     }
 492 }
 493
 494 sub check_control($)
 495 {
 496   my $base_path = shift;
 497
 498   scan_files($base_path, 0);
 499
 500   foreach my $p (keys %pkgs)
 501     {
 502       my %pc_filenames;
 503       my @libs_wo_pcfile;
 504       open(F, "find '$base_path/$p' -name Makefile -o -name Make.rules |")
 505         || die "Cannot start find: $!";
 506       while (my $file = <F>)
 507         {
 508           my $is_lib_build;
 509           my $found_pc_filename;
 510           my $not_public;
 511           chomp $file;
 512           open(M, $file) || die "Cannot open \"$_\": $!";
 513           while (<M>)
 514             {
 515               chomp;
 516               $found_pc_filename = $1
 517                 if /^\s*PC_FILENAME\s*:?=\s*(.+)\s*$/;
 518               $is_lib_build = 1
 519                 if /^\s*include\s+.+\/mk\/lib.mk\s*$/;
 520               $not_public = 1
 521                 if /^\s*NOTARGETSTOINSTALL\s*:?=\s/;
 522             }
 523           close M;
 524
 525           print "ERROR: $p: Not public but PC_FILENAME given\n"
 526             if defined $not_public and defined $found_pc_filename;
 527
 528           unless (defined $not_public)
 529             {
 530               if (defined $found_pc_filename)
 531                 {
 532                   $found_pc_filename =~ s/\$\(PKGNAME\)/$p/;
 533                   $pc_filenames{$found_pc_filename} = 1;
 534                 }
 535               elsif (defined $is_lib_build)
 536                 {
 537                   $pc_filenames{$p} = 1;
 538                   push @libs_wo_pcfile, $file;
 539                 }
 540             }
 541         }
 542
 543       foreach my $a (keys %pc_filenames)
 544         {
 545           print "ERROR: $p: Missing in provides '$a'\n"
 546             if not defined $provided{$a} or $provided{$a} ne $p;
 547         }
 548
 549       foreach my $a (keys %provided)
 550         {
 551           print "ERROR: $p: Provide not found as PC_FILENAME '$a'\n"
 552             if $provided{$a} eq $p and not defined $pc_filenames{$a};
 553         }
 554
 555       print "ERROR: $p: Contains multiple libs without PC_FILENAME:\n",
 556             "       ", join("\n       ", @libs_wo_pcfile), "\n"
 557         if scalar @libs_wo_pcfile > 1;
 558
 559       close F;
 560     }
 561
 562   print "TODO: check if something is provided by multiple packages\n";
 563 }
 564
 565
 566 sub show_pkg_deps($$@)
 567 {
 568   my $base_path = shift;
 569   my $prefix = shift;
 570   scan_files($base_path, 0);
 571
 572   my @p = figure_out_pkg_dependecies(@_);
 573
 574   print join("\n", map { "$prefix$_" } sort @p), "\n" if $prefix;
 575   print join(' ', sort @p), "\n"                      unless $prefix;
 576 }
 577
 578 sub show_pkg_deps_and_rdeps($$@)
 579 {
 580   my $base_path = shift;
 581   my $prefix = shift;
 582   scan_files($base_path, 0);
 583
 584   my %r = figure_out_dependant_pkgs(@_);
 585   my @p = figure_out_pkg_dependecies(@_, keys %r);
 586
 587   print join("\n", map { "$prefix$_" } sort @p), "\n" if $prefix;
 588   print join(' ', sort @p), "\n"                      unless $prefix;
 589 }
 590
 591 sub show_maintainer($@)
 592 {
 593   scan_files(shift, 1);
 594
 595   if (@_)
 596     {
 597       my %m;
 598
 599       foreach (@_)
 600         {
 601           if ($maintainer{$_})
 602             {
 603               $m{$_}++ foreach @{$maintainer{$_}};
 604             }
 605           else
 606             {
 607               $m{'NO MAINTAINER'} = 1;
 608             }
 609         }
 610
 611       print join(", ", keys %m), "\n";
 612     }
 613   else
 614     {
 615       my %m;
 616       foreach (keys %pkgs)
 617         {
 618           if ($maintainer{$_})
 619             {
 620               print "$_: ", join(', ', @{$maintainer{$_}}), "\n";
 621               $m{$_}++ foreach @{$maintainer{$_}};
 622             }
 623           else
 624             {
 625               print "$_: NO MAINTAINER\n";
 626             }
 627         }
 628       print "Stats:\n", join("\n", map { sprintf "%3d: %s", $m{$_}, $_ } sort { $m{$b} <=> $m{$a} } keys %m), "\n";
 629     }
 630 }
 631
 632
 633 sub smooth_control_file($$)
 634 {
 635   my $path = shift;
 636   my $pkg = shift;
 637
 638   scan_for_provided_pkg_configs($path, $pkg, 1);
 639
 640   print "Provides: ".join(' ', keys %provided)."\n";
 641   print "Requires: ".join(' ', @{$requires{$pkg}})."\n";
 642 }
 643
 644 # a bit of hand-crafted option parsing, if it gets more use getopt
 645 my @aliases_dirs;
 646 while (1)
 647   {
 648     last unless defined $ARGV[0];
 649     if ($ARGV[0] eq '-A')
 650       {
 651         shift;
 652         push @aliases_dirs, shift;
 653       }
 654     elsif ($ARGV[0] eq '-P')
 655       {
 656         shift;
 657         set_pcfiledir_for_aliases(shift),
 658       }
 659     else
 660       {
 661         last;
 662       }
 663   }
 664
 665 my $cmd         = $ARGV[0];
 666 my $base_path   = $ARGV[1];
 667
 668 die "Missing arguments"
 669   if not defined $cmd or not defined $base_path;
 670
 671 read_aliases_dir($_, $cmd eq 'generate') foreach @aliases_dirs;
 672
 673 if ($cmd eq 'generate') {
 674   generate_dep_makefile($base_path);
 675 } elsif ($cmd eq 'dot') {
 676   generate_dot_file_all($base_path, '>-');
 677 } elsif ($cmd eq 'overviewset') {
 678   generate_overview_set($base_path, $ARGV[2]);
 679 } elsif ($cmd eq 'pkgdeps') {
 680   show_pkg_deps($base_path, undef, @ARGV[2 .. $#ARGV]);
 681 } elsif ($cmd eq 'pkgdepspath') {
 682   show_pkg_deps($base_path, $ARGV[2], @ARGV[3 .. $#ARGV]);
 683 } elsif ($cmd eq 'pkgdepsandrdeps') {
 684   show_pkg_deps_and_rdeps($base_path, undef, @ARGV[2 .. $#ARGV]);
 685 } elsif ($cmd eq 'collect') {
 686   die "Missing argument" unless defined $ARGV[2];
 687   smooth_control_file("$base_path/$ARGV[2]", $ARGV[2]);
 688 } elsif ($cmd eq 'maintainer') {
 689   show_maintainer($base_path, @ARGV[2 .. $#ARGV]);
 690 } elsif ($cmd eq 'check') {
 691   check_control($base_path);
 692 } else {
 693   die "Invalid command '$cmd'";
 694 }