chiark - git - mdw - dpkg/blob - scripts/Dpkg/Dist/Files.pm

   1 # Copyright © 2014-2015 Guillem Jover <guillem@debian.org>
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  15
  16 package Dpkg::Dist::Files;
  17
  18 use strict;
  19 use warnings;
  20
  21 our $VERSION = '0.01';
  22
  23 use IO::Dir;
  24
  25 use Dpkg::Gettext;
  26 use Dpkg::ErrorHandling;
  27
  28 use parent qw(Dpkg::Interface::Storable);
  29
  30 sub new {
  31     my ($this, %opts) = @_;
  32     my $class = ref($this) || $this;
  33
  34     my $self = {
  35         options => [],
  36         files => {},
  37     };
  38     foreach my $opt (keys %opts) {
  39         $self->{$opt} = $opts{$opt};
  40     }
  41     bless $self, $class;
  42
  43     return $self;
  44 }
  45
  46 sub reset {
  47     my $self = shift;
  48
  49     $self->{files} = {};
  50 }
  51
  52 sub parse_filename {
  53     my ($self, $fn) = @_;
  54
  55     my $file;
  56
  57     if ($fn =~ m/^(([-+:.0-9a-z]+)_([^_]+)_([-\w]+)\.([a-z0-9.]+))$/) {
  58         $file->{filename} = $1;
  59         $file->{package} = $2;
  60         $file->{version} = $3;
  61         $file->{arch} = $4;
  62         $file->{package_type} = $5;
  63     } elsif ($fn =~ m/^([-+:.,_0-9a-zA-Z~]+)$/) {
  64         $file->{filename} = $1;
  65     } else {
  66         $file = undef;
  67     }
  68
  69     return $file;
  70 }
  71
  72 sub parse {
  73     my ($self, $fh, $desc) = @_;
  74     my $count = 0;
  75
  76     local $_;
  77     binmode $fh;
  78
  79     while (<$fh>) {
  80         chomp;
  81
  82         my $file;
  83
  84         if (m/^(\S+) (\S+) (\S+)$/) {
  85             $file = $self->parse_filename($1);
  86             error(g_('badly formed package name in files list file, line %d'), $.)
  87                 unless defined $file;
  88             $file->{section} = $2;
  89             $file->{priority} = $3;
  90         } else {
  91             error(g_('badly formed line in files list file, line %d'), $.);
  92         }
  93
  94         if (defined $self->{files}->{$file->{filename}}) {
  95             warning(g_('duplicate files list entry for file %s (line %d)'),
  96                     $file->{filename}, $.);
  97         } else {
  98             $count++;
  99             $self->{files}->{$file->{filename}} = $file;
 100         }
 101     }
 102
 103     return $count;
 104 }
 105
 106 sub load_dir {
 107     my ($self, $dir) = @_;
 108
 109     my $count = 0;
 110     my $dh = IO::Dir->new($dir) or syserr(g_('cannot open directory %s'), $dir);
 111
 112     while (defined(my $file = $dh->read)) {
 113         my $pathname = "$dir/$file";
 114         next unless -f $pathname;
 115         $count += $self->load($pathname);
 116     }
 117
 118     return $count;
 119 }
 120
 121 sub get_files {
 122     my $self = shift;
 123
 124     return map { $self->{files}->{$_} } sort keys %{$self->{files}};
 125 }
 126
 127 sub get_file {
 128     my ($self, $filename) = @_;
 129
 130     return $self->{files}->{$filename};
 131 }
 132
 133 sub add_file {
 134     my ($self, $filename, $section, $priority) = @_;
 135
 136     my $file = $self->parse_filename($filename);
 137     error(g_('invalid filename %s'), $filename) unless defined $file;
 138     $file->{section} = $section;
 139     $file->{priority} = $priority;
 140
 141     $self->{files}->{$filename} = $file;
 142
 143     return $file;
 144 }
 145
 146 sub del_file {
 147     my ($self, $filename) = @_;
 148
 149     delete $self->{files}->{$filename};
 150 }
 151
 152 sub filter {
 153     my ($self, %opts) = @_;
 154     my $remove = $opts{remove} // sub { 0 };
 155     my $keep = $opts{keep} // sub { 1 };
 156
 157     foreach my $filename (keys %{$self->{files}}) {
 158         my $file = $self->{files}->{$filename};
 159
 160         if (not &$keep($file) or &$remove($file)) {
 161             delete $self->{files}->{$filename};
 162         }
 163     }
 164 }
 165
 166 sub output {
 167     my ($self, $fh) = @_;
 168     my $str = '';
 169
 170     binmode $fh if defined $fh;
 171
 172     foreach my $filename (sort keys %{$self->{files}}) {
 173         my $file = $self->{files}->{$filename};
 174         my $entry = "$filename $file->{section} $file->{priority}\n";
 175
 176         print { $fh } $entry if defined $fh;
 177         $str .= $entry;
 178     }
 179
 180     return $str;
 181 }
 182
 183 1;