Debbugs/DebArchive.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # Copyright 2017 by Don Armstrong <don@donarmstrong.com>.
   7
   8 package Debbugs::DebArchive;
   9
  10 use warnings;
  11 use strict;
  12
  13 =head1 NAME
  14
  15 Debbugs::DebArchive -- Routines for reading files from Debian archives
  16
  17 =head1 SYNOPSIS
  18
  19 use Debbugs::DebArchive;
  20
  21    read_packages('/srv/mirrors/ftp.debian.org/ftp/dist',
  22                  sub { print map {qq($_\n)} @_ },
  23                  Term::ProgressBar->new(),
  24                 );
  25
  26
  27 =head1 DESCRIPTION
  28
  29 This module implements a set of routines for reading Packages.gz, Sources.gz and
  30 Release files from the dists directory of a Debian archive.
  31
  32 =head1 BUGS
  33
  34 None known.
  35
  36 =cut
  37
  38
  39 use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT);
  40 use base qw(Exporter);
  41
  42 BEGIN {
  43     $VERSION = 1.00;
  44     $DEBUG = 0 unless defined $DEBUG;
  45
  46     @EXPORT = ();
  47     %EXPORT_TAGS = (read => [qw(read_release_file read_packages),
  48                             ],
  49                    );
  50     @EXPORT_OK = ();
  51     Exporter::export_ok_tags(keys %EXPORT_TAGS);
  52     $EXPORT_TAGS{all} = [@EXPORT_OK];
  53 }
  54
  55 use File::Spec qw();
  56 use File::Basename;
  57 use Debbugs::Config qw(:config);
  58 use Debbugs::Common qw(open_compressed_file make_list);
  59 use IO::Dir;
  60
  61 use Carp;
  62
  63 =over
  64
  65 =item read_release_file
  66
  67      read_release_file('stable/Release')
  68
  69 Reads a Debian release file and returns a hashref of information about the
  70 release file, including the Packages and Sources files for that distribution
  71
  72 =cut
  73
  74 sub read_release_file {
  75     my ($file) = @_;
  76     # parse release
  77     my $rfh =  open_compressed_file($file) or
  78         die "Unable to open $file for reading: $!";
  79     my %dist_info;
  80     my $in_sha1;
  81     my %p_f;
  82     while (<$rfh>) {
  83         chomp;
  84         if (s/^(\S+):\s*//) {
  85             if ($1 eq 'SHA1'or $1 eq 'SHA256') {
  86                 $in_sha1 = 1;
  87                 next;
  88             }
  89             $dist_info{$1} = $_;
  90         } elsif ($in_sha1) {
  91             s/^\s//;
  92             my ($sha,$size,$f) = split /\s+/,$_;
  93             next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
  94             next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
  95             my ($component,$arch,$package_source) = ($1,$2,$3);
  96             $arch =~ s/binary-//;
  97             next if exists $p_f{$component}{$arch} and
  98                 $p_f{$component}{$arch} =~ /\.xz$/;
  99             $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
 100         }
 101     }
 102     return (\%dist_info,\%p_f);
 103 }
 104
 105 =item read_packages
 106
 107      read_packages($dist_dir,$callback,$progress)
 108
 109 =over
 110
 111 =item dist_dir
 112
 113 Path to dists directory
 114
 115 =item callback
 116
 117 Function which is called with key, value pairs of suite, arch, component,
 118 Package, Source, Version, and Maintainer information for each package in the
 119 Packages file.
 120
 121 =item progress
 122
 123 Optional Term::ProgressBar object to output progress while reading packages.
 124
 125 =back
 126
 127
 128 =cut
 129
 130 sub read_packages {
 131     my ($dist_dir,$callback,$p) = @_;
 132
 133     my %s_p;
 134     my $tot = 0;
 135     for my $dist (make_list($dist_dir)) {
 136         my $dist_dir_h = IO::Dir->new($dist);
 137         my @dist_names =
 138             grep { $_ !~ /^\./ and
 139                    -d $dist.'/'.$_ and
 140                    not -l $dist.'/'.$_
 141                } $dist_dir_h->read or
 142                die "Unable to read from dir: $!";
 143         $dist_dir_h->close or
 144             die "Unable to close dir: $!";
 145         while (my $dist = shift @dist_names) {
 146             my $dir = $dist_dir.'/'.$dist;
 147             my ($dist_info,$package_files) =
 148                 read_release_file(File::Spec->catfile($dist_dir,
 149                                                       $dist,
 150                                                       'Release'));
 151             $s_p{$dist_info->{Codename}} = $package_files;
 152         }
 153         for my $suite (keys %s_p) {
 154             for my $component (keys %{$s_p{$suite}}) {
 155                 $tot += scalar keys %{$s_p{$suite}{$component}};
 156             }
 157         }
 158     }
 159     $p->target($tot) if $p;
 160     my $done_archs = 0;
 161     # parse packages files
 162     for my $suite (keys %s_p) {
 163         my $pkgs = 0;
 164         for my $component (keys %{$s_p{$suite}}) {
 165             my @archs = keys %{$s_p{$suite}{$component}};
 166             if (grep {$_ eq 'source'} @archs) {
 167                 @archs = ('source',grep {$_ ne 'source'} @archs);
 168             }
 169             for my $arch (@archs) {
 170                 my $pfh =  open_compressed_file($s_p{$suite}{$component}{$arch}) or
 171                     die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
 172                 local $_;
 173                 local $/ = '';  # paragraph mode
 174                 while (<$pfh>) {
 175                     my %pkg;
 176                     for my $field (qw(Package Maintainer Version Source)) {
 177                         /^\Q$field\E: (.*)/m;
 178                         $pkg{$field} = $1;
 179                     }
 180                     next unless defined $pkg{Package} and
 181                         defined $pkg{Version};
 182                     $pkg{suite} = $suite;
 183                     $pkg{arch} = $arch;
 184                     $pkg{component} = $component;
 185                     $callback->(%pkg);
 186                 }
 187                 $p->update(++$done_archs) if $p;
 188             }
 189         }
 190     }
 191     $p->remove() if $p;
 192 }
 193
 194 =back
 195
 196 =cut
 197
 198 1;
 199
 200 __END__
 201 # Local Variables:
 202 # indent-tabs-mode: nil
 203 # cperl-indent-level: 4
 204 # End: