File Coverage

bin/unburden-home-dir
Criterion Covered Total %
statement 322 328 100.0
branch 133 146 95.9
condition 31 32 100.0
subroutine 40 41 100.0
pod n/a
total 526 547 98.9


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