# File Coverage

bin/unburden-home-dir
Criterion | Covered | Total | %
--- | --- | --- | ---
statement |  |  | n/a
branch |  |  | n/a
condition |  |  | n/a
subroutine |  |  | n/a
pod |  |  | n/a
total |  |  | n/a

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