| 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 | 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 | 16535 32356 2003 | use Config::File; | ||||
| 48 | 13 13 13 13 | 86 73562 2059 3097 | use Getopt::Std; $Getopt::Std::STANDARD_HELP_VERSION = 1; | ||||
| 49 | 13 13 13 | 186 60 2745 | use File::Path qw(mkpath rmtree); | ||||
| 50 | 13 13 13 | 196 63 2901 | use File::Basename; | ||||
| 51 | 13 13 13 | 10738 53676 3066 | use File::BaseDir qw(config_home); | ||||
| 52 | 13 13 13 | 12911 344124 2324 | use File::Touch; | ||||
| 53 | 13 13 13 | 14145 785750 1643 | use File::Rsync; | ||||
| 54 | 13 13 13 | 12384 47811 2782 | use File::Which; | ||||
| 55 | 13 13 13 | 243 73 1625 | use IO::Handle; | ||||
| 56 | 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 | 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 | 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 | 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 | 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 | 488967 | my $_ = shift; | ||||
| 180 | 48 | 503 | chomp; | ||||
| 181 | 48 | 4536 | say unless m(^sent |^total size|^\s*$); | ||||
| 182 | }, | ||||||
| 183 | 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 | 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 | 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 | 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 | 98 | my ($from, $to) = @_; | ||||
| 208 | 11 | 282 | say "Moving $from -> $to"; | ||||
| 209 | 11 | 163 | unless ($DRYRUN) { | ||||
| 210 | 9 | 185 | if (-d $from) { | ||||
| 211 | 8 | 141 | $from .= '/' unless $from =~ m(/$); | ||||
| 212 | 8 | 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 | 10 | my ($old, $new) = @_; | ||||
| 231 | 1 | 7 | create_parent_directories($new); | ||||
| 232 | 1 | 11 | say "Symlinking $new -> $old"; | ||||
| 233 | 1 | 10 | unless ($DRYRUN) { | ||||
| 234 | 1 | 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 | 64 | my $file = shift; | ||||
| 244 | 10 | 1814 | my $parent_dir = dirname($file); | ||||
| 245 | 10 | 382 | unless (-d $parent_dir) { | ||||
| 246 | 3 | 78 | say "Create parent directories for $file"; | ||||
| 247 | 3 | 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 | 46 | my ($type, $item, $target) = @_; | ||||
| 258 | |||||||
| 259 | # Shall we create not yet existing directories or files as symlink? | ||||||
| 260 | # Case 1: directory | ||||||
| 261 | 1 | 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 | 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 | 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 | 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 | 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 | 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 | 28 | if ( -e $target ) { | ||||
| 303 | 0 | 0 | my $unexpected_type = check_for_unexpected_type($type, $target); | ||||
| 304 | 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 | 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 | 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 | 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 | 83 | my ($item) = @_; | ||||
| 347 | 9 | 57 | my $lsof_output = undef; | ||||
| 348 | |||||||
| 349 | 9 | 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 | 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 | 85 | my ($itemexpanded, $target) = @_; | ||||
| 371 | |||||||
| 372 | 9 | 137 | create_parent_directories($target); | ||||
| 373 | 9 | 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 | 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 | unless ($DRYRUN) { | ||||
| 387 | 0 | 0 | $is_dir and rmtree($itemexpanded, { verbose => 1 }) ; | ||||
| 388 | 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 | 13 | my ($type, $target) = @_; | ||||
| 399 | |||||||
| 400 | 1 | 47 | say "Create $target"; | ||||
| 401 | 1 | 15 | unless ($DRYRUN) { | ||||
| 402 | 1 | 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 | 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 | 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 | 145 | my ($itemexpanded, $target) = @_; | ||||
| 426 | |||||||
| 427 | 9 | 195 | say "Symlinking $target -> $itemexpanded"; | ||||
| 428 | 9 | 139 | unless ($DRYRUN) { | ||||
| 429 | 8 | 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 | 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 | 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 | 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 | 295 | unless ($is_file or $is_dir) { | ||||
| 453 | 0 | 0 | return unknown_element('type', $type); | ||||
| 454 | } | ||||||
| 455 | |||||||
| 456 | 9 | 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 | 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 | 243 | my ($type, $itemexpanded, $target, $action) = @_; | ||||
| 474 | |||||||
| 475 | 9 | 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 | 67 | return $unexpected_type if $unexpected_type; | ||||
| 481 | |||||||
| 482 | 9 | 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 | 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 | 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 | 183 | my $path = shift; | ||||
| 530 | # Remove home directory, i.e. check just from below the home directory | ||||||
| 531 | 19 | 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 | 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 | 269 | my ($type, $itemexpanded, $itemglob, $replacement, $action) = @_; | ||||
| 554 | |||||||
| 555 | # Skip entries where wildcard where passed | ||||||
| 556 | 19 | 308 | if ($itemexpanded =~ /[][*?]/) { | ||||
| 557 | 0 | 0 | warn "Skipping '$itemexpanded' due to unmatched wildcard.\n"; | ||||
| 558 | 0 | 0 | return 0; | ||||
| 559 | } | ||||||
| 560 | |||||||
| 561 | 19 | 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 | 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 | 26 | my ($itemexpanded, $item_in_home, $target_glob) = @_; | ||||
| 592 | |||||||
| 593 | # Skip entries where wildcard where passed | ||||||
| 594 | 2 | 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 | 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 | 30 | if ($itemexpanded eq $link_target) { | ||||
| 609 | 2 | 28 | say "Removing symlink $item_in_home"; | ||||
| 610 | 2 | 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 | 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 | 530 | next unless -r $list; | ||||
| 638 | |||||||
| 639 | # Clean up this and that | ||||||
| 640 | 13 | 803 | open(LIST, '<', $list) or die "Can't open $list: $!"; | ||||
| 641 | 13 | 1140 | while (<LIST>) { | ||||
| 642 | 27 | 1264 | next if /^#|^ *$/; | ||||
| 643 | |||||||
| 644 | 24 | 222 | chomp; | ||||
| 645 | 24 | 470 | my ($action, $type, $item, $replacement) = split; | ||||
| 646 | |||||||
| 647 | 24 | 302 | next unless defined $action; | ||||
| 648 | |||||||
| 649 | 23 | 984 | if (!defined($item) or !defined($replacement)) { | ||||
| 650 | 0 | 0 | warn "Can't parse '$_', skipping..."; | ||||
| 651 | 0 | 0 | next; | ||||
| 652 | } | ||||||
| 653 | 23 | 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 | 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 | 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 | 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 | 33 | if (defined($FILTER)) { | ||||
| 673 | 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 | 302 | if (defined($FILTER)) { | ||||
| 680 | 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); | ||||