File: | bin/unburden-home-dir |
Coverage: | 68.6% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | #!/usr/bin/perl | ||||||
2 | # | ||||||
3 | # This file causes a list of directories to be removed or moved off | ||||||
4 | # the users home directory into a given other directory. Usually this | ||||||
5 | # is used to relief NFS home directories of the burden of caches and | ||||||
6 | # other performance needing directories. | ||||||
7 | # | ||||||
8 | # Copyright (C) 2010-2012 by Axel Beckert <beckert@phys.ethz.ch>, | ||||||
9 | # Department of Physics, ETH Zurich. | ||||||
10 | # | ||||||
11 | # This program is free software: you can redistribute it and/or modify | ||||||
12 | # it under the terms of the GNU General Public License as published by | ||||||
13 | # the Free Software Foundation, either version 2 of the License, or | ||||||
14 | # (at your option) any later version. | ||||||
15 | # | ||||||
16 | # This program is distributed in the hope that it will be useful, but | ||||||
17 | # WITHOUT ANY WARRANTY; without even the implied warranty of | ||||||
18 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | ||||||
19 | # General Public License for more details. | ||||||
20 | # | ||||||
21 | # You should have received a copy of the GNU General Public License | ||||||
22 | # along with this program. If not, see http://www.gnu.org/licenses/. | ||||||
23 | # | ||||||
24 | |||||||
25 | 13 13 13 | 68284 384421 658 | use Modern::Perl; | ||||
26 | |||||||
27 | # Globally define version | ||||||
28 | 13 | 5178775 | our $VERSION = '0.3.2'; | ||||
29 | |||||||
30 | # Configuration variables to be used in configuration files | ||||||
31 | 13 | 188 | my $CONFIG = { | ||||
32 | TARGETDIR => '/tmp', | ||||||
33 | FILELAYOUT => '.unburden-%u/%s', | ||||||
34 | }; | ||||||
35 | |||||||
36 | # Just show what would be done | ||||||
37 | 13 | 91 | my $DRYRUN = undef; | ||||
38 | |||||||
39 | # Undo feature | ||||||
40 | 13 | 78 | my $REVERT = 0; | ||||
41 | |||||||
42 | # Defaul base name | ||||||
43 | 13 | 109 | my $BASENAME = 'unburden-home-dir'; | ||||
44 | 13 | 168 | my $LISTSUFFIX = 'list'; | ||||
45 | |||||||
46 | # Load Modules | ||||||
47 | 13 13 13 | 16535 32356 2003 | use Config::File; | ||||
48 | 13 13 13 13 | 86 73562 2059 3097 | use Getopt::Std; $Getopt::Std::STANDARD_HELP_VERSION = 1; | ||||
49 | 13 13 13 | 186 60 2745 | use File::Path qw(mkpath rmtree); | ||||
50 | 13 13 13 | 196 63 2901 | use File::Basename; | ||||
51 | 13 13 13 | 10738 53676 3066 | use File::BaseDir qw(config_home); | ||||
52 | 13 13 13 | 12911 344124 2324 | use File::Touch; | ||||
53 | 13 13 13 | 14145 785750 1643 | use File::Rsync; | ||||
54 | 13 13 13 | 12384 47811 2782 | use File::Which; | ||||
55 | 13 13 13 | 243 73 1625 | use IO::Handle; | ||||
56 | 13 13 13 | 18346 329142 2416478 | use Data::Dumper; | ||||
57 | |||||||
58 | # Declare and initialise some variables | ||||||
59 | 13 | 104 | my %OPTIONS = (); | ||||
60 | 13 | 87 | my $FILTER = undef; | ||||
61 | 13 | 19438 | my $UID = getpwuid($<); | ||||
62 | 13 | 161 | my $USE_LSOF = 1; | ||||
63 | 13 | 106 | my $LSOF_CMD = undef; | ||||
64 | |||||||
65 | # Some messages for Getopt::Std | ||||||
66 | sub VERSION_MESSAGE { | ||||||
67 | 0 | 0 | my ($fh, $getoptpkg, $getoptversion, $cmdlineargs) = @_; | ||||
68 | |||||||
69 | 0 | 0 | say $fh "Unburden Home Directory $VERSION\n"; | ||||
70 | |||||||
71 | 0 | 0 | return; | ||||
72 | } | ||||||
73 | |||||||
74 | sub HELP_MESSAGE { | ||||||
75 | 0 | 0 | my ($fh, $getoptpkg, $getoptversion, $cmdlineargs) = @_; | ||||
76 | |||||||
77 | 0 | 0 | say $fh "Usage: $0 [ -F | -n | -u | -b basename | (-c|-C) conffile | -f filter | (-l|-L) listfile ] | ||||
78 | $0 ( -h | --help | --version ) | ||||||
79 | |||||||
80 | Options with parameters: | ||||||
81 | |||||||
82 | -b use the given string as basename instead of \"$BASENAME\". | ||||||
83 | |||||||
84 | -c read an additional configuration file | ||||||
85 | |||||||
86 | -C read only the given configuration file | ||||||
87 | |||||||
88 | -f just unburden those directory matched by the given filter (a perl | ||||||
89 | regular expression) -- it matches the already unburdened | ||||||
90 | directories if used together with -u. | ||||||
91 | |||||||
92 | -l read an additional list file | ||||||
93 | |||||||
94 | -L read only the given list file | ||||||
95 | |||||||
96 | Options without parameters: | ||||||
97 | |||||||
98 | -F Do not check if to-be-(re)moved files and directories are still | ||||||
99 | in use (aka *F*orce (re)moving). | ||||||
100 | |||||||
101 | -n dry run (show what would be done) | ||||||
102 | |||||||
103 | -u undo (reverse the functionality and put stuff back into the home | ||||||
104 | directory) | ||||||
105 | |||||||
106 | -h, --help show this help | ||||||
107 | |||||||
108 | --version show the program's version | ||||||
109 | "; | ||||||
110 | |||||||
111 | 0 | 0 | return; | ||||
112 | } | ||||||
113 | |||||||
114 | # Parse command line options | ||||||
115 | 13 | 1168 | getopts('hnufFb:c:C:l:L:', \%OPTIONS); | ||||
116 | |||||||
117 | 13 | 3969 | for (keys %OPTIONS) { | ||||
118 | 28 | 391 | when('h') { | ||||
119 | 0 | 0 | my $fh = IO::Handle->new_from_fd(fileno(STDERR),'w'); | ||||
120 | 0 | 0 | VERSION_MESSAGE($fh); | ||||
121 | 0 | 0 | HELP_MESSAGE($fh); | ||||
122 | 0 | 0 | exit 0; | ||||
123 | } | ||||||
124 | 28 2 | 656 27 | when('b') { $BASENAME = $OPTIONS{b}; } | ||||
125 | } | ||||||
126 | |||||||
127 | # By default check for a system wide and a user configuration and list file | ||||||
128 | 13 | 817 | my @CONFFILES = ("/etc/$BASENAME", | ||||
129 | "$ENV{HOME}/.$BASENAME", | ||||||
130 | config_home($BASENAME).'/config'); | ||||||
131 | 13 | 3020 | my @LISTFILES = ("/etc/$BASENAME.$LISTSUFFIX", | ||||
132 | "$ENV{HOME}/.$BASENAME.$LISTSUFFIX", | ||||||
133 | config_home($BASENAME)."/$LISTSUFFIX"); | ||||||
134 | |||||||
135 | 13 | 1710 | for (keys %OPTIONS) { | ||||
136 | 28 11 | 207 155 | when('C') { @CONFFILES = ($OPTIONS{C}); } | ||||
137 | 17 0 | 102 0 | when('c') { push(@CONFFILES, $OPTIONS{c}); } | ||||
138 | 17 11 | 106 152 | when('L') { @LISTFILES = ($OPTIONS{L}); } | ||||
139 | 6 0 | 37 0 | when('l') { push(@LISTFILES, $OPTIONS{l}); } | ||||
140 | 6 2 | 39 18 | when('n') { $DRYRUN = 1; } | ||||
141 | 4 2 | 28 17 | when('u') { $REVERT = 1; } | ||||
142 | 2 0 | 13 0 | when('F') { $USE_LSOF = 0; } | ||||
143 | 2 | 21 | when('f') { | ||||
144 | 0 0 | 0 0 | eval { $FILTER = qr/$OPTIONS{f}/; }; | ||||
145 | 0 | 0 | if ($@) { | ||||
146 | 0 | 0 | report_serious_problem("parameter to -f", "\n$@"); | ||||
147 | 0 | 0 | exit 2; | ||||
148 | } | ||||||
149 | } | ||||||
150 | } | ||||||
151 | |||||||
152 | # Check for configuration files and read them | ||||||
153 | 13 | 120 | foreach my $configfile (@CONFFILES) { | ||||
154 | 17 | 2361 | if ( -e $configfile ) { | ||||
155 | 13 | 674 | $CONFIG = { %$CONFIG, | ||||
156 | 13 | 140 | %{Config::File::read_config_file($configfile)} }; | ||||
157 | } | ||||||
158 | } | ||||||
159 | |||||||
160 | # Fix some values | ||||||
161 | 13 | 22499 | $UID =~ s/\s+//gs; | ||||
162 | |||||||
163 | # Remove quotes and line-feeds from values | ||||||
164 | 13 | 189 | foreach my $key (keys %$CONFIG) { | ||||
165 | 26 | 201 | chomp($CONFIG->{$key}); | ||||
166 | 26 | 331 | $CONFIG->{$key} =~ s/^([\'\"])(.*)\1$/$2/; | ||||
167 | } | ||||||
168 | |||||||
169 | # Set proper umask when creating files or directories. Save current | ||||||
170 | # umask before. | ||||||
171 | 13 | 279 | my $OLDUMASK = umask(); | ||||
172 | 13 | 83 | umask(077); | ||||
173 | |||||||
174 | # Initialize rsync object | ||||||
175 | my $rsync = File::Rsync->new({ | ||||||
176 | archive => 1, | ||||||
177 | verbose => 1, | ||||||
178 | outfun => sub { | ||||||
179 | 48 | 488967 | my $_ = shift; | ||||
180 | 48 | 503 | chomp; | ||||
181 | 48 | 4536 | say unless m(^sent |^total size|^\s*$); | ||||
182 | }, | ||||||
183 | 0 0 | 0 0 | errfun => sub { chomp; warn "$_[0]\n"; }, | ||||
184 | 13 | 1181 | }); | ||||
185 | |||||||
186 | # Check for lsof in search path | ||||||
187 | 13 | 14993 | my $which_lsof = which('lsof'); | ||||
188 | 13 | 12344 | if (!$which_lsof) { | ||||
189 | 0 | 0 | warn "WARNING: lsof not found, not checking for files in use.\n"; | ||||
190 | 0 | 0 | $USE_LSOF = 0; | ||||
191 | } | ||||||
192 | |||||||
193 | # Standard Error reporting function; Warning | ||||||
194 | sub report_problem { | ||||||
195 | 0 | 0 | warn "WARNING: Can't handle $_[0]: $_[1]"; | ||||
196 | 0 | 0 | return; | ||||
197 | } | ||||||
198 | |||||||
199 | # Standard Error reporting function; Error | ||||||
200 | sub report_serious_problem { | ||||||
201 | 0 | 0 | warn "ERROR: Can't handle $_[0]: $_[1]"; | ||||
202 | 0 | 0 | return; | ||||
203 | } | ||||||
204 | |||||||
205 | # Actually move a directory or file | ||||||
206 | sub move ($$) { | ||||||
207 | 11 | 98 | my ($from, $to) = @_; | ||||
208 | 11 | 282 | say "Moving $from -> $to"; | ||||
209 | 11 | 163 | unless ($DRYRUN) { | ||||
210 | 9 | 185 | if (-d $from) { | ||||
211 | 8 | 141 | $from .= '/' unless $from =~ m(/$); | ||||
212 | 8 | 94 | $to .= '/' unless $to =~ m(/$); | ||||
213 | |||||||
214 | 8 | 969 | my $rc = $rsync->exec({ | ||||
215 | src => $from, | ||||||
216 | dst => $to, | ||||||
217 | }); | ||||||
218 | 8 | 33191 | rmtree($from); | ||||
219 | } else { | ||||||
220 | 1 | 5457 | my $rc = system(qw(mv -v), $from, $to); | ||||
221 | 1 | 77 | return !($? >> 8); | ||||
222 | } | ||||||
223 | } | ||||||
224 | 10 | 375 | return 1; | ||||
225 | } | ||||||
226 | |||||||
227 | # Create a symlink. Create its parent directories if they don't yet | ||||||
228 | # exist. | ||||||
229 | sub create_symlink_and_parents { | ||||||
230 | 1 | 10 | my ($old, $new) = @_; | ||||
231 | 1 | 7 | create_parent_directories($new); | ||||
232 | 1 | 11 | say "Symlinking $new -> $old"; | ||||
233 | 1 | 10 | unless ($DRYRUN) { | ||||
234 | 1 | 134 | symlink($old, $new) | ||||
235 | or die "Couldn't symlink $new -> $old: $!"; | ||||||
236 | } | ||||||
237 | 1 | 6 | return; | ||||
238 | } | ||||||
239 | |||||||
240 | # Create those parent directories for a given file or directory name | ||||||
241 | # which don't yet exist. | ||||||
242 | sub create_parent_directories { | ||||||
243 | 10 | 64 | my $file = shift; | ||||
244 | 10 | 1814 | my $parent_dir = dirname($file); | ||||
245 | 10 | 382 | unless (-d $parent_dir) { | ||||
246 | 3 | 78 | say "Create parent directories for $file"; | ||||
247 | 3 | 585 | mkpath($parent_dir, { verbose => 1 }) unless $DRYRUN; | ||||
248 | } | ||||||
249 | 10 | 76 | return; | ||||
250 | } | ||||||
251 | |||||||
252 | # In case of uppercase type letters, create symlinks as replacement | ||||||
253 | # for directories files which may not even exist yet. Common cases are | ||||||
254 | # trash directories which are created when something gets put into the | ||||||
255 | # trashcan, etc. | ||||||
256 | sub possibly_create_non_existing_stuff { | ||||||
257 | 1 | 46 | my ($type, $item, $target) = @_; | ||||
258 | |||||||
259 | # Shall we create not yet existing directories or files as symlink? | ||||||
260 | # Case 1: directory | ||||||
261 | 1 | 11 | if ( $type eq 'D' ) { | ||||
262 | # TODO: Refactor create_symlink_and_parents so that its | ||||||
263 | # create_parent_directories call isn't redundant in this case. | ||||||
264 | 1 | 29 | say "Create directory $target and parents"; | ||||
265 | 1 | 361 | mkpath($target, { verbose => 1 }) unless $DRYRUN; | ||||
266 | 1 | 13 | create_symlink_and_parents($target, $item); | ||||
267 | } | ||||||
268 | |||||||
269 | # Case 2: file | ||||||
270 | elsif ( $type eq 'F' ) { | ||||||
271 | 0 | 0 | create_parent_directories($target); | ||||
272 | 0 | 0 | say "Touching $target"; | ||||
273 | 0 | 0 | touch($target) unless $DRYRUN; | ||||
274 | 0 | 0 | create_symlink_and_parents($target, $item) | ||||
275 | } | ||||||
276 | 1 | 6 | return 0; | ||||
277 | } | ||||||
278 | |||||||
279 | # Dangling links may happen if the destination directory has been | ||||||
280 | # weeped, e.g. due to being on an tmpfs mount or by tmpreaper, etc. | ||||||
281 | sub fix_dangling_links { | ||||||
282 | 1 | 97 | my ($type, $itemexpanded, $target) = @_; | ||||
283 | 1 | 36 | my $link = readlink($itemexpanded); | ||||
284 | 1 | 13 | my $is_dir = type_is_directory($type); | ||||
285 | 1 | 13 | my $is_file = type_is_file($type); | ||||
286 | |||||||
287 | # Accept existing symlinks or unburden-home-dir.list entries for | ||||||
288 | # directories with or without trailing slash | ||||||
289 | 1 | 15 | if ($is_dir) { | ||||
290 | 1 | 13 | $link =~ s{/$}{}; | ||||
291 | 1 | 8 | $itemexpanded =~ s{/$}{}; | ||||
292 | 1 | 23 | $target =~ s{/$}{}; | ||||
293 | } | ||||||
294 | |||||||
295 | # Check if link target is wanted target | ||||||
296 | 1 | 13 | if ( $link ne $target ) { | ||||
297 | 0 | 0 | report_problem($itemexpanded, "$link not equal $target"); | ||||
298 | 0 | 0 | return 1; | ||||
299 | } | ||||||
300 | |||||||
301 | # Check if target exists and is same type | ||||||
302 | 1 | 28 | if ( -e $target ) { | ||||
303 | 0 | 0 | my $unexpected_type = check_for_unexpected_type($type, $target); | ||||
304 | 0 | 0 | return $unexpected_type if $unexpected_type; | ||||
305 | } | ||||||
306 | # Symlink is there, but file or directory not | ||||||
307 | else { | ||||||
308 | 1 | 12 | create_object_of_type($type, $target); | ||||
309 | } | ||||||
310 | 1 | 10 | return 0; | ||||
311 | } | ||||||
312 | |||||||
313 | # Find pid and command in lsof output | ||||||
314 | sub parse_lsof_output { | ||||||
315 | 9 | 100 | my ($output) = @_; | ||||
316 | 9 | 56 | chomp($output); | ||||
317 | 9 | 127 | my @lines = split(/\n/, $output); | ||||
318 | |||||||
319 | 9 | 67 | my $result = ''; | ||||
320 | 9 | 45 | my $pid; | ||||
321 | 9 | 40 | my $cmd; | ||||
322 | |||||||
323 | 9 | 149 | foreach my $line (@lines) { | ||||
324 | 0 | 0 | if ($line =~ /^p(.*)$/) { | ||||
325 | 0 | 0 | $pid = $1; | ||||
326 | 0 | 0 | $cmd = undef; | ||||
327 | } elsif ($line =~ /^c(.*)$/) { | ||||||
328 | 0 | 0 | $cmd = $1; | ||||
329 | 0 | 0 | unless ($pid) { | ||||
330 | 0 | 0 | report_problem("lsof output", "No pid before command: $line"); | ||||
331 | 0 | 0 | next; | ||||
332 | } | ||||||
333 | 0 | 0 | $result .= sprintf(" %5i (%s)\n", $pid, $cmd); | ||||
334 | 0 | 0 | $pid = undef; | ||||
335 | } else { | ||||||
336 | 0 | 0 | report_problem("line in lsof output", $line); | ||||
337 | } | ||||||
338 | } | ||||||
339 | |||||||
340 | 9 | 114 | return $result; | ||||
341 | |||||||
342 | } | ||||||
343 | |||||||
344 | # Check if files in to be moved directories are currently in use. | ||||||
345 | sub files_in_use { | ||||||
346 | 9 | 83 | my ($item) = @_; | ||||
347 | 9 | 57 | my $lsof_output = undef; | ||||
348 | |||||||
349 | 9 | 186 | if (-d $item) { | ||||
350 | 8 | 2122731 | $lsof_output = `find '$item' -print0 | buffer | xargs -0 lsof -F c`; | ||||
351 | } elsif (-f _) { | ||||||
352 | 1 | 255645 | $lsof_output = `lsof -F c '$item'`; | ||||
353 | } else { | ||||||
354 | 0 | 0 | report_problem("Not checking for open files in $item: neither file nor directory"); | ||||
355 | 0 | 0 | return; | ||||
356 | } | ||||||
357 | |||||||
358 | 9 | 344 | my $lsof_parsed = parse_lsof_output($lsof_output); | ||||
359 | |||||||
360 | 9 | 200 | if ($lsof_parsed) { | ||||
361 | 0 | 0 | report_problem($item, "in use, not (re)moving. Process list:\n$lsof_parsed"); | ||||
362 | 0 | 0 | return 1; | ||||
363 | } else { | ||||||
364 | 9 | 323 | return 0; | ||||
365 | } | ||||||
366 | } | ||||||
367 | |||||||
368 | # Move a directory or file (higher level function) | ||||||
369 | sub action_move { | ||||||
370 | 9 | 85 | my ($itemexpanded, $target) = @_; | ||||
371 | |||||||
372 | 9 | 137 | create_parent_directories($target); | ||||
373 | 9 | 93 | move($itemexpanded, $target) | ||||
374 | or die "Couldn't move $itemexpanded -> $target: $!"; | ||||||
375 | 9 | 154 | return; | ||||
376 | } | ||||||
377 | |||||||
378 | # Handle directory or file which should be emptied (higher level function) | ||||||
379 | sub action_delete_and_recreate { | ||||||
380 | 0 | 0 | my ($type, $itemexpanded, $target) = @_; | ||||
381 | |||||||
382 | 0 | 0 | my $is_file = type_is_file($type); | ||||
383 | 0 | 0 | my $is_dir = type_is_directory($type); | ||||
384 | |||||||
385 | 0 | 0 | say "Delete $itemexpanded"; | ||||
386 | 0 | 0 | unless ($DRYRUN) { | ||||
387 | 0 | 0 | $is_dir and rmtree($itemexpanded, { verbose => 1 }) ; | ||||
388 | 0 | 0 | $is_file and (unlink($itemexpanded) | ||||
389 | || die "Couldn't delete $itemexpanded: $!"); | ||||||
390 | } | ||||||
391 | 0 | 0 | create_object_of_type($type, $target); | ||||
392 | |||||||
393 | 0 | 0 | return; | ||||
394 | } | ||||||
395 | |||||||
396 | # Generic create function for both, directories and files | ||||||
397 | sub create_object_of_type { | ||||||
398 | 1 | 13 | my ($type, $target) = @_; | ||||
399 | |||||||
400 | 1 | 47 | say "Create $target"; | ||||
401 | 1 | 15 | unless ($DRYRUN) { | ||||
402 | 1 | 11 | if (type_is_directory($type)) { | ||||
403 | 1 | 897 | mkpath($target, { verbose => 1 }); | ||||
404 | } | ||||||
405 | elsif (type_is_file($type)) { | ||||||
406 | 0 | 0 | create_parent_directories($target); | ||||
407 | 0 | 0 | say "Touching $target"; | ||||
408 | 0 | 0 | touch($target) || die "Couldn't touch $target: $!"; | ||||
409 | } | ||||||
410 | } | ||||||
411 | |||||||
412 | 1 | 19 | return; | ||||
413 | } | ||||||
414 | |||||||
415 | # Bail out on common assertion | ||||||
416 | sub unknown_element { | ||||||
417 | 0 | 0 | my ($what, $unknown) = @_; | ||||
418 | |||||||
419 | 0 | 0 | warn "Unknown $what '$unknown'. This should never happen."; | ||||
420 | 0 | 0 | return 255; | ||||
421 | } | ||||||
422 | |||||||
423 | # Create a symlink | ||||||
424 | sub create_symlink { | ||||||
425 | 9 | 145 | my ($itemexpanded, $target) = @_; | ||||
426 | |||||||
427 | 9 | 195 | say "Symlinking $target -> $itemexpanded"; | ||||
428 | 9 | 139 | unless ($DRYRUN) { | ||||
429 | 8 | 1680 | symlink($target, $itemexpanded) | ||||
430 | or die "Couldn't symlink $target -> $itemexpanded: $!"; | ||||||
431 | } | ||||||
432 | 9 | 93 | return; | ||||
433 | } | ||||||
434 | |||||||
435 | # Check if the expected type of an object is "directory" | ||||||
436 | sub type_is_directory { | ||||||
437 | 34 | 670 | return (lc(shift) eq 'd'); | ||||
438 | } | ||||||
439 | |||||||
440 | # Check if the expected type of an object is "file" | ||||||
441 | sub type_is_file { | ||||||
442 | 11 | 181 | return (lc(shift) eq 'f'); | ||||
443 | } | ||||||
444 | |||||||
445 | # Check if an object has an unexpected type (higher level function) | ||||||
446 | sub check_for_unexpected_type { | ||||||
447 | 9 | 92 | my ($type, $itemexpanded) = @_; | ||||
448 | |||||||
449 | 9 | 93 | my $is_file = type_is_file($type); | ||||
450 | 9 | 85 | my $is_dir = type_is_directory($type); | ||||
451 | |||||||
452 | 9 | 295 | unless ($is_file or $is_dir) { | ||||
453 | 0 | 0 | return unknown_element('type', $type); | ||||
454 | } | ||||||
455 | |||||||
456 | 9 | 147 | if ($is_file and !-f $itemexpanded) { | ||||
457 | 0 | 0 | report_serious_problem($itemexpanded, | ||||
458 | 'Unexpected type (not a file)'); | ||||||
459 | 0 | 0 | return 1; | ||||
460 | } | ||||||
461 | |||||||
462 | 9 | 458 | if ($is_dir and !-d $itemexpanded) { | ||||
463 | 0 | 0 | report_serious_problem($itemexpanded, | ||||
464 | 'Unexpected type (not a directory)'); | ||||||
465 | 0 | 0 | return 1; | ||||
466 | } | ||||||
467 | |||||||
468 | 9 | 67 | return; | ||||
469 | } | ||||||
470 | |||||||
471 | # Top-level function run once per to-be-changed-item | ||||||
472 | sub do_it { | ||||||
473 | 9 | 243 | my ($type, $itemexpanded, $target, $action) = @_; | ||||
474 | |||||||
475 | 9 | 203 | if ( $USE_LSOF and files_in_use($itemexpanded) ) { | ||||
476 | 0 | 0 | return 0; | ||||
477 | } | ||||||
478 | |||||||
479 | 9 | 138 | my $unexpected_type = check_for_unexpected_type($type, $itemexpanded); | ||||
480 | 9 | 67 | return $unexpected_type if $unexpected_type; | ||||
481 | |||||||
482 | 9 | 294 | if ( $action eq 'r' or $action eq 'd' ) { | ||||
483 | 0 | 0 | action_delete_and_recreate($type, $itemexpanded, $target); | ||||
484 | } | ||||||
485 | elsif ( $action eq 'm' ) { | ||||||
486 | 9 | 226 | action_move($itemexpanded, $target); | ||||
487 | } | ||||||
488 | else { | ||||||
489 | 0 | 0 | return unknown_element('action', $action); | ||||
490 | } | ||||||
491 | |||||||
492 | 9 | 216 | create_symlink($itemexpanded, $target); | ||||
493 | |||||||
494 | 9 | 89 | return 0; | ||||
495 | } | ||||||
496 | |||||||
497 | # Parse and fill placeholders in target definition | ||||||
498 | sub calculate_target { | ||||||
499 | 13 | 116 | my $replacement = shift; | ||||
500 | 13 | 231 | my $target = $CONFIG->{FILELAYOUT}; | ||||
501 | |||||||
502 | 13 | 117 | $target =~ s|%u|$UID|g; | ||||
503 | 13 | 239 | $target =~ s|%s|$replacement|g; | ||||
504 | |||||||
505 | 13 | 236 | return $CONFIG->{TARGETDIR}."/$target"; | ||||
506 | } | ||||||
507 | |||||||
508 | # Parse and fill wildcards | ||||||
509 | sub fill_in_wildcard_matches { | ||||||
510 | 13 | 203 | my ($itemglob, $itemexpanded, $target) = @_; | ||||
511 | |||||||
512 | # Replace %<n> (e.g. %1) with the n-th wildcard match. Uses perl | ||||||
513 | # here as it would be too complicated and way less readable if | ||||||
514 | # written as (bourne) shell script. | ||||||
515 | |||||||
516 | # Change from globbing to regexp | ||||||
517 | 13 | 136 | $itemglob =~ s/\?/(.)/g; | ||||
518 | 13 | 158 | $itemglob =~ s/\*/(.*)/g; | ||||
519 | |||||||
520 | 13 | 689 | my @result = $itemexpanded =~ m($itemglob)g; | ||||
521 | |||||||
522 | 13 12 | 215 328 | $target =~ s/\%(\d+)/$result[$1-1]/eg; | ||||
523 | |||||||
524 | 13 | 180 | return $target; | ||||
525 | } | ||||||
526 | |||||||
527 | # Check if the path to something to unburden already contains a symlink | ||||||
528 | sub symlink_in_path { | ||||||
529 | 19 | 183 | my $path = shift; | ||||
530 | # Remove home directory, i.e. check just from below the home directory | ||||||
531 | 19 | 1004 | if ($path =~ s($ENV{HOME}/?)()) { | ||||
532 | # Split up into components, but remove the last one (which we | ||||||
533 | # are requested to handle, so we shouldn't check that now) | ||||||
534 | 19 | 593 | my @path_elements = split(m(/), $path); | ||||
535 | 19 | 153 | pop(@path_elements); | ||||
536 | |||||||
537 | 19 | 347 | foreach my $i (0..$#path_elements) { | ||||
538 | 29 | 594 | my $path_to_check = $ENV{HOME}.'/'.join('/', @path_elements[0..$i]); | ||||
539 | #say "Check if $path_to_check is a symlink"; | ||||||
540 | 29 | 1111 | return $path_to_check if -l $path_to_check; | ||||
541 | } | ||||||
542 | 11 | 208 | return 0; | ||||
543 | } else { | ||||||
544 | 0 | 0 | report_serious_problem("Can't find home directory ($ENV{HOME}) in $path!"); | ||||
545 | } | ||||||
546 | |||||||
547 | 0 | 0 | return; | ||||
548 | } | ||||||
549 | |||||||
550 | # Handle replacement requests and check if they're sane | ||||||
551 | sub replace { | ||||||
552 | # replace $type $i $item $replacement | ||||||
553 | 19 | 269 | my ($type, $itemexpanded, $itemglob, $replacement, $action) = @_; | ||||
554 | |||||||
555 | # Skip entries where wildcard where passed | ||||||
556 | 19 | 308 | if ($itemexpanded =~ /[][*?]/) { | ||||
557 | 0 | 0 | warn "Skipping '$itemexpanded' due to unmatched wildcard.\n"; | ||||
558 | 0 | 0 | return 0; | ||||
559 | } | ||||||
560 | |||||||
561 | 19 | 247 | if (my $symlink = symlink_in_path($itemexpanded)) { | ||||
562 | 8 | 1228 | warn "Skipping '$itemexpanded' due to symlink in path: $symlink\n"; | ||||
563 | 8 | 485 | return 0; | ||||
564 | } | ||||||
565 | |||||||
566 | 11 | 114 | my $target = fill_in_wildcard_matches($itemglob, $itemexpanded, | ||||
567 | calculate_target($replacement)); | ||||||
568 | |||||||
569 | # Check if the source exists | ||||||
570 | 11 | 774 | if ( ! -e $itemexpanded and ! -l $itemexpanded ) { | ||||
571 | 1 | 9 | possibly_create_non_existing_stuff($type, $itemexpanded, $target); | ||||
572 | } | ||||||
573 | # Check if source is already a symlink | ||||||
574 | elsif ( -l $itemexpanded ) { | ||||||
575 | 1 | 16 | fix_dangling_links($type, $itemexpanded, $target); | ||||
576 | } | ||||||
577 | |||||||
578 | # TODO: Check available disk space | ||||||
579 | # Should use report_serious_problem | ||||||
580 | |||||||
581 | # No symlink yet, then actually move or remove! | ||||||
582 | else { | ||||||
583 | 9 | 152 | do_it($type, $itemexpanded, $target, $action); | ||||
584 | } | ||||||
585 | |||||||
586 | 11 | 1035 | return; | ||||
587 | } | ||||||
588 | |||||||
589 | # Core functionality of the undo feature | ||||||
590 | sub revert { | ||||||
591 | 2 | 26 | my ($itemexpanded, $item_in_home, $target_glob) = @_; | ||||
592 | |||||||
593 | # Skip entries where wildcard where passed | ||||||
594 | 2 | 34 | if ($itemexpanded =~ /[][*?]/) { | ||||
595 | 0 | 0 | warn "Skipping '$target_glob' due to unmatched wildcard.\n"; | ||||
596 | 0 | 0 | return 0; | ||||
597 | } | ||||||
598 | |||||||
599 | 2 | 33 | $item_in_home = "$ENV{HOME}/" . | ||||
600 | fill_in_wildcard_matches($target_glob, $itemexpanded, $item_in_home); | ||||||
601 | 2 | 77 | say "Trying to revert $itemexpanded to $item_in_home"; | ||||
602 | |||||||
603 | 2 | 92 | if (-l $item_in_home) { | ||||
604 | 2 | 268 | my $link_target = readlink($item_in_home); | ||||
605 | 2 | 22 | $itemexpanded =~ s{/$}{}; | ||||
606 | 2 | 16 | $link_target =~ s{/$}{}; | ||||
607 | |||||||
608 | 2 | 30 | if ($itemexpanded eq $link_target) { | ||||
609 | 2 | 28 | say "Removing symlink $item_in_home"; | ||||
610 | 2 | 219 | unlink($item_in_home) unless $DRYRUN; | ||||
611 | 2 | 27 | move($itemexpanded, $item_in_home); | ||||
612 | } else { | ||||||
613 | 0 | 0 | warn "Ignoring symlink $item_in_home as it points to $link_target ". | ||||
614 | "and not to $itemexpanded as expected.\n"; | ||||||
615 | } | ||||||
616 | } | ||||||
617 | |||||||
618 | 2 | 162 | return; | ||||
619 | } | ||||||
620 | |||||||
621 | # Parse wildcards backwards | ||||||
622 | sub exchange_wildcards_and_replacements { | ||||||
623 | 2 | 21 | my ($wildcard, $replacement) = @_; | ||||
624 | 2 | 13 | my $i = 1; | ||||
625 | 2 | 56 | while ($replacement =~ /\%(\d+)/) { | ||||
626 | 6 | 66 | my $number = $1; | ||||
627 | 6 | 48 | my $prev = $number-1; | ||||
628 | 6 6 | 452 112 | $wildcard =~ s/^(([^*]*[*?]){$prev}[^*]*)([?*])/"$1\%".$i++/e; | ||||
629 | 6 | 55 | my $wildcardtype = $3; | ||||
630 | 6 | 129 | $replacement =~ s/\%(\d+)/$wildcardtype/; | ||||
631 | } | ||||||
632 | 2 | 40 | return ($wildcard, $replacement); | ||||
633 | } | ||||||
634 | |||||||
635 | # Main loop over all items in list files | ||||||
636 | 13 | 126 | for my $list (@LISTFILES) { | ||||
637 | 17 | 530 | next unless -r $list; | ||||
638 | |||||||
639 | # Clean up this and that | ||||||
640 | 13 | 803 | open(LIST, '<', $list) or die "Can't open $list: $!"; | ||||
641 | 13 | 1140 | while (<LIST>) { | ||||
642 | 27 | 1264 | next if /^#|^ *$/; | ||||
643 | |||||||
644 | 24 | 222 | chomp; | ||||
645 | 24 | 470 | my ($action, $type, $item, $replacement) = split; | ||||
646 | |||||||
647 | 24 | 302 | next unless defined $action; | ||||
648 | |||||||
649 | 23 | 984 | if (!defined($item) or !defined($replacement)) { | ||||
650 | 0 | 0 | warn "Can't parse '$_', skipping..."; | ||||
651 | 0 | 0 | next; | ||||
652 | } | ||||||
653 | 23 | 275 | unless ( type_is_directory($type) or type_is_file($type) ) { | ||||
654 | 0 | 0 | warn "Can't parse type '$type', must be 'd', 'D', 'f' or 'F', skipping..."; | ||||
655 | 0 | 0 | next; | ||||
656 | } | ||||||
657 | 23 | 1014 | if ( $action ne 'd' and $action ne 'r' and $action ne 'm' ) { | ||||
658 | 0 | 0 | warn "Can't parse action '$action', must be 'd', 'r' or 'm', skipping..."; | ||||
659 | 0 | 0 | next; | ||||
660 | } | ||||||
661 | |||||||
662 | 23 | 397 | if ( $item =~ m(^(\.\.)?/) ) { | ||||
663 | 2 | 309 | warn "$item would be outside of the home directory, skipping...\n"; | ||||
664 | 2 | 56 | next; | ||||
665 | } | ||||||
666 | |||||||
667 | 21 | 233 | if ($REVERT) { | ||||
668 | 2 | 22 | ($item, $replacement) = exchange_wildcards_and_replacements($item, $replacement); | ||||
669 | |||||||
670 | 2 | 27 | my $replacement_path = calculate_target($replacement); | ||||
671 | 2 | 618 | for my $i (glob($replacement_path)) { | ||||
672 | 2 | 33 | if (defined($FILTER)) { | ||||
673 | 0 | 0 | next unless ($i =~ $FILTER); | ||||
674 | } | ||||||
675 | 2 | 34 | revert($i, $item, $replacement); | ||||
676 | } | ||||||
677 | } else { | ||||||
678 | 19 | 5362 | for my $i (glob("$ENV{HOME}/$item")) { | ||||
679 | 19 | 302 | if (defined($FILTER)) { | ||||
680 | 0 | 0 | next unless ($i =~ $FILTER); | ||||
681 | } | ||||||
682 | 19 | 234 | replace($type, $i, $item, $replacement, $action); | ||||
683 | } | ||||||
684 | } | ||||||
685 | } | ||||||
686 | 13 | 617 | close(LIST); | ||||
687 | } | ||||||
688 | |||||||
689 | # Restore original umask | ||||||
690 | 13 | 0 | umask($OLDUMASK); |