1 files changed, 200 insertions, 0 deletions
diff --git a/lib/Lintian/Processable/Source/Orig.pm b/lib/Lintian/Processable/Source/Orig.pm
new file mode 100644
index 0000000..dd263f5
--- /dev/null
+++ b/lib/Lintian/Processable/Source/Orig.pm
@@ -0,0 +1,200 @@
+# -*- perl -*- Lintian::Processable::Source::Orig
+#
+# Copyright (C) 2020 Felix Lechner
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the Free
+# Software Foundation; either version 2 of the License, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
+# more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program.  If not, see <http://www.gnu.org/licenses/>.
+
+package Lintian::Processable::Source::Orig;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use List::SomeUtils qw(uniq);
+use List::UtilsBy qw(sort_by);
+use Path::Tiny;
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Index;
+
+const my $EMPTY => q{};
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+
+use Moo::Role;
+use namespace::clean;
+
+=head1 NAME
+
+Lintian::Processable::Source::Orig - access to collected data about the upstream (orig) sources
+
+=head1 SYNOPSIS
+
+    use Lintian::Processable;
+
+=head1 DESCRIPTION
+
+Lintian::Processable::Source::Orig provides an interface to collected data about the upstream (orig) sources.
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item orig
+
+Returns the index for orig.tar.gz.
+
+=cut
+
+my %DECOMPRESS_COMMAND = (
+    'gz' => 'gzip --decompress --stdout',
+    'bz2' => 'bzip2 --decompress --stdout',
+    'xz' => 'xz --decompress --stdout',
+);
+
+has orig => (
+    is => 'rw',
+    lazy => 1,
+    default => sub {
+        my ($self) = @_;
+
+        my $index = Lintian::Index->new;
+        my $archive = $self->basename;
+        $index->identifier("$archive (orig)");
+        $index->basedir($self->basedir . $SLASH . 'orig');
+
+        return $index
+          if $self->native;
+
+        # source packages can be unpacked anywhere; no anchored roots
+        $index->anchored(0);
+
+        my %components = %{$self->components};
+
+        # keep sort order; root is missing below otherwise
+        my @tarballs = sort_by { $components{$_} } keys %components;
+
+        for my $tarball (@tarballs) {
+
+            my $component = $components{$tarball};
+
+            # so far, all archives with components had an extra level
+            my $component_dir = $index->basedir;
+            $component_dir .= $SLASH . $component
+              if length $component;
+
+            my $subindex = Lintian::Index->new;
+            $subindex->basedir($component_dir);
+
+            # source packages can be unpacked anywhere; no anchored roots
+            $index->anchored(0);
+
+            my ($extension) = ($tarball =~ /\.([^.]+)$/);
+            die encode_utf8("Source component $tarball has no file exension\n")
+              unless length $extension;
+
+            my $decompress = $DECOMPRESS_COMMAND{lc $extension};
+            die encode_utf8("Don't know how to decompress $tarball")
+              unless $decompress;
+
+            my @command
+              = (split($SPACE, $decompress),
+                $self->basedir . $SLASH . $tarball);
+
+            my $errors = $subindex->create_from_piped_tar(\@command);
+
+            push(@{$index->unpack_messages}, "$tarball . $_")
+              for grep { !/^tar: Ignoring / } uniq split(/\n/, $errors);
+
+            # treat hard links like regular files
+            my @hardlinks = grep { $_->is_hardlink } @{$subindex->sorted_list};
+            for my $item (@hardlinks) {
+
+                my $target = $subindex->lookup($item->link);
+
+                $item->unpacked_path($target->unpacked_path);
+                $item->size($target->size);
+                $item->link($EMPTY);
+
+                # turn into a regular file
+                my $perm = $item->perm;
+                $perm =~ s/^-/h/;
+                $item->perm($perm);
+
+                $item->path_info(
+                    ($item->path_info & ~Lintian::Index::Item::TYPE_HARDLINK)
+                    | Lintian::Index::Item::TYPE_FILE);
+            }
+
+            my @prefixes = @{$subindex->sorted_list};
+
+            # keep top level prefixes; no trailing slashes
+            s{^([^/]+).*$}{$1}s for @prefixes;
+
+            # squash identical values; ignore root entry ('')
+            my @unique = grep { length } uniq @prefixes;
+
+            # check for single common value
+            if (@unique == 1) {
+
+                # no trailing slash for directories
+                my $common = $unique[0];
+
+                # proceed if no file with that name (lacks slash)
+                my $conflict = $subindex->lookup($common);
+                unless (defined $conflict) {
+
+                    if ($common ne $component || length $component) {
+
+                        # shortens paths; keeps same base directory
+                        my $sub_errors = $subindex->drop_common_prefix;
+
+                        push(@{$index->unpack_errors}, "$tarball . $_")
+                          for uniq split(/\n/, $sub_errors);
+                    }
+                }
+            }
+
+            # lowers base directory to match index being merged into
+            $subindex->capture_common_prefix
+              if length $component;
+
+            $index->merge_in($subindex);
+        }
+
+        return $index;
+    }
+);
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Felix Lechner <felix.lechner@lease-up.com> for
+Lintian.
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et