1003 lines
24 KiB
Perl
Executable File
1003 lines
24 KiB
Perl
Executable File
#! /usr/bin/perl -W
|
|
|
|
use strict;
|
|
|
|
my $do_cluster_subgraphs = 0;
|
|
my $collapse_clusters = 0;
|
|
my $ignore_missing = 0;
|
|
|
|
my $controlfile = 'Control';
|
|
my $controlfile_local = 'Control.local';
|
|
my $prj_aliases_dir = 'prj-config/aliases.d';
|
|
my %pkgs;
|
|
my %provided;
|
|
my %nodes;
|
|
my %clusters;
|
|
|
|
my $pcfiledir_for_aliases;
|
|
|
|
sub new_node
|
|
{
|
|
my $n = shift;
|
|
$n = {} unless defined $n;
|
|
$n->{requires} = [] unless defined $n->{requires};
|
|
$n->{optional} = [] unless defined $n->{optional};
|
|
$n->{provides} = [] unless defined $n->{provides};
|
|
$n->{'source-pkg'} = [] unless defined $n->{'source-pkg'};
|
|
$n->{maintainer} = [] unless defined $n->{maintainer};
|
|
return $n
|
|
}
|
|
|
|
sub add_node($$)
|
|
{
|
|
my $n = shift;
|
|
my $cluster = shift;
|
|
|
|
my $name = $n->{name};
|
|
$nodes{$name} = $n;
|
|
|
|
if (not defined $cluster and $name =~ /(.*)\/([^\/]*)/)
|
|
{
|
|
$cluster = $1;
|
|
$name = $2;
|
|
}
|
|
if (defined $cluster)
|
|
{
|
|
#print STDERR "new node: '$name' '$cluster'\n";
|
|
$clusters{$cluster} = { name => $cluster, nodes => {} }
|
|
unless defined $clusters{$cluster};
|
|
|
|
my $c = $clusters{$cluster};
|
|
$c->{nodes}->{$name} = $n;
|
|
$n->{cluster} = $c;
|
|
}
|
|
|
|
$provided{$_} = $n foreach (@{$n->{provides}});
|
|
|
|
return $n;
|
|
}
|
|
|
|
sub set_pcfiledir_for_aliases($)
|
|
{
|
|
$pcfiledir_for_aliases = shift;
|
|
}
|
|
|
|
sub write_alias_pcfile($@)
|
|
{
|
|
my $alias = shift;
|
|
|
|
die "Path for pc-files not set, use '-P dir'"
|
|
unless defined $pcfiledir_for_aliases;
|
|
|
|
open(U, ">$pcfiledir_for_aliases/$alias.pc")
|
|
|| die "Cannot create '$pcfiledir_for_aliases/$alias.pc': $!";
|
|
|
|
print U "Name: $alias\n".
|
|
"Version: 0\n".
|
|
"Description: Alias Dependency Package\n".
|
|
"Requires: ".join(' ', @_)."\n";
|
|
|
|
close U;
|
|
}
|
|
|
|
sub add_alias($$@)
|
|
{
|
|
my $alias = shift;
|
|
my $cluster = shift;
|
|
|
|
add_node(new_node({
|
|
name => $alias,
|
|
alias => 1,
|
|
provides => [ $alias ],
|
|
requires => [ @_ ] }), $cluster);
|
|
}
|
|
|
|
sub write_alias_pc_files()
|
|
{
|
|
foreach my $n (values %nodes)
|
|
{
|
|
next unless $n->{alias};
|
|
write_alias_pcfile($n->{name}, @{$n->{requires}});
|
|
}
|
|
}
|
|
|
|
sub is_alias($)
|
|
{
|
|
my $a = shift;
|
|
defined $nodes{$a}->{alias};
|
|
}
|
|
|
|
sub read_aliases_dir($$)
|
|
{
|
|
my $dir = shift;
|
|
my $cluster = shift;
|
|
|
|
opendir(A, $dir) || die "Cannot open directory '$dir': $!";
|
|
|
|
foreach my $file (sort readdir(A))
|
|
{
|
|
next if $file =~ /^\./;
|
|
next if -d $file;
|
|
|
|
open(F, "$dir/$file") || die "Cannot open file '$dir/$file': $!";
|
|
my $line = 0;
|
|
|
|
while (<F>)
|
|
{
|
|
$line++;
|
|
chomp;
|
|
s/\#.*//;
|
|
s/^\s+$//;
|
|
next if /^$/;
|
|
if (/^\s*(\S+)\s*:?=\s*(.+)/)
|
|
{
|
|
add_alias($1, $cluster, split(/\s+/, $2));
|
|
}
|
|
else
|
|
{
|
|
die "Invalid syntax in $dir/$file:$line";
|
|
}
|
|
}
|
|
|
|
close F;
|
|
}
|
|
|
|
closedir A;
|
|
}
|
|
|
|
|
|
sub scan_for_provided_pkg_configs
|
|
{
|
|
my $node = shift;
|
|
my $path = shift;
|
|
my $pkg = shift;
|
|
my $scan_all = shift;
|
|
|
|
$node->{disabled} = 1 if -e "$path/broken" or -e "$path/obsolete";
|
|
|
|
return if not $scan_all and $node->{disabled};
|
|
|
|
foreach my $ctfn ($controlfile, $controlfile_local)
|
|
{
|
|
if (open(A, "$path/$ctfn"))
|
|
{
|
|
my $o;
|
|
{
|
|
undef local $/;
|
|
$o = <A>;
|
|
}
|
|
|
|
$o =~ s/#.*$//gm;
|
|
$o =~ s/\n[ \t]+/ /smg;
|
|
|
|
my $control_entry = sub
|
|
{
|
|
my $tag = shift;
|
|
return 0 unless $o =~ /^$tag:[ \t]*(.+)$/im;
|
|
push @{$node->{$tag}}, split /\s+/, $1;
|
|
$o = $`."\n".$';
|
|
return 1;
|
|
};
|
|
|
|
while (1)
|
|
{
|
|
last unless $control_entry->('optional')
|
|
|| $control_entry->('requires')
|
|
|| $control_entry->('provides')
|
|
|| $control_entry->('source-pkg')
|
|
|| $control_entry->('maintainer');
|
|
}
|
|
|
|
close A;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub find_pkg_dirs
|
|
{
|
|
my ($base_path, $cdir, $scan_all, $depth, $process) = @_;
|
|
|
|
read_aliases_dir("$base_path/$cdir$prj_aliases_dir", substr($cdir, 0, -1))
|
|
if -d "$base_path/$cdir$prj_aliases_dir";
|
|
|
|
my $dh;
|
|
opendir($dh, "$base_path/$cdir") || die "Cannot readdir in '$base_path/$cdir': $!";
|
|
|
|
foreach (readdir($dh))
|
|
{
|
|
my $pkg = "$cdir$_";
|
|
my $path = "$base_path/$pkg";
|
|
|
|
$path = readlink $path if -l $path;
|
|
next unless -d $path;
|
|
next if /^\./ or /^CVS$/;
|
|
if (-e "$path/$controlfile")
|
|
{
|
|
&$process($base_path, $pkg);
|
|
next;
|
|
}
|
|
find_pkg_dirs($base_path, "$pkg/", $scan_all, $depth - 1, $process)
|
|
if $depth > 0;
|
|
}
|
|
closedir $dh;
|
|
}
|
|
|
|
# search for Control files and aliases in prj-config directories
|
|
# starting from base_path (first argument)
|
|
# the second argument(scan_all) control whether disabled packages shall
|
|
# be handled as well
|
|
sub scan_files
|
|
{
|
|
my $base_path = shift;
|
|
my $scan_all = shift;
|
|
|
|
find_pkg_dirs($base_path, "", $scan_all, 2, sub {
|
|
my ($base, $pkg) = @_;
|
|
$pkgs{$pkg} = 1;
|
|
my $n = new_node({ name => $pkg, pkg => 1 });
|
|
scan_for_provided_pkg_configs($n, "$base/$pkg", $pkg, $scan_all);
|
|
add_node($n, undef);
|
|
});
|
|
}
|
|
|
|
# same as scan_files but only use the list of directories given as
|
|
# after the second argument.
|
|
# NOTE: this function does not scan for prj-config directories, these must
|
|
# be given using '-A' arguments
|
|
sub scan_files_dirs
|
|
{
|
|
my $base = shift;
|
|
my $scan_all = shift;
|
|
my @subdirs = @_;
|
|
|
|
foreach my $pkg (@subdirs)
|
|
{
|
|
$pkgs{$pkg} = 1;
|
|
my $n = new_node({ name => $pkg, pkg => 1 });
|
|
scan_for_provided_pkg_configs($n, "$base/$pkg", $pkg, $scan_all);
|
|
add_node($n, undef);
|
|
}
|
|
}
|
|
|
|
sub generate_single_dep
|
|
{
|
|
my ($tag, $n, $ignore_missing, $error_count) = @_;
|
|
return 0 unless @{$n->{$tag}};
|
|
|
|
my $a = $n->{name};
|
|
|
|
print "# $a $tag ".join(' ', @{$n->{$tag}})."\n";
|
|
print ".PHONY: $a\n" if $n->{alias};
|
|
print "$a:";
|
|
foreach (sort @{$n->{$tag}})
|
|
{
|
|
if (defined $provided{$_} and not $provided{$_}->{disabled})
|
|
{
|
|
print " $provided{$_}->{name}";
|
|
}
|
|
elsif (not $ignore_missing and not defined $n->{disabled} and not is_alias($a))
|
|
{
|
|
print STDERR "ERROR: Package providing \"$_\" not found as required by \"$a\".\n";
|
|
$$error_count++;
|
|
}
|
|
}
|
|
print "\n";
|
|
return 1;
|
|
}
|
|
|
|
sub generate_dep_makefile
|
|
{
|
|
scan_files_dirs(shift, 1, @_);
|
|
write_alias_pc_files();
|
|
my $error_count = 0;
|
|
|
|
print "# Automatically generated Makefile for dependencies\n";
|
|
print "#\n";
|
|
print "# ", `date`;
|
|
print "#\n";
|
|
|
|
my %p = %pkgs;
|
|
|
|
foreach my $a (sort keys %nodes)
|
|
{
|
|
my $n = $nodes{$a};
|
|
my $d = generate_single_dep('requires', $n, $ignore_missing, \$error_count);
|
|
$d |= generate_single_dep('optional', $n, 1, \$error_count);
|
|
delete $p{$a} if $d;
|
|
}
|
|
|
|
print "\n# project targets\n";
|
|
foreach (keys %clusters)
|
|
{
|
|
next unless $_;
|
|
my $nodes = $clusters{$_}->{nodes};
|
|
print "$_:";
|
|
foreach (values %$nodes)
|
|
{
|
|
print " $_->{name}" unless is_alias($_);
|
|
}
|
|
print "\n";
|
|
}
|
|
|
|
# delete those packages that do not have dependencies, to avoid circular
|
|
# 'make' deps
|
|
foreach (keys %p)
|
|
{
|
|
delete $p{$_} if $_ eq $p{$_};
|
|
}
|
|
|
|
print "\n# pakages w/o deps\n.PHONY: ".join(' ', sort keys %p)."\n" if %p;
|
|
|
|
if ($error_count)
|
|
{
|
|
print STDERR "PANIC: Detected $error_count dependency error(s).\n";
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
# get the package providing the given abstract target
|
|
sub get_providing_pkg($$)
|
|
{
|
|
my $n = shift;
|
|
my $r = shift;
|
|
my $p = $provided{$n};
|
|
return $p if defined $p;
|
|
print STDERR "ERROR: no package providing '$n' found, as required by '$r'\n";
|
|
return undef;
|
|
}
|
|
|
|
# get the source package given a package and the name of the source package
|
|
sub get_src_pkg($$)
|
|
{
|
|
my $pkg = shift;
|
|
my $src_pkg_name = shift;
|
|
my $c = $pkg->{cluster};
|
|
my $spkg;
|
|
# search in our cluster first
|
|
$spkg = $c->{nodes}->{$src_pkg_name} if defined $c;
|
|
# if not found try it globally
|
|
$spkg = $nodes{$src_pkg_name} unless defined $spkg;
|
|
return $spkg;
|
|
}
|
|
|
|
sub get_deps_recursive(@)
|
|
{
|
|
my %required;
|
|
my $done = 0;
|
|
|
|
$required{$_->{name}} = $_ foreach @_;
|
|
|
|
while (not $done)
|
|
{
|
|
$done = 1;
|
|
foreach my $pkg (values %required)
|
|
{
|
|
foreach my $spkg (@{$pkg->{'source-pkg'}})
|
|
{
|
|
my $s = get_src_pkg($pkg, $spkg);
|
|
if (not defined $s)
|
|
{
|
|
print STDERR "ERROR: source package '$spkg' ".
|
|
"of package '$pkg->{name}' not found\n";
|
|
next;
|
|
}
|
|
$done = 0 unless defined $required{$s->{name}};
|
|
$required{$s->{name}} = $s;
|
|
}
|
|
|
|
foreach my $rpkg (@{$pkg->{requires}})
|
|
{
|
|
my $r = get_providing_pkg($rpkg, $pkg->{name});
|
|
next unless defined $r;
|
|
$done = 0 unless defined $required{$r->{name}};
|
|
$required{$r->{name}} = $r;
|
|
}
|
|
}
|
|
}
|
|
|
|
return values %required;
|
|
}
|
|
|
|
sub figure_out_pkg_dependecies(@)
|
|
{
|
|
my %newpkgs;
|
|
foreach (@_)
|
|
{
|
|
if (not defined $nodes{$_})
|
|
{
|
|
if (not defined $provided{$_})
|
|
{
|
|
print STDERR "WARNING: '$_' does not exist (forgot -A?).\n";
|
|
next;
|
|
}
|
|
$newpkgs{$provided{$_}->{name}} = $provided{$_};
|
|
}
|
|
else
|
|
{
|
|
$newpkgs{$_} = $nodes{$_};
|
|
}
|
|
}
|
|
return map $_->{name}, get_deps_recursive(values %newpkgs);
|
|
}
|
|
|
|
# this sub figures out which packages depend on the given ones
|
|
sub figure_out_dependant_pkgs(@)
|
|
{
|
|
my %h;
|
|
my %r;
|
|
$h{$_} = 1 foreach @_;
|
|
|
|
while (1)
|
|
{
|
|
my %tmp = %r;
|
|
foreach my $node (values %nodes)
|
|
{
|
|
foreach (@{$node->{requires}})
|
|
{
|
|
my $p = $_;
|
|
$p = $provided{$_}->{name} if defined $provided{$_};
|
|
$tmp{$node->{name}} = 1 if defined $h{$p} or $tmp{$p};
|
|
}
|
|
}
|
|
|
|
last if scalar keys %r == scalar keys %tmp;
|
|
%r = %tmp;
|
|
}
|
|
|
|
# remove aliases
|
|
foreach my $p (keys %r)
|
|
{
|
|
delete $r{$p} if is_alias($p);
|
|
}
|
|
|
|
%r;
|
|
}
|
|
|
|
sub disabled_requirements
|
|
{
|
|
my $n = shift;
|
|
return 1 if $n->{disabled_because_of_deps};
|
|
foreach (@{$n->{requires}})
|
|
{
|
|
my $p = $provided{$_};
|
|
if (not defined $p or $p->{disabled} or disabled_requirements($p))
|
|
{
|
|
$n->{disabled_because_of_deps} = 1;
|
|
return 1;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub generate_dot_file_all($$)
|
|
{
|
|
my $base_path = shift;
|
|
my $output = shift;
|
|
scan_files($base_path, 1) if defined $base_path;
|
|
my $error_count = 0;
|
|
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
|
|
= localtime(time);
|
|
$year += 1900;
|
|
$mon++;
|
|
|
|
open O, $output or die "Cannot open '$output': $!";
|
|
|
|
print O "# Automatically generated\n";
|
|
print O "#\n";
|
|
print O "# ", `date`;
|
|
print O "#\n";
|
|
print O "digraph dep {\n";
|
|
print O " compound=true;\n";
|
|
print O " graph [ label = \"\\nSource based package dependency\\n",
|
|
sprintf("%02d. %02d. %04d, %02d:%02d \"];\n",
|
|
$mday, $mon, $year, $hour, $min);
|
|
|
|
#my %disabled_because_of_deps = figure_out_dependant_pkgs(%disabled);
|
|
|
|
if ($do_cluster_subgraphs)
|
|
{
|
|
foreach my $a (sort keys %clusters)
|
|
{
|
|
print O " subgraph \"cluster_$a\" {\n";
|
|
foreach my $b (sort keys %{$clusters{$a}->{nodes}})
|
|
{
|
|
print O " \"$b\";\n";
|
|
}
|
|
print O " }\n";
|
|
}
|
|
}
|
|
|
|
sub get_node_name($)
|
|
{
|
|
my $n = shift;
|
|
return $n unless $collapse_clusters and defined $nodes{$n}->{cluster};
|
|
return $nodes{$n}->{cluster}->{name};
|
|
}
|
|
|
|
sub gen_node($$)
|
|
{
|
|
my $n = shift;
|
|
my $onodes = shift;
|
|
return if defined $onodes->{$n};
|
|
$onodes->{$n} = 1;
|
|
my @attr;
|
|
|
|
if (defined $clusters{$n}) {
|
|
push @attr, "shape=box";
|
|
} elsif (is_alias($n)) {
|
|
push @attr, "shape=septagon";
|
|
}
|
|
|
|
my $node = $nodes{$n};
|
|
if (defined $node) {
|
|
if (defined $node->{disabled}) {
|
|
push @attr, "style=filled", "fillcolor=red";
|
|
} elsif (disabled_requirements($node)) {
|
|
push @attr, "style=filled", "fillcolor=sandybrown";
|
|
}
|
|
}
|
|
print O " \"$n\" [".join(', ', @attr)."]\n" if @attr;
|
|
}
|
|
|
|
sub gen_edge($$$)
|
|
{
|
|
my $s = shift;
|
|
my $e = shift;
|
|
my $edges = shift;
|
|
|
|
return if $s eq $e;
|
|
my $outgoing = $edges->{$s};
|
|
return if defined $outgoing and defined $outgoing->{$e};
|
|
$outgoing->{$e} = 1 if defined $outgoing;
|
|
$edges->{$s} = { $e => 1 } unless defined $outgoing;
|
|
|
|
print O " \"$s\" -> \"$e\" [color=black]\n";
|
|
}
|
|
|
|
my %onodes;
|
|
my %edges;
|
|
|
|
foreach my $a (sort keys %nodes)
|
|
{
|
|
my $node = $nodes{$a};
|
|
my $lnode = get_node_name($a);
|
|
gen_node($lnode, \%onodes);
|
|
|
|
foreach (sort @{$node->{requires}})
|
|
{
|
|
if (defined $provided{$_})
|
|
{
|
|
gen_edge($lnode, get_node_name($provided{$_}->{name}), \%edges);
|
|
}
|
|
elsif (not defined $node->{disabled} and not $node->{alias})
|
|
{
|
|
print STDERR "ERROR: Package providing \"$_\" not found as required by \"$a\".\n";
|
|
$error_count++;
|
|
}
|
|
}
|
|
print O "\n";
|
|
}
|
|
|
|
print O "}\n";
|
|
|
|
close O;
|
|
|
|
if ($error_count)
|
|
{
|
|
print STDERR "PANIC: Detected $error_count dependency error(s).\n";
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
sub resolve_requires($)
|
|
{
|
|
my $n = shift;
|
|
foreach (@{$n->{requires}})
|
|
{
|
|
my $p = get_providing_pkg($_, $n->{name});
|
|
next unless defined $p;
|
|
$p->{required_by}->{$n->{name}} = $n;
|
|
$n->{requires_pkgs}->{$p->{name}} = $p;
|
|
}
|
|
|
|
foreach (@{$n->{'source-pkg'}})
|
|
{
|
|
my $p = get_src_pkg($n, $_);
|
|
next unless defined $p;
|
|
$p->{src_required_by}->{$n->{name}} = $n;
|
|
$n->{src_requires_pkgs}->{$p->{name}} = $p;
|
|
}
|
|
}
|
|
|
|
sub gen_required_dot_subtree
|
|
{
|
|
my $pnode = shift;
|
|
my $file = shift;
|
|
my $seen = shift;
|
|
my $edges = shift;
|
|
|
|
my @attribs = ("style=filled, fillcolor=yellow1");
|
|
|
|
$seen->{$pnode->{name}} = 1;
|
|
|
|
foreach (values %{$pnode->{requires_pkgs}})
|
|
{
|
|
my $edge = "\"$pnode->{name}\" -> \"$_->{name}\"";
|
|
next if defined $edges->{$edge};
|
|
|
|
$edges->{$edge} = 1;
|
|
my @attr;
|
|
push @attr, @attribs;
|
|
push @attr, "shape=septagon" if $_->{alias};
|
|
print $file " \"$_->{name}\" [".join(',',@attr)."]\n" if @attr;
|
|
print $file " $edge\n";
|
|
|
|
next if $seen->{$_->{name}};
|
|
gen_required_dot_subtree($_, $file, $seen, $edges);
|
|
}
|
|
|
|
foreach (values %{$pnode->{src_requires_pkgs}})
|
|
{
|
|
my @attr;
|
|
push @attr, @attribs;
|
|
push @attr, "shape=septagon" if $_->{alias};
|
|
print $file " \"$_->{name}\" [".join(',',@attr)."]\n" if @attr;
|
|
print $file " \"$pnode->{name}\" -> \"$_->{name}\" [constraint=false,style=dotted]\n";
|
|
}
|
|
}
|
|
|
|
sub gen_required_by_dot_subtree
|
|
{
|
|
my $p = shift;
|
|
my $file = shift;
|
|
my $seen = shift;
|
|
my $edges = shift;
|
|
|
|
my @attribs = ("style=filled, fillcolor=seagreen1");
|
|
|
|
$seen->{$p->{name}} = 1;
|
|
|
|
foreach (values %{$p->{required_by}})
|
|
{
|
|
my $edge = "\"$_->{name}\" -> \"$p->{name}\"";
|
|
next if defined $edges->{$edge};
|
|
|
|
$edges->{$edge} = 1;
|
|
my @attr;
|
|
push @attr, @attribs;
|
|
push @attr, "shape=septagon" if $_->{alias};
|
|
print $file " \"$_->{name}\" [".join(',',@attr)."]\n" if @attr;
|
|
print $file " $edge\n";
|
|
|
|
next if $seen->{$_->{name}};
|
|
gen_required_by_dot_subtree($_, $file, $seen, $edges);
|
|
}
|
|
}
|
|
|
|
sub generate_overview_set($$)
|
|
{
|
|
my $base_path = shift;
|
|
my $output_dir = shift;
|
|
|
|
die "Output directory not given." unless defined $output_dir;
|
|
|
|
scan_files($base_path, 1);
|
|
my $error_count = 0;
|
|
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)
|
|
= localtime(time);
|
|
$year += 1900;
|
|
$mon++;
|
|
my $datestring = sprintf("%02d. %02d. %04d, %02d:%02d",
|
|
$mday, $mon, $year, $hour, $min);
|
|
|
|
generate_dot_file_all(undef, "| tred | dot -Tsvg -o $output_dir/all.svg");
|
|
|
|
open INDEX, ">$output_dir/index.html" or die "Cannot create $output_dir/index.html: $!";
|
|
print INDEX <<EOFOO;
|
|
<html>
|
|
<head>
|
|
<title>TUD:OS package dependency overview</title>
|
|
</head>
|
|
<body>
|
|
<h2>TUD:OS package dependency overview</h2>
|
|
<p>Generated: $datestring</p>
|
|
<p>
|
|
Legend of overview graphs:
|
|
<ul>
|
|
<li>Red: Broken package</li>
|
|
<li>Lightred: Package broken because it depends on broken package but is itself not broken</li>
|
|
</ul>
|
|
Legend of package graphs:
|
|
<ul>
|
|
<li>Blue: The package itself</li>
|
|
<li>Green: Reverse dependency of package</li>
|
|
<li>Yellow: Dependency of package</li>
|
|
</ul>
|
|
</p>
|
|
<p><a href=\"all.svg\">General overview</a><br/></p>
|
|
<table border=\"1\"><tr><td>Package</td><td>Maintainer(s)</td><td>Deps</td><td>Reverse Deps</td></tr>
|
|
EOFOO
|
|
|
|
resolve_requires($_) foreach values %nodes;
|
|
|
|
foreach my $pkg (sort keys %pkgs)
|
|
{
|
|
my $pnode = $nodes{$pkg};
|
|
(my $pkg_file = $pkg) =~ s/\//_/g;
|
|
|
|
open F, "| dot -Tsvg -o $output_dir/p_$pkg_file.svg" || die "Cannot open $output_dir/p_$pkg_file.svg: $!";
|
|
#open F, ">$output_dir/pkg_$pkg.dot" || die "Cannot open pkg_$pkg.dot: $!";
|
|
|
|
print F "# Automatically generated\n";
|
|
print F "#\n";
|
|
print F "# ", `date`;
|
|
print F "#\n";
|
|
print F "digraph dep {\n";
|
|
print F " graph [ label = \"\\nSource based package dependency for package '$pkg'\\n",
|
|
"$datestring\"];\n";
|
|
|
|
gen_required_dot_subtree($pnode, *F);
|
|
gen_required_by_dot_subtree($pnode, *F);
|
|
|
|
my %rev_deps = figure_out_dependant_pkgs($pkg);
|
|
my @deps = figure_out_pkg_dependecies($pkg);
|
|
print F " \"$pkg\" [style=filled, fillcolor=dodgerblue];\n";
|
|
print F "}\n";
|
|
close F;
|
|
|
|
# Generate HTML content
|
|
|
|
print INDEX "<tr><td><a href=\"p_$pkg_file.svg\">$pkg</a></td><td>\n";
|
|
print INDEX defined $pnode->{maintainer}
|
|
? (join " ", map { "<a href=\"mailto:$_\">$_</a>" } @{$pnode->{maintainer}}) : "none";
|
|
print INDEX "</td><td>\n";
|
|
foreach my $a (sort @deps)
|
|
{
|
|
(my $a_file = $a) =~ s/\//_/g;
|
|
print INDEX " <a href=\"p_$a_file.svg\">$a</a> ";
|
|
}
|
|
print INDEX "</td><td>\n";
|
|
foreach my $a (sort keys %rev_deps)
|
|
{
|
|
(my $a_file = $a) =~ s/\//_/g;
|
|
print INDEX " <a href=\"p_$a_file.svg\">$a</a> ";
|
|
}
|
|
print INDEX "</td></tr>\n";
|
|
}
|
|
|
|
print INDEX "</table>\n";
|
|
print INDEX "</body>\n</html>\n";
|
|
close INDEX;
|
|
|
|
if ($error_count)
|
|
{
|
|
print STDERR "PANIC: Detected $error_count dependency error(s).\n";
|
|
exit(1);
|
|
}
|
|
}
|
|
|
|
sub check_control($)
|
|
{
|
|
my $base_path = shift;
|
|
|
|
scan_files($base_path, 0);
|
|
|
|
foreach my $p (keys %pkgs)
|
|
{
|
|
my %pc_filenames;
|
|
my @libs_wo_pcfile;
|
|
open(F, "find '$base_path/$p' -name Makefile -o -name Make.rules |")
|
|
|| die "Cannot start find: $!";
|
|
while (my $file = <F>)
|
|
{
|
|
my $is_lib_build;
|
|
my $found_pc_filename;
|
|
my $not_public;
|
|
chomp $file;
|
|
open(M, $file) || die "Cannot open \"$_\": $!";
|
|
while (<M>)
|
|
{
|
|
chomp;
|
|
$found_pc_filename = $1
|
|
if /^\s*PC_FILENAME\s*:?=\s*(.+)\s*$/;
|
|
$is_lib_build = 1
|
|
if /^\s*include\s+.+\/mk\/lib.mk\s*$/;
|
|
$not_public = 1
|
|
if /^\s*NOTARGETSTOINSTALL\s*:?=\s/;
|
|
}
|
|
close M;
|
|
|
|
print "ERROR: $p: Not public but PC_FILENAME given\n"
|
|
if defined $not_public and defined $found_pc_filename;
|
|
|
|
unless (defined $not_public)
|
|
{
|
|
if (defined $found_pc_filename)
|
|
{
|
|
$found_pc_filename =~ s/\$\(PKGNAME\)/$p/;
|
|
$pc_filenames{$found_pc_filename} = 1;
|
|
}
|
|
elsif (defined $is_lib_build)
|
|
{
|
|
my $pkgname = $p;
|
|
$pkgname = $1 if $p =~ /.*\/([^\/]*)/;
|
|
|
|
$pc_filenames{$pkgname} = 1;
|
|
push @libs_wo_pcfile, $file;
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach my $a (keys %pc_filenames)
|
|
{
|
|
print "ERROR: $p: Missing in provides '$a'\n"
|
|
if not defined $provided{$a} or $provided{$a}->{name} ne $p;
|
|
}
|
|
|
|
foreach my $a (keys %provided)
|
|
{
|
|
print "ERROR: $p: Provide not found as PC_FILENAME '$a'\n"
|
|
if $provided{$a}->{name} eq $p and not defined $pc_filenames{$a};
|
|
|
|
if ($provided{$a}->{name} eq $p and not defined $pc_filenames{$a}) {
|
|
print "P: ".join(' ', keys %pc_filenames)."\n";
|
|
}
|
|
}
|
|
|
|
print "ERROR: $p: Contains multiple libs without PC_FILENAME:\n",
|
|
" ", join("\n ", @libs_wo_pcfile), "\n"
|
|
if scalar @libs_wo_pcfile > 1;
|
|
|
|
close F;
|
|
}
|
|
|
|
print "TODO: check if something is provided by multiple packages\n";
|
|
}
|
|
|
|
|
|
sub show_pkg_deps($$@)
|
|
{
|
|
my $base_path = shift;
|
|
my $prefix = shift;
|
|
scan_files($base_path, 0);
|
|
|
|
my @p = figure_out_pkg_dependecies(@_);
|
|
|
|
print join("\n", map { "$prefix$_" } sort @p), "\n" if $prefix;
|
|
print join(' ', sort @p), "\n" unless $prefix;
|
|
}
|
|
|
|
sub show_pkg_deps_and_rdeps($$@)
|
|
{
|
|
my $base_path = shift;
|
|
my $prefix = shift;
|
|
|
|
scan_files($base_path, 0);
|
|
|
|
my %r = figure_out_dependant_pkgs(@_);
|
|
my @p = figure_out_pkg_dependecies(@_, keys %r);
|
|
|
|
print join("\n", map { "$prefix$_" } sort @p), "\n" if $prefix;
|
|
print join(' ', sort @p), "\n" unless $prefix;
|
|
}
|
|
|
|
sub show_maintainer($@)
|
|
{
|
|
scan_files(shift, 1);
|
|
|
|
if (@_)
|
|
{
|
|
my %m;
|
|
|
|
foreach (@_)
|
|
{
|
|
next if $_->{alias};
|
|
|
|
my $pkg = $nodes{$_};
|
|
if ($pkg->{maintainer})
|
|
{
|
|
$m{$_}++ foreach @{$pkg->{maintainer}};
|
|
}
|
|
else
|
|
{
|
|
$m{'NO MAINTAINER'} = 1;
|
|
}
|
|
}
|
|
|
|
print join(", ", keys %m), "\n";
|
|
}
|
|
else
|
|
{
|
|
my %m;
|
|
foreach (values %nodes)
|
|
{
|
|
next if $_->{alias};
|
|
|
|
if ($_->{maintainer})
|
|
{
|
|
print "$_->{name}: ", join(', ', @{$_->{maintainer}}), "\n";
|
|
$m{$_}++ foreach @{$_->{maintainer}};
|
|
}
|
|
else
|
|
{
|
|
print "$_->{name}: NO MAINTAINER\n";
|
|
}
|
|
}
|
|
print "Stats:\n", join("\n", map { sprintf "%3d: %s", $m{$_}, $_ } sort { $m{$b} <=> $m{$a} } keys %m), "\n";
|
|
}
|
|
}
|
|
|
|
|
|
sub smooth_control_file($$)
|
|
{
|
|
my $path = shift;
|
|
my $pkg = shift;
|
|
|
|
my $node = new_node({ name => $pkg, pkg => 1 });
|
|
|
|
scan_for_provided_pkg_configs($node, $path, $pkg, 1);
|
|
add_node($node, undef);
|
|
|
|
print "Provides: ".join(' ', keys %provided)."\n";
|
|
print "Requires: ".join(' ', @{$nodes{$pkg}->{requires}})."\n";
|
|
}
|
|
|
|
# a bit of hand-crafted option parsing, if it gets more use getopt
|
|
my @aliases_dirs;
|
|
while (1)
|
|
{
|
|
last unless defined $ARGV[0];
|
|
if ($ARGV[0] eq '-A')
|
|
{
|
|
shift;
|
|
push @aliases_dirs, shift;
|
|
}
|
|
elsif ($ARGV[0] eq '-P')
|
|
{
|
|
shift;
|
|
set_pcfiledir_for_aliases(shift),
|
|
}
|
|
elsif ($ARGV[0] eq '-I')
|
|
{
|
|
shift;
|
|
$ignore_missing = 1;
|
|
}
|
|
else
|
|
{
|
|
last;
|
|
}
|
|
}
|
|
|
|
my $cmd = shift @ARGV;
|
|
my $base_path = shift @ARGV;
|
|
|
|
die "Missing arguments"
|
|
if not defined $cmd or not defined $base_path;
|
|
|
|
read_aliases_dir($_, undef) foreach @aliases_dirs;
|
|
|
|
if ($cmd eq 'generate') {
|
|
generate_dep_makefile($base_path, @ARGV);
|
|
} elsif ($cmd eq 'dot') {
|
|
generate_dot_file_all($base_path, '>-');
|
|
} elsif ($cmd eq 'overviewset') {
|
|
generate_overview_set($base_path, $ARGV[0]);
|
|
} elsif ($cmd eq 'pkgdeps') {
|
|
show_pkg_deps($base_path, undef, @ARGV[0 .. $#ARGV]);
|
|
} elsif ($cmd eq 'pkgdepspath') {
|
|
show_pkg_deps($base_path, $ARGV[0], @ARGV[1 .. $#ARGV]);
|
|
} elsif ($cmd eq 'pkgdepsandrdeps') {
|
|
show_pkg_deps_and_rdeps($base_path, undef, @ARGV[0 .. $#ARGV]);
|
|
} elsif ($cmd eq 'collect') {
|
|
die "Missing argument" unless defined $ARGV[0];
|
|
smooth_control_file("$base_path/$ARGV[0]", $ARGV[0]);
|
|
} elsif ($cmd eq 'maintainer') {
|
|
show_maintainer($base_path, @ARGV[0 .. $#ARGV]);
|
|
} elsif ($cmd eq 'check') {
|
|
check_control($base_path);
|
|
} else {
|
|
die "Invalid command '$cmd'";
|
|
}
|