| 27 | 27 |
use v5.14;
|
| 28 | 28 |
use IPC::System::Simple qw(capturex $EXITVAL);
|
| 29 | 29 |
use File::Which;
|
|
30 |
use File::Temp qw(tempdir);
|
|
31 |
use File::Slurper qw(read_text write_text);
|
|
32 |
use POSIX qw(strftime);
|
|
33 |
use File::Copy qw(move);
|
|
34 |
use File::Basename qw(fileparse);
|
| 30 | 35 |
|
| 31 | 36 |
$ENV{LC_ALL} = 'C';
|
| 32 | 37 |
|
|
| 38 | 43 |
my $call_apt = 0;
|
| 39 | 44 |
my $use_ssh = 0;
|
| 40 | 45 |
my $show_all = 0;
|
|
46 |
my $gen_deb = 0;
|
| 41 | 47 |
|
| 42 | 48 |
my %pkgs;
|
|
49 |
my @programs = ();
|
| 43 | 50 |
my @out_of_date_files;
|
| 44 | 51 |
foreach my $arg (@ARGV) {
|
| 45 | 52 |
if ($arg eq '--install') {
|
| 46 | 53 |
$call_apt = 1;
|
| 47 | 54 |
next;
|
| 48 | 55 |
}
|
|
56 |
if ($arg eq '--deb') {
|
|
57 |
die "Package equivs needs to be installed to use the option '--deb'.\n"
|
|
58 |
unless which('equivs-build');
|
|
59 |
$gen_deb = 1;
|
|
60 |
next;
|
|
61 |
}
|
| 49 | 62 |
if ($arg eq '--ssh') {
|
|
63 |
die "Package openssh-client needs to be installed to use the option '--ssh'.\n"
|
|
64 |
unless which('ssh');
|
| 50 | 65 |
$use_ssh = 1;
|
| 51 | 66 |
next;
|
| 52 | 67 |
}
|
|
| 58 | 73 |
my %build_ids;
|
| 59 | 74 |
if ($arg =~ /^\d+$/) {
|
| 60 | 75 |
%build_ids = get_build_ids_from_pid($arg);
|
|
76 |
|
|
77 |
# Document which file was looked for
|
|
78 |
push(@programs, readlink("/proc/$arg/exe"));
|
| 61 | 79 |
} else {
|
| 62 | 80 |
%build_ids = get_build_ids_from_file($arg);
|
| 63 | 81 |
}
|
|
| 99 | 117 |
if ($call_apt) {
|
| 100 | 118 |
my @cmd = (qw(apt install --no-install-recommends), @pkgs);
|
| 101 | 119 |
|
|
120 |
# Shall we generate a metapackage and install that one?
|
|
121 |
if ($gen_deb) {
|
|
122 |
my $pkg = gen_pkg(@pkgs);
|
|
123 |
@cmd = (qw(apt install), $pkg);
|
|
124 |
}
|
|
125 |
|
| 102 | 126 |
# Are we root?
|
| 103 | 127 |
unless ($> == 0) {
|
| 104 | 128 |
|
|
| 120 | 144 |
|
| 121 | 145 |
# Finally execute the command constructed above
|
| 122 | 146 |
exec(@cmd);
|
|
147 |
|
|
148 |
# Shall we just generate a .deb, but not install it?
|
|
149 |
} elsif ($gen_deb) {
|
|
150 |
my $pkg = gen_pkg(@pkgs);
|
|
151 |
my $target = $ENV{TMPDIR} // '/tmp';
|
|
152 |
move($pkg, $target);
|
|
153 |
my $filename = $target.'/'.fileparse($pkg);
|
|
154 |
say "Metapackage has been generated at $filename.";
|
|
155 |
say "Install it like this with root privileges:";
|
|
156 |
say "";
|
|
157 |
say "apt install $filename";
|
| 123 | 158 |
|
| 124 | 159 |
# No options, so just display the list of still needed packages.
|
| 125 | 160 |
} else {
|
|
| 240 | 275 |
if (is_core_file($filename)) {
|
| 241 | 276 |
return get_build_ids_from_core($filename);
|
| 242 | 277 |
} else {
|
|
278 |
# Document which file was looked for
|
|
279 |
push(@programs, $filename);
|
|
280 |
|
| 243 | 281 |
my @filenames = get_files_from_elf($filename);
|
| 244 | 282 |
my %build_ids;
|
| 245 | 283 |
foreach my $filename (@filenames) {
|
|
| 262 | 300 |
{
|
| 263 | 301 |
my ($filename) = @_;
|
| 264 | 302 |
my $output = capturex(qw(eu-unstrip --list-only --core), $filename);
|
|
303 |
|
|
304 |
# Document which file was looked for (fifth field in first line)
|
|
305 |
my $program = (split(' ', (split(/\n/, $output))[0]))[4];
|
|
306 |
push(@programs, $program);
|
| 265 | 307 |
|
| 266 | 308 |
return parse_eu_unstrip($output);
|
| 267 | 309 |
}
|
|
| 347 | 389 |
return;
|
| 348 | 390 |
}
|
| 349 | 391 |
|
|
392 |
sub gen_pkg {
|
|
393 |
my @pkgs = @_;
|
|
394 |
my $tempdir = tempdir( ( $ENV{TMPDIR} ? $ENV{TMPDIR} : '/tmp' ).
|
|
395 |
'/find-dbgsym-packages-equivs_XXXXX',
|
|
396 |
CLEANUP => 1 );
|
|
397 |
|
|
398 |
# Generating the necessary strings for generating the metapackage
|
|
399 |
my %replacements = ();
|
|
400 |
|
|
401 |
$replacements{CALL} = "$0 ".join(' ', @ARGV);
|
|
402 |
$replacements{DATE} = strftime('%a, %d %b %Y %T %z', localtime());
|
|
403 |
$replacements{DEPENDS} = join(', ', @pkgs);
|
|
404 |
$replacements{USER} = getlogin();
|
|
405 |
$replacements{HOST} = `hostname`;
|
|
406 |
$replacements{AOM} = $show_all ? 'all' : 'currently missing';
|
|
407 |
|
|
408 |
chomp($replacements{USER});
|
|
409 |
chomp($replacements{HOST});
|
|
410 |
|
|
411 |
my $dg_version = `dpkg-query -f '\${Version}' -W debian-goodies`;
|
|
412 |
$replacements{DGVERSION} = $dg_version;
|
|
413 |
|
|
414 |
my @now = localtime;
|
|
415 |
my $pkg_version = strftime(
|
|
416 |
'%Y.%m.%dT%H.%M.%S+dg'.$dg_version,
|
|
417 |
localtime()
|
|
418 |
);
|
|
419 |
$replacements{PKGVERSION} = $pkg_version;
|
|
420 |
|
|
421 |
my %programs = map { $_ => 1 } @programs;
|
|
422 |
$replacements{PROGRAMS} = ' * ' .
|
|
423 |
join("\n * ", sort keys %programs);
|
|
424 |
|
|
425 |
$replacements{PACKAGE} = 'dbgsym-pkgs-for-' .
|
|
426 |
join('-',
|
|
427 |
map {
|
|
428 |
s(^.*/)();
|
|
429 |
s/\W//g;
|
|
430 |
s/[-_]//g;
|
|
431 |
lc($_);
|
|
432 |
}
|
|
433 |
sort keys %programs
|
|
434 |
);
|
|
435 |
|
|
436 |
# Replace placeholders with actual data
|
|
437 |
foreach my $file (qw(changelog control readme)) {
|
|
438 |
gen_file_from_template(
|
|
439 |
( -d './find-dbgsym-packages-templates/' ?
|
|
440 |
'./find-dbgsym-packages-templates/' :
|
|
441 |
'/usr/share/debian-goodies/find-dbgsym-packages-templates/' )
|
|
442 |
. $file,
|
|
443 |
"$tempdir/$file",
|
|
444 |
\%replacements
|
|
445 |
);
|
|
446 |
}
|
|
447 |
|
|
448 |
# Generate the .deb
|
|
449 |
chdir($tempdir);
|
|
450 |
#system("head -100 *");
|
|
451 |
my $pkgbuild = capturex(qw(equivs-build control));
|
|
452 |
#system("dpkg-deb --info *.deb");
|
|
453 |
|
|
454 |
my @debs = glob('*.deb');
|
|
455 |
# Sanity check
|
|
456 |
die "$0: BUG: Not exactly one .deb file generated" unless $#debs == 0;
|
|
457 |
|
|
458 |
return $tempdir.'/'.$debs[0];
|
|
459 |
}
|
|
460 |
|
|
461 |
sub gen_file_from_template {
|
|
462 |
my ($input, $output, $replacements) = @_;
|
|
463 |
|
|
464 |
my $text = read_text($input);
|
|
465 |
|
|
466 |
foreach my $key (%$replacements) {
|
|
467 |
$text =~ s/__${key}__/$replacements->{$key}/g;
|
|
468 |
}
|
|
469 |
|
|
470 |
write_text($output, $text);
|
|
471 |
}
|
|
472 |
|
| 350 | 473 |
sub usage
|
| 351 | 474 |
{
|
| 352 | 475 |
print << "EOF";
|
| 353 | 476 |
usage:
|
| 354 | |
$0 [--install] [--ssh] [--all] <core file or PID or program> [ ... ]
|
|
477 |
$0 [--install] [--ssh] [--deb] [--all] \
|
|
478 |
<core file or PID or program> [ ... ]
|
| 355 | 479 |
|
| 356 | 480 |
You must already have the correct debug lines in your sources.list and have
|
| 357 | 481 |
executed 'apt-get update'.
|