Adding upstream version 2.23.7.upstream/2.23.7upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 477 insertions, 0 deletions

diff --git a/scripts/debi.pl b/scripts/debi.pl
new file mode 100755
index 0000000..7e10f53
--- /dev/null
+++ b/scripts/debi.pl
@@ -0,0 +1,477 @@
+#!/usr/bin/perl
+
+# debi:  Install current version of deb package
+# debc:  List contents of current version of deb package
+#
+# debi and debc originally by Christoph Lameter <clameter@debian.org>
+# Copyright Christoph Lameter <clameter@debian.org>
+# The now defunct debit originally by Jim Van Zandt <jrv@vanzandt.mv.com>
+# Copyright 1999 Jim Van Zandt <jrv@vanzandt.mv.com>
+# Modifications by Julian Gilbey <jdg@debian.org>, 1999-2003
+# Copyright 1999-2003, Julian Gilbey <jdg@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+use 5.008;
+use strict;
+use warnings;
+use Getopt::Long qw(:config bundling permute no_getopt_compat);
+use File::Basename;
+use filetest 'access';
+use Cwd;
+use Dpkg::Control;
+use Dpkg::Changelog::Parse qw(changelog_parse);
+use Dpkg::IPC;
+
+my $progname = basename($0, '.pl');    # the '.pl' is for when we're debugging
+my $modified_conf_msg;
+
+sub usage_i {
+    print <<"EOF";
+Usage: $progname [options] [.changes file] [package ...]
+  Install the .deb file(s) just created, as listed in the generated
+  .changes file or the .changes file specified.  If packages are listed,
+  only install those specified packages from the .changes file.
+  Options:
+    --no-conf or      Don\'t read devscripts config files;
+      --noconf          must be the first option given
+    -a<arch>          Search for .changes file made for Debian build <arch>
+    -t<target>        Search for .changes file made for GNU <target> arch
+    --debs-dir DIR    Look for the changes and debs files in DIR instead of
+                      the parent of the current package directory
+    --multi           Search for multiarch .changes file made by dpkg-cross
+    --upgrade         Only upgrade packages; don't install new ones.
+    --check-dirname-level N
+                      How much to check directory names:
+                      N=0   never
+                      N=1   only if program changes directory (default)
+                      N=2   always
+    --check-dirname-regex REGEX
+                      What constitutes a matching directory name; REGEX is
+                      a Perl regular expression; the string \`PACKAGE\' will
+                      be replaced by the package name; see manpage for details
+                      (default: 'PACKAGE(-.+)?')
+    --with-depends    Install packages with their depends.
+    --tool TOOL       Use the specified tool for installing the dependencies
+                      of the package(s) to be installed.
+                      (default: apt-get)
+    --help            Show this message
+    --version         Show version and copyright information
+
+Default settings modified by devscripts configuration files:
+$modified_conf_msg
+EOF
+}
+
+sub usage_c {
+    print <<"EOF";
+Usage: $progname [options] [.changes file] [package ...]
+  Display the contents of the .deb or .udeb file(s) just created, as listed
+  in the generated .changes file or the .changes file specified.
+  If packages are listed, only display those specified packages
+  from the .changes file.  Options:
+    --no-conf or      Don\'t read devscripts config files;
+      --noconf          must be the first option given
+    -a<arch>          Search for changes file made for Debian build <arch>
+    -t<target>        Search for changes file made for GNU <target> arch
+    --debs-dir DIR    Look for the changes and debs files in DIR instead of
+                      the parent of the current package directory
+    --list-changes    only list the .changes file
+    --list-debs       only list the .deb files; don't display their contents
+    --multi           Search for multiarch .changes file made by dpkg-cross
+    --check-dirname-level N
+                      How much to check directory names:
+                      N=0   never
+                      N=1   only if program changes directory (default)
+                      N=2   always
+    --check-dirname-regex REGEX
+                      What constitutes a matching directory name; REGEX is
+                      a Perl regular expression; the string \`PACKAGE\' will
+                      be replaced by the package name; see manpage for details
+                      (default: 'PACKAGE(-.+)?')
+    --help            Show this message
+    --version         Show version and copyright information
+
+Default settings modified by devscripts configuration files:
+$modified_conf_msg
+EOF
+}
+
+if    ($progname eq 'debi') { *usage = \&usage_i; }
+elsif ($progname eq 'debc') { *usage = \&usage_c; }
+else { die "Unrecognised invocation name: $progname\n"; }
+
+my $version = <<"EOF";
+This is $progname, from the Debian devscripts package, version ###VERSION###
+This code is copyright 1999-2003, Julian Gilbey <jdg\@debian.org>,
+all rights reserved.
+Based on original code by Christoph Lameter and James R. Van Zandt.
+This program comes with ABSOLUTELY NO WARRANTY.
+You are free to redistribute this code under the terms of
+the GNU General Public License, version 2 or later.
+EOF
+
+# Start by setting default values
+my $debsdir;
+my $debsdir_warning;
+my $check_dirname_level = 1;
+my $check_dirname_regex = 'PACKAGE(-.+)?';
+my $install_tool        = (-t STDOUT ? 'apt' : 'apt-get');
+
+# Next, read configuration files and then command line
+# The next stuff is boilerplate
+
+if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
+    $modified_conf_msg = "  (no configuration files read)";
+    shift;
+} else {
+    my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
+    my %config_vars  = (
+        'DEBRELEASE_DEBS_DIR'            => '..',
+        'DEVSCRIPTS_CHECK_DIRNAME_LEVEL' => 1,
+        'DEVSCRIPTS_CHECK_DIRNAME_REGEX' => 'PACKAGE(-.+)?',
+    );
+    my %config_default = %config_vars;
+
+    my $shell_cmd;
+    # Set defaults
+    foreach my $var (keys %config_vars) {
+        $shell_cmd .= qq[$var="$config_vars{$var}";\n];
+    }
+    $shell_cmd .= 'for file in ' . join(" ", @config_files) . "; do\n";
+    $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
+    # Read back values
+    foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
+    my $shell_out = `/bin/bash -c '$shell_cmd'`;
+    @config_vars{ keys %config_vars } = split /\n/, $shell_out, -1;
+
+    # Check validity
+    $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} =~ /^[012]$/
+      or $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} = 1;
+    # We do not replace this with a default directory to avoid accidentally
+    # installing a broken package
+    $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%/+%/%;
+    $config_vars{'DEBRELEASE_DEBS_DIR'} =~ s%(.)/$%$1%;
+    $debsdir_warning
+      = "config file specified DEBRELEASE_DEBS_DIR directory $config_vars{'DEBRELEASE_DEBS_DIR'} does not exist!";
+
+    foreach my $var (sort keys %config_vars) {
+        if ($config_vars{$var} ne $config_default{$var}) {
+            $modified_conf_msg .= "  $var=$config_vars{$var}\n";
+        }
+    }
+    $modified_conf_msg ||= "  (none)\n";
+    chomp $modified_conf_msg;
+
+    $debsdir             = $config_vars{'DEBRELEASE_DEBS_DIR'};
+    $check_dirname_level = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'};
+    $check_dirname_regex = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_REGEX'};
+}
+
+# Command line options next
+my ($opt_help, $opt_version, $opt_a, $opt_t, $opt_debsdir, $opt_multi);
+my $opt_upgrade;
+my ($opt_level,        $opt_regex, $opt_noconf);
+my ($opt_tool,         $opt_with_depends);
+my ($opt_list_changes, $opt_list_debs);
+GetOptions(
+    "help"                  => \$opt_help,
+    "version"               => \$opt_version,
+    "a=s"                   => \$opt_a,
+    "t=s"                   => \$opt_t,
+    "debs-dir=s"            => \$opt_debsdir,
+    "m|multi"               => \$opt_multi,
+    "u|upgrade"             => \$opt_upgrade,
+    "check-dirname-level=s" => \$opt_level,
+    "check-dirname-regex=s" => \$opt_regex,
+    "with-depends"          => \$opt_with_depends,
+    "tool=s"                => \$opt_tool,
+    "noconf"                => \$opt_noconf,
+    "no-conf"               => \$opt_noconf,
+    "list-changes"          => \$opt_list_changes,
+    "list-debs"             => \$opt_list_debs,
+  )
+  or die
+"Usage: $progname [options] [.changes file] [package ...]\nRun $progname --help for more details\n";
+
+if ($opt_help)    { usage();        exit 0; }
+if ($opt_version) { print $version; exit 0; }
+if ($opt_noconf) {
+    die
+"$progname: --no-conf is only acceptable as the first command-line option!\n";
+}
+
+my ($targetarch, $targetgnusystem);
+$targetarch      = $opt_a ? "-a$opt_a" : "";
+$targetgnusystem = $opt_t ? "-t$opt_t" : "";
+
+if (defined $opt_level) {
+    if ($opt_level =~ /^[012]$/) { $check_dirname_level = $opt_level; }
+    else {
+        die
+"$progname: unrecognised --check-dirname-level value (allowed are 0,1,2)\n";
+    }
+}
+
+if (defined $opt_regex) { $check_dirname_regex = $opt_regex; }
+
+if ($opt_tool) {
+    $install_tool = $opt_tool;
+}
+
+# Is a .changes file listed on the command line?
+my ($changes, $mchanges, $arch);
+if (@ARGV and $ARGV[0] =~ /\.changes$/) {
+    $changes = shift;
+}
+
+# Need to determine $arch in any event
+$arch = `dpkg-architecture $targetarch $targetgnusystem -qDEB_HOST_ARCH`;
+if ($? != 0 or !$arch) {
+    die "$progname: unable to determine target architecture.\n";
+}
+chomp $arch;
+
+my @foreign_architectures;
+unless ($opt_a || $opt_t || $progname eq 'debc') {
+    @foreign_architectures
+      = map { chomp; $_ } `dpkg --print-foreign-architectures`;
+}
+
+my $chdir = 0;
+
+if (!defined $changes) {
+    if ($opt_debsdir) {
+        $opt_debsdir =~ s%/+%/%;
+        $opt_debsdir =~ s%(.)/$%$1%;
+        $debsdir_warning = "--debs-dir directory $opt_debsdir does not exist!";
+        $debsdir         = $opt_debsdir;
+    }
+
+    if (!-d $debsdir) {
+        die "$progname: $debsdir_warning\n";
+    }
+
+    # Look for .changes file via debian/changelog
+    until (-r 'debian/changelog') {
+        $chdir = 1;
+        chdir '..' or die "$progname: can't chdir ..: $!\n";
+        if (cwd() eq '/') {
+            die
+"$progname: cannot find readable debian/changelog anywhere!\nAre you in the source code tree?\n";
+        }
+    }
+
+    if (-e ".svn/deb-layout") {
+        # Cope with format of svn-buildpackage tree
+        my $fh;
+        open($fh, "<", ".svn/deb-layout")
+          || die "Can't open .svn/deb-layout: $!\n";
+        my ($build_area) = grep /^buildArea=/, <$fh>;
+        close($fh);
+        if (defined($build_area) and not $opt_debsdir) {
+            chomp($build_area);
+            $build_area =~ s/^buildArea=//;
+            $debsdir = $build_area if -d $build_area;
+        }
+    }
+
+    # Find the source package name and version number
+    my $changelog = changelog_parse();
+
+    die "$progname: no package name in changelog!\n"
+      unless exists $changelog->{'Source'};
+    die "$progname: no package version in changelog!\n"
+      unless exists $changelog->{'Version'};
+
+    # Is the directory name acceptable?
+    if ($check_dirname_level == 2
+        or ($check_dirname_level == 1 and $chdir)) {
+        my $re = $check_dirname_regex;
+        $re =~ s/PACKAGE/\\Q$changelog->{'Source'}\\E/g;
+        my $gooddir;
+        if   ($re =~ m%/%) { $gooddir = eval "cwd() =~ /^$re\$/;"; }
+        else               { $gooddir = eval "basename(cwd()) =~ /^$re\$/;"; }
+
+        if (!$gooddir) {
+            my $pwd = cwd();
+            die <<"EOF";
+$progname: found debian/changelog for package $changelog->{'Source'} in the directory
+  $pwd
+but this directory name does not match the package name according to the
+regex  $check_dirname_regex.
+
+To run $progname on this package, see the --check-dirname-level and
+--check-dirname-regex options; run $progname --help for more info.
+EOF
+        }
+    }
+
+    my $sversion = $changelog->{'Version'};
+    $sversion =~ s/^\d+://;
+    my $package = $changelog->{'Source'};
+    my $pva     = "${package}_${sversion}_${arch}";
+    $changes = "$debsdir/$pva.changes";
+
+    if (!-e $changes and -d "../build-area") {
+        # Try out default svn-buildpackage structure in case
+        # we were going to fail anyway...
+        $changes = "../build-area/$pva.changes";
+    }
+
+    if ($opt_multi) {
+        my @mchanges = glob("$debsdir/${package}_${sversion}_*+*.changes");
+        @mchanges = grep { /[_+]$arch[\.+]/ } @mchanges;
+        $mchanges = $mchanges[0] || '';
+        $mchanges ||= "$debsdir/${package}_${sversion}_multi.changes"
+          if -f "$debsdir/${package}_${sversion}_multi.changes";
+    }
+}
+
+if ($opt_list_changes) {
+    printf "%s\n", $changes;
+    exit(0);
+}
+
+chdir dirname($changes)
+  or die "$progname: can't chdir to $changes directory: $!\n";
+$changes  = basename($changes);
+$mchanges = basename($mchanges) if $opt_multi;
+
+if (!-r $changes or $opt_multi and $mchanges and !-r $mchanges) {
+    die "$progname: can't read $changes"
+      . (($opt_multi and $mchanges) ? " or $mchanges" : "") . "!\n";
+}
+
+if (!-r $changes and $opt_multi) {
+    $changes = $mchanges;
+} else {
+    $opt_multi = 0;
+}
+# $opt_multi now tells us whether we're actually using a multi-arch .changes
+# file
+
+my @debs = ();
+my %pkgs = map { $_ => 0 } @ARGV;
+my $ctrl = Dpkg::Control->new(name => $changes, type => CTRL_FILE_CHANGES);
+$ctrl->load($changes);
+for (split(/\n/, $ctrl->{Files})) {
+    # udebs are only supported for debc
+    if (   (($progname eq 'debi') && (/ (\S*\.deb)$/))
+        || (($progname eq 'debc') && (/ (\S*\.u?deb)$/))) {
+        my $deb = $1;
+        open(my $stdout, '-|', 'dpkg-deb', '-f', $deb);
+        my $fields = Dpkg::Control->new(name => $deb, type => CTRL_PKG_DEB);
+        $fields->parse($stdout, $deb);
+        my $pkg = $fields->{Package};
+
+        # don't want to install other archs' .debs, unless they are
+        # Multi-Arch: same:
+        next
+          unless (
+               $progname eq 'debc'
+            || $fields->{Architecture} eq 'all'
+            || $fields->{Architecture} eq $arch
+            || (($fields->{'Multi-Arch'} || 'no') eq 'same'
+                && grep { $_ eq $fields->{Architecture} }
+                @foreign_architectures));
+
+        if (@ARGV) {
+            if (exists $pkgs{$pkg}) {
+                push @debs, $deb;
+                $pkgs{$pkg}++;
+            } elsif (exists $pkgs{$deb}) {
+                push @debs, $deb;
+                $pkgs{$deb}++;
+            }
+        } else {
+            push @debs, $deb;
+        }
+    }
+}
+
+if (!@debs) {
+    die
+      "$progname: no appropriate .debs found in the changes file $changes!\n";
+}
+
+if ($progname eq 'debi') {
+    my @upgrade = $opt_upgrade ? ('-O') : ();
+    if ($opt_with_depends) {
+        if ($install_tool =~ /^apt(?:-get)?$/ && !$opt_upgrade) {
+            spawn(
+                exec =>
+                  [$install_tool, 'install', '--reinstall', "./$changes"],
+                wait_child => 1
+            );
+        } else {
+            my @apt_opts;
+
+            if ($install_tool =~ /^apt(?:-get)?$/) {
+                push @apt_opts, '--with-source', "./$changes";
+            }
+
+            spawn(
+                exec       => ['dpkg', @upgrade, '--unpack', @debs],
+                wait_child => 1
+            );
+            spawn(
+                exec       => [$install_tool, @apt_opts, '-f', 'install'],
+                wait_child => 1
+            );
+        }
+    } else {
+        if ($install_tool =~ /^apt(?:-get)?$/ && $opt_upgrade) {
+            spawn(
+                exec => [
+                    $install_tool,    'install',
+                    '--only-upgrade', '--reinstall',
+                    "./$changes"
+                ],
+                wait_child => 1
+            );
+        } else {
+            spawn(exec => ['dpkg', @upgrade, '-i', @debs], wait_child => 1);
+        }
+    }
+} else {
+    # $progname eq 'debc'
+    foreach my $deb (@debs) {
+        if ($opt_list_debs) {
+            printf "%s/%s\n", cwd(), $deb;
+            next;
+        }
+        print "$deb\n";
+        print '-' x length($deb), "\n";
+        system('dpkg-deb', '-I', $deb) == 0
+          or die "$progname: dpkg-deb -I $deb failed\n";
+        system('dpkg-deb', '-c', $deb) == 0
+          or die "$progname: dpkg-deb -c $deb failed\n";
+        print "\n";
+    }
+}
+
+# Now do a sanity check
+if (@ARGV) {
+    foreach my $pkg (keys %pkgs) {
+        if ($pkgs{$pkg} == 0) {
+            warn "$progname: package $pkg not found in $changes, ignoring\n";
+        } elsif ($pkgs{$pkg} > 1) {
+            warn
+"$progname: package $pkg found more than once in $changes, installing all\n";
+        }
+    }
+}
+
+exit 0;