Adding upstream version 2.23.7.upstream/2.23.7upstream

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

1 files changed, 534 insertions, 0 deletions

diff --git a/scripts/dpkg-depcheck.pl b/scripts/dpkg-depcheck.pl
new file mode 100755
index 0000000..afa2d75
--- /dev/null
+++ b/scripts/dpkg-depcheck.pl
@@ -0,0 +1,534 @@
+#!/usr/bin/perl
+
+# Copyright Bill Allombert <ballombe@debian.org> 2001.
+# Modifications copyright 2002-2005 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 strict;
+use warnings;
+use 5.006_000;    # our() commands
+use Cwd;
+use File::Basename;
+use Getopt::Long;
+
+use Devscripts::Set;
+use Devscripts::Packages;
+use Devscripts::PackageDeps;
+
+# Function prototypes
+sub process_features ($$);
+sub getusedfiles (@);
+sub filterfiles (@);
+
+# Global options
+our %opts;
+
+# A list of files that do not belong to a Debian package but are known
+# to never create a dependency
+our @known_files = (
+    "/etc/ld.so.cache",   "/etc/dpkg/shlibs.default",
+    "/etc/dpkg/dpkg.cfg", "/etc/devscripts.conf"
+);
+
+# This will be given information about features later on
+our (%feature, %default_feature);
+
+my $progname = basename($0);
+my $modified_conf_msg;
+
+sub usage () {
+    my @ed = ("disabled", "enabled");
+    print <<"EOF";
+Usage:
+  $progname [options] <command>
+Run <command> and then output packages used to do this.
+Options:
+  Which packages to report:
+    -a, --all              Report all packages used to run <command>
+    -b, --build-depends    Do not report build-essential or essential packages
+                           used or any of their (direct or indirect)
+                           dependencies
+    -d, --ignore-dev-deps  Do not show packages used which are direct
+                           dependencies of -dev packages used
+    -m, --min-deps         Output a minimal set of packages needed, taking
+                           into account direct dependencies
+    -m implies -d and both imply -b; -a gives additional dependency information
+    if used in conjunction with -b, -d or -m
+
+  -C, --C-locale           Run command with C locale
+  --no-C-locale            Don\'t change locale
+  -l, --list-files         Report list of files used in each package
+  --no-list-files          Do not report list of files used in each package
+  -o, --output=FILE        Output diagnostic to FILE instead of stdout
+  -O, --strace-output=FILE Write strace output to FILE when tracing <command>
+                           instead of a temporary file
+  -I, --strace-input=FILE  Get strace output from FILE instead of tracing
+                           <command>; strace must be run with -f -q for this
+                           to work
+
+  -f, --features=LIST      Enable or disabled features given in
+                           comma-separated LIST as follows:
+    +feature or feature      enable feature
+    -feature                 disable feature
+
+    Known features and default setting:
+      warn-local             ($ed[$default_feature{'warn-local'}]) warn if files in /usr/local are used
+      discard-check-version  ($ed[$default_feature{'discard-check-version'}]) discard execve with only
+                             --version argument; this works around some
+                             configure scripts that check for binaries they
+                             don\'t use
+      trace-local            ($ed[$default_feature{'trace-local'}]) also try to identify file
+                             accesses in /usr/local
+      catch-alternatives     ($ed[$default_feature{'catch-alternatives'}]) catch access to alternatives
+      discard-sgml-catalogs  ($ed[$default_feature{'discard-sgml-catalogs'}]) discard access to SGML
+                             catalogs; some SGML tools read all the
+                             registered catalogs at startup.
+
+  --no-conf, --noconf        Don\'t read devscripts config files;
+                             must be the first option given
+  -h, --help                 Display this help and exit
+  -v, --version              Output version information and exit
+
+Default settings modified by devscripts configuration files:
+$modified_conf_msg
+EOF
+}
+
+sub version () {
+    print <<'EOF';
+This is $progname, from the Debian devscripts package, version ###VERSION###
+Copyright Bill Allombert <ballombe@debian.org> 2001.
+Modifications copyright 2002, 2003 Julian Gilbey <jdg@debian.org>
+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
+}
+
+# Main program
+
+# Features:
+# This are heuristics used to speed up the process.
+# Since they may be considered as "kludges" or worse "bugs"
+# by some, they can be deactivated
+# 0 disabled by default, 1 enabled by default.
+%feature = (
+    "warn-local"            => 1,
+    "discard-check-version" => 1,
+    "trace-local"           => 0,
+    "catch-alternatives"    => 1,
+    "discard-sgml-catalogs" => 1,
+);
+%default_feature = %feature;
+
+# First process configuration file options, then check for command-line
+# options.  This is pretty much 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    = ('DPKG_DEPCHECK_OPTIONS' => '',);
+    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;
+
+    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;
+
+    if ($config_vars{'DPKG_DEPCHECK_OPTIONS'} ne '') {
+        unshift @ARGV, split(' ', $config_vars{'DPKG_DEPCHECK_OPTIONS'});
+    }
+}
+
+# Default option:
+$opts{"pkgs"}    = 'all';
+$opts{"allpkgs"} = 0;
+
+Getopt::Long::Configure('bundling', 'require_order');
+GetOptions(
+    "h|help"                     => sub { usage();   exit; },
+    "v|version"                  => sub { version(); exit; },
+    "a|all"                      => sub { $opts{"allpkgs"} = 1; },
+    "b|build-depends"            => sub { $opts{"pkgs"}    = 'build'; },
+    "d|ignore-dev-deps"          => sub { $opts{"pkgs"}    = 'dev'; },
+    "m|min-deps"                 => sub { $opts{"pkgs"}    = 'min'; },
+    "C|C-locale"                 => \$opts{"C"},
+    "no-C-locale|noC-locale"     => sub { $opts{"C"} = 0; },
+    "l|list-files"               => \$opts{"l"},
+    "no-list-files|nolist-files" => sub { $opts{"l"} = 0; },
+    "o|output=s"                 => \$opts{"o"},
+    "O|strace-output=s"          => \$opts{"strace-output"},
+    "I|strace-input=s"           => \$opts{"strace-input"},
+    "f|features=s"               => \&process_features,
+    "no-conf"                    => \$opts{"noconf"},
+    "noconf"                     => \$opts{"noconf"},
+) or do { usage; exit 1; };
+
+if ($opts{"noconf"}) {
+    die
+"$progname: --no-conf is only acceptable as the first command-line option!\n";
+}
+
+if ($opts{"pkgs"} eq 'all') {
+    $opts{"allpkgs"} = 0;
+} else {
+    # We don't initialise the packages database before doing this check,
+    # as that takes quite some time
+    unless (system('dpkg -L build-essential >/dev/null 2>&1') >> 8 == 0) {
+        die
+"You must have the build-essential package installed or use the --all option\n";
+    }
+}
+
+@ARGV > 0
+  or $opts{"strace-input"}
+  or die
+  "You need to specify a command!  Run $progname --help for more info\n";
+
+# Run the command and trace it to see what's going on
+my @usedfiles = getusedfiles(@ARGV);
+
+if ($opts{"o"}) {
+    $opts{"o"} =~ s%^(\s)%./$1%;
+    open STDOUT, "> $opts{'o'}"
+      or warn
+      "Cannot open $opts{'o'} for writing: $!\nTrying to use stdout instead\n";
+} else {
+    # Visual space
+    print "\n\n";
+    print '-' x 70, "\n";
+}
+
+# Get each file once only, and drop any we are not interested in.
+# Also, expand all symlinks so we get full pathnames of the real file accessed.
+@usedfiles = filterfiles(@usedfiles);
+
+# Forget about the few files we are expecting to see but can ignore
+@usedfiles = SetMinus(\@usedfiles, \@known_files);
+
+# For a message at the end
+my $number_files_used = scalar @usedfiles;
+
+# Initialise the packages database unless --all is given
+my $packagedeps;
+
+# @used_ess_files will contain those files used which are in essential packages
+my @used_ess_files;
+
+# Exclude essential and build-essential packages?
+if ($opts{"pkgs"} ne 'all') {
+    $packagedeps = Devscripts::PackageDeps->fromStatus();
+    my @essential = PackagesMatch('^Essential: yes$');
+    my @essential_packages
+      = $packagedeps->full_dependencies('build-essential', @essential);
+    my @essential_files = PackagesToFiles(@essential_packages);
+    @used_ess_files = SetInter(\@usedfiles, \@essential_files);
+    @usedfiles      = SetMinus(\@usedfiles, \@used_ess_files);
+}
+
+# Now let's find out which packages are used...
+my @ess_packages = FilesToPackages(@used_ess_files);
+my @packages     = FilesToPackages(@usedfiles);
+my %dep_packages = ();    # packages which are depended upon by others
+
+# ... and remove their files from the filelist
+if ($opts{"l"}) {
+    # Have to do it slowly :-(
+    if ($opts{"allpkgs"}) {
+        print
+"Files used in each of the needed build-essential or essential packages:\n";
+        foreach my $pkg (sort @ess_packages) {
+            my @pkgfiles = PackagesToFiles($pkg);
+            print "Files used in (build-)essential package $pkg:\n  ",
+              join("\n  ", SetInter(\@used_ess_files, \@pkgfiles)), "\n";
+        }
+        print "\n";
+    }
+    print "Files used in each of the needed packages:\n";
+    foreach my $pkg (sort @packages) {
+        my @pkgfiles = PackagesToFiles($pkg);
+        print "Files used in package $pkg:\n  ",
+          join("\n  ", SetInter(\@usedfiles, \@pkgfiles)), "\n";
+        # We take care to note any files used which
+        # do not appear in any package
+        @usedfiles = SetMinus(\@usedfiles, \@pkgfiles);
+    }
+    print "\n";
+} else {
+    # We take care to note any files used which
+    # do not appear in any package
+    my @pkgfiles = PackagesToFiles(@packages);
+    @usedfiles = SetMinus(\@usedfiles, \@pkgfiles);
+}
+
+if ($opts{"pkgs"} eq 'dev') {
+    # We also remove any direct dependencies of '-dev' packages
+    my %pkgs;
+    @pkgs{@packages} = (1) x @packages;
+
+    foreach my $pkg (@packages) {
+        next unless $pkg =~ /-dev$/;
+        my @deps = $packagedeps->dependencies($pkg);
+        foreach my $dep (@deps) {
+            $dep = $$dep[0] if ref $dep;
+            if (exists $pkgs{$dep}) {
+                $dep_packages{$dep} = $pkg;
+                delete $pkgs{$dep};
+            }
+        }
+    }
+
+    @packages = keys %pkgs;
+} elsif ($opts{"pkgs"} eq 'min') {
+    # Do a mindep job on the package list
+    my ($packages_ref, $dep_packages_ref)
+      = $packagedeps->min_dependencies(@packages);
+    @packages     = @$packages_ref;
+    %dep_packages = %$dep_packages_ref;
+}
+
+print "Summary: $number_files_used files considered.\n" if $opts{"l"};
+# Ignore unrecognised /var/... files
+@usedfiles = grep !/^\/var\//, @usedfiles;
+if (@usedfiles) {
+    warn "The following files did not appear to belong to any package:\n";
+    warn join("\n", @usedfiles) . "\n";
+}
+
+print "Packages ", ($opts{"pkgs"} eq 'all') ? "used" : "needed", ":\n  ";
+print join("\n  ", @packages),                                   "\n";
+
+if ($opts{"allpkgs"}) {
+    if (@ess_packages) {
+        print "\n(Build-)Essential packages used:\n  ";
+        print join("\n  ", @ess_packages), "\n";
+    } else {
+        print "\nNo (Build-)Essential packages used\n";
+    }
+
+    if (scalar keys %dep_packages) {
+        print "\nOther packages used with depending packages listed:\n";
+        foreach my $pkg (sort keys %dep_packages) {
+            print "  $pkg  <=  $dep_packages{$pkg}\n";
+        }
+    }
+}
+
+exit 0;
+
+### Subroutines
+
+# This sub is handed two arguments: f or feature, and the setting
+
+sub process_features ($$) {
+    foreach (split(',', $_[1])) {
+        my $state = 1;
+        m/^-/ and $state = 0;
+        s/^[-+]//;
+        if (exists $feature{$_}) {
+            $feature{$_} = $state;
+        } else {
+            die("Unknown feature $_\n");
+        }
+    }
+}
+
+# Get used files.  This runs the requested command (given as parameters
+# to this sub) under strace and then parses the output, returning a list
+# of all absolute filenames successfully opened or execve'd.
+
+sub getusedfiles (@) {
+    my $file;
+    if ($opts{"strace-input"}) {
+        $file = $opts{"strace-input"};
+    } else {
+        my $old_locale = $ENV{'LC_ALL'} || undef;
+        $file = $opts{"strace-output"}
+          || `mktemp --tmpdir dpkg-depcheck.XXXXXXXXXX`;
+        chomp $file;
+        $file =~ s%^(\s)%./$1%;
+        my @strace_cmd = (
+            'strace', '-e', 'trace=open,openat,execve', '-f',
+            '-q',     '-o', $file,                      @_
+        );
+        $ENV{'LC_ALL'} = "C" if $opts{"C"};
+        system(@strace_cmd);
+        $? >> 8 == 0
+          or die "Running strace failed (command line:\n@strace_cmd\n";
+        if (defined $old_locale) { $ENV{'LC_ALL'} = $old_locale; }
+        else                     { delete $ENV{'LC_ALL'}; }
+    }
+
+    my %openfiles = ();
+    open FILE, $file or die "Cannot open $file for reading: $!\n";
+    while (<FILE>) {
+        # We only consider absolute filenames
+        m/^\d+\s+(\w+)\((?:[\w\d_]*, )?\"(\/.*?)\",.*\) = (-?\d+)/ or next;
+        my ($syscall, $filename, $status) = ($1, $2, $3);
+        if ($syscall eq 'open' || $syscall eq 'openat') {
+            next unless $status >= 0;
+        } elsif ($syscall eq 'execve') {
+            next unless $status == 0;
+        } else {
+            next;
+        }    # unrecognised syscall
+        next
+          if $feature{"discard-check-version"}
+          and m/execve\(\"\Q$filename\E\", \[\"[^\"]+\", "--version"\], /;
+        # So it's a real file
+        $openfiles{$filename} = 1;
+    }
+
+    unlink $file unless $opts{"strace-input"} or $opts{"strace-output"};
+
+    return keys %openfiles;
+}
+
+# Select those files which we are interested in, as determined by the
+# user-specified options
+
+sub filterfiles (@) {
+    my %files        = ();
+    my %local_files  = ();
+    my %alternatives = ();
+    my $pwd          = cwd();
+
+    foreach my $file (@_) {
+        next unless -f $file;
+        $file = Cwd::abs_path($file);
+
+        my @links    = ();
+        my $prevlink = '';
+        foreach (ListSymlinks($file, $pwd)) {
+            if (m%^/(usr|var)/local(/|\z)%) {
+                $feature{"warn-local"} and $local_files{$_} = 1;
+                unless ($feature{"trace-local"}) {
+                    $prevlink = $_;
+                    next;
+                }
+            } elsif ($feature{"discard-sgml-catalogs"}
+                and m%^/usr/share/(sgml/.*\.cat|.*/catalog)%) {
+                next;
+            } elsif ($feature{"catch-alternatives"} and m%^/etc/alternatives/%)
+            {
+                $alternatives{ "$prevlink --> " . readlink($_) } = 1
+                  if $prevlink;
+            }
+            $prevlink = $_;
+            # If it's not in one of these dirs, we skip it
+            next unless m%^/(bin|etc|lib|sbin|usr|var)%;
+            push @links, $_;
+        }
+
+        @files{@links} = (1) x @links;
+    }
+
+    if (keys %local_files) {
+        print "warning: files in /usr/local or /var/local used:\n",
+          join("\n", sort keys %local_files), "\n";
+    }
+    if (keys %alternatives) {
+        print "warning: alternatives used:\n",
+          join("\n", sort keys %alternatives), "\n";
+    }
+
+    return keys %files;
+}
+
+# The purpose here is to find out all the symlinks crossed by a file access.
+# We work from the end of the filename (basename) back towards the root of
+# the filename (solving bug#246006 where /usr is a symlink to another
+# filesystem), repeating this process until we end up with an absolute
+# filename with no symlinks in it.  We return a list of all of the
+# full filenames encountered.
+# For example, if /usr -> /moved/usr, then
+# /usr/bin/X11/xapp would yield:
+# /usr/bin/X11/xapp, /usr/X11R6/bin/xapp, /moved/usr/X11R6/bin/xapp
+
+# input: file, pwd
+# output: if symlink found: (readlink-replaced file, prefix)
+#         if not: (file, '')
+
+sub NextSymlink ($) {
+    my $file = shift;
+
+    my $filestart = $file;
+    my $fileend   = '';
+
+    while ($filestart ne '/') {
+        if (-l $filestart) {
+            my $link   = readlink($filestart);
+            my $parent = dirname $filestart;
+            if ($link =~ m%^/%) {    # absolute symlink
+                return $link . $fileend;
+            }
+            while ($link =~ s%^\./%%) { }
+            # The following is not actually correct: if we have
+            # /usr -> /moved/usr and /usr/mylib -> ../mylibdir, then
+            # /usr/mylib should resolve to /moved/mylibdir, not /mylibdir
+            # But if we try to take this into account, we would need to
+            # use something like Cwd(), which would immediately resolve
+            # /usr -> /moved/usr, losing us the opportunity of recognising
+            # the filename we want.  This is a bug we'll probably have to
+            # cope with.
+            # One way of doing this correctly would be to have a function
+            # resolvelink which would recursively resolve any initial ../ in
+            # symlinks, but no more than that.  But I don't really want to
+            # implement this unless it really proves to be necessary:
+            # people shouldn't be having evil symlinks like that on their
+            # system!!
+            while ($link =~ s%^\.\./%%) { $parent = dirname $parent; }
+            return $parent . '/' . $link . $fileend;
+        } else {
+            $fileend   = '/' . basename($filestart) . $fileend;
+            $filestart = dirname($filestart);
+        }
+    }
+    return undef;
+}
+
+# input: file, pwd
+# output: list of full filenames encountered en route
+
+sub ListSymlinks ($$) {
+    my ($file, $path) = @_;
+
+    if ($file !~ m%^/%) { $file = "$path/$file"; }
+
+    my @fn = ($file);
+
+    while ($file = NextSymlink($file)) {
+        push @fn, $file;
+    }
+
+    return @fn;
+}