libdebbugs-perl 2.6.0 / usr / share / perl5 / Debbugs / DebArchive.pm

# 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: