scripts/dpkg-name.pl

   1 #!/usr/bin/perl
   2 #
   3 # dpkg-name
   4 #
   5 # Copyright © 1995,1996 Erick Branderhorst <branderh@debian.org>.
   6 # Copyright © 2006-2010, 2012-2015 Guillem Jover <guillem@debian.org>
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  20
  21 use warnings;
  22 use strict;
  23
  24 use List::Util qw(none);
  25 use File::Basename;
  26 use File::Path qw(make_path);
  27
  28 use Dpkg ();
  29 use Dpkg::Gettext;
  30 use Dpkg::ErrorHandling;
  31 use Dpkg::Version;
  32 use Dpkg::Control;
  33 use Dpkg::Arch qw(get_host_arch);
  34
  35 textdomain('dpkg-dev');
  36
  37 my %options = (
  38     subdir => 0,
  39     destdir => '',
  40     createdir => 0,
  41     overwrite => 0,
  42     symlink => 0,
  43     architecture => 1,
  44 );
  45
  46 sub version()
  47 {
  48     printf(g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION);
  49 }
  50
  51 sub usage()
  52 {
  53     printf(g_("Usage: %s [<option>...] <file>...\n"), $Dpkg::PROGNAME);
  54
  55     print(g_("
  56 Options:
  57   -a, --no-architecture    no architecture part in filename.
  58   -o, --overwrite          overwrite if file exists.
  59   -k, --symlink            don't create a new file, but a symlink.
  60   -s, --subdir [dir]       move file into subdirectory (use with care).
  61   -c, --create-dir         create target directory if not there (use with care).
  62   -?, --help               show this help message.
  63   -v, --version            show the version.
  64
  65 file.deb changes to <package>_<version>_<architecture>.<package_type>
  66 according to the 'underscores convention'.
  67 "));
  68 }
  69
  70 sub fileexists($)
  71 {
  72     my $filename = shift;
  73
  74     if (-f $filename) {
  75         return 1;
  76     } else {
  77         warning(g_("cannot find '%s'"), $filename);
  78         return 0;
  79     }
  80 }
  81
  82 sub filesame($$)
  83 {
  84     my ($a, $b) = @_;
  85     my @sta = stat($a);
  86     my @stb = stat($b);
  87
  88     # Same device and inode numbers.
  89     return (@sta and @stb and $sta[0] == $stb[0] and $sta[1] == $stb[1]);
  90 }
  91
  92 sub getfields($)
  93 {
  94     my $filename = shift;
  95
  96     # Read the fields
  97     open(my $cdata_fh, '-|', 'dpkg-deb', '-f', '--', $filename)
  98         or syserr(g_('cannot open %s'), $filename);
  99     my $fields = Dpkg::Control->new(type => CTRL_PKG_DEB);
 100     $fields->parse($cdata_fh, sprintf(g_('binary control file %s'), $filename));
 101     close($cdata_fh);
 102
 103     return $fields;
 104 }
 105
 106 sub getarch($$)
 107 {
 108     my ($filename, $fields) = @_;
 109
 110     my $arch = $fields->{Architecture};
 111     if (not $fields->{Architecture} and $options{architecture}) {
 112         $arch = get_host_arch();
 113         warning(g_("assuming architecture '%s' for '%s'"), $arch, $filename);
 114     }
 115
 116     return $arch;
 117 }
 118
 119 sub getname($$$)
 120 {
 121     my ($filename, $fields, $arch) = @_;
 122
 123     my $pkg = $fields->{Package};
 124     my $v = Dpkg::Version->new($fields->{Version});
 125     my $version = $v->as_string(omit_epoch => 1);
 126     my $type = $fields->{'Package-Type'} || 'deb';
 127
 128     my $tname;
 129     if ($options{architecture}) {
 130         $tname = "$pkg\_$version\_$arch.$type";
 131     } else {
 132         $tname = "$pkg\_$version.$type";
 133     }
 134     (my $name = $tname) =~ s/ //g;
 135     if ($tname ne $name) { # control fields have spaces
 136         warning(g_("bad package control information for '%s'"), $filename);
 137     }
 138     return $name;
 139 }
 140
 141 sub getdir($$$)
 142 {
 143     my ($filename, $fields, $arch) = @_;
 144     my $dir;
 145
 146     if (!$options{destdir}) {
 147         $dir = dirname($filename);
 148         if ($options{subdir}) {
 149             my $section = $fields->{Section};
 150             if (!$section) {
 151                 $section = 'no-section';
 152                 warning(g_("assuming section '%s' for '%s'"), $section,
 153                         $filename);
 154             }
 155             if (none { $section eq $_ } qw(no-section contrib non-free)) {
 156                 $dir = "unstable/binary-$arch/$section";
 157             } else {
 158                 $dir = "$section/binary-$arch";
 159             }
 160         }
 161     } else {
 162         $dir = $options{destdir};
 163     }
 164
 165     return $dir;
 166 }
 167
 168 sub move($)
 169 {
 170     my $filename = shift;
 171
 172     if (fileexists($filename)) {
 173         my $fields = getfields($filename);
 174
 175         unless (exists $fields->{Package}) {
 176             warning(g_("no Package field found in '%s', skipping package"),
 177                     $filename);
 178             return;
 179         }
 180
 181         my $arch = getarch($filename, $fields);
 182
 183         my $name = getname($filename, $fields, $arch);
 184
 185         my $dir = getdir($filename, $fields, $arch);
 186         if (! -d $dir) {
 187             if ($options{createdir}) {
 188                 if (make_path($dir)) {
 189                     info(g_("created directory '%s'"), $dir);
 190                 } else {
 191                     error(g_("cannot create directory '%s'"), $dir);
 192                 }
 193             } else {
 194                 error(g_("no such directory '%s', try --create-dir (-c) option"),
 195                       $dir);
 196             }
 197         }
 198
 199         my $newname = "$dir/$name";
 200
 201         my @command;
 202         if ($options{symlink}) {
 203             @command = qw(ln -s --);
 204         } else {
 205             @command = qw(mv --);
 206         }
 207
 208         if (filesame($newname, $filename)) {
 209             warning(g_("skipping '%s'"), $filename);
 210         } elsif (-f $newname and not $options{overwrite}) {
 211             warning(g_("cannot move '%s' to existing file"), $filename);
 212         } elsif (system(@command, $filename, $newname) == 0) {
 213             info(g_("moved '%s' to '%s'"), basename($filename), $newname);
 214         } else {
 215             error(g_('mkdir can be used to create directory'));
 216         }
 217     }
 218 }
 219
 220 my @files;
 221
 222 while (@ARGV) {
 223     $_ = shift(@ARGV);
 224     if (m/^-\?|--help$/) {
 225         usage();
 226         exit(0);
 227     } elsif (m/^-v|--version$/) {
 228         version();
 229         exit(0);
 230     } elsif (m/^-c|--create-dir$/) {
 231         $options{createdir} = 1;
 232     } elsif (m/^-s|--subdir$/) {
 233         $options{subdir} = 1;
 234         if (-d $ARGV[0]) {
 235             $options{destdir} = shift(@ARGV);
 236         }
 237     } elsif (m/^-o|--overwrite$/) {
 238         $options{overwrite} = 1;
 239     } elsif (m/^-k|--symlink$/) {
 240         $options{symlink} = 1;
 241     } elsif (m/^-a|--no-architecture$/) {
 242         $options{architecture} = 0;
 243     } elsif (m/^--$/) {
 244         push @files, @ARGV;
 245         last;
 246     } elsif (m/^-/) {
 247         usageerr(g_("unknown option '%s'"), $_);
 248     } else {
 249         push @files, $_;
 250     }
 251 }
 252
 253 @files or usageerr(g_('need at least a filename'));
 254
 255 foreach my $file (@files) {
 256     move($file);
 257 }
 258
 259 0;