470 lines
9.8 KiB
Perl
470 lines
9.8 KiB
Perl
#!/usr/bin/perl
|
|
|
|
# $OpenBSD: check-problems,v 1.4 2016/09/14 15:02:41 espie Exp $
|
|
# Copyright (c) 2004, 2010 Marc Espie <espie@openbsd.org>
|
|
#
|
|
# Permission to use, copy, modify, and distribute this software for any
|
|
# purpose with or without fee is hereby granted, provided that the above
|
|
# copyright notice and this permission notice appear in all copies.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
# check all packages in the current directory, and report common directory
|
|
# issues
|
|
|
|
use strict;
|
|
use warnings;
|
|
my ($ports1);
|
|
|
|
use FindBin;
|
|
BEGIN {
|
|
$ports1 = $ENV{PORTSDIR} || '/usr/ports';
|
|
}
|
|
use lib ("$ports1/infrastructure/lib", "$FindBin::Bin/../lib");
|
|
|
|
use File::Spec;
|
|
use File::Path;
|
|
use File::Basename;
|
|
use OpenBSD::PkgCfl;
|
|
use OpenBSD::Mtree;
|
|
use OpenBSD::PlistScanner;
|
|
|
|
# code for checking directories
|
|
sub register_dir
|
|
{
|
|
my ($d, $h) = @_;
|
|
return if defined $h->{$d};
|
|
$h->{$d} = 1;
|
|
register_dir(dirname($d), $h);
|
|
}
|
|
|
|
package OpenBSD::PackingElement;
|
|
sub check_common_dirs
|
|
{
|
|
}
|
|
|
|
package OpenBSD::PackingElement::FileBase;
|
|
use File::Basename;
|
|
sub check_common_dirs
|
|
{
|
|
my ($item, $t) = @_;
|
|
my $d = File::Spec->canonpath($item->fullname);
|
|
main::register_dir(dirname($d), $t->{need_dirs});
|
|
}
|
|
|
|
package OpenBSD::PackingElement::DirlikeObject;
|
|
sub check_common_dirs
|
|
{
|
|
my ($item, $t) = @_;
|
|
my $d = File::Spec->canonpath($item->fullname);
|
|
$t->{dirs}->{$d} = 1;
|
|
}
|
|
|
|
package OpenBSD::PackingElement::Dependency;
|
|
sub check_common_dirs
|
|
{
|
|
my ($item, $t, $o) = @_;
|
|
$t->{deps}{$item->{def}} = 1;
|
|
$o->{wanted}{$item->{def}} //= $o->{currentname};
|
|
}
|
|
|
|
# code for checking conflicts
|
|
package OpenBSD::PackingElement;
|
|
sub register
|
|
{
|
|
}
|
|
|
|
sub known_page
|
|
{
|
|
}
|
|
|
|
sub add_extra_manpage
|
|
{
|
|
}
|
|
|
|
package OpenBSD::PackingElement::FileBase;
|
|
|
|
my $pkg_list = {};
|
|
my $seen = {};
|
|
|
|
sub register
|
|
{
|
|
my ($self, $o, $pkgname) = @_;
|
|
|
|
my $all_conflict = $o->{filehash};
|
|
|
|
my $file = File::Spec->canonpath($self->fullname);
|
|
# build one single list for each pkgnames combination
|
|
if (exists $all_conflict->{$file}) {
|
|
$pkg_list->{$all_conflict->{$file}}{$pkgname} ||=
|
|
[@{$all_conflict->{$file}}, $pkgname ];
|
|
$all_conflict->{$file} =
|
|
$pkg_list->{$all_conflict->{$file}}{$pkgname};
|
|
} elsif (exists $seen->{$file}) {
|
|
$pkg_list->{$seen->{$file}}{$pkgname} ||=
|
|
[ @{$seen->{$file}}, $pkgname ];
|
|
$all_conflict->{$file} =
|
|
$pkg_list->{$seen->{$file}}{$pkgname};
|
|
delete $seen->{$file};
|
|
} else {
|
|
$pkg_list->{$pkgname} ||= [$pkgname];
|
|
$seen->{$file} = $pkg_list->{$pkgname};
|
|
}
|
|
}
|
|
|
|
package OpenBSD::PackingElement::Dependency;
|
|
sub register
|
|
{
|
|
my ($self, $o, $pkgname) = @_;
|
|
$o->{wanted}{$self->{def}} //= $o->{currentname};
|
|
push @{$o->{all_deps}{$pkgname}}, $self->{def};
|
|
}
|
|
|
|
package OpenBSD::PackingElement::Manpage;
|
|
|
|
sub is_dest
|
|
{
|
|
my $self = shift;
|
|
return $self->name =~ m/man\/cat[^\/]+\/[^\/]+\.0$/o;
|
|
}
|
|
|
|
sub dest_to_source
|
|
{
|
|
my $self = shift;
|
|
my $v = $self->name;
|
|
$v =~ s/(man\/)cat([^\/]+)(\/[^\/]+)\.0$/$1man$2$3.$2/;
|
|
return $v;
|
|
}
|
|
|
|
sub known_page
|
|
{
|
|
my ($self, $h) = @_;
|
|
$h->{File::Spec->canonpath($self->fullname)} = 1;
|
|
}
|
|
|
|
sub add_extra_manpage
|
|
{
|
|
my ($self, $known, $plist) = @_;
|
|
if ($self->is_source) {
|
|
my $dest = $self->source_to_dest;
|
|
my $fullname = $self->cwd."/".$dest;
|
|
my $file = File::Spec->canonpath($fullname);
|
|
if (!$known->{$file}) {
|
|
OpenBSD::PackingElement::Manpage->add($plist, $dest);
|
|
$known->{$file} = 1;
|
|
}
|
|
}
|
|
if ($self->is_dest) {
|
|
my $src = $self->dest_to_source;
|
|
my $fullname = $self->cwd."/".$src;
|
|
my $file = File::Spec->canonpath($fullname);
|
|
if (!$known->{$file}) {
|
|
OpenBSD::PackingElement::Manpage->add($plist, $src);
|
|
$known->{$file} = 1;
|
|
}
|
|
}
|
|
}
|
|
|
|
package CheckProblemsScanner;
|
|
our @ISA = (qw(OpenBSD::PlistScanner));
|
|
use OpenBSD::PackageInfo;
|
|
|
|
sub add_more_man
|
|
{
|
|
my ($self, $plist) = @_;
|
|
my $knownman = {};
|
|
$plist->known_page($knownman);
|
|
$plist->add_extra_manpage($knownman, $plist);
|
|
}
|
|
|
|
sub register_plist
|
|
{
|
|
my ($self, $plist) = @_;
|
|
|
|
my $pkgname = $plist->pkgname;
|
|
$self->{got}{$pkgname} = 1;
|
|
|
|
if ($self->{do_dirs}) {
|
|
$self->{db}{$pkgname} //= {
|
|
pkgname => $pkgname,
|
|
missing_deps => {},
|
|
dirs => {},
|
|
need_dirs => {},
|
|
deps => {},
|
|
problems => {}
|
|
};
|
|
|
|
$plist->check_common_dirs($self->{db}{$pkgname}, $self);
|
|
}
|
|
|
|
if ($self->{do_conflicts}) {
|
|
$self->{conflicts}{$pkgname} =
|
|
OpenBSD::PkgCfl->make_conflict_list($plist);
|
|
if ($self->ui->opt('e')) {
|
|
$self->add_more_man($plist);
|
|
}
|
|
$plist->register($self, $pkgname);
|
|
}
|
|
}
|
|
|
|
sub handle_options
|
|
{
|
|
my $self = shift;
|
|
$self->{signature_style} = 'unsigned';
|
|
$self->SUPER::handle_options('CD',
|
|
"[-CDeSv] [-d plist_dir] [-o output] [-p ports_dir] [pkgname ...]");
|
|
}
|
|
|
|
sub new
|
|
{
|
|
my ($class) = @_;
|
|
my $o = $class->SUPER::new('check-problems');
|
|
|
|
if ($o->ui->opt('D') && $o->ui->opt('C')) {
|
|
$o->ui->usage("Won't compute anything");
|
|
}
|
|
|
|
$o->{do_dirs} = !$o->ui->opt('D');
|
|
$o->{do_conflicts} = !$o->ui->opt('C');
|
|
|
|
if ($o->{do_dirs}) {
|
|
$o->{db} = {};
|
|
$o->{mtree} = {
|
|
'/usr/local/lib/X11' => 1,
|
|
'/usr/local/include/X11' => 1,
|
|
'/usr/local/lib/X11/app-defaults' => 1
|
|
};
|
|
OpenBSD::Mtree::parse($o->{mtree}, '/',
|
|
'/etc/mtree/4.4BSD.dist');
|
|
OpenBSD::Mtree::parse($o->{mtree}, '/',
|
|
'/etc/mtree/BSD.x11.dist');
|
|
}
|
|
if ($o->{do_conflicts}) {
|
|
$o->{filehash} = {};
|
|
$o->{conflicts} = {};
|
|
$o->{all_deps} = {};
|
|
}
|
|
return $o;
|
|
}
|
|
|
|
|
|
# for common dirs
|
|
sub parent_has_dir
|
|
{
|
|
my ($self, $db, $t, $dir) = @_;
|
|
|
|
for my $dep (keys %{$t->{deps}}) {
|
|
if (!defined $db->{$dep}) {
|
|
if (!defined $self->{missing_deps}{$dep}) {
|
|
$self->ui->errsay("#1 : #2 not found", $t->{pkgname},
|
|
$dep);
|
|
$self->{missing_deps}{$dep} = 1;
|
|
}
|
|
next;
|
|
}
|
|
if ($db->{$dep}->{dirs}->{$dir} ||
|
|
$self->parent_has_dir($db, $db->{$dep}, $dir)) {
|
|
$t->{dirs}{$dir} = 1;
|
|
return 1;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub parent_has_problem
|
|
{
|
|
my ($db, $t, $dir) = @_;
|
|
for my $dep (keys %{$t->{deps}}) {
|
|
next if !defined $db->{$dep};
|
|
if ($db->{$dep}->{problems}->{$dir}) {
|
|
return 1;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub build_common_dirs
|
|
{
|
|
my ($self) = @_;
|
|
my $db = $self->{db};
|
|
my $mtree = $self->{mtree};
|
|
my @l = keys %$db;
|
|
|
|
$self->progress->for_list("Checking common dirs", \@l,
|
|
sub {
|
|
my $pkgname = shift;
|
|
my $t = $db->{$pkgname};
|
|
for my $dir (keys(%{$t->{need_dirs}})) {
|
|
return if $t->{dirs}{$dir};
|
|
return if $mtree->{$dir};
|
|
return if $self->parent_has_dir($db, $t, $dir);
|
|
$t->{problems}{$dir} = 1;
|
|
}
|
|
});
|
|
$self->progress->next;
|
|
}
|
|
|
|
sub show_common_dirs
|
|
{
|
|
my ($self) = @_;
|
|
my $db = $self->{db};
|
|
|
|
for my $pkgname (sort {$self->fullname($a) cmp $self->fullname($b)}
|
|
keys %$db) {
|
|
my @l=();
|
|
my $t = $db->{$pkgname};
|
|
for my $dir (keys %{$t->{problems}}) {
|
|
next if parent_has_problem($db, $t, $dir);
|
|
push(@l, $dir);
|
|
}
|
|
if (@l != 0) {
|
|
$self->say("#1: #2", $self->fullname($pkgname),
|
|
join(', ', sort @l));
|
|
}
|
|
}
|
|
}
|
|
|
|
# for conflicts
|
|
my $cache3 = {};
|
|
my $cache4 = {};
|
|
|
|
sub direct_conflict
|
|
{
|
|
my ($conflicts, $pkg, $pkg2) = @_;
|
|
|
|
return $cache3->{$pkg}{$pkg2} //= $conflicts->{$pkg}->conflicts_with($pkg2);
|
|
}
|
|
|
|
sub has_a_conflict
|
|
{
|
|
my ($conflicts, $deps, $pkg, $pkg2) = @_;
|
|
return $cache4->{$pkg}{$pkg2} //= find_a_conflict($conflicts, $deps, $pkg, $pkg2);
|
|
}
|
|
|
|
sub find_a_conflict
|
|
{
|
|
my ($conflicts, $deps, $pkg, $pkg2) = @_;
|
|
return 0 if $pkg eq $pkg2;
|
|
|
|
if (defined $conflicts->{$pkg} &&
|
|
direct_conflict($conflicts, $pkg, $pkg2)) {
|
|
return 1;
|
|
}
|
|
if (defined $deps->{$pkg}) {
|
|
for my $dep (@{$deps->{$pkg}}) {
|
|
if (has_a_conflict($conflicts, $deps, $dep, $pkg2)) {
|
|
return 1;
|
|
}
|
|
}
|
|
}
|
|
if (defined $deps->{$pkg2}) {
|
|
for my $dep (@{$deps->{$pkg2}}) {
|
|
if (has_a_conflict($conflicts, $deps, $pkg, $dep)) {
|
|
return 1;
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub compute_true_conflicts
|
|
{
|
|
my ($self, $l) = @_;
|
|
my $conflicts = $self->{conflicts};
|
|
my $deps = $self->{all_deps};
|
|
# create a list of unconflicting packages.
|
|
my $l2 = [];
|
|
for my $pkg (@$l) {
|
|
my $keepit = 0;
|
|
for my $pkg2 (@$l) {
|
|
next if $pkg eq $pkg2;
|
|
if (!(has_a_conflict($conflicts, $deps, $pkg, $pkg2) ||
|
|
has_a_conflict($conflicts, $deps, $pkg2, $pkg))) {
|
|
$keepit = 1;
|
|
last;
|
|
}
|
|
}
|
|
if ($keepit) {
|
|
push(@$l2, $pkg);
|
|
}
|
|
}
|
|
return $l2;
|
|
}
|
|
|
|
sub compute_conflicts
|
|
{
|
|
my ($self) = @_;
|
|
|
|
$self->progress->set_header("Compute file problems");
|
|
my $c = {};
|
|
my $c2 = {};
|
|
my $r = {};
|
|
my $cache = {};
|
|
|
|
my $h = $self->{filehash};
|
|
my $total = scalar(keys %$h);
|
|
my $i =0;
|
|
while (my ($key, $l) = each %$h) {
|
|
$self->progress->show(++$i, $total);
|
|
if (!defined $c->{$l}) {
|
|
my %s = map {($_, 1)} @$l;
|
|
$c->{$l} = [sort keys %s];
|
|
$c2->{$l} = join(',', @{$c->{$l}});
|
|
}
|
|
my $hv = $c2->{$l};
|
|
$l = $c->{$l};
|
|
next if @$l == 1;
|
|
$cache->{$hv} //= $self->compute_true_conflicts($l);
|
|
my $result = $cache->{$hv};
|
|
if (@$result != 0) {
|
|
my $newkey = join(',',
|
|
sort map { $self->fullname($_) } @$result);
|
|
if (@$result == 1) {
|
|
$newkey.="-> was ".join(',', @$l);
|
|
}
|
|
push(@{$r->{$newkey}}, $key);
|
|
}
|
|
}
|
|
$self->progress->next;
|
|
return $r;
|
|
}
|
|
|
|
sub show_conflicts
|
|
{
|
|
my ($self, $result) = @_;
|
|
for my $cfl (sort keys %$result) {
|
|
$self->say("#1", $cfl);
|
|
for my $f (sort @{$result->{$cfl}}) {
|
|
$self->say("\t#1", $f);
|
|
}
|
|
}
|
|
}
|
|
|
|
sub display_results
|
|
{
|
|
my $self = shift;
|
|
|
|
if ($self->{do_dirs}) {
|
|
$self->build_common_dirs;
|
|
$self->say("Common dirs:");
|
|
$self->show_common_dirs;
|
|
}
|
|
if ($self->{do_conflicts}) {
|
|
my $result = $self->compute_conflicts;
|
|
$self->say("Conflicts:");
|
|
$self->show_conflicts($result);
|
|
}
|
|
}
|
|
|
|
|
|
package main;
|
|
|
|
my $o = CheckProblemsScanner->new;
|
|
$o->run;
|