t/fake_ftpdist

   1 #!/usr/bin/perl
   2 # fake_ftpdist generates a fake Debian apt archive for testing
   3 # and is released under the terms of the GNU GPL version 3, or any
   4 # later version, at your option. See the file README and COPYING for
   5 # more information.
   6 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 fake_ftpdist - generates a fake Debian apt archive for testing from a real apt archive
  18
  19 =head1 SYNOPSIS
  20
  21 fake_ftpdist [options]
  22
  23 Options:
  24 --debug, -d debugging level (Default 0)
  25 --help, -h display this help
  26 --man, -m display manual
  27
  28 =head1 OPTIONS
  29
  30 =over
  31
  32 =item B<--debug, -d>
  33
  34 Debug verbosity. (Default 0)
  35
  36 =item B<--help, -h>
  37
  38 Display brief usage information.
  39
  40 =item B<--man, -m>
  41
  42 Display this manual.
  43
  44 =back
  45
  46 =head1 EXAMPLES
  47
  48 C<fake_ftpdist --ftpdist /srv/ftp.debian.org/ftp/dists>
  49
  50 =cut
  51
  52 use Debbugs::Common qw(open_compressed_file);
  53 use IO::Dir;
  54 use File::Basename;
  55
  56 use vars qw($DEBUG);
  57
  58 my %options = (debug           => 0,
  59                help            => 0,
  60                man             => 0,
  61               );
  62
  63 GetOptions(\%options,
  64            'ftpdist=s',
  65            'progress',
  66            'debug|d+','help|h|?','man|m');
  67
  68 pod2usage() if $options{help};
  69 pod2usage({verbose=>2}) if $options{man};
  70
  71 $DEBUG = $options{debug};
  72
  73 my @USAGE_ERRORS;
  74
  75 if ($options{progress}) {
  76     eval "use Term::ProgressBar";
  77     push @USAGE_ERRORS, "You asked for a progress bar, but Term::ProgressBar isn't installed" if $@;
  78 }
  79
  80 if (not defined $options{ftpdist}) {
  81     push @USAGE_ERRORS, "You must provide an --ftpdist option";
  82 }
  83
  84 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  85
  86 my $prog_bar;
  87 if ($options{progress}) {
  88     $prog_bar = eval "Term::ProgressBar->new({count => 1,ETA=>q(linear)})";
  89     warn "Unable to initialize progress bar: $@" if not $prog_bar;
  90 }
  91
  92 my $dist_dir = IO::Dir->new($options{ftpdist}) or
  93     die "Unable to open directory $options{ftpdist}: $!";
  94 my @dist_names =
  95         grep { $_ !~ /^\./ and
  96                -d $options{ftpdist}.'/'.$_ and
  97                not -l $options{ftpdist}.'/'.$_
  98            } $dist_dir->read;
  99 my %s_p;
 100 my %s_di;
 101 while (my $dist = shift @dist_names) {
 102         my $dist_dir = $options{ftpdist}.'/'.$dist;
 103         my ($dist_info,$package_files) =
 104             read_release_file($dist_dir.'/Release');
 105         $s_di{$dist_info->{Codename}} = $dist_info;
 106         $s_p{$dist_info->{Codename}} = $package_files;
 107 }
 108 my $tot = 0;
 109 for my $suite (keys %s_p) {
 110         for my $component (keys %{$s_p{$suite}}) {
 111             $tot += scalar keys %{$s_p{$suite}{$component}};
 112         }
 113 }
 114 $prog_bar->target($tot) if $prog_bar;
 115 my $i = 0;
 116 my $avg_pkgs = 0;
 117 my $tot_suites = scalar keys %s_p;
 118 my $done_suites=0;
 119 my $completed_pkgs=0;
 120 # parse packages files
 121 for my $suite (keys %s_p) {
 122     my $suite_has_packages = 0;
 123     for my $component (keys %{$s_p{$suite}}) {
 124         my @archs = keys %{$s_p{$suite}{$component}};
 125         if (grep {$_ eq 'source'} @archs) {
 126             @archs = ('source',grep {$_ ne 'source'} @archs);
 127         }
 128         for my $arch (@archs) {
 129             # we only need a few architectures
 130             if ($arch !~ /(all|source|amd64|i386)/) {
 131                 $prog_bar->update(++$i);
 132                 next;
 133             }
 134             my $pfh =  open_compressed_file($s_p{$suite}{$component}{$arch}) or
 135                 die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
 136             local $_;
 137             local $/ = '';      # paragraph mode
 138             my @pkgs;
 139             while (<$pfh>) {
 140                 my %pkg;
 141                 for my $field (qw(Package Source)) {
 142                     /^\Q$field\E: (.*)/m;
 143                     $pkg{$field} = $1;
 144                 }
 145                 next unless defined $pkg{Package};
 146                 # skip packages which we aren't actually interested in
 147                 next unless interesting_package(\%pkg);
 148                 $pkg{paragraph} = $_;
 149                 push @pkgs,\%pkg;
 150             }
 151             if (@pkgs) {
 152                 $suite_has_packages = 1;
 153                 output_packages($suite,$component,$arch,\@pkgs);
 154             }
 155             $prog_bar->update(++$i);
 156         }
 157     }
 158     build_release($suite,$s_di{$suite}) if $suite_has_packages;
 159 }
 160 $prog_bar->remove() if $prog_bar;
 161
 162 sub build_release {
 163     my ($suite,$dist_info) = @_;
 164
 165     my $release_file;
 166     my $apt_ftparchive;
 167     open($apt_ftparchive,
 168          '-|',
 169          'apt-ftparchive','release',
 170          $suite,
 171          (map {exists $dist_info->{$_}?
 172                    ('-o=APT::FTPArchive::Release::'.$_.'='.
 173                     $dist_info->{$_}):()}
 174             qw(Description Origin Suite Version Codename Components Date)
 175          )) or
 176              die "Unable to run apt-ftparchive: $!";
 177     local $/;
 178     my ($rf_temp) = <$apt_ftparchive>;
 179     close($apt_ftparchive) or
 180         die "apt-ftparchive failed: $!";
 181     open($release_file,'>',"$suite/Release") or
 182         die "Unable to open file $suite/Release: $!";
 183     print {$release_file} $rf_temp or
 184         die "Unable to print to release file: $!";
 185     close($release_file) or
 186         die "Unable to close release file: $!";
 187 }
 188
 189 sub output_packages {
 190     my ($suite,$component,$arch,$pkgs) = @_;
 191     mkdir_if_ne($suite);
 192     mkdir_if_ne("$suite/$component");
 193     mkdir_if_ne("$suite/$component/$arch");
 194     my $packages;
 195     open($packages,">:encoding(UTF-8)","$suite/$component/$arch/Packages");
 196     for my $pkg (@{$pkgs}) {
 197         # replace all e-mail address looking things with foo@example.com
 198         $pkg->{paragraph} =~
 199             s/(<\S+\@)\S+(>)/${1}example.com${2}/g;
 200         print {$packages} $pkg->{paragraph};
 201     }
 202     close($packages);
 203 }
 204
 205
 206 sub mkdir_if_ne {
 207     if (! -d $_[0]) {
 208         mkdir $_[0] or die "unable to mkdir $_[0]";
 209     }
 210 }
 211
 212 sub interesting_package {
 213     my ($pkg) = @_;
 214     # currently, we only want debbugs, packages containing libc, or source of
 215     # glibc. Add more packages here if there are interesting cases we need to
 216     # debug
 217     if ($pkg->{Package} eq 'debbugs' or
 218         ($pkg->{Source} // $pkg->{Package}) eq 'glibc'
 219        ) {
 220         return 1;
 221     }
 222     return 0;
 223 }
 224
 225
 226 sub read_release_file {
 227     my ($file) = @_;
 228     # parse release
 229     my $rfh =  open_compressed_file($file) or
 230         die "Unable to open $file for reading: $!";
 231     my %dist_info;
 232     my $in_sha1;
 233     my %p_f;
 234     while (<$rfh>) {
 235         chomp;
 236         if (s/^(\S+):\s*//) {
 237             if ($1 eq 'SHA1'or $1 eq 'SHA256') {
 238                 $in_sha1 = 1;
 239                 next;
 240             }
 241             $dist_info{$1} = $_;
 242         } elsif ($in_sha1) {
 243             s/^\s//;
 244             my ($sha,$size,$f) = split /\s+/,$_;
 245             next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
 246             next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
 247             my ($component,$arch,$package_source) = ($1,$2,$3);
 248             next if exists $p_f{$component}{$arch};
 249             $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
 250         }
 251     }
 252     return (\%dist_info,\%p_f);
 253 }
 254
 255
 256 __END__
 257 # Local Variables:
 258 # indent-tabs-mode: nil
 259 # cperl-indent-level: 4
 260 # End: