use strict;
use warnings;
use 5.020;
use experimental 'smartmatch';
use autodie;
use Try::Tiny;
use File::Find;
use File::stat;
use Digest::MD5;
sub load_portage_data {
my %data;
find(
{
wanted => sub {
$_ eq 'CONTENTS' or return;
open my $fh,'<',$File::Find::name;
while (defined(my $line=<$fh>)) {
chomp $line;
if ($line =~ /^dir /) {
my ($path) = $line =~ m{\A dir [ ] (.+)\z}x;
$data{$path}={kind=>'dir'};
}
elsif ($line =~ /^obj /) {
my ($path,$md5,$mtime) = $line =~
m{\A obj [ ] (.+) [ ] ([0-9a-f]+) [ ] ([0-9]+)\z}x;
$data{$path} = {
kind => 'obj',
md5 => $md5,
mtime => $mtime,
};
}
elsif ($line =~ /^sym /) {
my ($path,$dest,$mtime) = $line =~
m{\A sym [ ] (.+) [ ]->[ ] (.+) [ ] ([0-9]+)\z}x;
$data{$path} = {
kind => 'sym',
dest => $dest,
mtime => $mtime,
};
}
else {
warn "WTF? <$line> in $File::Find::name\n";
}
}
},
},
'/var/db/pkg',
);
return \%data;
}
sub match_file {
my ($fn,$data) = @_;
my $file_info = $data->{$fn} || $data->{ $fn =~ s{^/lib64/}{/lib/}r };
my $fs = lstat($fn);
my $kind = -l $fs ? 'sym' : -d $fs ? 'dir' : 'obj';
my %ret = (
kind => $kind,
dev => $fs->dev,
errs => [],
);
my $errs = $ret{errs};
if (!$file_info) {
push @$errs, 'O';
return \%ret;
}
if ($kind ne $file_info->{kind}) {
push @$errs, 'K';
return \%ret;
}
return \%ret if $kind eq 'dir';
my $mtime = $fs->mtime;
if ($mtime != $file_info->{mtime}) {
push @$errs, 'T';
}
if ($kind eq 'sym') {
my $dest = readlink($fn);
if ($dest ne $file_info->{dest}) {
push @$errs, 'L';
}
}
else {
my $d = Digest::MD5->new;
try {
open my $fh,'<:raw',$fn;
$d->addfile($fh);
my $md5 = $d->hexdigest;
if ($md5 ne $file_info->{md5}) {
push @$errs, '5';
}
}
catch { push @$errs, '*' };
}
return \%ret;
}
my $prune_rx = qr{\A / (?:home/|ssd/|vm-disk/|net/|dev/|sys/|proc/|run/|tmp/|var/(?:db/pkg/|cache/|spool/|run/|log/)|usr/(?:src/linux/|portage/)) }x;
my $data = load_portage_data;
warn "loaded\n";
my $root_stat = stat('/');
my $root_dev = $root_stat->dev;
my %symbol_for_kind=(
dir => '/',
sym => '@',
obj => '',
);
find(
{
no_chdir => 1,
wanted => sub {
if (/$prune_rx/) {
$File::Find::prune=1;
return;
}
my $match = match_file($_,$data);
if (@{$match->{errs}}) {
say $_, $symbol_for_kind{$match->{kind}},
' ',@{$match->{errs}};
}
if (
($_ ne '/'
and $match->{kind} eq 'dir'
and 'O' ~~ $match->{errs})
or
($match->{dev} != $root_dev)
) {
$File::Find::prune=1;
}
},
},
'/',
);