stow.in

   1 #!@PERL@
   2
   3 # GNU Stow - manage the installation of multiple software packages
   4 # Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
   5 # Copyright (C) 2000, 2001 Guillaume Morin
   6 # Copyright (C) 2007 Kahlil Hodgson
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21
  22 use strict;
  23 use warnings;
  24
  25 require 5.005;
  26 use POSIX qw(getcwd);
  27 use Getopt::Long;
  28
  29 my $Version = '@VERSION@';
  30 my $ProgramName = $0;
  31 $ProgramName =~ s{.*/}{};
  32
  33 # Verbosity rules:
  34 #
  35 #   0: errors only
  36 # > 0: print operations: LINK/UNLINK/MKDIR/RMDIR
  37 # > 1: print trace: stow/unstow package/contents/node
  38 # > 2: print trace detail: "_this_ already points to _that_"
  39 #
  40 # All output (except for version() and usage()) is to stderr to preserve
  41 # backward compatibility.
  42
  43 # These are the defaults for command line options
  44 our %Option = (
  45     help       => 0,
  46     conflicts  => 0,
  47     action     => 'stow',
  48     simulate   => 0,
  49     verbose    => 0,
  50     paranoid   => 0,
  51     dir        => undef,
  52     target     => undef,
  53     ignore     => [],
  54     override   => [],
  55     defer      => [],
  56 );
  57
  58 # This becomes static after option processing
  59 our $Stow_Path; # only use in main loop and find_stowed_path()
  60
  61 # Store conflicts during pre-processing
  62 our @Conflicts = ();
  63
  64 # Store command line packges to stow (-S and -R)
  65 our @Pkgs_To_Stow   = ();
  66
  67 # Store command line packages to unstow (-D and -R)
  68 our @Pkgs_To_Delete = ();
  69
  70 # The following structures are used by the abstractions that allow us to
  71 # defer operating on the filesystem until after all potential conflcits have
  72 # been assessed.
  73
  74 # our @Tasks:  list of operations to be performed (in order)
  75 # each element is a hash ref of the form
  76 #   {
  77 #       action => ...
  78 #       type   => ...
  79 #       path   => ...  (unique)
  80 #       source => ...  (only for links)
  81 #   }
  82 our @Tasks    = ();
  83
  84 # my %Dir_Task_For: map a path to the corresponding directory task reference
  85 # This structurew allows us to quickly determine if a path has an existing
  86 # directory task associated with it.
  87 our %Dir_Task_For = ();
  88
  89 # my %Link_Task_For: map a path to the corresponding directory task reference
  90 # This structurew allows us to quickly determine if a path has an existing
  91 # directory task associated with it.
  92 our %Link_Task_For = ();
  93
  94 # NB: directory tasks and link tasks are NOT mutually exclusive
  95
  96 # put the main loop in this block so we can load the
  97 # rest of the code as a module for testing
  98 if ( not caller() ) {
  99
 100     process_options();
 101     set_stow_path();
 102
 103     # current dir is now the target directory
 104
 105     for my $package (@Pkgs_To_Delete) {
 106         if (not -d join_paths($Stow_Path,$package)) {
 107             error("The given package name ($package) is not in your stow path");
 108         }
 109         if ($Option{'verbose'} > 1) {
 110             warn "Unstowing package $package...\n";
 111         }
 112         if ($Option{'compat'}) {
 113             unstow_contents_orig(
 114                 join_paths($Stow_Path,$package), # path to package
 115                 '',                              # target is current_dir
 116             );
 117         }
 118         else {
 119             unstow_contents(
 120                 join_paths($Stow_Path,$package), # path to package
 121                 '',                              # target is current_dir
 122             );
 123         }
 124         if ($Option{'verbose'} > 1) {
 125             warn "Unstowing package $package...done\n";
 126         }
 127     }
 128
 129     for my $package (@Pkgs_To_Stow) {
 130         if (not -d join_paths($Stow_Path,$package)) {
 131             error("The given package name ($package) is not in your stow path");
 132         }
 133         if ($Option{'verbose'} > 1) {
 134             warn "Stowing package $package...\n";
 135         }
 136         stow_contents(
 137             join_paths($Stow_Path,$package), # path package
 138             '',                              # target is current dir
 139             join_paths($Stow_Path,$package), # source from target
 140         );
 141         if ($Option{'verbose'} > 1) {
 142             warn "Stowing package $package...done\n";
 143         }
 144     }
 145
 146     # --verbose:   tell me what you are planning to do
 147     # --simulate:  don't execute planned operations
 148     # --conflicts: just list any detected conflicts
 149
 150     if (scalar @Conflicts) {
 151         warn "WARNING: conflicts detected.\n";
 152         if ($Option{'conflicts'}) {
 153             map { warn $_ } @Conflicts;
 154         }
 155         warn "WARNING: all operations aborted.\n";
 156     }
 157     else {
 158         process_tasks();
 159     }
 160 }
 161
 162
 163 #===== SUBROUTINE ===========================================================
 164 # Name      : process_options()
 165 # Purpose   : parse command line options and update the %Option hash
 166 # Parameters: none
 167 # Returns   : n/a
 168 # Throws    : a fatal error if a bad command line option is given
 169 # Comments  : checks @ARGV for valid package names
 170 #============================================================================
 171 sub process_options {
 172
 173     get_defaults();
 174     #$,="\n"; print @ARGV,"\n"; # for debugging rc file
 175
 176     Getopt::Long::config('no_ignore_case', 'bundling', 'permute');
 177     GetOptions(
 178         'v'              => sub { $Option{'verbose'}++            },
 179         'verbose:i'      => sub { $Option{'verbose'}+= $_[1] || 1 },
 180         'h|help'         => sub { $Option{'help'}         = '1'   },
 181         'n|no|simulate'  => sub { $Option{'simulate'}     = '1'   },
 182         'c|conflicts'    => sub { $Option{'conflicts'}    = '1'   },
 183         'V|version'      => sub { $Option{'version'}      = '1'   },
 184         'p|compat'       => sub { $Option{'compat'}       = '1'   },
 185         'd|dir=s'        => sub { $Option{'dir'}          = $_[1] },
 186         't|target=s'     => sub { $Option{'target'}       = $_[1] },
 187
 188         # clean and pre-compile any regex's at parse time
 189         'ignore=s' =>
 190         sub {
 191             my $regex = strip_quotes($_[1]);
 192             push @{$Option{'ignore'}}, qr($regex\z)
 193         },
 194
 195         'override=s' =>
 196         sub {
 197             my $regex = strip_quotes($_[1]);
 198             push @{$Option{'override'}}, qr(\A$regex)
 199         },
 200
 201         'defer=s' =>
 202         sub {
 203             my $regex = strip_quotes($_[1]);
 204             push @{$Option{'defer'}}, qr(\A$regex) ;
 205         },
 206
 207         # a little craziness so we can do different actions on the same line:
 208         # a -D, -S, or -R changes the action that will be performed on the
 209         # package arguments that follow it.
 210         'D|delete'  => sub { $Option{'action'} = 'delete'    },
 211         'S|stow'    => sub { $Option{'action'} = 'stow'      },
 212         'R|restow'  => sub { $Option{'action'} = 'restow'    },
 213         '<>' =>
 214         sub {
 215             if ($Option{'action'} eq 'restow') {
 216                 push @Pkgs_To_Delete, $_[0];
 217                 push @Pkgs_To_Stow, $_[0];
 218             }
 219             elsif ($Option{'action'} eq 'delete') {
 220                 push @Pkgs_To_Delete, $_[0];
 221             }
 222             else {
 223                 push @Pkgs_To_Stow, $_[0];
 224             }
 225         },
 226     ) or usage();
 227
 228     #print "$Option{'dir'}\n"; print "$Option{'target'}\n"; exit;
 229
 230     # clean any leading and trailing whitespace in paths
 231     if ($Option{'dir'}) {
 232         $Option{'dir'}    =~ s/\A +//;
 233         $Option{'dir'}    =~ s/ +\z//;
 234     }
 235     if ($Option{'target'}) {
 236         $Option{'target'} =~ s/\A +//;
 237         $Option{'target'} =~ s/ +\z//;
 238     }
 239
 240     if ($Option{'help'}) {
 241         usage();
 242     }
 243     if ($Option{'version'}) {
 244         version();
 245     }
 246     if ($Option{'conflicts'}) {
 247         $Option{'simulate'} = 1;
 248     }
 249
 250     if (not scalar @Pkgs_To_Stow and not scalar @Pkgs_To_Delete ) {
 251         usage("No packages named");
 252     }
 253
 254     # check package arguments
 255     for my $package ( (@Pkgs_To_Stow, @Pkgs_To_Delete) ) {
 256         $package =~ s{/+$}{};    # delete trailing slashes
 257         if ( $package =~ m{/} ) {
 258             error("Slashes are not permitted in package names");
 259         }
 260     }
 261
 262     return;
 263 }
 264
 265 #===== SUBROUTINE ============================================================
 266 # Name      : get_defaults()
 267 # Purpose   : search for default settings in any .stow files
 268 # Parameters: none
 269 # Returns   : n/a
 270 # Throws    : no exceptions
 271 # Comments  : prepends the contents '~/.stowrc' and '.stowrc' to the command
 272 #           : line so they get parsed just like noremal arguments. (This was
 273 #           : hacked in so that Emil and I could set different preferences).
 274 #=============================================================================
 275 sub get_defaults {
 276
 277     my @defaults = ();
 278     for my $file ($ENV{'HOME'}.'/.stowrc','.stowrc') {
 279         if (-r $file ) {
 280             warn "Loading defaults from $file\n";
 281             open my $FILE, '<', $file
 282                 or die "Could not open $file for reading\n";
 283             while (my $line = <$FILE> ){
 284                 chomp $line;
 285                 push @defaults, split " ", $line;
 286             }
 287             close $FILE or die "Could not close open file: $file\n";
 288         }
 289     }
 290     # doing this inline does not seem to work
 291     unshift @ARGV, @defaults;
 292     return;
 293 }
 294
 295 #===== SUBROUTINE ===========================================================
 296 # Name      : usage()
 297 # Purpose   : print program usage message and exit
 298 # Parameters: msg => string to prepend to the usage message
 299 # Returns   : n/a
 300 # Throws    : n/a
 301 # Comments  : if 'msg' is given, then exit with non-zero status
 302 #============================================================================
 303 sub usage {
 304     my ($msg) = @_;
 305
 306     if ($msg) {
 307         print "$ProgramName: $msg\n\n";
 308     }
 309
 310     print <<"EOT";
 311 $ProgramName (GNU Stow) version $Version
 312
 313 SYNOPSIS:
 314
 315     $ProgramName [OPTION ...] [-D|-S|-R] PACKAGE ... [-D|-S|-R] PACKAGE ...
 316
 317 OPTIONS:
 318
 319     -n, --no              Do not actually make any filesystem changes
 320     -c, --conflicts       Scan for and print any conflicts, implies -n
 321     -d DIR, --dir=DIR     Set stow dir to DIR (default is current dir)
 322     -t DIR, --target=DIR  Set target to DIR (default is parent of stow dir)
 323     -v, --verbose[=N]     Increase verbosity (levels are 0,1,2,3;
 324                             -v or --verbose adds 1; --verbose=N sets level)
 325
 326     -S, --stow            Stow the package names that follow this option
 327     -D, --delete          Unstow the package names that follow this option
 328     -R, --restow          Restow (like stow -D followed by stow -S)
 329     -p, --compat          use legacy algorithm for unstowing
 330
 331     --ignore=REGEX        ignore files ending in this perl regex
 332     --defer=REGEX         defer stowing files begining with this perl regex
 333                           if the file is already stowed to another package
 334     --override=REGEX      force stowing files begining with this perl regex
 335                           if the file is already stowed to another package
 336     -V, --version         Show stow version number
 337     -h, --help            Show this help
 338 EOT
 339     exit( $msg ? 1 : 0 );
 340 }
 341
 342 #===== SUBROUTINE ===========================================================
 343 # Name      : set_stow_path()
 344 # Purpose   : find the relative path to the stow directory
 345 # Parameters: none
 346 # Returns   : a relative path
 347 # Throws    : fatal error if either default directories or those set by the
 348 #           : the command line flags are not valid.
 349 # Comments  : This sets the current working directory to $Option{target}
 350 #============================================================================
 351 sub set_stow_path {
 352
 353     # Changing dirs helps a lot when soft links are used
 354     # Also prevents problems when 'stow_dir' or 'target' are
 355     # supplied as relative paths (FIXME: examples?)
 356
 357     my $current_dir = getcwd();
 358
 359     # default stow dir is the current directory
 360     if (not $Option{'dir'} ) {
 361         $Option{'dir'} = getcwd();
 362     }
 363     if (not chdir($Option{'dir'})) {
 364         error("Cannot chdir to target tree: '$Option{'dir'}'");
 365     }
 366     my $stow_dir = getcwd();
 367
 368     # back to start in case target is relative
 369     if (not chdir($current_dir)) {
 370         error("Your directory does not seem to exist anymore");
 371     }
 372
 373     # default target is the parent of the stow directory
 374     if (not $Option{'target'}) {
 375         $Option{'target'} = parent($Option{'dir'});
 376     }
 377     if (not chdir($Option{'target'})) {
 378         error("Cannot chdir to target tree: $Option{'target'}");
 379     }
 380
 381     # set our one global
 382     $Stow_Path = relative_path(getcwd(),$stow_dir);
 383
 384     if ($Option{'verbose'} > 1) {
 385         warn "current dir is ".getcwd()."\n";
 386         warn "stow dir path is $Stow_Path\n";
 387     }
 388 }
 389
 390 #===== SUBROUTINE ===========================================================
 391 # Name      : stow_contents()
 392 # Purpose   : stow the contents of the given directory
 393 # Parameters: $path    => relative path to source dir from current directory
 394 #           : $source  => relative path to symlink source from the dir of target
 395 #           : $target  => relative path to symlink target from the current directory
 396 # Returns   : n/a
 397 # Throws    : a fatal error if directory cannot be read
 398 # Comments  : stow_node() and stow_contents() are mutually recursive
 399 #           : $source and $target are used for creating the symlink
 400 #           : $path is used for folding/unfolding trees as necessary
 401 #============================================================================
 402 sub stow_contents {
 403
 404     my ($path, $target, $source) = @_;
 405
 406     if ($Option{'verbose'} > 1){
 407         warn "Stowing contents of $path\n";
 408     }
 409     if ($Option{'verbose'} > 2){
 410         warn "--- $target => $source\n";
 411     }
 412
 413     if (not -d $path) {
 414         error("stow_contents() called on a non-directory: $path");
 415     }
 416
 417     opendir my $DIR, $path
 418         or error("cannot read directory: $path");
 419     my @listing = readdir $DIR;
 420     closedir $DIR;
 421
 422     NODE:
 423     for my $node (@listing) {
 424         next NODE if $node eq '.';
 425         next NODE if $node eq '..';
 426         next NODE if ignore($node);
 427         stow_node(
 428             join_paths($path,  $node),   # path
 429             join_paths($target,$node),   # target
 430             join_paths($source,$node),   # source
 431         );
 432     }
 433 }
 434
 435 #===== SUBROUTINE ===========================================================
 436 # Name      : stow_node()
 437 # Purpose   : stow the given node
 438 # Parameters: $path    => realtive path to source node from the current directory
 439 #           : $target  => realtive path to symlink target from the current directory
 440 #           : $source  => realtive path to symlink source from the dir of target
 441 # Returns   : n/a
 442 # Throws    : fatal exception if a conflict arises
 443 # Comments  : stow_node() and stow_contents() are mutually recursive
 444 #           : $source and $target are used for creating the symlink
 445 #           : $path is used for folding/unfolding trees as necessary
 446 #============================================================================
 447 sub stow_node {
 448
 449     my ($path, $target, $source) = @_;
 450
 451     if ($Option{'verbose'} > 1) {
 452         warn "Stowing $path\n";
 453     }
 454     if ($Option{'verbose'} > 2) {
 455         warn "--- $target => $source\n";
 456     }
 457
 458     # don't try to stow absolute symlinks (they cant be unstowed)
 459     if (-l $source) {
 460         my $second_source = read_a_link($source);
 461         if ($second_source =~ m{\A/} ) {
 462             conflict("source is an absolute symlink $source => $second_source");
 463             if ($Option{'verbose'} > 2) {
 464                 warn "absolute symlinks cannot be unstowed";
 465             }
 466             return;
 467         }
 468     }
 469
 470     # does the target already exist?
 471     if (is_a_link($target)) {
 472
 473         # where is the link pointing?
 474         my $old_source = read_a_link($target);
 475         if (not $old_source) {
 476             error("Could not read link: $target");
 477         }
 478         if ($Option{'verbose'} > 2) {
 479             warn "--- Evaluate existing link: $target => $old_source\n";
 480         }
 481
 482         # does it point to a node under our stow directory?
 483         my $old_path = find_stowed_path($target, $old_source);
 484         if (not $old_path) {
 485             conflict("existing target is not owned by stow: $target");
 486             return; # XXX #
 487         }
 488
 489         # does the existing $target actually point to anything?
 490         if (is_a_node($old_path)) {
 491             if ($old_source eq $source) {
 492                 if ($Option{'verbose'} > 2) {
 493                     warn "--- Skipping $target as it already points to $source\n";
 494                 }
 495             }
 496             elsif (defer($target)) {
 497                 if ($Option{'verbose'} > 2) {
 498                     warn "--- deferring installation of: $target\n";
 499                 }
 500             }
 501             elsif (override($target)) {
 502                 if ($Option{'verbose'} > 2) {
 503                     warn "--- overriding installation of: $target\n";
 504                 }
 505                 do_unlink($target);
 506                 do_link($source,$target);
 507             }
 508             elsif (is_a_dir(join_paths(parent($target),$old_source)) &&
 509                    is_a_dir(join_paths(parent($target),$source))     ) {
 510
 511                 # if the existing link points to a directory,
 512                 # and the proposed new link points to a directory,
 513                 # then we can unfold the tree at that point
 514
 515                 if ($Option{'verbose'} > 2){
 516                     warn "--- Unfolding $target\n";
 517                 }
 518                 do_unlink($target);
 519                 do_mkdir($target);
 520                 stow_contents($old_path, $target, join_paths('..',$old_source));
 521                 stow_contents($path,     $target, join_paths('..',$source));
 522             }
 523             else {
 524                 conflict(
 525                     q{existing target is stowed to a different package: %s => %s},
 526                     $target,
 527                     $old_source,
 528                 );
 529             }
 530         }
 531         else {
 532             # the existing link is invalid, so replace it with a good link
 533             if ($Option{'verbose'} > 2){
 534                 warn "--- replacing invalid link: $path\n";
 535             }
 536             do_unlink($target);
 537             do_link($source, $target);
 538         }
 539     }
 540     elsif (is_a_node($target)) {
 541         if ($Option{'verbose'} > 2) {
 542             warn("--- Evaluate existing node: $target\n");
 543         }
 544         if (is_a_dir($target)) {
 545             stow_contents($path, $target, join_paths('..',$source));
 546         }
 547         else {
 548             conflict(
 549                 qq{existing target is neither a link nor a directory: $target}
 550             );
 551         }
 552     }
 553     else {
 554         do_link($source, $target);
 555     }
 556     return;
 557 }
 558
 559 #===== SUBROUTINE ===========================================================
 560 # Name      : unstow_contents_orig()
 561 # Purpose   : unstow the contents of the given directory
 562 # Parameters: $path    => relative path to source dir from current directory
 563 #           : $target  => relative path to symlink target from the current directory
 564 # Returns   : n/a
 565 # Throws    : a fatal error if directory cannot be read
 566 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 567 #           : Here we traverse the target tree, rather than the source tree.
 568 #============================================================================
 569 sub unstow_contents_orig {
 570
 571     my ($path, $target) = @_;
 572
 573     #  don't try to remove anything under a stow directory
 574     if ($target eq $Stow_Path or -e "$target/.stow" or -e "$target/.nonstow") {
 575         return;
 576     }
 577     if ($Option{'verbose'} > 1){
 578         warn "Unstowing in $target\n";
 579     }
 580     if ($Option{'verbose'} > 2){
 581         warn "--- path is $path\n";
 582     }
 583     if (not -d $target) {
 584         error("unstow_contents() called on a non-directory: $target");
 585     }
 586
 587     opendir my $DIR, $target
 588         or error("cannot read directory: $target");
 589     my @listing = readdir $DIR;
 590     closedir $DIR;
 591
 592     NODE:
 593     for my $node (@listing) {
 594         next NODE if $node eq '.';
 595         next NODE if $node eq '..';
 596         next NODE if ignore($node);
 597         unstow_node_orig(
 598             join_paths($path,   $node), # path
 599             join_paths($target, $node), # target
 600         );
 601     }
 602 }
 603
 604 #===== SUBROUTINE ===========================================================
 605 # Name      : unstow_node_orig()
 606 # Purpose   : unstow the given node
 607 # Parameters: $path    => relative path to source node from the current directory
 608 #           : $target  => relative path to symlink target from the current directory
 609 # Returns   : n/a
 610 # Throws    : fatal error if a conflict arises
 611 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 612 #============================================================================
 613 sub unstow_node_orig {
 614
 615     my ($path, $target) = @_;
 616
 617     if ($Option{'verbose'} > 1) {
 618         warn "Unstowing $target\n";
 619     }
 620     if ($Option{'verbose'} > 2) {
 621         warn "--- path is $path\n";
 622     }
 623
 624     # does the target exist
 625     if (is_a_link($target)) {
 626         if ($Option{'verbose'} > 2) {
 627             warn("Evaluate existing link: $target\n");
 628         }
 629
 630         # where is the link pointing?
 631         my $old_source = read_a_link($target);
 632         if (not $old_source) {
 633             error("Could not read link: $target");
 634         }
 635
 636         # does it point to a node under our stow directory?
 637         my $old_path = find_stowed_path($target, $old_source);
 638         if (not $old_path) {
 639             # skip links not owned by stow
 640             return; # XXX #
 641         }
 642
 643         # does the existing $target actually point to anything
 644         if (-e  $old_path) {
 645             # does link points to the right place
 646             if ($old_path eq $path) {
 647                 do_unlink($target);
 648             }
 649             elsif (override($target)) {
 650                 if ($Option{'verbose'} > 2) {
 651                     warn("--- overriding installation of: $target\n");
 652                 }
 653                 do_unlink($target);
 654             }
 655             # else leave it alone
 656         }
 657         else {
 658             if ($Option{'verbose'} > 2){
 659                 warn "--- removing invalid link into a stow directory: $path\n";
 660             }
 661             do_unlink($target);
 662         }
 663     }
 664     elsif (-d $target) {
 665         unstow_contents_orig($path, $target);
 666
 667         # this action may have made the parent directory foldable
 668         if (my $parent = foldable($target)) {
 669             fold_tree($target,$parent);
 670         }
 671     }
 672     return;
 673 }
 674
 675 #===== SUBROUTINE ===========================================================
 676 # Name      : unstow_contents()
 677 # Purpose   : unstow the contents of the given directory
 678 # Parameters: $path    => relative path to source dir from current directory
 679 #           : $target  => relative path to symlink target from the current directory
 680 # Returns   : n/a
 681 # Throws    : a fatal error if directory cannot be read
 682 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 683 #           : Here we traverse the target tree, rather than the source tree.
 684 #============================================================================
 685 sub unstow_contents {
 686
 687     my ($path, $target) = @_;
 688
 689     #  don't try to remove anything under a stow directory
 690     if ($target eq $Stow_Path or -e "$target/.stow") {
 691         return;
 692     }
 693     if ($Option{'verbose'} > 1){
 694         warn "Unstowing in $target\n";
 695     }
 696     if ($Option{'verbose'} > 2){
 697         warn "--- path is $path\n";
 698     }
 699     if (not -d $path) {
 700         error("unstow_contents() called on a non-directory: $path");
 701     }
 702
 703     opendir my $DIR, $path
 704         or error("cannot read directory: $path");
 705     my @listing = readdir $DIR;
 706     closedir $DIR;
 707
 708     NODE:
 709     for my $node (@listing) {
 710         next NODE if $node eq '.';
 711         next NODE if $node eq '..';
 712         next NODE if ignore($node);
 713         unstow_node(
 714             join_paths($path,   $node), # path
 715             join_paths($target, $node), # target
 716         );
 717     }
 718     if (-d $target) {
 719         cleanup_invalid_links($target);
 720     }
 721 }
 722
 723 #===== SUBROUTINE ===========================================================
 724 # Name      : unstow_node()
 725 # Purpose   : unstow the given node
 726 # Parameters: $path    => relative path to source node from the current directory
 727 #           : $target  => relative path to symlink target from the current directory
 728 # Returns   : n/a
 729 # Throws    : fatal error if a conflict arises
 730 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 731 #============================================================================
 732 sub unstow_node {
 733
 734     my ($path, $target) = @_;
 735
 736     if ($Option{'verbose'} > 1) {
 737         warn "Unstowing $path\n";
 738     }
 739     if ($Option{'verbose'} > 2) {
 740         warn "--- target is $target\n";
 741     }
 742
 743     # does the target exist
 744     if (is_a_link($target)) {
 745         if ($Option{'verbose'} > 2) {
 746             warn("Evaluate existing link: $target\n");
 747         }
 748
 749         # where is the link pointing?
 750         my $old_source = read_a_link($target);
 751         if (not $old_source) {
 752             error("Could not read link: $target");
 753         }
 754
 755         if ($old_source =~ m{\A/}) {
 756             warn "ignoring a absolute symlink: $target => $old_source\n";
 757             return; # XXX #
 758         }
 759
 760         # does it point to a node under our stow directory?
 761         my $old_path = find_stowed_path($target, $old_source);
 762         if (not $old_path) {
 763              conflict(
 764                  qq{existing target is not owned by stow: $target => $old_source}
 765              );
 766             return; # XXX #
 767         }
 768
 769         # does the existing $target actually point to anything
 770         if (-e  $old_path) {
 771             # does link points to the right place
 772             if ($old_path eq $path) {
 773                 do_unlink($target);
 774             }
 775
 776             # XXX we quietly ignore links that are stowed to a different
 777             # package.
 778
 779             #elsif (defer($target)) {
 780             #    if ($Option{'verbose'} > 2) {
 781             #        warn("--- deferring to installation of: $target\n");
 782             #    }
 783             #}
 784             #elsif (override($target)) {
 785             #    if ($Option{'verbose'} > 2) {
 786             #        warn("--- overriding installation of: $target\n");
 787             #    }
 788             #    do_unlink($target);
 789             #}
 790             #else {
 791             #    conflict(
 792             #        q{existing target is stowed to a different package: %s => %s},
 793             #        $target,
 794             #        $old_source
 795             #    );
 796             #}
 797         }
 798         else {
 799             if ($Option{'verbose'} > 2){
 800                 warn "--- removing invalid link into a stow directory: $path\n";
 801             }
 802             do_unlink($target);
 803         }
 804     }
 805     elsif (-e $target) {
 806         if ($Option{'verbose'} > 2) {
 807             warn("Evaluate existing node: $target\n");
 808         }
 809         if (-d $target) {
 810             unstow_contents($path, $target);
 811
 812             # this action may have made the parent directory foldable
 813             if (my $parent = foldable($target)) {
 814                 fold_tree($target,$parent);
 815             }
 816         }
 817         else {
 818             conflict(
 819                 qq{existing target is neither a link nor a directory: $target},
 820             );
 821         }
 822     }
 823     return;
 824 }
 825
 826 #===== SUBROUTINE ===========================================================
 827 # Name      : find_stowed_path()
 828 # Purpose   : determine if the given link points to a member of a
 829 #           : stowed package
 830 # Parameters: $target => path to a symbolic link under current directory
 831 #           : $source => where that link points to
 832 # Returns   : relative path to stowed node (from the current directory)
 833 #           : or '' if link is not owned by stow
 834 # Throws    : fatal exception if link is unreadable
 835 # Comments  : allow for stow dir not being under target dir
 836 #           : we could put more logic under here for multiple stow dirs
 837 #============================================================================
 838 sub find_stowed_path {
 839
 840     my ($target, $source) = @_;
 841
 842     # evaluate softlink relative to its target
 843     my $path = join_paths(parent($target), $source);
 844
 845     # search for .stow files
 846     my $dir = '';
 847     for my $part (split m{/+}, $path) {
 848        $dir = join_paths($dir,$part);
 849        if (-f "$dir/.stow") {
 850             return $path;
 851        }
 852     }
 853
 854     # compare with $Stow_Path
 855     my @path = split m{/+}, $path;
 856     my @stow_path = split m{/+}, $Stow_Path;
 857
 858     # strip off common prefixes
 859     while ( @path && @stow_path ) {
 860         if ( (shift @path) ne (shift @stow_path) ) {
 861             return '';
 862         }
 863     }
 864     if (@stow_path) {
 865         # @path is not under @stow_dir
 866         return '';
 867     }
 868
 869     return $path
 870 }
 871
 872 #===== SUBROUTINE ============================================================
 873 # Name      : cleanup_invalid_links()
 874 # Purpose   : clean up invalid links that may block folding
 875 # Parameters: $dir => path to directory to check
 876 # Returns   : n/a
 877 # Throws    : no exceptions
 878 # Comments  : removing files from a stowed package is probably a bad practice
 879 #           : so this kind of clean up is not _really_ stow's responsibility;
 880 #           : however, failing to clean up can block tree folding, so we'll do
 881 #           : it anyway
 882 #=============================================================================
 883 sub cleanup_invalid_links {
 884
 885     my ($dir) = @_;
 886
 887     if (not -d $dir) {
 888         error("cleanup_invalid_links() called with a non-directory: $dir");
 889     }
 890
 891     opendir my $DIR, $dir
 892         or error("cannot read directory: $dir");
 893     my @listing = readdir $DIR;
 894     closedir $DIR;
 895
 896     NODE:
 897     for my $node (@listing) {
 898         next NODE if $node eq '.';
 899         next NODE if $node eq '..';
 900
 901         my $node_path = join_paths($dir,$node);
 902
 903         if (-l $node_path and not exists $Link_Task_For{$node_path}) {
 904
 905             # where is the link pointing?
 906             # (dont use read_a_link here)
 907             my $source = readlink($node_path);
 908             if (not $source) {
 909                 error("Could not read link $node_path");
 910             }
 911
 912             if (
 913                 not -e join_paths($dir,$source) and  # bad link
 914                 find_stowed_path($node_path,$source) # owned by stow
 915             ){
 916                 if ($Option{'verbose'} > 2) {
 917                     warn "--- removing stale link: $node_path => ",
 918                           join_paths($dir,$source), "\n";
 919                 }
 920                 do_unlink($node_path);
 921             }
 922         }
 923     }
 924     return;
 925 }
 926
 927
 928 #===== SUBROUTINE ===========================================================
 929 # Name      : foldable()
 930 # Purpose   : determine if a tree can be folded
 931 # Parameters: target => path to a directory
 932 # Returns   : path to the parent dir iff the tree can be safely folded
 933 # Throws    : n/a
 934 # Comments  : the path returned is relative to the parent of $target,
 935 #           : that is, it can be used as the source for a replacement symlink
 936 #============================================================================
 937 sub foldable {
 938
 939     my ($target) = @_;
 940
 941     if ($Option{'verbose'} > 2){
 942         warn "--- Is $target foldable?\n";
 943     }
 944
 945     opendir my $DIR, $target
 946         or error(qq{Cannot read directory "$target" ($!)\n});
 947     my @listing = readdir $DIR;
 948     closedir $DIR;
 949
 950     my $parent = '';
 951     NODE:
 952     for my $node (@listing) {
 953
 954         next NODE if $node eq '.';
 955         next NODE if $node eq '..';
 956
 957         my $path =  join_paths($target,$node);
 958
 959         # skip nodes scheduled for removal
 960         next NODE if not is_a_node($path);
 961
 962         # if its not a link then we can't fold its parent
 963         return '' if not is_a_link($path);
 964
 965         # where is the link pointing?
 966         my $source = read_a_link($path);
 967         if (not $source) {
 968             error("Could not read link $path");
 969         }
 970         if ($parent eq '') {
 971             $parent = parent($source)
 972         }
 973         elsif ($parent ne parent($source)) {
 974             return '';
 975         }
 976     }
 977     return '' if not $parent;
 978
 979     # if we get here then all nodes inside $target are links, and those links
 980     # point to nodes inside the same directory.
 981
 982     # chop of leading '..' to get the path to the common parent directory
 983     # relative to the parent of our $target
 984     $parent =~ s{\A\.\./}{};
 985
 986     # if the resulting path is owned by stow, we can fold it
 987     if (find_stowed_path($target,$parent)) {
 988         if ($Option{'verbose'} > 2){
 989             warn "--- $target is foldable\n";
 990         }
 991         return $parent;
 992     }
 993     else {
 994         return '';
 995     }
 996 }
 997
 998 #===== SUBROUTINE ===========================================================
 999 # Name      : fold_tree()
