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 21use warnings; 22use strict; 23 24use File::Basename; 25use File::Path qw(make_path); 26 27use Dpkg (); 28use Dpkg::Gettext; 29use Dpkg::ErrorHandling; 30use Dpkg::Version; 31use Dpkg::Control; 32use Dpkg::Arch qw(get_host_arch); 33 34textdomain('dpkg-dev'); 35 36my %options = ( 37 subdir => 0, 38 destdir => '', 39 createdir => 0, 40 overwrite => 0, 41 symlink => 0, 42 architecture => 1, 43); 44 45sub version() 46{ 47 printf(g_("Debian %s version %s.\n"), $Dpkg::PROGNAME, $Dpkg::PROGVERSION); 48} 49 50sub usage() 51{ 52 printf(g_("Usage: %s [<option>...] <file>...\n"), $Dpkg::PROGNAME); 53 54 print(g_(" 55Options: 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 64file.deb changes to <package>_<version>_<architecture>.<package_type> 65according to the 'underscores convention'. 66")); 67} 68 69sub 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 81sub 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 91sub 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 105sub 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 118sub 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 140sub 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 168sub 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 220my @files; 221 222while (@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 255foreach my $file (@files) { 256 move($file); 257} 258 2590; 260