File Coverage

bin/unburden-home-dir
Criterion Covered Total %
statement 343 349 99.4
branch 147 160 96.2
condition 33 35 97.1
subroutine 41 42 100.0
pod n/a
total 564 586 98.4


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-2015 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 88     88   59358 use strict;
  88         83  
  88         1974  
26 88     88   209 use warnings;
  88         54  
  88         1241  
27 88     88   1050 use 5.010;
  88         133  
28              
29             # Globally define version
30 88         4092139 our $VERSION = '0.4~dev';
31              
32             # Load Modules
33 88     88   11736 use Config::File;
  88         366480  
  88         2436  
34 88     88   123 use Getopt::Std; $Getopt::Std::STANDARD_HELP_VERSION = 1;
  88         77343  
  88         2071  
  88         3671  
35 88     88   265 use File::Path qw(mkpath rmtree);
  88         346  
  88         3090  
36 88     88   266 use File::Basename;
  88         47  
  88         3626  
37 88     88   11156 use File::BaseDir qw(config_home);
  88         53620  
  88         3423  
38 88     88   16996 use File::Slurp;
  88         556613  
  88         3807  
39 88     88   13548 use File::Touch;
  88         461152  
  88         2926  
40 88     88   21494 use File::Rsync;
  88         1083516  
  88         1745  
41 88     88   15881 use File::Which;
  88         41680  
  88         2876  
42 88     88   320 use IO::Handle;
  88         95  
  88         1528  
43 88     88   11730 use String::Expand;
  88         34855  
  88         2716  
44 88     88   288 use Data::Dumper;
  88         66  
  88         251314  
