diff options
Diffstat (limited to 'scripts/dpkg-name.pl')
| -rwxr-xr-x | scripts/dpkg-name.pl | 259 |
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; |