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