45              
46             # Determine default value for target directory
47 88         103 my $default_target = '/tmp';
48 88 100       1202 if (defined($ENV{TMPDIR})) { # defined() doesn't autovivicate
49 44         57 $default_target = $ENV{TMPDIR};
50             }
51 88 50       1774 if (-r '/proc/mounts') {
52 88         80 my $runtime_dir = '/run/user';
53 88 100       162 if (defined($ENV{XDG_RUNTIME_DIR})) { # defined() doesn't autovivicate
54 44         51 $runtime_dir = $ENV{XDG_RUNTIME_DIR};
55             }
56 88         211 $runtime_dir .= "/$<"; # typically something like /run/user/1000
57              
58 88         184 my @mounts = read_file('/proc/mounts');
59 88         15330 foreach my $mount (@mounts) {
60 2816         4054 my @mount = split(/\s+/, $mount);
61 2816 100       3376 if ($mount[1] eq $runtime_dir) {
62 44         38 $default_target = $runtime_dir;
63 44         116 last;
64             }
65             }
66             }
67              
68             # Configuration variables to be used in configuration files
69 88         193 my $CONFIG = {
70             TARGETDIR => $default_target,
71             FILELAYOUT => '.unburden-%u/%s',
72             };
73              
74             # Just show what would be done
75 88         78 my $DRYRUN = undef;
76              
77             # Undo feature
78 88         65 my $REVERT = 0;
79              
80             # Defaul base name
81 88         67 my $BASENAME = 'unburden-home-dir';
82 88         67 my $LISTSUFFIX = 'list';
83              
84             # Declare and initialise some variables
85 88         104 my %OPTIONS = ();
86 88         69 my $FILTER = undef;
87 88         23330 my $UID = getpwuid($<);
88 88         121 my $USE_LSOF = 1;
89 88         71 my $LSOF_CMD = undef;
90              
91             # Some messages for Getopt::Std
92             sub VERSION_MESSAGE {
93 6     6   127 my ($fh, $getoptpkg, $getoptversion, $cmdlineargs) = @_;
94              
95 6         50 say $fh "Unburden Home Directory $VERSION\n";
96              
97 6         11 return;
98             }
99              
100             sub HELP_MESSAGE {
101 4     4   14 my ($fh, $getoptpkg, $getoptversion, $cmdlineargs) = @_;
102              
103 4         14 say $fh "Usage: $0 [ -F | -n | -u | -b basename | (-c|-C) conffile | -f filter | (-l|-L) listfile ]
104             $0 ( -h | --help | --version )
105              
106             Options with parameters:
107              
108             -b use the given string as basename instead of \"$BASENAME\".
109              
110             -c read an additional configuration file
111              
112             -C read only the given configuration file
113              
114             -f just unburden those directory matched by the given filter (a perl
115             regular expression) -- it matches the already unburdened
116             directories if used together with -u.
117              
118             -l read an additional list file
119              
120             -L read only the given list file
121              
122             Options without parameters:
123              
124             -F Do not check if to-be-(re)moved files and directories are still
125             in use (aka *F*orce (re)moving).
126              
127             -n dry run (show what would be done)
128              
129             -u undo (reverse the functionality and put stuff back into the home
130             directory)
131              
132             -h, --help show this help
133              
134             --version show the program's version
135             ";
136              
137 4         4 return;
138             }
139              
140             # Parse command line options
141 88         268 getopts('hnuf:Fb:c:C:l:L:', \%OPTIONS);
142              
143 84         4408 foreach my $key (keys %OPTIONS) {
144 350 100       637 if ($key eq 'h') {
    100          
145 2         13 my $fh = IO::Handle->new_from_fd(fileno(STDOUT),'w');
146 2         92 VERSION_MESSAGE($fh);
147 2         3 HELP_MESSAGE($fh);
148 2         76 exit 0;
149             }
150 4         10 elsif ($key eq 'b') { $BASENAME = $OPTIONS{b}; }
151             }
152              
153             # By default check for a system wide and a user configuration and list file
154 82         352 my @CONFFILES = ("/etc/$BASENAME",
155             "$ENV{HOME}/.$BASENAME",
156             config_home($BASENAME).'/config');
157 82         1983 my @LISTFILES = ("/etc/$BASENAME.$LISTSUFFIX",
158             "$ENV{HOME}/.$BASENAME.$LISTSUFFIX",
159             config_home($BASENAME)."/$LISTSUFFIX");
160              
161 82         703 foreach my $key (keys %OPTIONS) {
162 343 100       641 if ($key eq 'C') { @CONFFILES = ($OPTIONS{C}); }
  77 100       108  
    100          
    100          
    100          
    100          
    100          
    100          
163 76         83 elsif ($key eq 'c') { push(@CONFFILES, $OPTIONS{c}); }
164 77         107 elsif ($key eq 'L') { @LISTFILES = ($OPTIONS{L}); }
165 77         87 elsif ($key eq 'l') { push(@LISTFILES, $OPTIONS{l}); }
166 12         8 elsif ($key eq 'n') { $DRYRUN = 1; }
167 8         17 elsif ($key eq 'u') { $REVERT = 1; }
168 6         2 elsif ($key eq 'F') { $USE_LSOF = 0; }
169             elsif ($key eq 'f') {
170 6         5 eval { $FILTER = qr/$OPTIONS{f}/; };
  6         67  
171 6 100       10 if ($@) {
172 2         3 report_serious_problem("parameter to -f", $OPTIONS{f});
173 2         37 exit 2;
174             }
175             }
176             }
177              
178             # Check for configuration files and read them
179 80         98 foreach my $configfile (@CONFFILES) {
180 117 100       590 if ( -e $configfile ) {
181             # Workaround RT#98542 in Config::File 1.50 and earlier
182 109         242 my $cf = Config::File::read_config_file($configfile);
183 109 100       21270 if (defined($cf)) {
184 80         427 $CONFIG = { %$CONFIG, %$cf };
185             }
186             }
187             }
188              
189             # Fix some values
190 80         140 $UID =~ s/\s+//gs;
191              
192             # Expand environment variables
193 80         217 expand_strings($CONFIG, \%ENV);
194              
195             # Remove quotes and line-feeds from values
196 80         4198 foreach my $key (keys %$CONFIG) {
197 160         138 chomp($CONFIG->{$key});
198 160         214 $CONFIG->{$key} =~ s/^([\'\"])(.*)\1$/$2/;
199             }
200              
201             # Set proper umask when creating files or directories. Save current
202             # umask before.
203 80         224 my $OLDUMASK = umask();
204 80         75 umask(077);
205              
206             # Initialize rsync object
207             my $rsync = File::Rsync->new(
208             archive => 1,
209             verbose => 1,
210             outfun => sub {
211 134     134   970510 my $output = shift;
212 134         139 chomp($output);
213 134 100       617 say $output unless $output =~ m(^sent |^total size|^\s*$);
214             },
215             errfun => sub {
216             # uncoverable subroutine
217 0     0   0 chomp; # uncoverable statement
218 0         0 warn "$_[0]\n"; # uncoverable statement
219             },
220 80         673 );
221              
222             # Check for lsof in search path
223 80         18056 my $which_lsof = which('lsof');
224             # Extra check for crappy distributions which place lsof outside a
225             # user's $PATH. Fixes GH#8.
226 80 50 66     5497 if (!$which_lsof and -x '/usr/sbin/lsof') {
227 0         0 $which_lsof = '/usr/sbin/lsof';
228             }
229 80 100       150 if (!$which_lsof) {
230 2         50 warn "WARNING: lsof not found, not checking for files in use.\n";
231 2         3 $USE_LSOF = 0;
232             } else {
233 78         89 $LSOF_CMD = $which_lsof;
234             }
235              
236             # Standard Error reporting function; Warning
237             sub report_problem {
238 8     8   172 warn "WARNING: Can't handle $_[0]: $_[1]";
239 8         15 return;
240             }
241              
242             # Standard Error reporting function; Error
243             sub report_serious_problem {
244 12     12   269 warn "ERROR: Can't handle $_[0]: $_[1]";
245 12         15 return;
246             }
247              
248             # Actually move a directory or file
249             sub move {
250 34     34   44 my ($from, $to) = @_;
251 34         138 say "Moving $from -> $to";
252 34 100       68 unless ($DRYRUN) {
253 30 100       80 if (-d $from) {
254 22         42 $from .= '/';
255 22         24 $to .= '/';
256              
257 22         179 my $rc = $rsync->exec(
258             src => $from,
259             dst => $to,
260             );
261 22         5018 rmtree($from);
262             } else {
263 8         11840 my $rc = system(qw(mv -v), $from, $to);
264 8         140 return !($? >> 8);
265             }
266             }
267 26         125 return 1;
268             }
269              
270             # Create a symlink. Create its parent directories if they don't yet
271             # exist.
272             sub create_symlink_and_parents {
273 12     12   11 my ($old, $new) = @_;
274 12         12 create_parent_directories($new);
275 12         23 say "Symlinking $new -> $old";
276 12 100       14 unless ($DRYRUN) {
277             # uncoverable branch true
278 8 50       90 symlink($old, $new)
279             or die "Couldn't symlink $new -> $old: $!";
280             }
281 12         16 return;
282             }
283              
284             # Create those parent directories for a given file or directory name
285             # which don't yet exist.
286             sub create_parent_directories {
287 50     50   41 my $file = shift;
288 50         1910 my $parent_dir = dirname($file);
289 50 100       194 unless (-d $parent_dir) {
290 16         52 say "Create parent directories for $file";
291 16 100       598 mkpath($parent_dir, { verbose => 1 }) unless $DRYRUN;
292             }
293 50         52 return;
294             }
295              
296             # In case of uppercase type letters, create symlinks as replacement
297             # for directories files which may not even exist yet. Common cases are
298             # trash directories which are created when something gets put into the
299             # trashcan, etc.
300             sub possibly_create_non_existing_stuff {
301 12     12   12 my ($type, $item, $target) = @_;
302              
303             # Shall we create not yet existing directories or files as symlink?
304             # Case 1: directory
305 12 100       27 if ( $type eq 'D' ) {
    50          
306             # TODO: Refactor create_symlink_and_parents so that its
307             # create_parent_directories call isn't redundant in this case.
308 4         17 say "Create directory $target and parents";
309 4 100       225 mkpath($target, { verbose => 1 }) unless $DRYRUN;
310 4         9 create_symlink_and_parents($target, $item);
311             }
312              
313             # Case 2: file
314             elsif ( $type eq 'F' ) {
315 8         14 create_parent_directories($target);
316 8         33 say "Touching $target";
317 8 100       22 touch($target) unless $DRYRUN;
318 8         359 create_symlink_and_parents($target, $item)
319             }
320 12         13 return 0;
321             }
322              
323             # Dangling links may happen if the destination directory has been
324             # weeped, e.g. due to being on an tmpfs mount or by tmpreaper, etc.
325             sub fix_dangling_links {
326 10     10   11 my ($type, $itemexpanded, $target) = @_;
327 10         20 my $link = readlink($itemexpanded);
328 10         12 my $is_dir = type_is_directory($type);
329 10         11 my $is_file = type_is_file($type);
330              
331             # Accept existing symlinks or unburden-home-dir.list entries for
332             # directories with or without trailing slash
333 10 100       14 if ($is_dir) {
334 6         6 $link =~ s{/$}{};
335 6         7 $itemexpanded =~ s{/$}{};
336 6         6 $target =~ s{/$}{};
337             }
338              
339             # Check if link target is wanted target
340 10 100       28 if ( $link ne $target ) {
341 2         4 report_problem($itemexpanded, "$link not equal $target");
342 2         2 return 1;
343             }
344              
345             # Check if target exists and is same type
346 8 100       21 if ( -e $target ) {
347 6         9 my $unexpected_type = check_for_unexpected_type($type, $target);
348 6 100       13 return $unexpected_type if $unexpected_type;
349             }
350             # Symlink is there, but file or directory not
351             else {
352 2         2 create_object_of_type($type, $target);
353             }
354 4         7 return 0;
355             }
356              
357             # Find pid and command in lsof output
358             sub parse_lsof_output {
359 34     34   68 my ($output) = @_;
360 34         72 chomp($output);
361 34         144 my @lines = split(/\n/, $output);
362              
363 34         82 my $result = '';
364 34         39 my $pid;
365             my $cmd;
366              
367 34         139 foreach my $line (@lines) {
368 6 100       36 if ($line =~ /^p(.*)$/) {
    100          
369 2         10 $pid = $1;
370 2         5 $cmd = undef;
371             } elsif ($line =~ /^c(.*)$/) {
372 2         5 $cmd = $1;
373             # uncoverable branch true
374 2 50       8 unless ($pid) {
375             # uncoverable statement
376 0         0 report_problem("lsof output", "No pid before command: $line");
377 0         0 next; # uncoverable statement
378             }
379 2         10 $result .= sprintf(" %5i (%s)\n", $pid, $cmd);
380 2         2 $pid = undef;
381             } else {
382             # uncoverable statement
383 2         9 report_problem("unexpected line in lsof output", $line);
384             }
385             }
386              
387 34         103 return $result;
388              
389             }
390              
391             # Check if files in to be moved directories are currently in use.
392             sub files_in_use {
393 36     36   31 my ($item) = @_;
394 36         37 my $lsof_output = undef;
395              
396 36 100       80 if (-d $item) {
    100          
397 26         1685627 $lsof_output = `$LSOF_CMD -F c +D '$item'`;
398             } elsif (-f _) {
399 8         542194 $lsof_output = `$LSOF_CMD -F c '$item'`;
400             } else {
401 2         5 report_problem("checking open files in $item", "neither file nor directory");
402 2         8 return;
403             }
404              
405 34         382 my $lsof_parsed = parse_lsof_output($lsof_output);
406              
407 34 100       132 if ($lsof_parsed) {
408 2         5 report_problem($item, "in use, not (re)moving. Process list:\n$lsof_parsed");
409 2         24 return 1;
410             } else {
411 32         434 return 0;
412             }
413             }
414              
415             # Move a directory or file (higher level function)
416             sub action_move {
417 28     28   38 my ($itemexpanded, $target) = @_;
418              
419 28         77 create_parent_directories($target);
420             # uncoverable branch true
421 28 50       60 move($itemexpanded, $target)
422             or die "Couldn't move $itemexpanded -> $target: $!";
423 28         119 return;
424             }
425              
426             # Handle directory or file which should be emptied (higher level function)
427             sub action_delete_and_recreate {
428 8     8   11 my ($type, $itemexpanded, $target) = @_;
429              
430 8         14 my $is_file = type_is_file($type);
431 8         10 my $is_dir = type_is_directory($type);
432              
433 8         52 say "Delete $itemexpanded";
434 8 100       15 unless ($DRYRUN) {
435 4 100       551 $is_dir and rmtree($itemexpanded, { verbose => 1 }) ;
436             # uncoverable condition right
437 4 100 50     78 $is_file and (unlink($itemexpanded)
438             or die "Couldn't delete $itemexpanded: $!");
439             }
440 8         19 create_object_of_type($type, $target);
441              
442 8         7 return;
443             }
444              
445             # Generic create function for both, directories and files
446             sub create_object_of_type {
447 10     10   13 my ($type, $target) = @_;
448              
449 10         22 say "Create $target";
450 10 100       17 unless ($DRYRUN) {
451 6 100       9 if (type_is_directory($type)) {
    50          
452 4         385 mkpath($target, { verbose => 1 });
453             }
454             elsif (type_is_file($type)) {
455 2         5 create_parent_directories($target);
456 2         4 say "Touching $target";
457             # uncoverable branch true
458 2 50       18 touch($target) or die "Couldn't touch $target: $!";
459             }
460             }
461              
462 10         151 return;
463             }
464              
465             # Create a symlink
466             sub create_symlink {
467 36     36   53 my ($itemexpanded, $target) = @_;
468              
469 36         109 say "Symlinking $target -> $itemexpanded";
470 36 100       70 unless ($DRYRUN) {
471             # uncoverable branch true
472 30 50       412 symlink($target, $itemexpanded)
473             or die "Couldn't symlink $target -> $itemexpanded: $!";
474             }
475 36         40 return;
476             }
477              
478             # Check if the expected type of an object is "directory"
479             sub type_is_directory {
480 174     174   679 return (lc(shift) eq 'd');
481             }
482              
483             # Check if the expected type of an object is "file"
484             sub type_is_file {
485 104     104   414 return (lc(shift) eq 'f');
486             }
487              
488             # Check if an object has an unexpected type (higher level function)
489             sub check_for_unexpected_type {
490 48     48   58 my ($type, $itemexpanded) = @_;
491              
492 48         76 my $is_file = type_is_file($type);
493 48         98 my $is_dir = type_is_directory($type);
494              
495 48 100 100     275 if ($is_file and !-f $itemexpanded) {
496 6         15 report_serious_problem($itemexpanded,
497             'Unexpected type (not a file)');
498 6         7 return 1;
499             }
500              
501 42 100 100     394 if ($is_dir and !-d $itemexpanded) {
502 4         5 report_serious_problem($itemexpanded,
503             'Unexpected type (not a directory)');
504 4         4 return 1;
505             }
506              
507 38         55 return;
508             }
509              
510             # Top-level function run once per to-be-changed-item
511             sub do_it {
512 44     44   59 my ($type, $itemexpanded, $target, $action) = @_;
513              
514 44 100 100     163 if ( $USE_LSOF and files_in_use($itemexpanded) ) {
515 2         7 return 0;
516             }
517              
518 42         133 my $unexpected_type = check_for_unexpected_type($type, $itemexpanded);
519 42 100       66 return $unexpected_type if $unexpected_type;
520              
521 36 100 100     233 if ( $action eq 'r' or $action eq 'd' ) {
    50          
522 8         18 action_delete_and_recreate($type, $itemexpanded, $target);
523             }
524             elsif ( $action eq 'm' ) {
525 28         50 action_move($itemexpanded, $target);
526             }
527              
528 36         133 create_symlink($itemexpanded, $target);
529              
530 36         74 return 0;
531             }
532              
533             # Parse and fill placeholders in target definition
534             sub calculate_target {
535 76     76   67 my $replacement = shift;
536 76         105 my $target = $CONFIG->{FILELAYOUT};
537              
538 76         90 $target =~ s|%u|$UID|g;
539 76         154 $target =~ s|%s|$replacement|g;
540              
541 76         239 return $CONFIG->{TARGETDIR}."/$target";
542             }
543              
544             # Parse and fill wildcards
545             sub fill_in_wildcard_matches {
546 74     74   73 my ($itemglob, $itemexpanded, $target) = @_;
547              
548             # Replace %<n> (e.g. %1) with the n-th wildcard match. Uses perl
549             # here as it would be too complicated and way less readable if
550             # written as (bourne) shell script.
551              
552             # Change from globbing to regexp
553 74         74 $itemglob =~ s/\?/(.)/g;
554 74         71 $itemglob =~ s/\*/(.*)/g;
555              
556 74         536 my @result = $itemexpanded =~ m($itemglob)g;
557              
558 74         89 $target =~ s/\%(\d+)/$result[$1-1]/eg;
  24         48  
559              
560 74         100 return $target;
561             }
562              
563             # Check if the path to something to unburden already contains a symlink
564             sub symlink_in_path {
565 82     82   75 my $path = shift;
566             # Remove home directory, i.e. check just from below the home directory
567             # uncoverable branch false
568 82 50       751 if ($path =~ s($ENV{HOME}/?)()) {
569             # Split up into components, but remove the last one (which we
570             # are requested to handle, so we shouldn't check that now)
571 82         181 my @path_elements = split(m(/), $path);
572 82         73 pop(@path_elements);
573              
574 82         170 foreach my $i (0..$#path_elements) {
575 94         194 my $path_to_check = $ENV{HOME}.'/'.join('/', @path_elements[0..$i]);
576             #say "Check if $path_to_check is a symlink";
577 94 100       333 return $path_to_check if -l $path_to_check;
578             }
579 66         163 return 0;
580             } else {
581             # uncoverable statement
582 0         0 report_serious_problem("Can't find home directory ($ENV{HOME}) in $path!");
583             }
584             }
585              
586             # Handle replacement requests and check if they're sane
587             sub replace {
588             # replace $type $i $item $replacement
589 82     82   125 my ($type, $itemexpanded, $itemglob, $replacement, $action) = @_;
590              
591 82 100       129 if (my $symlink = symlink_in_path($itemexpanded)) {
592 16         186 warn "Skipping '$itemexpanded' due to symlink in path: $symlink\n";
593 16         74 return 0;
594             }
595              
596 66         118 my $target = fill_in_wildcard_matches($itemglob, $itemexpanded,
597             calculate_target($replacement));
598              
599             # Check if the source exists
600 66 100 100     421 if ( ! -e $itemexpanded and ! -l $itemexpanded ) {
    100          
601 12         25 possibly_create_non_existing_stuff($type, $itemexpanded, $target);
602             }
603             # Check if source is already a symlink
604             elsif ( -l $itemexpanded ) {
605 10         29 fix_dangling_links($type, $itemexpanded, $target);
606             }
607              
608             # TODO: Check available disk space
609             # Should use report_serious_problem
610              
611             # No symlink yet, then actually move or remove!
612             else {
613 44         105 do_it($type, $itemexpanded, $target, $action);
614             }
615              
616 66         664 return;
617             }
618              
619             # Core functionality of the undo feature
620             sub revert {
621 8     8   9 my ($itemexpanded, $item_in_home, $target_glob) = @_;
622              
623 8         19 $item_in_home = "$ENV{HOME}/" .
624             fill_in_wildcard_matches($target_glob, $itemexpanded, $item_in_home);
625 8         53 say "Trying to revert $itemexpanded to $item_in_home";
626              
627 8 50       40 if (-l $item_in_home) {
628 8         31 my $link_target = readlink($item_in_home);
629 8         8 $itemexpanded =~ s{/$}{};
630 8         7 $link_target =~ s{/$}{};
631              
632 8 100       15 if ($itemexpanded eq $link_target) {
633 6         6 say "Removing symlink $item_in_home";
634 6 100       89 unlink($item_in_home) unless $DRYRUN;
635 6         16 move($itemexpanded, $item_in_home);
636             } else {
637 2         42 warn "Ignoring symlink $item_in_home as it points to $link_target ".
638             "and not to $itemexpanded as expected.\n";
639             }
640             }
641              
642 8         89 return;
643             }
644              
645             # Parse wildcards backwards
646             sub exchange_wildcards_and_replacements {
647 10     10   9 my ($wildcard, $replacement) = @_;
648 10         9 my $i = 1;
649 10         28 while ($replacement =~ /\%(\d+)/) {
650 12         9 my $number = $1;
651 12         14 my $prev = $number-1;
652 12         223 $wildcard =~ s/^(([^*]*[*?]){$prev}[^*]*)([?*])/"$1\%".$i++/e;
  12         21  
653 12         16 my $wildcardtype = $3;
654 12         32 $replacement =~ s/\%(\d+)/$wildcardtype/;
655             }
656 10         17 return ($wildcard, $replacement);
657             }
658              
659             # Main loop over all items in list files
660 80         107 for my $list (@LISTFILES) {
661 118 100       404 next unless -e $list;
662 110 100       235 unless (-r _) {
663 2         55 warn "List file $list isn't readable, skipping";
664 2         3 next;
665             }
666              
667             # Clean up this and that
668 108         72 my $list_fh;
669             # uncoverable branch true
670 108 50       1010 open($list_fh, '<', $list) or die "Can't open $list: $!";
671 108         8503 while (<$list_fh>) {
672 116 100       592 next if /^#|^ *$/;
673              
674 110         117 chomp;
675 110         277 my ($action, $type, $item, $replacement) = split;
676              
677 110 100       229 next unless defined $action;
678              
679             # Expand environment variables in item and replacement only
680 108 100       431 $item = expand_string($item, \%ENV) if defined($item);
681 108 100       2468 $replacement = expand_string($replacement, \%ENV) if defined($replacement);
682              
683 108 100 100     1244 if (not (defined($item) and defined($replacement) and
      100        
684             # $item can't be '' since $replacement is undef then
685             $replacement ne '')) {
686 6         139 warn "Can't parse '$_', skipping...";
687 6         19 next;
688             }
689 102 100 100     205 unless ( type_is_directory($type) or type_is_file($type) ) {
690 2         51 warn "Can't parse type '$type', must be 'd', 'D', 'f' or 'F', skipping...";
691 2         7 next;
692             }
693 100 100 100     838 if ( $action ne 'd' and $action ne 'r' and $action ne 'm' ) {
      100        
694 2         58 warn "Can't parse action '$action', must be 'd', 'r' or 'm', skipping...";
695 2         7 next;
696             }
697              
698 98 100       211 if ( $item =~ m(^(\.\.)?/) ) {
699 4         106 warn "$item would be outside of the home directory, skipping...\n";
700 4         14 next;
701             }
702              
703 94 100       165 if ($REVERT) {
704 10         23 ($item, $replacement) = exchange_wildcards_and_replacements($item, $replacement);
705              
706 10         25 my $replacement_path = calculate_target($replacement);
707 10         317 for my $i (glob($replacement_path)) {
708 10 100       17 if (defined($FILTER)) {
709 4 100       22 next unless ($i =~ $FILTER);
710             }
711 8         13 revert($i, $item, $replacement);
712             }
713             } else {
714 84         1855 for my $i (glob("$ENV{HOME}/$item")) {
715 84 100       145 if (defined($FILTER)) {
716 4 100       18 next unless ($i =~ $FILTER);
717             }
718 82         139 replace($type, $i, $item, $replacement, $action);
719             }
720             }
721             }
722 108         673 close($list_fh);
723             }
724              
725             # Restore original umask
726 80         2162 umask($OLDUMASK);