From cbffab246997fb5a06211dfb706b54e5ae5bb59f Mon Sep 17 00:00:00 2001
From: Daniel Baumann <daniel.baumann@progress-linux.org>
Date: Sun, 7 Apr 2024 16:58:51 +0200
Subject: Adding upstream version 1.21.22.

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
---
 scripts/dpkg-name.pl | 259 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 259 insertions(+)
 create mode 100755 scripts/dpkg-name.pl

(limited to 'scripts/dpkg-name.pl')

diff --git a/scripts/dpkg-name.pl b/scripts/dpkg-name.pl
new file mode 100755
index 0000000..0fc4b32
--- /dev/null
+++ b/scripts/dpkg-name.pl
@@ -0,0 +1,259 @@
+#!/usr/bin/perl
+#
+# dpkg-name
+#
+# Copyright © 1995,1996 Erick Branderhorst <branderh@debian.org>.
+# Copyright © 2006-2010, 2012-2015 Guillem Jover <guillem@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 warnings;
+use strict;
+
+use List::Util qw(none);
+use File::Basename;
+use File::Path qw(make_path);
+
+use Dpkg ();
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Version;
+use Dpkg::Control;
+use Dpkg::Arch qw(get_host_arch);
+
+textdomain('dpkg-dev');
+
+my %options = (
+    subdir => 0,
+    destdir => '',
+    createdir => 0,
+    overwrite => 0,
+    symlink => 0,
+    architecture => 1,
+);
+
+sub version()
+{
+    printf(g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION);
+}
+
+sub usage()
+{
+    printf(g_("Usage: %s [<option>...] <file>...\n"), $Dpkg::PROGNAME);
+
+    print(g_("
+Options:
+  -a, --no-architecture    no architecture part in filename.
+  -o, --overwrite          overwrite if file exists.
+  -k, --symlink            don't create a new file, but a symlink.
+  -s, --subdir [dir]       move file into subdirectory (use with care).
+  -c, --create-dir         create target directory if not there (use with care).
+  -?, --help               show this help message.
+  -v, --version            show the version.
+
+file.deb changes to <package>_<version>_<architecture>.<package_type>
+according to the 'underscores convention'.
+"));
+}
+
+sub fileexists($)
+{
+    my $filename = shift;
+
+    if (-f $filename) {
+        return 1;
+    } else {
+        warning(g_("cannot find '%s'"), $filename);
+        return 0;
+    }
+}
+
+sub filesame($$)
+{
+    my ($a, $b) = @_;
+    my @sta = stat($a);
+    my @stb = stat($b);
+
+    # Same device and inode numbers.
+    return (@sta and @stb and $sta[0] == $stb[0] and $sta[1] == $stb[1]);
+}
+
+sub getfields($)
+{
+    my $filename = shift;
+
+    # Read the fields
+    open(my $cdata_fh, '-|', 'dpkg-deb', '-f', '--', $filename)
+        or syserr(g_('cannot open %s'), $filename);
+    my $fields = Dpkg::Control->new(type => CTRL_PKG_DEB);
+    $fields->parse($cdata_fh, sprintf(g_('binary control file %s'), $filename));
+    close($cdata_fh);
+
+    return $fields;
+}
+
+sub getarch($$)
+{
+    my ($filename, $fields) = @_;
+
+    my $arch = $fields->{Architecture};
+    if (not $fields->{Architecture} and $options{architecture}) {
+        $arch = get_host_arch();
+        warning(g_("assuming architecture '%s' for '%s'"), $arch, $filename);
+    }
+
+    return $arch;
+}
+
+sub getname($$$)
+{
+    my ($filename, $fields, $arch) = @_;
+
+    my $pkg = $fields->{Package};
+    my $v = Dpkg::Version->new($fields->{Version});
+    my $version = $v->as_string(omit_epoch => 1);
+    my $type = $fields->{'Package-Type'} || 'deb';
+
+    my $tname;
+    if ($options{architecture}) {
+        $tname = "$pkg\_$version\_$arch.$type";
+    } else {
+        $tname = "$pkg\_$version.$type";
+    }
+    (my $name = $tname) =~ s/ //g;
+    if ($tname ne $name) { # control fields have spaces
+        warning(g_("bad package control information for '%s'"), $filename);
+    }
+    return $name;
+}
+
+sub getdir($$$)
+{
+    my ($filename, $fields, $arch) = @_;
+    my $dir;
+
+    if (!$options{destdir}) {
+        $dir = dirname($filename);
+        if ($options{subdir}) {
+            my $section = $fields->{Section};
+            if (!$section) {
+                $section = 'no-section';
+                warning(g_("assuming section '%s' for '%s'"), $section,
+                        $filename);
+            }
+            if (none { $section eq $_ } qw(no-section contrib non-free)) {
+                $dir = "unstable/binary-$arch/$section";
+            } else {
+                $dir = "$section/binary-$arch";
+            }
+        }
+    } else {
+        $dir = $options{destdir};
+    }
+
+    return $dir;
+}
+
+sub move($)
+{
+    my $filename = shift;
+
+    if (fileexists($filename)) {
+        my $fields = getfields($filename);
+
+        unless (exists $fields->{Package}) {
+            warning(g_("no Package field found in '%s', skipping package"),
+                    $filename);
+            return;
+        }
+
+        my $arch = getarch($filename, $fields);
+
+        my $name = getname($filename, $fields, $arch);
+
+        my $dir = getdir($filename, $fields, $arch);
+        if (! -d $dir) {
+            if ($options{createdir}) {
+                if (make_path($dir)) {
+                    info(g_("created directory '%s'"), $dir);
+                } else {
+                    error(g_("cannot create directory '%s'"), $dir);
+                }
+            } else {
+                error(g_("no such directory '%s', try --create-dir (-c) option"),
+                      $dir);
+            }
+        }
+
+        my $newname = "$dir/$name";
+
+        my @command;
+        if ($options{symlink}) {
+            @command = qw(ln -s --);
+        } else {
+            @command = qw(mv --);
+        }
+
+        if (filesame($newname, $filename)) {
+            warning(g_("skipping '%s'"), $filename);
+        } elsif (-f $newname and not $options{overwrite}) {
+            warning(g_("cannot move '%s' to existing file"), $filename);
+        } elsif (system(@command, $filename, $newname) == 0) {
+            info(g_("moved '%s' to '%s'"), basename($filename), $newname);
+        } else {
+            error(g_('mkdir can be used to create directory'));
+        }
+    }
+}
+
+my @files;
+
+while (@ARGV) {
+    $_ = shift(@ARGV);
+    if (m/^-\?|--help$/) {
+        usage();
+        exit(0);
+    } elsif (m/^-v|--version$/) {
+        version();
+        exit(0);
+    } elsif (m/^-c|--create-dir$/) {
+        $options{createdir} = 1;
+    } elsif (m/^-s|--subdir$/) {
+        $options{subdir} = 1;
+        if (-d $ARGV[0]) {
+            $options{destdir} = shift(@ARGV);
+        }
+    } elsif (m/^-o|--overwrite$/) {
+        $options{overwrite} = 1;
+    } elsif (m/^-k|--symlink$/) {
+        $options{symlink} = 1;
+    } elsif (m/^-a|--no-architecture$/) {
+        $options{architecture} = 0;
+    } elsif (m/^--$/) {
+        push @files, @ARGV;
+        last;
+    } elsif (m/^-/) {
+        usageerr(g_("unknown option '%s'"), $_);
+    } else {
+        push @files, $_;
+    }
+}
+
+@files or usageerr(g_('need at least a filename'));
+
+foreach my $file (@files) {
+    move($file);
+}
+
+0;
-- 
cgit v1.2.3