--- /dev/null
+# This module is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
+
+package Debbugs::DebArchive;
+
+use warnings;
+use strict;
+
+=head1 NAME
+
+Debbugs::DebArchive -- Routines for reading files from Debian archives
+
+=head1 SYNOPSIS
+
+use Debbugs::DebArchive;
+
+ read_packages('/srv/mirrors/ftp.debian.org/ftp/dist',
+ sub { print map {qq($_\n)} @_ },
+ Term::ProgressBar->new(),
+ );
+
+
+=head1 DESCRIPTION
+
+This module implements a set of routines for reading Packages.gz, Sources.gz and
+Release files from the dists directory of a Debian archive.
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+
+use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
+use base qw(Exporter);
+
+BEGIN {
+ $VERSION = 1.00;
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (read => [qw(read_release_file read_packages),
+ ],
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+}
+
+use File::Spec qw();
+use File::Basename;
+use Debbugs::Config qw(:config);
+use Debbugs::Common qw(open_compressed_file make_list);
+use IO::Dir;
+
+use Carp;
+
+=over
+
+=item read_release_file
+
+ read_release_file('stable/Release')
+
+Reads a Debian release file and returns a hashref of information about the
+release file, including the Packages and Sources files for that distribution
+
+=cut
+
+sub read_release_file {
+ my ($file) = @_;
+ # parse release
+ my $rfh = open_compressed_file($file) or
+ die "Unable to open $file for reading: $!";
+ my %dist_info;
+ my $in_sha1;
+ my %p_f;
+ while (<$rfh>) {
+ chomp;
+ if (s/^(\S+):\s*//) {
+ if ($1 eq 'SHA1'or $1 eq 'SHA256') {
+ $in_sha1 = 1;
+ next;
+ }
+ $dist_info{$1} = $_;
+ } elsif ($in_sha1) {
+ s/^\s//;
+ my ($sha,$size,$f) = split /\s+/,$_;
+ next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
+ next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
+ my ($component,$arch,$package_source) = ($1,$2,$3);
+ $arch =~ s/binary-//;
+ next if exists $p_f{$component}{$arch} and
+ $p_f{$component}{$arch} =~ /\.xz$/;
+ $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
+ }
+ }
+ return (\%dist_info,\%p_f);
+}
+
+=item read_packages
+
+ read_packages($dist_dir,$callback,$progress)
+
+=over
+
+=item dist_dir
+
+Path to dists directory
+
+=item callback
+
+Function which is called with key, value pairs of suite, arch, component,
+Package, Source, Version, and Maintainer information for each package in the
+Packages file.
+
+=item progress
+
+Optional Term::ProgressBar object to output progress while reading packages.
+
+=back
+
+
+=cut
+
+sub read_packages {
+ my ($dist_dir,$callback,$p) = @_;
+
+ my %s_p;
+ my $tot = 0;
+ for my $dist (make_list($dist_dir)) {
+ my $dist_dir_h = IO::Dir->new($dist);
+ my @dist_names =
+ grep { $_ !~ /^\./ and
+ -d $dist.'/'.$_ and
+ not -l $dist.'/'.$_
+ } $dist_dir_h->read or
+ die "Unable to read from dir: $!";
+ $dist_dir_h->close or
+ die "Unable to close dir: $!";
+ while (my $dist = shift @dist_names) {
+ my $dir = $dist_dir.'/'.$dist;
+ my ($dist_info,$package_files) =
+ read_release_file(File::Spec->catfile($dist_dir,
+ $dist,
+ 'Release'));
+ $s_p{$dist_info->{Codename}} = $package_files;
+ }
+ for my $suite (keys %s_p) {
+ for my $component (keys %{$s_p{$suite}}) {
+ $tot += scalar keys %{$s_p{$suite}{$component}};
+ }
+ }
+ }
+ $p->target($tot) if $p;
+ my $done_archs = 0;
+ # parse packages files
+ for my $suite (keys %s_p) {
+ my $pkgs = 0;
+ for my $component (keys %{$s_p{$suite}}) {
+ my @archs = keys %{$s_p{$suite}{$component}};
+ if (grep {$_ eq 'source'} @archs) {
+ @archs = ('source',grep {$_ ne 'source'} @archs);
+ }
+ for my $arch (@archs) {
+ my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or
+ die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
+ local $_;
+ local $/ = ''; # paragraph mode
+ while (<$pfh>) {
+ my %pkg;
+ for my $field (qw(Package Maintainer Version Source)) {
+ /^\Q$field\E: (.*)/m;
+ $pkg{$field} = $1;
+ }
+ next unless defined $pkg{Package} and
+ defined $pkg{Version};
+ $pkg{suite} = $suite;
+ $pkg{arch} = $arch;
+ $pkg{component} = $component;
+ $callback->(%pkg);
+ }
+ $p->update(++$done_archs) if $p;
+ }
+ }
+ }
+ $p->remove() if $p;
+}
+
+=back
+
+=cut
+
+1;
+
+__END__
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End: