1#!/usr/bin/perl 2 3# debi: Install current version of deb package 4# debc: List contents of current version of deb package 5# 6# debi and debc originally by Christoph Lameter <clameter@debian.org> 7# Copyright Christoph Lameter <clameter@debian.org> 8# The now defunct debit originally by Jim Van Zandt <jrv@vanzandt.mv.com> 9# Copyright 1999 Jim Van Zandt <jrv@vanzandt.mv.com> 10# Modifications by Julian Gilbey <jdg@debian.org>, 1999-2003 11# Copyright 1999-2003, Julian Gilbey <jdg@debian.org> 12# 13# This program is free software; you can redistribute it and/or modify 14# it under the terms of the GNU General Public License as published by 15# the Free Software Foundation; either version 2 of the License, or 16# (at your option) any later version. 17# 18# This program is distributed in the hope that it will be useful, 19# but WITHOUT ANY WARRANTY; without even the implied warranty of 20# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21# GNU General Public License for more details. 22# 23# You should have received a copy of the GNU General Public License 24# along with this program. If not, see <https://www.gnu.org/licenses/>. 25 26use 5.008; 27use strict; 28use warnings; 29use Getopt::Long qw(:config bundling permute no_getopt_compat); 30use File::Basename; 31use filetest 'access'; 32use Cwd; 33use Dpkg::Control; 34use Dpkg::Changelog::Parse qw(changelog_parse); 35use Dpkg::IPC; 36 37my $progname = basename($0, '.pl'); # the '.pl' is for when we're debugging 38my $modified_conf_msg; 39 40sub usage_i { 41 print <<"EOF"; 42Usage: $progname [options] [.changes file] [package ...] 43 Install the .deb file(s) just created, as listed in the generated 44 .changes file or the .changes file specified. If packages are listed, 45 only install those specified packages from the .changes file. 46 Options: 47 --no-conf or Don\'t read devscripts config files; 48 --noconf must be the first option given 49 -a<arch> Search for .changes file made for Debian build <arch> 50 -t<target> Search for .changes file made for GNU <target> arch 51 --debs-dir DIR Look for the changes and debs files in DIR instead of 52 the parent of the current package directory 53 --multi Search for multiarch .changes file made by dpkg-cross 54 --upgrade Only upgrade packages; don't install new ones. 55 --check-dirname-level N 56 How much to check directory names: 57 N=0 never 58 N=1 only if program changes directory (default) 59 N=2 always 60 --check-dirname-regex REGEX 61 What constitutes a matching directory name; REGEX is 62 a Perl regular expression; the string \`PACKAGE\' will 63 be replaced by the package name; see manpage for details 64 (default: 'PACKAGE(-.+)?') 65 --with-depends Install packages with their depends. 66 --tool TOOL Use the specified tool for installing the dependencies 67 of the package(s) to be installed. 68 (default: apt-get) 69 --help Show this message 70 --version Show version and copyright information 71 72Default settings modified by devscripts configuration files: 73$modified_conf_msg 74EOF 75} 76 77sub usage_c { 78 print <<"EOF"; 79Usage: $progname [options] [.changes file] [package ...] 80 Display the contents of the .deb or .udeb file(s) just created, as listed 81 in the generated .changes file or the .changes file specified. 82 If packages are listed, only display those specified packages 83 from the .changes file. Options: 84 --no-conf or Don\'t read devscripts config files; 85 --noconf must be the first option given 86 -a<arch> Search for changes file made for Debian build <arch> 87 -t<target> Search for changes file made for GNU <target> arch 88 --debs-dir DIR Look for the changes and debs files in DIR instead of 89 the parent of the current package directory 90 --list-changes only list the .changes file 91 --list-debs only list the .deb files; don't display their contents 92 --multi Search for multiarch .changes file made by dpkg-cross 93 --check-dirname-level N 94 How much to check directory names: 95 N=0 never 96 N=1 only if program changes directory (default) 97 N=2 always 98 --check-dirname-regex REGEX 99 What constitutes a matching directory name; REGEX is 100 a Perl regular expression; the string \`PACKAGE\' will 101 be replaced by the package name; see manpage for details 102 (default: 'PACKAGE(-.+)?') 103 --help Show this message 104 --version Show version and copyright information 105 106Default settings modified by devscripts configuration files: 107$modified_conf_msg 108EOF 109} 110 111if ($progname eq 'debi') { *usage = \&usage_i; } 112elsif ($progname eq 'debc') { *usage = \&usage_c; } 113else { die "Unrecognised invocation name: $progname\n"; } 114 115my $version = <<"EOF"; 116This is $progname, from the Debian devscripts package, version ###VERSION### 117This code is copyright 1999-2003, Julian Gilbey <jdg\@debian.org>, 118all rights reserved. 119Based on original code by Christoph Lameter and James R. Van Zandt. 120This program comes with ABSOLUTELY NO WARRANTY. 121You are free to redistribute this code under the terms of 122the GNU General Public License, version 2 or later. 123EOF 124 125# Start by setting default values 126my $debsdir; 127my $debsdir_warning; 128my $check_dirname_level = 1; 129my $check_dirname_regex = 'PACKAGE(-.+)?'; 130my $install_tool = (-t STDOUT ? 'apt' : 'apt-get'); 131 132# Next, read configuration files and then command line 133# The next stuff is boilerplate 134 135if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) { 136 $modified_conf_msg = " (no configuration files read)"; 137 shift; 138} else { 139 my @config_files = ('/etc/devscripts.conf', '~/.devscripts'); 140 my %config_vars = ( 141 'DEBRELEASE_DEBS_DIR' => '..', 142 'DEVSCRIPTS_CHECK_DIRNAME_LEVEL' => 1, 143 'DEVSCRIPTS_CHECK_DIRNAME_REGEX' => 'PACKAGE(-.+)?', 144 ); 145 my %config_default = %config_vars; 146 147 my $shell_cmd; 148 # Set defaults 149 foreach my $var (keys %config_vars) { 150 $shell_cmd .= qq[$var="$config_vars{$var}";\n]; 151 } 152 $shell_cmd .= 'for file in ' . join(" ", @config_files) . "; do\n"; 153 $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n"; 154 # Read back values 155 foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" } 156 my $shell_out = `/bin/bash -c '$shell_cmd'`; 157 @config_vars{ keys %config_vars } = split /\n/, $shell_out, -1; 158 159 # Check validity 160 $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} =~ /^[012]$/ 161 or $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} = 1; 162 # We do not replace this with a default directory to avoid accidentally 163 # installing a broken package 164 $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%/+%/%; 165 $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%(.)/$%$1%; 166 $debsdir_warning 167 = "config file specified DEBRELEASE_DEBS_DIR directory $config_vars{'DEBRELEASE_DEBS_DIR'} does not exist!"; 168 169 foreach my $var (sort keys %config_vars) { 170 if ($config_vars{$var} ne $config_default{$var}) { 171 $modified_conf_msg .= " $var=$config_vars{$var}\n"; 172 } 173 } 174 $modified_conf_msg ||= " (none)\n"; 175 chomp $modified_conf_msg; 176 177 $debsdir = $config_vars{'DEBRELEASE_DEBS_DIR'}; 178 $check_dirname_level = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'}; 179 $check_dirname_regex = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_REGEX'}; 180} 181 182# Command line options next 183my ($opt_help, $opt_version, $opt_a, $opt_t, $opt_debsdir, $opt_multi); 184my $opt_upgrade; 185my ($opt_level, $opt_regex, $opt_noconf); 186my ($opt_tool, $opt_with_depends); 187my ($opt_list_changes, $opt_list_debs); 188GetOptions( 189 "help" => \$opt_help, 190 "version" => \$opt_version, 191 "a=s" => \$opt_a, 192 "t=s" => \$opt_t, 193 "debs-dir=s" => \$opt_debsdir, 194 "m|multi" => \$opt_multi, 195 "u|upgrade" => \$opt_upgrade, 196 "check-dirname-level=s" => \$opt_level, 197 "check-dirname-regex=s" => \$opt_regex, 198 "with-depends" => \$opt_with_depends, 199 "tool=s" => \$opt_tool, 200 "noconf" => \$opt_noconf, 201 "no-conf" => \$opt_noconf, 202 "list-changes" => \$opt_list_changes, 203 "list-debs" => \$opt_list_debs, 204 ) 205 or die 206"Usage: $progname [options] [.changes file] [package ...]\nRun $progname --help for more details\n"; 207 208if ($opt_help) { usage(); exit 0; } 209if ($opt_version) { print $version; exit 0; } 210if ($opt_noconf) { 211 die 212"$progname: --no-conf is only acceptable as the first command-line option!\n"; 213} 214 215my ($targetarch, $targetgnusystem); 216$targetarch = $opt_a ? "-a$opt_a" : ""; 217$targetgnusystem = $opt_t ? "-t$opt_t" : ""; 218 219if (defined $opt_level) { 220 if ($opt_level =~ /^[012]$/) { $check_dirname_level = $opt_level; } 221 else { 222 die 223"$progname: unrecognised --check-dirname-level value (allowed are 0,1,2)\n"; 224 } 225} 226 227if (defined $opt_regex) { $check_dirname_regex = $opt_regex; } 228 229if ($opt_tool) { 230 $install_tool = $opt_tool; 231} 232 233# Is a .changes file listed on the command line? 234my ($changes, $mchanges, $arch); 235if (@ARGV and $ARGV[0] =~ /\.changes$/) { 236 $changes = shift; 237} 238 239# Need to determine $arch in any event 240$arch = `dpkg-architecture $targetarch $targetgnusystem -qDEB_HOST_ARCH`; 241if ($? != 0 or !$arch) { 242 die "$progname: unable to determine target architecture.\n"; 243} 244chomp $arch; 245 246my @foreign_architectures; 247unless ($opt_a || $opt_t || $progname eq 'debc') { 248 @foreign_architectures 249 = map { chomp; $_ } `dpkg --print-foreign-architectures`; 250} 251 252my $chdir = 0; 253 254if (!defined $changes) { 255 if ($opt_debsdir) { 256 $opt_debsdir =~ s%/+%/%; 257 $opt_debsdir =~ s%(.)/$%$1%; 258 $debsdir_warning = "--debs-dir directory $opt_debsdir does not exist!"; 259 $debsdir = $opt_debsdir; 260 } 261 262 if (!-d $debsdir) { 263 die "$progname: $debsdir_warning\n"; 264 } 265 266 # Look for .changes file via debian/changelog 267 until (-r 'debian/changelog') { 268 $chdir = 1; 269 chdir '..' or die "$progname: can't chdir ..: $!\n"; 270 if (cwd() eq '/') { 271 die 272"$progname: cannot find readable debian/changelog anywhere!\nAre you in the source code tree?\n"; 273 } 274 } 275 276 if (-e ".svn/deb-layout") { 277 # Cope with format of svn-buildpackage tree 278 my $fh; 279 open($fh, "<", ".svn/deb-layout") 280 || die "Can't open .svn/deb-layout: $!\n"; 281 my ($build_area) = grep /^buildArea=/, <$fh>; 282 close($fh); 283 if (defined($build_area) and not $opt_debsdir) { 284 chomp($build_area); 285 $build_area =~ s/^buildArea=//; 286 $debsdir = $build_area if -d $build_area; 287 } 288 } 289 290 # Find the source package name and version number 291 my $changelog = changelog_parse(); 292 293 die "$progname: no package name in changelog!\n" 294 unless exists $changelog->{'Source'}; 295 die "$progname: no package version in changelog!\n" 296 unless exists $changelog->{'Version'}; 297 298 # Is the directory name acceptable? 299 if ($check_dirname_level == 2 300 or ($check_dirname_level == 1 and $chdir)) { 301 my $re = $check_dirname_regex; 302 $re =~ s/PACKAGE/\\Q$changelog->{'Source'}\\E/g; 303 my $gooddir; 304 if ($re =~ m%/%) { $gooddir = eval "cwd() =~ /^$re\$/;"; } 305 else { $gooddir = eval "basename(cwd()) =~ /^$re\$/;"; } 306 307 if (!$gooddir) { 308 my $pwd = cwd(); 309 die <<"EOF"; 310$progname: found debian/changelog for package $changelog->{'Source'} in the directory 311 $pwd 312but this directory name does not match the package name according to the 313regex $check_dirname_regex. 314 315To run $progname on this package, see the --check-dirname-level and 316--check-dirname-regex options; run $progname --help for more info. 317EOF 318 } 319 } 320 321 my $sversion = $changelog->{'Version'}; 322 $sversion =~ s/^\d+://; 323 my $package = $changelog->{'Source'}; 324 my $pva = "${package}_${sversion}_${arch}"; 325 $changes = "$debsdir/$pva.changes"; 326 327 if (!-e $changes and -d "../build-area") { 328 # Try out default svn-buildpackage structure in case 329 # we were going to fail anyway... 330 $changes = "../build-area/$pva.changes"; 331 } 332 333 if ($opt_multi) { 334 my @mchanges = glob("$debsdir/${package}_${sversion}_*+*.changes"); 335 @mchanges = grep { /[_+]$arch[\.+]/ } @mchanges; 336 $mchanges = $mchanges[0] || ''; 337 $mchanges ||= "$debsdir/${package}_${sversion}_multi.changes" 338 if -f "$debsdir/${package}_${sversion}_multi.changes"; 339 } 340} 341 342if ($opt_list_changes) { 343 printf "%s\n", $changes; 344 exit(0); 345} 346 347chdir dirname($changes) 348 or die "$progname: can't chdir to $changes directory: $!\n"; 349$changes = basename($changes); 350$mchanges = basename($mchanges) if $opt_multi; 351 352if (!-r $changes or $opt_multi and $mchanges and !-r $mchanges) { 353 die "$progname: can't read $changes" 354 . (($opt_multi and $mchanges) ? " or $mchanges" : "") . "!\n"; 355} 356 357if (!-r $changes and $opt_multi) { 358 $changes = $mchanges; 359} else { 360 $opt_multi = 0; 361} 362# $opt_multi now tells us whether we're actually using a multi-arch .changes 363# file 364 365my @debs = (); 366my %pkgs = map { $_ => 0 } @ARGV; 367my $ctrl = Dpkg::Control->new(name => $changes, type => CTRL_FILE_CHANGES); 368$ctrl->load($changes); 369for (split(/\n/, $ctrl->{Files})) { 370 # udebs are only supported for debc 371 if ( (($progname eq 'debi') && (/ (\S*\.deb)$/)) 372 || (($progname eq 'debc') && (/ (\S*\.u?deb)$/))) { 373 my $deb = $1; 374 open(my $stdout, '-|', 'dpkg-deb', '-f', $deb); 375 my $fields = Dpkg::Control->new(name => $deb, type => CTRL_PKG_DEB); 376 $fields->parse($stdout, $deb); 377 my $pkg = $fields->{Package}; 378 379 # don't want to install other archs' .debs, unless they are 380 # Multi-Arch: same: 381 next 382 unless ( 383 $progname eq 'debc' 384 || $fields->{Architecture} eq 'all' 385 || $fields->{Architecture} eq $arch 386 || (($fields->{'Multi-Arch'} || 'no') eq 'same' 387 && grep { $_ eq $fields->{Architecture} } 388 @foreign_architectures)); 389 390 if (@ARGV) { 391 if (exists $pkgs{$pkg}) { 392 push @debs, $deb; 393 $pkgs{$pkg}++; 394 } elsif (exists $pkgs{$deb}) { 395 push @debs, $deb; 396 $pkgs{$deb}++; 397 } 398 } else { 399 push @debs, $deb; 400 } 401 } 402} 403 404if (!@debs) { 405 die 406 "$progname: no appropriate .debs found in the changes file $changes!\n"; 407} 408 409if ($progname eq 'debi') { 410 my @upgrade = $opt_upgrade ? ('-O') : (); 411 if ($opt_with_depends) { 412 if ($install_tool =~ /^apt(?:-get)?$/ && !$opt_upgrade) { 413 spawn( 414 exec => 415 [$install_tool, 'install', '--reinstall', "./$changes"], 416 wait_child => 1 417 ); 418 } else { 419 my @apt_opts; 420 421 if ($install_tool =~ /^apt(?:-get)?$/) { 422 push @apt_opts, '--with-source', "./$changes"; 423 } 424 425 spawn( 426 exec => ['debpkg', @upgrade, '--unpack', @debs], 427 wait_child => 1 428 ); 429 spawn( 430 exec => [$install_tool, @apt_opts, '-f', 'install'], 431 wait_child => 1 432 ); 433 } 434 } else { 435 if ($install_tool =~ /^apt(?:-get)?$/ && $opt_upgrade) { 436 spawn( 437 exec => [ 438 $install_tool, 'install', 439 '--only-upgrade', '--reinstall', 440 "./$changes" 441 ], 442 wait_child => 1 443 ); 444 } else { 445 spawn(exec => ['debpkg', @upgrade, '-i', @debs], wait_child => 1); 446 } 447 } 448} else { 449 # $progname eq 'debc' 450 foreach my $deb (@debs) { 451 if ($opt_list_debs) { 452 printf "%s/%s\n", cwd(), $deb; 453 next; 454 } 455 print "$deb\n"; 456 print '-' x length($deb), "\n"; 457 system('dpkg-deb', '-I', $deb) == 0 458 or die "$progname: dpkg-deb -I $deb failed\n"; 459 system('dpkg-deb', '-c', $deb) == 0 460 or die "$progname: dpkg-deb -c $deb failed\n"; 461 print "\n"; 462 } 463} 464 465# Now do a sanity check 466if (@ARGV) { 467 foreach my $pkg (keys %pkgs) { 468 if ($pkgs{$pkg} == 0) { 469 warn "$progname: package $pkg not found in $changes, ignoring\n"; 470 } elsif ($pkgs{$pkg} > 1) { 471 warn 472"$progname: package $pkg found more than once in $changes, installing all\n"; 473 } 474 } 475} 476 477exit 0; 478