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	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 Force (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);