File: | Dpkg/Dist/Files.pm |
Coverage: | 86.7% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
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 | 1 1 1 | 2 1 12 | use strict; | ||||
19 | 1 1 1 | 2 0 28 | use warnings; | ||||
20 | |||||||
21 | our $VERSION = '0.01'; | ||||||
22 | |||||||
23 | 1 1 1 | 129 3868 18 | use IO::Dir; | ||||
24 | |||||||
25 | 1 1 1 | 194 1 24 | use Dpkg::Gettext; | ||||
26 | 1 1 1 | 205 1 32 | use Dpkg::ErrorHandling; | ||||
27 | |||||||
28 | 1 1 1 | 3 0 2 | use parent qw(Dpkg::Interface::Storable); | ||||
29 | |||||||
30 | sub new { | ||||||
31 | 1 | 0 | 1 | my ($this, %opts) = @_; | |||
32 | 1 | 3 | my $class = ref($this) || $this; | ||||
33 | |||||||
34 | 1 | 1 | my $self = { | ||||
35 | options => [], | ||||||
36 | files => {}, | ||||||
37 | }; | ||||||
38 | 1 | 1 | foreach my $opt (keys %opts) { | ||||
39 | 0 | 0 | $self->{$opt} = $opts{$opt}; | ||||
40 | } | ||||||
41 | 1 | 1 | bless $self, $class; | ||||
42 | |||||||
43 | 1 | 1 | return $self; | ||||
44 | } | ||||||
45 | |||||||
46 | sub reset { | ||||||
47 | 5 | 0 | 5 | my $self = shift; | |||
48 | |||||||
49 | 5 | 14 | $self->{files} = {}; | ||||
50 | } | ||||||
51 | |||||||
52 | sub parse_filename { | ||||||
53 | 33 | 0 | 23 | my ($self, $fn) = @_; | |||
54 | |||||||
55 | 33 | 16 | my $file; | ||||
56 | |||||||
57 | 33 | 54 | if ($fn =~ m/^(([-+:.0-9a-z]+)_([^_]+)_([-\w]+)\.([a-z0-9.]+))$/) { | ||||
58 | # Artifact using the common <name>_<version>_<arch>.<type> pattern. | ||||||
59 | 18 | 17 | $file->{filename} = $1; | ||||
60 | 18 | 16 | $file->{package} = $2; | ||||
61 | 18 | 8 | $file->{version} = $3; | ||||
62 | 18 | 14 | $file->{arch} = $4; | ||||
63 | 18 | 15 | $file->{package_type} = $5; | ||||
64 | } elsif ($fn =~ m/^([-+:.,_0-9a-zA-Z~]+)$/) { | ||||||
65 | # Artifact with no common pattern, usually called byhand or raw, as | ||||||
66 | # they might require manual processing on the server side, or custom | ||||||
67 | # actions per file type. | ||||||
68 | 14 | 11 | $file->{filename} = $1; | ||||
69 | } else { | ||||||
70 | 1 | 1 | $file = undef; | ||||
71 | } | ||||||
72 | |||||||
73 | 33 | 19 | return $file; | ||||
74 | } | ||||||
75 | |||||||
76 | sub parse { | ||||||
77 | 7 | 1 | 6 | my ($self, $fh, $desc) = @_; | |||
78 | 7 | 5 | my $count = 0; | ||||
79 | |||||||
80 | 7 | 3 | local $_; | ||||
81 | 7 | 7 | binmode $fh; | ||||
82 | |||||||
83 | 7 | 25 | while (<$fh>) { | ||||
84 | 27 | 17 | chomp; | ||||
85 | |||||||
86 | 27 | 20 | my $file; | ||||
87 | |||||||
88 | 27 | 43 | if (m/^(\S+) (\S+) (\S+)((?:\s+[0-9a-z-]+=\S+)*)$/) { | ||||
89 | 27 | 22 | $file = $self->parse_filename($1); | ||||
90 | 27 | 22 | error(g_('badly formed file name in files list file, line %d'), $.) | ||||
91 | unless defined $file; | ||||||
92 | 27 | 26 | $file->{section} = $2; | ||||
93 | 27 | 19 | $file->{priority} = $3; | ||||
94 | 27 | 15 | my $attrs = $4; | ||||
95 | 27 10 | 20 14 | $file->{attrs} = { map { split /=/ } split ' ', $attrs }; | ||||
96 | } else { | ||||||
97 | 0 | 0 | error(g_('badly formed line in files list file, line %d'), $.); | ||||
98 | } | ||||||
99 | |||||||
100 | 27 | 38 | if (defined $self->{files}->{$file->{filename}}) { | ||||
101 | warning(g_('duplicate files list entry for file %s (line %d)'), | ||||||
102 | 0 | 0 | $file->{filename}, $.); | ||||
103 | } else { | ||||||
104 | 27 | 15 | $count++; | ||||
105 | 27 | 29 | $self->{files}->{$file->{filename}} = $file; | ||||
106 | } | ||||||
107 | } | ||||||
108 | |||||||
109 | 7 | 8 | return $count; | ||||
110 | } | ||||||
111 | |||||||
112 | sub load_dir { | ||||||
113 | 1 | 0 | 1 | my ($self, $dir) = @_; | |||
114 | |||||||
115 | 1 | 0 | my $count = 0; | ||||
116 | 1 | 3 | my $dh = IO::Dir->new($dir) or syserr(g_('cannot open directory %s'), $dir); | ||||
117 | |||||||
118 | 1 | 35 | while (defined(my $file = $dh->read)) { | ||||
119 | 5 | 26 | my $pathname = "$dir/$file"; | ||||
120 | 5 | 16 | next unless -f $pathname; | ||||
121 | 3 | 3 | $count += $self->load($pathname); | ||||
122 | } | ||||||
123 | |||||||
124 | 1 | 4 | return $count; | ||||
125 | } | ||||||
126 | |||||||
127 | sub get_files { | ||||||
128 | 1 | 0 | 2 | my $self = shift; | |||
129 | |||||||
130 | 1 5 1 | 0 5 2 | return map { $self->{files}->{$_} } sort keys %{$self->{files}}; | ||||
131 | } | ||||||
132 | |||||||
133 | sub get_file { | ||||||
134 | 12 | 0 | 8 | my ($self, $filename) = @_; | |||
135 | |||||||
136 | 12 | 14 | return $self->{files}->{$filename}; | ||||
137 | } | ||||||
138 | |||||||
139 | sub add_file { | ||||||
140 | 5 | 0 | 5 | my ($self, $filename, $section, $priority, %attrs) = @_; | |||
141 | |||||||
142 | 5 | 4 | my $file = $self->parse_filename($filename); | ||||
143 | 5 | 3 | error(g_('invalid filename %s'), $filename) unless defined $file; | ||||
144 | 5 | 4 | $file->{section} = $section; | ||||
145 | 5 | 3 | $file->{priority} = $priority; | ||||
146 | 5 | 4 | $file->{attrs} = \%attrs; | ||||
147 | |||||||
148 | 5 | 3 | $self->{files}->{$filename} = $file; | ||||
149 | |||||||
150 | 5 | 5 | return $file; | ||||
151 | } | ||||||
152 | |||||||
153 | sub del_file { | ||||||
154 | 1 | 0 | 1 | my ($self, $filename) = @_; | |||
155 | |||||||
156 | 1 | 2 | delete $self->{files}->{$filename}; | ||||
157 | } | ||||||
158 | |||||||
159 | sub filter { | ||||||
160 | 3 | 0 | 3 | my ($self, %opts) = @_; | |||
161 | 3 2 | 6 2 | my $remove = $opts{remove} // sub { 0 }; | ||||
162 | 3 5 | 5 7 | my $keep = $opts{keep} // sub { 1 }; | ||||
163 | |||||||
164 | 3 3 | 2 3 | foreach my $filename (keys %{$self->{files}}) { | ||||
165 | 15 | 13 | my $file = $self->{files}->{$filename}; | ||||
166 | |||||||
167 | 15 | 6 | if (not $keep->($file) or $remove->($file)) { | ||||
168 | 9 | 12 | delete $self->{files}->{$filename}; | ||||
169 | } | ||||||
170 | } | ||||||
171 | } | ||||||
172 | |||||||
173 | sub output { | ||||||
174 | 7 | 1 | 6 | my ($self, $fh) = @_; | |||
175 | 7 | 4 | my $str = ''; | ||||
176 | |||||||
177 | 7 | 6 | binmode $fh if defined $fh; | ||||
178 | |||||||
179 | 7 7 | 3 14 | foreach my $filename (sort keys %{$self->{files}}) { | ||||
180 | 26 | 18 | my $file = $self->{files}->{$filename}; | ||||
181 | 26 | 17 | my $entry = "$filename $file->{section} $file->{priority}"; | ||||
182 | |||||||
183 | 26 | 17 | if (exists $file->{attrs}) { | ||||
184 | 26 26 | 11 21 | foreach my $attr (sort keys %{$file->{attrs}}) { | ||||
185 | 9 | 8 | $entry .= " $attr=$file->{attrs}->{$attr}"; | ||||
186 | } | ||||||
187 | } | ||||||
188 | |||||||
189 | 26 | 10 | $entry .= "\n"; | ||||
190 | |||||||
191 | 26 0 | 18 0 | print { $fh } $entry if defined $fh; | ||||
192 | 26 | 19 | $str .= $entry; | ||||
193 | } | ||||||
194 | |||||||
195 | 7 | 13 | return $str; | ||||
196 | } | ||||||
197 | |||||||
198 | 1; |