From 574ff042367055d332502a7d94730c8c1cce86b5 Mon Sep 17 00:00:00 2001
From: dakkar <dakkar@thenautilus.net>
Date: Sat, 13 Jul 2019 15:14:06 +0100
Subject: add portage-scan

---
 bin/portage-scan | 141 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 141 insertions(+)
 create mode 100644 bin/portage-scan

(limited to 'bin')

diff --git a/bin/portage-scan b/bin/portage-scan
new file mode 100644
index 0000000..f5a0d98
--- /dev/null
+++ b/bin/portage-scan
@@ -0,0 +1,141 @@
+#!/usr/bin/env perl
+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'; # nothing else to check
+
+    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;
+            }
+        },
+    },
+    '/',
+);
-- 
cgit v1.2.3