| 3 | 3 |
# program/library.
|
| 4 | 4 |
#
|
| 5 | 5 |
# Copyright (C) 2017 Stefan Fritsch <sf@debian.org>
|
|
6 |
# Copyright (C) 2017 Paul Wise <pabs@debian.org>
|
| 6 | 7 |
#
|
| 7 | 8 |
# This program is free software; you can redistribute it and/or modify
|
| 8 | 9 |
# it under the terms of the GNU General Public License as published by
|
|
| 40 | 41 |
}
|
| 41 | 42 |
|
| 42 | 43 |
foreach my $id (keys %build_ids) {
|
| 43 | |
my $name = $build_ids{$id};
|
|
44 |
my ($path, $name) = @{$build_ids{$id}};
|
| 44 | 45 |
|
| 45 | 46 |
next if $name =~ /^linux-vdso[.]so[.]/;
|
| 46 | 47 |
|
| 47 | 48 |
my @p = get_debs_from_id($id);
|
| 48 | 49 |
if (scalar @p == 0) {
|
| 49 | |
warn "Cannot find debug package for $name ($id)\n";
|
|
50 |
@p = get_debs_from_path($path);
|
|
51 |
if (scalar @p == 0) {
|
|
52 |
warn "Cannot find debug package for $name ($id)\n";
|
|
53 |
}
|
| 50 | 54 |
} elsif (scalar @p > 1) {
|
| 51 | 55 |
warn "Multiple packages for $name ($id): @p\n";
|
| 52 | 56 |
}
|
|
| 79 | 83 |
\s+
|
| 80 | 84 |
([[:xdigit:]]{40} [@] 0x[[:xdigit:]]+ | - )
|
| 81 | 85 |
\s+
|
| 82 | |
\S+
|
|
86 |
(\S+)
|
| 83 | 87 |
\s+
|
| 84 | 88 |
(\S+)
|
| 85 | 89 |
\s+
|
| 86 | 90 |
(\S.*)
|
| 87 | 91 |
$}ix) {
|
| 88 | 92 |
my $id = $1;
|
| 89 | |
my $debug = $2;
|
| 90 | |
my $name = $3;
|
|
93 |
my $path = $2;
|
|
94 |
my $debug = $3;
|
|
95 |
my $name = $4;
|
| 91 | 96 |
if ($debug ne '-') {
|
| 92 | 97 |
next;
|
| 93 | 98 |
}
|
|
| 102 | 107 |
} else {
|
| 103 | 108 |
die "BUG: id='$id'";
|
| 104 | 109 |
}
|
| 105 | |
$ids{$id} = $name;
|
|
110 |
if ($path eq '-' || $path eq '.') {
|
|
111 |
$path = $name;
|
|
112 |
$path =~ s{ \(deleted\)$}{};
|
|
113 |
}
|
|
114 |
$ids{$id} = [$path, $name];
|
| 106 | 115 |
} else {
|
| 107 | 116 |
warn "Cannot parse eu-unstrip output: '$line'\n";
|
| 108 | 117 |
}
|
|
| 141 | 150 |
|
| 142 | 151 |
my %pkgs = map { $_ => 1 } split(/\n/, $output);
|
| 143 | 152 |
return sort keys %pkgs;
|
|
153 |
}
|
|
154 |
|
|
155 |
sub get_debs_from_path
|
|
156 |
{
|
|
157 |
my ($path) = @_;
|
|
158 |
|
|
159 |
my $output;
|
|
160 |
eval {
|
|
161 |
($output, undef) = capturex(qw(dpkg-query --search --), $path);
|
|
162 |
};
|
|
163 |
if ($@) {
|
|
164 |
return;
|
|
165 |
}
|
|
166 |
|
|
167 |
my %pkgs = ();
|
|
168 |
foreach my $line (split(/\n/, $output)) {
|
|
169 |
if ($line =~ /^(.*): /) {
|
|
170 |
$pkgs{$1} = 1;
|
|
171 |
} else {
|
|
172 |
warn "Cannot parse dpkg-query output: '$line'\n";
|
|
173 |
}
|
|
174 |
}
|
|
175 |
my @pkgs = sort keys %pkgs;
|
|
176 |
my @strip_pkgs = map { s{:.*}{}; s{\d.*$}{}r } @pkgs;
|
|
177 |
|
|
178 |
eval {
|
|
179 |
($output, undef) = capturex(qw(dpkg-query --showformat ${source:Package}\n --show --), @pkgs);
|
|
180 |
};
|
|
181 |
if ($@) {
|
|
182 |
return;
|
|
183 |
}
|
|
184 |
|
|
185 |
my %dbg_pkgs = ();
|
|
186 |
foreach my $src_pkg (split(/\n/, $output)) {
|
|
187 |
my $output;
|
|
188 |
eval {
|
|
189 |
$output = capturex(qw(grep-aptavail --no-field-names --show-field Package --field Package --pattern -dbg --and --whole-pkg --field Source:Package --pattern), $src_pkg);
|
|
190 |
};
|
|
191 |
if ($@) {
|
|
192 |
warn "No dbg package for source '$src_pkg'\n";
|
|
193 |
next;
|
|
194 |
}
|
|
195 |
my %src_dbg_pkgs = map { $_ => 1 } split(/\n/, $output);
|
|
196 |
my @src_dbg_pkgs = keys %src_dbg_pkgs;
|
|
197 |
my @src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg-dbg/ } @src_dbg_pkgs } @pkgs;
|
|
198 |
@src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg.*-dbg/ } @src_dbg_pkgs } @pkgs unless @src_strip_pkgs;
|
|
199 |
@src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg-dbg/ } @src_dbg_pkgs } @strip_pkgs unless @src_strip_pkgs;
|
|
200 |
@src_strip_pkgs = map { my $pkg = $_; grep { /^$pkg.*-dbg/ } @src_dbg_pkgs } @strip_pkgs unless @src_strip_pkgs;
|
|
201 |
@src_dbg_pkgs = @src_strip_pkgs if @src_strip_pkgs;
|
|
202 |
map { $dbg_pkgs{$_} = 1; } @src_dbg_pkgs;
|
|
203 |
};
|
|
204 |
|
|
205 |
return sort keys %dbg_pkgs;
|
| 144 | 206 |
}
|
| 145 | 207 |
|
| 146 | 208 |
sub is_core_file
|