1000 # Purpose   : fold the given tree
1001 # Parameters: $source  => link to the folded tree source
1002 #           : $target => directory that we will replace with a link to $source
1003 # Returns   : n/a
1004 # Throws    : none
1005 # Comments  : only called iff foldable() is true so we can remove some checks
1006 #============================================================================
1007 sub fold_tree {
1008
1009     my ($target,$source) = @_;
1010
1011     if ($Option{'verbose'} > 2){
1012         warn "--- Folding tree: $target => $source\n";
1013     }
1014
1015     opendir my $DIR, $target
1016         or error(qq{Cannot read directory "$target" ($!)\n});
1017     my @listing = readdir $DIR;
1018     closedir $DIR;
1019
1020     NODE:
1021     for my $node (@listing) {
1022         next NODE if $node eq '.';
1023         next NODE if $node eq '..';
1024         next NODE if not is_a_node(join_paths($target,$node));
1025         do_unlink(join_paths($target,$node));
1026     }
1027     do_rmdir($target);
1028     do_link($source, $target);
1029     return;
1030 }
1031
1032
1033 #===== SUBROUTINE ===========================================================
1034 # Name      : conflict()
1035 # Purpose   : handle conflicts in stow operations
1036 # Parameters: paths that conflict
1037 # Returns   : n/a
1038 # Throws    : fatal exception unless 'conflicts' option is set
1039 # Comments  : indicates what type of conflict it is
1040 #============================================================================
1041 sub conflict {
1042     my ( $format, @args ) = @_;
1043
1044     my $message = sprintf($format, @args);
1045
1046     if ($Option{'verbose'}) {
1047         warn qq{CONFLICT: $message\n};
1048     }
1049     push @Conflicts, qq{CONFLICT: $message\n};
1050     return;
1051 }
1052
1053 #===== SUBROUTINE ============================================================
1054 # Name      : ignore
1055 # Purpose   : determine if the given path matches a regex in our ignore list
1056 # Parameters: none
1057 # Returns   : Boolean
1058 # Throws    : no exceptions
1059 # Comments  : none
1060 #=============================================================================
1061 sub ignore {
1062
1063     my ($path) = @_;
1064
1065     for my $suffix (@{$Option{'ignore'}}) {
1066         return 1 if $path =~ m/$suffix/;
1067     }
1068     return 0;
1069 }
1070
1071 #===== SUBROUTINE ============================================================
1072 # Name      : defer
1073 # Purpose   : determine if the given path matches a regex in our defer list
1074 # Parameters: none
1075 # Returns   : Boolean
1076 # Throws    : no exceptions
1077 # Comments  : none
1078 #=============================================================================
1079 sub defer {
1080
1081     my ($path) = @_;
1082
1083     for my $prefix (@{$Option{'defer'}}) {
1084         return 1 if $path =~ m/$prefix/;
1085     }
1086     return 0;
1087 }
1088
1089 #===== SUBROUTINE ============================================================
1090 # Name      : overide
1091 # Purpose   : determine if the given path matches a regex in our override list
1092 # Parameters: none
1093 # Returns   : Boolean
1094 # Throws    : no exceptions
1095 # Comments  : none
1096 #=============================================================================
1097 sub override {
1098
1099     my ($path) = @_;
1100
1101     for my $regex (@{$Option{'override'}}) {
1102         return 1 if $path =~ m/$regex/;
1103     }
1104     return 0;
1105 }
1106
1107 ##############################################################################
1108 #
1109 # The following code provides the abstractions that allow us to defer operating
1110 # on the filesystem until after all potential conflcits have been assessed.
1111 #
1112 ##############################################################################
1113
1114 #===== SUBROUTINE ===========================================================
1115 # Name      : process_tasks()
1116 # Purpose   : process each task in the @Tasks list
1117 # Parameters: none
1118 # Returns   : n/a
1119 # Throws    : fatal error if @Tasks is corrupted or a task fails
1120 # Comments  : task involve either creating or deleting dirs and symlinks
1121 #           : an action is set to 'skip' if it is found to be redundant
1122 #============================================================================
1123 sub process_tasks {
1124
1125     if ($Option{'verbose'} > 1) {
1126         warn "Processing tasks...\n"
1127     }
1128
1129     # strip out all tasks with a skip action
1130     @Tasks = grep { $_->{'action'} ne 'skip' } @Tasks;
1131
1132     if (not scalar @Tasks) {
1133         warn "There are no outstanding operations to perform.\n";
1134         return;
1135     }
1136     if ($Option{'simulate'}) {
1137         warn "WARNING: simulating so all operations are deferred.\n";
1138         return;
1139     }
1140
1141     for my $task (@Tasks) {
1142
1143         if ( $task->{'action'} eq 'create' ) {
1144             if ( $task->{'type'} eq 'dir' ) {
1145                 mkdir($task->{'path'}, 0777)
1146                     or error(qq(Could not create directory: $task->{'path'}));
1147             }
1148             elsif ( $task->{'type'} eq 'link' ) {
1149                 symlink $task->{'source'}, $task->{'path'}
1150                     or error(
1151                         q(Could not create symlink: %s => %s),
1152                         $task->{'path'},
1153                         $task->{'source'}
1154                 );
1155             }
1156             else {
1157                 internal_error(qq(bad task type: $task->{'type'}));
1158             }
1159         }
1160         elsif ( $task->{'action'} eq 'remove' ) {
1161             if ( $task->{'type'} eq 'dir' ) {
1162                 rmdir $task->{'path'}
1163                     or error(qq(Could not remove directory: $task->{'path'}));
1164             }
1165             elsif ( $task->{'type'} eq 'link' ) {
1166                 unlink $task->{'path'}
1167                     or error(qq(Could not remove link: $task->{'path'}));
1168             }
1169             else {
1170                 internal_error(qq(bad task type: $task->{'type'}));
1171             }
1172         }
1173         else {
1174             internal_error(qq(bad task action: $task->{'action'}));
1175         }
1176     }
1177     if ($Option{'verbose'} > 1) {
1178         warn "Processing tasks...done\n"
1179     }
1180     return;
1181 }
1182
1183 #===== SUBROUTINE ===========================================================
1184 # Name      : is_a_link()
1185 # Purpose   : is the given path a current or planned link
1186 # Parameters: none
1187 # Returns   : Boolean
1188 # Throws    : none
1189 # Comments  : returns false if an existing link is scheduled for removal
1190 #           : and true if a non-exsitent link is scheduled for creation
1191 #============================================================================
1192 sub is_a_link {
1193     my ($path) = @_;
1194
1195
1196     if ( exists $Link_Task_For{$path} ) {
1197
1198         my $action = $Link_Task_For{$path}->{'action'};
1199
1200         if ($action eq 'remove') {
1201             return 0;
1202         }
1203         elsif ($action eq 'create') {
1204             return 1;
1205         }
1206         else {
1207             internal_error("bad task action: $action");
1208         }
1209     }
1210     elsif (-l $path) {
1211         # check if any of its parent are links scheduled for removal
1212         # (need this for edge case during unfolding)
1213         my $parent = '';
1214         for my $part (split m{/+}, $path ) {
1215             $parent = join_paths($parent,$part);
1216             if ( exists $Link_Task_For{$parent} ) {
1217                 if ($Link_Task_For{$parent}->{'action'} eq 'remove') {
1218                     return 0;
1219                 }
1220             }
1221         }
1222         return 1;
1223     }
1224     return 0;
1225 }
1226
1227
1228 #===== SUBROUTINE ===========================================================
1229 # Name      : is_a_dir()
1230 # Purpose   : is the given path a current or planned directory
1231 # Parameters: none
1232 # Returns   : Boolean
1233 # Throws    : none
1234 # Comments  : returns false if an existing directory is scheduled for removal
1235 #           : and true if a non-existent directory is scheduled for creation
1236 #           : we also need to be sure we are not just following a link
1237 #============================================================================
1238 sub is_a_dir {
1239     my ($path) = @_;
1240
1241     if ( exists $Dir_Task_For{$path} ) {
1242         my $action = $Dir_Task_For{$path}->{'action'};
1243         if ($action eq 'remove') {
1244             return 0;
1245         }
1246         elsif ($action eq 'create') {
1247             return 1;
1248         }
1249         else {
1250             internal_error("bad task action: $action");
1251         }
1252     }
1253
1254     # are we really following a link that is scheduled for removal
1255     my $prefix = '';
1256     for my $part (split m{/+}, $path) {
1257         $prefix =  join_paths($prefix,$part);
1258         if (exists $Link_Task_For{$prefix} and
1259             $Link_Task_For{$prefix}->{'action'} eq 'remove') {
1260             return 0;
1261         }
1262     }
1263
1264     if (-d $path) {
1265         return 1;
1266     }
1267     return 0;
1268 }
1269
1270 #===== SUBROUTINE ===========================================================
1271 # Name      : is_a_node()
1272 # Purpose   : is the given path a current or planned node
1273 # Parameters: none
1274 # Returns   : Boolean
1275 # Throws    : none
1276 # Comments  : returns false if an existing node is scheduled for removal
1277 #           : true if a non-existent node is scheduled for creation
1278 #           : we also need to be sure we are not just following a link
1279 #============================================================================
1280 sub is_a_node {
1281     my ($path) = @_;
1282
1283     if ( exists $Link_Task_For{$path} ) {
1284
1285         my $action = $Link_Task_For{$path}->{'action'};
1286
1287         if ($action eq 'remove') {
1288             return 0;
1289         }
1290         elsif ($action eq 'create') {
1291             return 1;
1292         }
1293         else {
1294             internal_error("bad task action: $action");
1295         }
1296     }
1297
1298     if ( exists $Dir_Task_For{$path} ) {
1299
1300         my $action = $Dir_Task_For{$path}->{'action'};
1301
1302         if ($action eq 'remove') {
1303             return 0;
1304         }
1305         elsif ($action eq 'create') {
1306             return 1;
1307         }
1308         else {
1309             internal_error("bad task action: $action");
1310         }
1311     }
1312
1313     # are we really following a link that is scheduled for removal
1314     my $prefix = '';
1315     for my $part (split m{/+}, $path) {
1316         $prefix =  join_paths($prefix,$part);
1317         if ( exists $Link_Task_For{$prefix} and
1318              $Link_Task_For{$prefix}->{'action'} eq 'remove') {
1319             return 0;
1320         }
1321     }
1322
1323     if (-e $path) {
1324         return 1;
1325     }
1326     return 0;
1327 }
1328
1329 #===== SUBROUTINE ===========================================================
1330 # Name      : read_a_link()
1331 # Purpose   : return the source of a current or planned link
1332 # Parameters: $path => path to the link target
1333 # Returns   : a string
1334 # Throws    : fatal exception if the given path is not a current or planned
1335 #           : link
1336 # Comments  : none
1337 #============================================================================
1338 sub read_a_link {
1339
1340     my ($path) = @_;
1341
1342     if ( exists $Link_Task_For{$path} ) {
1343         my $action = $Link_Task_For{$path}->{'action'};
1344
1345         if ($action eq 'create') {
1346             return $Link_Task_For{$path}->{'source'};
1347         }
1348         elsif ($action eq 'remove') {
1349             internal_error(
1350                 "read_a_link() passed a path that is scheduled for removal: $path"
1351             );
1352         }
1353         else {
1354             internal_error("bad task action: $action");
1355         }
1356     }
1357     elsif (-l $path) {
1358         return readlink $path
1359             or error("Could not read link: $path");
1360     }
1361     internal_error("read_a_link() passed a non link path: $path\n");
1362 }
1363
1364 #===== SUBROUTINE ===========================================================
1365 # Name      : do_link()
1366 # Purpose   : wrap 'link' operation for later processing
1367 # Parameters: file => the file to link
1368 # Returns   : n/a
1369 # Throws    : error if this clashes with an existing planned operation
1370 # Comments  : cleans up operations that undo previous operations
1371 #============================================================================
1372 sub do_link {
1373
1374     my ( $oldfile, $newfile ) = @_;
1375
1376     if ( exists $Dir_Task_For{$newfile} ) {
1377
1378         my $task_ref = $Dir_Task_For{$newfile};
1379
1380         if ( $task_ref->{'action'} eq 'create' ) {
1381             if ($task_ref->{'type'} eq 'dir') {
1382                 internal_error(
1383                     "new link (%s => %s ) clashes with planned new directory",
1384                     $newfile,
1385                     $oldfile,
1386                 );
1387             }
1388         }
1389         elsif ( $task_ref->{'action'} eq 'remove' ) {
1390             # we may need to remove a directory before creating a link so continue;
1391         }
1392         else {
1393             internal_error("bad task action: $task_ref->{'action'}");
1394         }
1395     }
1396
1397     if ( exists $Link_Task_For{$newfile} ) {
1398
1399         my $task_ref = $Link_Task_For{$newfile};
1400
1401         if ( $task_ref->{'action'} eq 'create' ) {
1402             if ( $task_ref->{'source'} ne $oldfile ) {
1403                 internal_error(
1404                     "new link clashes with planned new link: %s => %s",
1405                     $task_ref->{'path'},
1406                     $task_ref->{'source'},
1407                 )
1408             }
1409             else {
1410                 if ($Option{'verbose'}) {
1411                     warn "LINK: $newfile => $oldfile (duplicates previous action)\n";
1412                 }
1413                 return;
1414             }
1415         }
1416         elsif ( $task_ref->{'action'} eq 'remove' ) {
1417             if ( $task_ref->{'source'} eq $oldfile ) {
1418                 # no need to remove a link we are going to recreate
1419                 if ($Option{'verbose'}) {
1420                     warn "LINK: $newfile => $oldfile (reverts previous action)\n";
1421                 }
1422                 $Link_Task_For{$newfile}->{'action'} = 'skip';
1423                 delete $Link_Task_For{$newfile};
1424                 return;
1425             }
1426             # we may need to remove a link to replace it so continue
1427         }
1428         else {
1429             internal_error("bad task action: $task_ref->{'action'}");
1430         }
1431     }
1432
1433     # creating a new link
1434     if ($Option{'verbose'}) {
1435         warn "LINK: $newfile => $oldfile\n";
1436     }
1437     my $task = {
1438         action  => 'create',
1439         type    => 'link',
1440         path    => $newfile,
1441         source  => $oldfile,
1442     };
1443     push @Tasks, $task;
1444     $Link_Task_For{$newfile} = $task;
1445
1446     return;
1447 }
1448
1449 #===== SUBROUTINE ===========================================================
1450 # Name      : do_unlink()
1451 # Purpose   : wrap 'unlink' operation for later processing
1452 # Parameters: $file => the file to unlink
1453 # Returns   : n/a
1454 # Throws    : error if this clashes with an existing planned operation
1455 # Comments  : will remove an existing planned link
1456 #============================================================================
1457 sub do_unlink {
1458
1459     my ($file) = @_;
1460
1461     if (exists $Link_Task_For{$file} ) {
1462         my $task_ref = $Link_Task_For{$file};
1463         if ( $task_ref->{'action'} eq 'remove' ) {
1464             if ($Option{'verbose'}) {
1465                 warn "UNLINK: $file (duplicates previous action)\n";
1466             }
1467             return;
1468         }
1469         elsif ( $task_ref->{'action'} eq 'create' ) {
1470             # do need to create a link then remove it
1471             if ($Option{'verbose'}) {
1472                 warn "UNLINK: $file (reverts previous action)\n";
1473             }
1474             $Link_Task_For{$file}->{'action'} = 'skip';
1475             delete $Link_Task_For{$file};
1476             return;
1477         }
1478         else {
1479             internal_error("bad task action: $task_ref->{'action'}");
1480         }
1481     }
1482
1483     if ( exists $Dir_Task_For{$file} and $Dir_Task_For{$file} eq 'create' ) {
1484         internal_error(
1485             "new unlink operation clashes with planned operation: %s dir %s",
1486             $Dir_Task_For{$file}->{'action'},
1487             $file
1488         );
1489     }
1490
1491     # remove the link
1492     if ($Option{'verbose'}) {
1493         #warn "UNLINK: $file (".(caller())[2].")\n";
1494         warn "UNLINK: $file\n";
1495     }
1496
1497     my $source = readlink $file or error("could not readlink $file");
1498
1499     my $task = {
1500         action  => 'remove',
1501         type    => 'link',
1502         path    => $file,
1503         source  => $source,
1504     };
1505     push @Tasks, $task;
1506     $Link_Task_For{$file} = $task;
1507
1508     return;
1509 }
1510
1511 #===== SUBROUTINE ===========================================================
1512 # Name      : do_mkdir()
1513 # Purpose   : wrap 'mkdir' operation
1514 # Parameters: $dir => the directory to remove
1515 # Returns   : n/a
1516 # Throws    : fatal exception if operation fails
1517 # Comments  : outputs a message if 'verbose' option is set
1518 #           : does not perform operation if 'simulate' option is set
1519 # Comments  : cleans up operations that undo previous operations
1520 #============================================================================
1521 sub do_mkdir {
1522     my ($dir) = @_;
1523
1524     if ( exists $Link_Task_For{$dir} ) {
1525
1526         my $task_ref = $Link_Task_For{$dir};
1527
1528         if ($task_ref->{'action'} eq 'create') {
1529             internal_error(
1530                 "new dir clashes with planned new link (%s => %s)",
1531                 $task_ref->{'path'},
1532                 $task_ref->{'source'},
1533             );
1534         }
1535         elsif ($task_ref->{'action'} eq 'remove') {
1536             # may need to remove a link before creating a directory so continue
1537         }
1538         else {
1539             internal_error("bad task action: $task_ref->{'action'}");
1540         }
1541     }
1542
1543     if ( exists $Dir_Task_For{$dir} ) {
1544
1545         my $task_ref = $Dir_Task_For{$dir};
1546
1547         if ($task_ref->{'action'} eq 'create') {
1548             if ($Option{'verbose'}) {
1549                 warn "MKDIR: $dir (duplicates previous action)\n";
1550             }
1551             return;
1552         }
1553         elsif ($task_ref->{'action'} eq 'remove') {
1554             if ($Option{'verbose'}) {
1555                 warn "MKDIR: $dir (reverts previous action)\n";
1556             }
1557             $Dir_Task_For{$dir}->{'action'} = 'skip';
1558             delete $Dir_Task_For{$dir};
1559             return;
1560         }
1561         else {
1562             internal_error("bad task action: $task_ref->{'action'}");
1563         }
1564     }
1565
1566     if ($Option{'verbose'}) {
1567         warn "MKDIR: $dir\n";
1568     }
1569     my $task = {
1570         action  => 'create',
1571         type    => 'dir',
1572         path    => $dir,
1573         source  => undef,
1574     };
1575     push @Tasks, $task;
1576     $Dir_Task_For{$dir} = $task;
1577
1578     return;
1579 }
1580
1581 #===== SUBROUTINE ===========================================================
1582 # Name      : do_rmdir()
1583 # Purpose   : wrap 'rmdir' operation
1584 # Parameters: $dir => the directory to remove
1585 # Returns   : n/a
1586 # Throws    : fatal exception if operation fails
1587 # Comments  : outputs a message if 'verbose' option is set
1588 #           : does not perform operation if 'simulate' option is set
1589 #============================================================================
1590 sub do_rmdir {
1591     my ($dir) = @_;
1592
1593     if (exists $Link_Task_For{$dir} ) {
1594         my $task_ref = $Link_Task_For{$dir};
1595         internal_error(
1596             "rmdir clashes with planned operation: %s link %s => %s",
1597             $task_ref->{'action'},
1598             $task_ref->{'path'},
1599             $task_ref->{'source'}
1600         );
1601     }
1602
1603     if (exists $Dir_Task_For{$dir} ) {
1604         my $task_ref = $Link_Task_For{$dir};
1605
1606         if ($task_ref->{'action'} eq 'remove' ) {
1607             if ($Option{'verbose'}) {
1608                 warn "RMDIR $dir (duplicates previous action)\n";
1609             }
1610             return;
1611         }
1612         elsif ($task_ref->{'action'} eq 'create' ) {
1613             if ($Option{'verbose'}) {
1614                 warn "MKDIR $dir (reverts previous action)\n";
1615             }
1616             $Link_Task_For{$dir}->{'action'} = 'skip';
1617             delete $Link_Task_For{$dir};
1618             return;
1619         }
1620         else {
1621             internal_error("bad task action: $task_ref->{'action'}");
1622         }
1623     }
1624
1625     if ($Option{'verbose'}) {
1626         warn "RMDIR $dir\n";
1627     }
1628     my $task = {
1629         action  => 'remove',
1630         type    => 'dir',
1631         path    => $dir,
1632         source  => '',
1633     };
1634     push @Tasks, $task;
1635     $Dir_Task_For{$dir} = $task;
1636
1637     return;
1638 }
1639
1640 #############################################################################
1641 #
1642 # General Utilities: nothing stow specific here.
1643 #
1644 #############################################################################
1645
1646 #===== SUBROUTINE ============================================================
1647 # Name      : strip_quotes
1648 # Purpose   : remove matching outer quotes from the given string
1649 # Parameters: none
1650 # Returns   : n/a
1651 # Throws    : no exceptions
1652 # Comments  : none
1653 #=============================================================================
1654 sub strip_quotes {
1655
1656     my ($string) = @_;
1657
1658     if ($string =~ m{\A\s*'(.*)'\s*\z}) {
1659         return $1;
1660     }
1661     elsif ($string =~ m{\A\s*"(.*)"\s*\z}) {
1662         return $1
1663     }
1664     return $string;
1665 }
1666
1667 #===== SUBROUTINE ===========================================================
1668 # Name      : relative_path()
1669 # Purpose   : find the relative path between two given paths
1670 # Parameters: path1 => a directory path
1671 #           : path2 => a directory path
1672 # Returns   : path2 relative to path1
1673 # Throws    : n/a
1674 # Comments  : only used once by main interactive routine
1675 #           : factored out for testing
1676 #============================================================================
1677 sub relative_path {
1678
1679     my ($path1, $path2) = @_;
1680
1681     my (@path1) = split m{/+}, $path1;
1682     my (@path2) = split m{/+}, $path2;
1683
1684     # drop common prefixes until we find a difference
1685     PREFIX:
1686     while ( @path1 && @path2 ) {
1687         last PREFIX if $path1[0] ne $path2[0];
1688         shift @path1;
1689         shift @path2;
1690     }
1691
1692     # prepend one '..' to $path2 for each component of $path1
1693     while ( shift @path1 ) {
1694         unshift @path2, '..';
1695     }
1696
1697     return join_paths(@path2);
1698 }
1699
1700 #===== SUBROUTINE ===========================================================
1701 # Name      : join_path()
1702 # Purpose   : concatenates given paths
1703 # Parameters: path1, path2, ... => paths
1704 # Returns   : concatenation of given paths
1705 # Throws    : n/a
1706 # Comments  : factors out redundant path elements:
1707 #           : '//' => '/' and 'a/b/../c' => 'a/c'
1708 #============================================================================
1709 sub join_paths {
1710
1711     my @paths = @_;
1712
1713     # weed out empty components and concatenate
1714     my $result = join '/', grep {!/\A\z/} @paths;
1715
1716     # factor out back references and remove redundant /'s)
1717     my @result = ();
1718     PART:
1719     for my $part ( split m{/+}, $result) {
1720         next PART if $part eq '.';
1721         if (@result && $part eq '..' && $result[-1] ne '..') {
1722             pop @result;
1723         }
1724         else {
1725             push @result, $part;
1726         }
1727     }
1728
1729     return join '/', @result;
1730 }
1731
1732 #===== SUBROUTINE ===========================================================
1733 # Name      : parent
1734 # Purpose   : find the parent of the given path
1735 # Parameters: @path => components of the path
1736 # Returns   : returns a path string
1737 # Throws    : n/a
1738 # Comments  : allows you to send multiple chunks of the path
1739 #           : (this feature is currently not used)
1740 #============================================================================
1741 sub parent {
1742     my @path = @_;
1743     my $path = join '/', @_;
1744     my @elts = split m{/+}, $path;
1745     pop @elts;
1746     return join '/', @elts;
1747 }
1748
1749 #===== SUBROUTINE ===========================================================
1750 # Name      : internal_error()
1751 # Purpose   : output internal error message in a consistent form and die
1752 # Parameters: $message => error message to output
1753 # Returns   : n/a
1754 # Throws    : n/a
1755 # Comments  : none
1756 #============================================================================
1757 sub internal_error {
1758     my ($format,@args) = @_;
1759     die "$ProgramName: INTERNAL ERROR: ".sprintf($format,@args)."\n",
1760         "This _is_ a bug. Please submit a bug report so we can fix it:-)\n";
1761 }
1762
1763 #===== SUBROUTINE ===========================================================
1764 # Name      : error()
1765 # Purpose   : output error message in a consistent form and die
1766 # Parameters: $message => error message to output
1767 # Returns   : n/a
1768 # Throws    : n/a
1769 # Comments  : none
1770 #============================================================================
1771 sub error {
1772     my ($format,@args) = @_;
1773     die "$ProgramName: ERROR: ".sprintf($format,@args)." ($!)\n";
1774 }
1775
1776 #===== SUBROUTINE ===========================================================
1777 # Name      : version()
1778 # Purpose   : print this programs verison and exit
1779 # Parameters: none
1780 # Returns   : n/a
1781 # Throws    : n/a
1782 # Comments  : none
1783 #============================================================================
1784 sub version {
1785     print "$ProgramName (GNU Stow) version $Version\n";
1786     exit 0;
1787 }
1788
1789 1; # return true so we can load this script as a module during unit testing
1790
1791 # Local variables:
1792 # mode: perl
1793 # End:
1794 # vim: ft=perl