chiark - git - mdw - dpkg/blob - 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 File::Basename;
  25 use File::Path qw(make_path);
  26
  27 use Dpkg ();
  28 use Dpkg::Gettext;
  29 use Dpkg::ErrorHandling;
  30 use Dpkg::Version;
  31 use Dpkg::Control;
  32 use Dpkg::Arch qw(get_host_arch);
  33
  34 textdomain('dpkg-dev');
  35
  36 my %options = (
  37     subdir => 0,
  38     destdir => '',
  39     createdir => 0,
  40     overwrite => 0,
  41     symlink => 0,
  42     architecture => 1,
  43 );
  44
  45 sub version()
  46 {
  47     printf(g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION);
  48 }
  49
  50 sub usage()
  51 {
  52     printf(g_("Usage: %s [<option>...] <file>...\n"), $Dpkg::PROGNAME);
  53
  54     print(g_("
  55 Options:
  56   -a, --no-architecture    no architecture part in filename.
  57   -o, --overwrite          overwrite if file exists.
  58   -k, --symlink            don't create a new file, but a symlink.
  59   -s, --subdir [dir]       move file into subdirectory (use with care).
  60   -c, --create-dir         create target directory if not there (use with care).
  61   -?, --help               show this help message.
  62   -v, --version            show the version.
  63
  64 file.deb changes to <package>_<version>_<architecture>.<package_type>
  65 according to the 'underscores convention'.
  66 "));
  67 }
  68
  69 sub fileexists($)
  70 {
  71     my $filename = shift;
  72
  73     if (-f $filename) {
  74         return 1;
  75     } else {
  76         warning(g_("cannot find '%s'"), $filename);
  77         return 0;
  78     }
  79 }
  80
  81 sub filesame($$)
  82 {
  83     my ($a, $b) = @_;
  84     my @sta = stat($a);
  85     my @stb = stat($b);
  86
  87     # Same device and inode numbers.
  88     return (@sta and @stb and $sta[0] == $stb[0] and $sta[1] == $stb[1]);
  89 }
  90
  91 sub getfields($)
  92 {
  93     my $filename = shift;
  94
  95     # Read the fields
  96     open(my $cdata_fh, '-|', 'dpkg-deb', '-f', '--', $filename)
  97         or syserr(g_('cannot open %s'), $filename);
  98     my $fields = Dpkg::Control->new(type => CTRL_PKG_DEB);
  99     $fields->parse($cdata_fh, sprintf(g_('binary control file %s'), $filename));
 100     close($cdata_fh);
 101
 102     return $fields;
 103 }
 104
 105 sub getarch($$)
 106 {
 107     my ($filename, $fields) = @_;
 108
 109     my $arch = $fields->{Architecture};
 110     if (not $fields->{Architecture} and $options{architecture}) {
 111         $arch = get_host_arch();
 112         warning(g_("assuming architecture '%s' for '%s'"), $arch, $filename);
 113     }
 114
 115     return $arch;
 116 }
 117
 118 sub getname($$$)
 119 {
 120     my ($filename, $fields, $arch) = @_;
 121
 122     my $pkg = $fields->{Package};
 123     my $v = Dpkg::Version->new($fields->{Version});
 124     my $version = $v->as_string(omit_epoch => 1);
 125     my $type = $fields->{'Package-Type'} || 'deb';
 126
 127     my $tname;
 128     if ($options{architecture}) {
 129         $tname = "$pkg\_$version\_$arch.$type";
 130     } else {
 131         $tname = "$pkg\_$version.$type";
 132     }
 133     (my $name = $tname) =~ s/ //g;
 134     if ($tname ne $name) { # control fields have spaces
 135         warning(g_("bad package control information for '%s'"), $filename);
 136     }
 137     return $name;
 138 }
 139
 140 sub getdir($$$)
 141 {
 142     my ($filename, $fields, $arch) = @_;
 143     my $dir;
 144
 145     if (!$options{destdir}) {
 146         $dir = dirname($filename);
 147         if ($options{subdir}) {
 148             my $section = $fields->{Section};
 149             if (!$section) {
 150                 $section = 'no-section';
 151                 warning(g_("assuming section '%s' for '%s'"), $section,
 152                         $filename);
 153             }
 154             if ($section ne 'non-free' and $section ne 'contrib' and
 155                 $section ne 'no-section') {
 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;