File Coverage: bin/unburden-home-dir

# File Coverage

File: | bin/unburden-home-dir
Coverage: | 68.6%

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