Commit | Line | Data |
---|---|---|
1479465f GJ |
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; |