summaryrefslogtreecommitdiffstats
path: root/scripts/dpkg-name.pl
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/dpkg-name.pl')
-rwxr-xr-xscripts/dpkg-name.pl259
1 files changed, 259 insertions, 0 deletions
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;