lib/Stow.pm.in

   1 #!/usr/bin/perl
   2
   3 package Stow;
   4
   5 =head1 NAME
   6
   7 Stow - manage the installation of multiple software packages
   8
   9 =head1 SYNOPSIS
  10
  11     my $stow = new Stow(%$options);
  12
  13     $stow->plan_unstow(@pkgs_to_unstow);
  14     $stow->plan_stow  (@pkgs_to_stow);
  15
  16     my @conflicts = $stow->get_conflicts;
  17     $stow->process_tasks() unless @conflicts;
  18
  19 =head1 DESCRIPTION
  20
  21 This is the backend Perl module for GNU Stow, a program for managing
  22 the installation of software packages, keeping them separate
  23 (C</usr/local/stow/emacs> vs. C</usr/local/stow/perl>, for example)
  24 while making them appear to be installed in the same place
  25 (C</usr/local>).
  26
  27 Stow doesn't store an extra state between runs, so there's no danger
  28 of mangling directories when file hierarchies don't match the
  29 database. Also, stow will never delete any files, directories, or
  30 links that appear in a stow directory, so it is always possible to
  31 rebuild the target tree.
  32
  33 =cut
  34
  35 use strict;
  36 use warnings;
  37
  38 use Carp qw(carp cluck croak confess);
  39 use File::Spec;
  40 use POSIX qw(getcwd);
  41
  42 use Stow::Util qw(set_debug_level debug error set_test_mode
  43                   join_paths restore_cwd canon_path parent);
  44
  45 our $ProgramName = 'stow';
  46 our $VERSION = '@VERSION@';
  47
  48 # These are the default options for each Stow instance.
  49 our %DEFAULT_OPTIONS = (
  50     conflicts  => 0,
  51     simulate   => 0,
  52     verbose    => 0,
  53     paranoid   => 0,
  54     compat     => 0,
  55     test_mode  => 0,
  56     ignore     => [],
  57     override   => [],
  58     defer      => [],
  59 );
  60
  61 =head1 CONSTRUCTORS
  62
  63 =head2 new(%options)
  64
  65 =head3 Required options
  66
  67 =over 4
  68
  69 =item * dir - the stow directory
  70
  71 =item * target - the target directory
  72
  73 =back
  74
  75 =head3 Non-mandatory options
  76
  77 =over 4
  78
  79 =item * conflicts
  80
  81 =item * simulate
  82
  83 =item * verbose
  84
  85 =item * paranoid
  86
  87 =item * ignore
  88
  89 =item * override
  90
  91 =item * defer
  92
  93 =back
  94
  95 N.B. This sets the current working directory to the target directory.
  96
  97 =cut
  98
  99 sub new {
 100     my $self = shift;
 101     my $class = ref($self) || $self;
 102     my %opts = @_;
 103
 104     my $new = bless { }, $class;
 105
 106     for my $required_arg (qw(dir target)) {
 107         croak "$class->new() called without '$required_arg' parameter\n"
 108             unless exists $opts{$required_arg};
 109         $new->{$required_arg} = delete $opts{$required_arg};
 110     }
 111
 112     for my $opt (keys %DEFAULT_OPTIONS) {
 113         $new->{$opt} = exists $opts{$opt} ? delete $opts{$opt}
 114                                           : $DEFAULT_OPTIONS{$opt};
 115     }
 116
 117     if (%opts) {
 118         croak "$class->new() called with unrecognised parameter(s): ",
 119             join(", ", keys %opts), "\n";
 120     }
 121
 122     $opts{'simulate'} = 1 if $opts{'conflicts'};
 123
 124     set_debug_level($new->get_verbosity());
 125     set_test_mode($new->{test_mode});
 126     $new->set_stow_dir();
 127     $new->init_state();
 128
 129     return $new;
 130 }
 131
 132 sub get_verbosity {
 133     my $self = shift;
 134
 135     return $self->{verbose} unless $self->{test_mode};
 136
 137     return 0 unless length $ENV{TEST_VERBOSE};
 138
 139     # Convert TEST_VERBOSE=y into numeric value
 140     $ENV{TEST_VERBOSE} = 3 if $ENV{TEST_VERBOSE} !~ /^\d+$/;
 141
 142     return $ENV{TEST_VERBOSE};
 143 }
 144
 145 =head2 set_stow_dir([$dir])
 146
 147 Sets a new stow directory.  This allows the use of multiple stow
 148 directories within one Stow instance, e.g.
 149
 150     $stow->plan_stow('foo');
 151     $stow->set_stow_dir('/different/stow/dir');
 152     $stow->plan_stow('bar');
 153     $stow->process_tasks;
 154
 155 If C<$dir> is omitted, uses the value of the C<dir> parameter passed
 156 to the L<new()> constructor.
 157
 158 =cut
 159
 160 sub set_stow_dir {
 161     my $self = shift;
 162     my ($dir) = @_;
 163     if (defined $dir) {
 164         $self->{dir} = $dir;
 165     }
 166
 167     my $stow_dir = canon_path($self->{dir});
 168
 169     $self->{stow_path} = File::Spec->abs2rel($stow_dir, $self->{target});
 170
 171     debug(2, "stow dir is $stow_dir");
 172     debug(2, "stow dir path relative to target $self->{target} is $self->{stow_path}");
 173 }
 174
 175 sub init_state {
 176     my $self = shift;
 177
 178     # Store conflicts during pre-processing
 179     $self->{conflicts} = [];
 180
 181     # Store command line packages to stow (-S and -R)
 182     $self->{pkgs_to_stow}   = [];
 183
 184     # Store command line packages to unstow (-D and -R)
 185     $self->{pkgs_to_delete} = [];
 186
 187     # The following structures are used by the abstractions that allow us to
 188     # defer operating on the filesystem until after all potential conflicts have
 189     # been assessed.
 190
 191     # $self->{tasks}:  list of operations to be performed (in order)
 192     # each element is a hash ref of the form
 193     #   {
 194     #       action => ...
 195     #       type   => ...
 196     #       path   => ...  (unique)
 197     #       source => ...  (only for links)
 198     #   }
 199     $self->{tasks} = [];
 200
 201     # $self->{dir_task_for}: map a path to the corresponding directory task reference
 202     # This structure allows us to quickly determine if a path has an existing
 203     # directory task associated with it.
 204     $self->{dir_task_for} = {};
 205
 206     # $self->{link_task_for}: map a path to the corresponding directory task reference
 207     # This structure allows us to quickly determine if a path has an existing
 208     # directory task associated with it.
 209     $self->{link_task_for} = {};
 210
 211     # N.B.: directory tasks and link tasks are NOT mutually exclusive due
 212     # to tree splitting (which involves a remove link task followed by
 213     # a create directory task).
 214 }
 215
 216 =head1 METHODS
 217
 218 =head2 plan_unstow(@packages)
 219
 220 Plan which symlink/directory creation/removal tasks need to be executed
 221 in order to unstow the given packages.  Any potential conflicts are then
 222 accessible via L<get_conflicts()>.
 223
 224 =cut
 225
 226 sub plan_unstow {
 227     my $self = shift;
 228     my @packages = @_;
 229
 230     $self->within_target_do(sub {
 231         for my $package (@packages) {
 232             if (not -d join_paths($self->{stow_path}, $package)) {
 233                 error("The given package name ($package) is not in your stow path $self->{stow_path}");
 234             }
 235             debug(2, "Planning unstow of package $package...");
 236             if ($self->{'compat'}) {
 237                 $self->unstow_contents_orig(
 238                     join_paths($self->{stow_path}, $package), # path to package
 239                     '.',                                      # target is current_dir
 240                 );
 241             }
 242             else {
 243                 $self->unstow_contents(
 244                     join_paths($self->{stow_path}, $package), # path to package
 245                     '.',                                      # target is current_dir
 246                 );
 247             }
 248             debug(2, "Planning unstow of package $package... done");
 249         }
 250     });
 251 }
 252
 253 =head2 plan_stow(@packages)
 254
 255 Plan which symlink/directory creation/removal tasks need to be executed
 256 in order to stow the given packages.  Any potential conflicts are then
 257 accessible via L<get_conflicts()>.
 258
 259 =cut
 260
 261 sub plan_stow {
 262     my $self = shift;
 263     my @packages = @_;
 264
 265     $self->within_target_do(sub {
 266         for my $package (@packages) {
 267             if (not -d join_paths($self->{stow_path}, $package)) {
 268                 error("The given package name ($package) is not in your stow path $self->{stow_path}");
 269             }
 270             debug(2, "Planning stow of package $package...");
 271             $self->stow_contents(
 272                 join_paths($self->{stow_path}, $package), # path package
 273                 '.',                                      # target is current dir
 274                 join_paths($self->{stow_path}, $package), # source from target
 275             );
 276             debug(2, "Planning stow of package $package... done");
 277         }
 278     });
 279 }
 280
 281 #===== METHOD ===============================================================
 282 # Name      : within_target_do()
 283 # Purpose   : execute code within target directory, preserving cwd
 284 # Parameters: $code => anonymous subroutine to execute within target dir
 285 # Returns   : n/a
 286 # Throws    : n/a
 287 # Comments  : This is done to ensure that the consumer of the Stow interface
 288 #           : doesn't have to worry about (a) what their cwd is, and
 289 #           : (b) that their cwd might change.
 290 #============================================================================
 291 sub within_target_do {
 292     my $self = shift;
 293     my ($code) = @_;
 294
 295     my $cwd = getcwd();
 296     chdir($self->{'target'})
 297         or error("Cannot chdir to target tree: $self->{'target'}");
 298     debug(3, "cwd now $self->{target}");
 299
 300     $self->$code();
 301
 302     restore_cwd($cwd);
 303     debug(3, "cwd restored to $cwd");
 304 }
 305
 306 #===== METHOD ===============================================================
 307 # Name      : stow_contents()
 308 # Purpose   : stow the contents of the given directory
 309 # Parameters: $path   => relative path to source dir from current directory
 310 #           : $target => relative path to symlink target from the current directory
 311 #           : $source => relative path to symlink source from the dir of target
 312 # Returns   : n/a
 313 # Throws    : a fatal error if directory cannot be read
 314 # Comments  : stow_node() and stow_contents() are mutually recursive
 315 #           : $source and $target are used for creating the symlink
 316 #           : $path is used for folding/unfolding trees as necessary
 317 #============================================================================
 318 sub stow_contents {
 319     my $self = shift;
 320     my ($path, $target, $source) = @_;
 321
 322     return if $self->should_skip_target_which_is_stow_dir($target);
 323
 324     my $cwd = getcwd();
 325     my $msg = "Stowing contents of $path (cwd=$cwd, stow dir=$self->{stow_path})";
 326     $msg =~ s!$ENV{HOME}/!~/!g;
 327     debug(2, $msg);
 328     debug(3, "--- $target => $source");
 329
 330     error("stow_contents() called with non-directory path: $path")
 331         unless -d $path;
 332     error("stow_contents() called with non-directory target: $target")
 333         unless $self->is_a_node($target);
 334
 335     opendir my $DIR, $path
 336         or error("cannot read directory: $path");
 337     my @listing = readdir $DIR;
 338     closedir $DIR;
 339
 340     NODE:
 341     for my $node (@listing) {
 342         next NODE if $node eq '.';
 343         next NODE if $node eq '..';
 344         next NODE if $self->ignore($node);
 345         $self->stow_node(
 346             join_paths($path,   $node),   # path
 347             join_paths($target, $node),   # target
 348             join_paths($source, $node),   # source
 349         );
 350     }
 351 }
 352
 353 #===== METHOD ===============================================================
 354 # Name      : stow_node()
 355 # Purpose   : stow the given node
 356 # Parameters: $path   => relative path to source node from the current directory
 357 #           : $target => relative path to symlink target from the current directory
 358 #           : $source => relative path to symlink source from the dir of target
 359 # Returns   : n/a
 360 # Throws    : fatal exception if a conflict arises
 361 # Comments  : stow_node() and stow_contents() are mutually recursive
 362 #           : $source and $target are used for creating the symlink
 363 #           : $path is used for folding/unfolding trees as necessary
 364 #============================================================================
 365 sub stow_node {
 366     my $self = shift;
 367     my ($path, $target, $source) = @_;
 368
 369     debug(2, "Stowing from $path");
 370     debug(3, "--- $target => $source");
 371
 372     # Don't try to stow absolute symlinks (they can't be unstowed)
 373     if (-l $source) {
 374         my $second_source = $self->read_a_link($source);
 375         if ($second_source =~ m{\A/}) {
 376             $self->conflict("source is an absolute symlink $source => $second_source");
 377             debug(3, "absolute symlinks cannot be unstowed");
 378             return;
 379         }
 380     }
 381
 382     # Does the target already exist?
 383     if ($self->is_a_link($target)) {
 384
 385         # Where is the link pointing?
 386         my $old_source = $self->read_a_link($target);
 387         if (not $old_source) {
 388             error("Could not read link: $target");
 389         }
 390         debug(3, "--- Evaluate existing link: $target => $old_source");
 391
 392         # Does it point to a node under our stow directory?
 393         my $old_path = $self->find_stowed_path($target, $old_source);
 394         if (not $old_path) {
 395             $self->conflict("existing target is not owned by stow: $target");
 396             return; # XXX #
 397         }
 398
 399         # Does the existing $target actually point to anything?
 400         if ($self->is_a_node($old_path)) {
 401             if ($old_source eq $source) {
 402                 debug(3, "--- Skipping $target as it already points to $source");
 403             }
 404             elsif ($self->defer($target)) {
 405                 debug(3, "--- deferring installation of: $target");
 406             }
 407             elsif ($self->override($target)) {
 408                 debug(3, "--- overriding installation of: $target");
 409                 $self->do_unlink($target);
 410                 $self->do_link($source, $target);
 411             }
 412             elsif ($self->is_a_dir(join_paths(parent($target), $old_source)) &&
 413                    $self->is_a_dir(join_paths(parent($target), $source))     ) {
 414
 415                 # If the existing link points to a directory,
 416                 # and the proposed new link points to a directory,
 417                 # then we can unfold (split open) the tree at that point
 418
 419                 debug(3, "--- Unfolding $target");
 420                 $self->do_unlink($target);
 421                 $self->do_mkdir($target);
 422                 $self->stow_contents($old_path, $target, join_paths('..', $old_source));
 423                 $self->stow_contents($path,     $target, join_paths('..', $source));
 424             }
 425             else {
 426                 $self->conflict(
 427                     q{existing target is stowed to a different package: %s => %s},
 428                     $target,
 429                     $old_source,
 430                 );
 431             }
 432         }
 433         else {
 434             # The existing link is invalid, so replace it with a good link
 435             debug(3, "--- replacing invalid link: $path");
 436             $self->do_unlink($target);
 437             $self->do_link($source, $target);
 438         }
 439     }
 440     elsif ($self->is_a_node($target)) {
 441         debug(3, "--- Evaluate existing node: $target");
 442         if ($self->is_a_dir($target)) {
 443             $self->stow_contents($path, $target, join_paths('..', $source));
 444         }
 445         else {
 446             $self->conflict(
 447                 qq{existing target is neither a link nor a directory: $target}
 448             );
 449         }
 450     }
 451     else {
 452         $self->do_link($source, $target);
 453     }
 454     return;
 455 }
 456
 457 #===== METHOD ===============================================================
 458 # Name      : should_skip_target_which_is_stow_dir()
 459 # Purpose   : determine whether target is a stow directory which should
 460 #           : not be stowed to or unstowed from
 461 # Parameters: $target => relative path to symlink target from the current directory
 462 # Returns   : true iff target is a stow directory
 463 # Throws    : n/a
 464 # Comments  : none
 465 #============================================================================
 466 sub should_skip_target_which_is_stow_dir {
 467     my $self = shift;
 468     my ($target) = @_;
 469
 470     # Don't try to remove anything under a stow directory
 471     if ($target eq $self->{stow_path}) {
 472         debug(2, "Skipping target which was current stow directory $target");
 473         return 1;
 474     }
 475
 476     if ($self->marked_stow_dir($target)) {
 477         debug(2, "Skipping protected directory $target");
 478         return 1;
 479     }
 480
 481     debug (4, "$target not protected");
 482     return 0;
 483 }
 484
 485 sub marked_stow_dir {
 486     my $self = shift;
 487     my ($target) = @_;
 488     for my $f (".stow", ".nonstow") {
 489         if (-e join_paths($target, $f)) {
 490             debug(4, "$target contained $f");
 491             return 1;
 492         }
 493     }
 494     return 0;
 495 }
 496
 497 #===== METHOD ===============================================================
 498 # Name      : unstow_contents_orig()
 499 # Purpose   : unstow the contents of the given directory
 500 # Parameters: $path   => relative path to source dir from current directory
 501 #           : $target => relative path to symlink target from the current directory
 502 # Returns   : n/a
 503 # Throws    : a fatal error if directory cannot be read
 504 # Comments  : unstow_node_orig() and unstow_contents_orig() are mutually recursive
 505 #           : Here we traverse the target tree, rather than the source tree.
 506 #============================================================================
 507 sub unstow_contents_orig {
 508     my $self = shift;
 509     my ($path, $target) = @_;
 510
 511     return if $self->should_skip_target_which_is_stow_dir($target);
 512
 513     my $cwd = getcwd();
 514     my $msg = "Unstowing from $target (compat mode, cwd=$cwd, stow dir=$self->{stow_path})";
 515     $msg =~ s!$ENV{HOME}/!~/!g;
 516     debug(2, $msg);
 517     debug(3, "--- source path is $path");
 518     # In compat mode we traverse the target tree not the source tree,
 519     # so we're unstowing the contents of /target/foo, there's no
 520     # guarantee that the corresponding /stow/mypkg/foo exists.
 521     error("unstow_contents_orig() called with non-directory target: $target")
 522         unless -d $target;
 523
 524     opendir my $DIR, $target
 525         or error("cannot read directory: $target");
 526     my @listing = readdir $DIR;
 527     closedir $DIR;
 528
 529     NODE:
 530     for my $node (@listing) {
 531         next NODE if $node eq '.';
 532         next NODE if $node eq '..';
 533         next NODE if $self->ignore($node);
 534         $self->unstow_node_orig(
 535             join_paths($path,   $node), # path
 536             join_paths($target, $node), # target
 537         );
 538     }
 539 }
 540
 541 #===== METHOD ===============================================================
 542 # Name      : unstow_node_orig()
 543 # Purpose   : unstow the given node
 544 # Parameters: $path   => relative path to source node from the current directory
 545 #           : $target => relative path to symlink target from the current directory
 546 # Returns   : n/a
 547 # Throws    : fatal error if a conflict arises
 548 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 549 #============================================================================
 550 sub unstow_node_orig {
 551     my $self = shift;
 552     my ($path, $target) = @_;
 553
 554     debug(2, "Unstowing $target (compat mode)");
 555     debug(3, "--- source path is $path");
 556
 557     # Does the target exist?
 558     if ($self->is_a_link($target)) {
 559         debug(3, "Evaluate existing link: $target");
 560
 561         # Where is the link pointing?
 562         my $old_source = $self->read_a_link($target);
 563         if (not $old_source) {
 564             error("Could not read link: $target");
 565         }
 566
 567         # Does it point to a node under our stow directory?
 568         my $old_path = $self->find_stowed_path($target, $old_source);
 569         if (not $old_path) {
 570             # We're traversing the target tree not the package tree,
 571             # so we definitely expect to find stuff not owned by stow.
 572             # Therefore we can't flag a conflict.
 573             return; # XXX #
 574         }
 575
 576         # Does the existing $target actually point to anything?
 577         if (-e $old_path) {
 578             # Does link point to the right place?
 579             if ($old_path eq $path) {
 580                 $self->do_unlink($target);
 581             }
 582             elsif ($self->override($target)) {
 583                 debug(3, "--- overriding installation of: $target");
 584                 $self->do_unlink($target);
 585             }
 586             # else leave it alone
 587         }
 588         else {
 589             debug(3, "--- removing invalid link into a stow directory: $path");
 590             $self->do_unlink($target);
 591         }
 592     }
 593     elsif (-d $target) {
 594         $self->unstow_contents_orig($path, $target);
 595
 596         # This action may have made the parent directory foldable
 597         if (my $parent = $self->foldable($target)) {
 598             $self->fold_tree($target, $parent);
 599         }
 600     }
 601     elsif (-e $target) {
 602         $self->conflict(
 603             qq{existing target is neither a link nor a directory: $target},
 604         );
 605     }
 606     else {
 607         debug(3, "$target did not exist to be unstowed");
 608     }
 609     return;
 610 }
 611
 612 #===== METHOD ===============================================================
 613 # Name      : unstow_contents()
 614 # Purpose   : unstow the contents of the given directory
 615 # Parameters: $path   => relative path to source dir from current directory
 616 #           : $target => relative path to symlink target from the current directory
 617 # Returns   : n/a
 618 # Throws    : a fatal error if directory cannot be read
 619 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 620 #           : Here we traverse the source tree, rather than the target tree.
 621 #============================================================================
 622 sub unstow_contents {
 623     my $self = shift;
 624     my ($path, $target) = @_;
 625
 626     return if $self->should_skip_target_which_is_stow_dir($target);
 627
 628     my $cwd = getcwd();
 629     my $msg = "Unstowing from $target (cwd=$cwd, stow dir=$self->{stow_path})";
 630     $msg =~ s!$ENV{HOME}/!~/!g;
 631     debug(2, $msg);
 632     debug(3, "--- source path is $path");
 633     # We traverse the source tree not the target tree, so $path must exist.
 634     error("unstow_contents() called with non-directory path: $path")
 635         unless -d $path;
 636     # When called at the top level, $target should exist.  And
 637     # unstow_node() should only call this via mutual recursion if
 638     # $target exists.
 639     error("unstow_contents() called with invalid target: $target")
 640         unless $self->is_a_node($target);
 641
 642     opendir my $DIR, $path
 643         or error("cannot read directory: $path");
 644     my @listing = readdir $DIR;
 645     closedir $DIR;
 646
 647     NODE:
 648     for my $node (@listing) {
 649         next NODE if $node eq '.';
 650         next NODE if $node eq '..';
 651         next NODE if $self->ignore($node);
 652         $self->unstow_node(
 653             join_paths($path,   $node), # path
 654             join_paths($target, $node), # target
 655         );
 656     }
 657     if (-d $target) {
 658         $self->cleanup_invalid_links($target);
 659     }
 660 }
 661
 662 #===== METHOD ===============================================================
 663 # Name      : unstow_node()
 664 # Purpose   : unstow the given node
 665 # Parameters: $path   => relative path to source node from the current directory
 666 #           : $target => relative path to symlink target from the current directory
 667 # Returns   : n/a
 668 # Throws    : fatal error if a conflict arises
 669 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 670 #============================================================================
 671 sub unstow_node {
 672     my $self = shift;
 673     my ($path, $target) = @_;
 674
 675     debug(2, "Unstowing $path");
 676     debug(3, "--- target is $target");
 677
 678     # Does the target exist?
 679     if ($self->is_a_link($target)) {
 680         debug(3, "Evaluate existing link: $target");
 681
 682         # Where is the link pointing?
 683         my $old_source = $self->read_a_link($target);
 684         if (not $old_source) {
 685             error("Could not read link: $target");
 686         }
 687
 688         if ($old_source =~ m{\A/}) {
 689             warn "ignoring an absolute symlink: $target => $old_source\n";
 690             return; # XXX #
 691         }
 692
 693         # Does it point to a node under our stow directory?
 694         my $old_path = $self->find_stowed_path($target, $old_source);
 695         if (not $old_path) {
 696              $self->conflict(
 697                  qq{existing target is not owned by stow: $target => $old_source}
 698              );
 699             return; # XXX #
 700         }
 701
 702         # Does the existing $target actually point to anything?
 703         if (-e $old_path) {
 704             # Does link points to the right place?
 705             if ($old_path eq $path) {
 706                 $self->do_unlink($target);
 707             }
 708
 709             # XXX we quietly ignore links that are stowed to a different
 710             # package.
 711
 712             #elsif (defer($target)) {
 713             #    debug(3, "--- deferring to installation of: $target");
 714             #}
 715             #elsif ($self->override($target)) {
 716             #    debug(3, "--- overriding installation of: $target");
 717             #    $self->do_unlink($target);
 718             #}
 719             #else {
 720             #    $self->conflict(
 721             #        q{existing target is stowed to a different package: %s => %s},
 722             #        $target,
 723             #        $old_source
 724             #    );
 725             #}
 726         }
 727         else {
 728             debug(3, "--- removing invalid link into a stow directory: $path");
 729             $self->do_unlink($target);
 730         }
 731     }
 732     elsif (-e $target) {
 733         debug(3, "Evaluate existing node: $target");
 734         if (-d $target) {
 735             $self->unstow_contents($path, $target);
 736
 737             # This action may have made the parent directory foldable
 738             if (my $parent = $self->foldable($target)) {
 739                 $self->fold_tree($target, $parent);
 740             }
 741         }
 742         else {
 743             $self->conflict(
 744                 qq{existing target is neither a link nor a directory: $target},
 745             );
 746         }
 747     }
 748     else {
 749         debug(3, "$target did not exist to be unstowed");
 750     }
 751     return;
 752 }
 753
 754 #===== METHOD ===============================================================
 755 # Name      : find_stowed_path()
 756 # Purpose   : determine if the given link points to a member of a
 757 #           : stowed package
 758 # Parameters: $target => path to a symbolic link under current directory
 759 #           : $source => where that link points to
 760 # Returns   : relative path to stowed node (from the current directory)
 761 #           : or '' if link is not owned by stow
 762 # Throws    : fatal exception if link is unreadable
 763 # Comments  : allow for stow dir not being under target dir
 764 #           : we could put more logic under here for multiple stow dirs
 765 #============================================================================
 766 sub find_stowed_path {
 767     my $self = shift;
 768     my ($target, $source) = @_;
 769
 770     # Evaluate softlink relative to its target
 771     my $path = join_paths(parent($target), $source);
 772     debug(4, "  is path $path under $self->{stow_path} ?");
 773
 774     # Search for .stow files
 775     my $dir = '';
 776     for my $part (split m{/+}, $path) {
 777         $dir = join_paths($dir, $part);
 778         return $path if $self->marked_stow_dir($dir);
 779     }
 780
 781     # Compare with $self->{stow_path}
 782     my @path = split m{/+}, $path;
 783     my @stow_path = split m{/+}, $self->{stow_path};
 784
 785     # Strip off common prefixes until one is empty
 786     while (@path && @stow_path) {
 787         if ((shift @path) ne (shift @stow_path)) {
 788             debug(4, "    no - either $path not under $self->{stow_path} or vice-versa");
 789             return '';
 790         }
 791     }
 792
 793     if (@stow_path) { # @path must be empty
 794         debug(4, "    no - $path is not under $self->{stow_path}");
 795         return '';
 796     }
 797
 798     debug(4, "    yes - in " . join_paths(@path));
 799     return $path;
 800 }
 801
 802 #===== METHOD ================================================================
 803 # Name      : cleanup_invalid_links()
 804 # Purpose   : clean up invalid links that may block folding
 805 # Parameters: $dir => path to directory to check
 806 # Returns   : n/a
 807 # Throws    : no exceptions
 808 # Comments  : removing files from a stowed package is probably a bad practice
 809 #           : so this kind of clean up is not _really_ stow's responsibility;
 810 #           : however, failing to clean up can block tree folding, so we'll do
 811 #           : it anyway
 812 #=============================================================================
 813 sub cleanup_invalid_links {
 814     my $self = shift;
 815     my ($dir) = @_;
 816
 817     if (not -d $dir) {
 818         error("cleanup_invalid_links() called with a non-directory: $dir");
 819     }
 820
 821     opendir my $DIR, $dir
 822         or error("cannot read directory: $dir");
 823     my @listing = readdir $DIR;
 824     closedir $DIR;
 825
 826     NODE:
 827     for my $node (@listing) {
 828         next NODE if $node eq '.';
 829         next NODE if $node eq '..';
 830
 831         my $node_path = join_paths($dir, $node);
 832
 833         if (-l $node_path and not exists $self->{link_task_for}{$node_path}) {
 834
 835             # Where is the link pointing?
 836             # (don't use read_a_link() here)
 837             my $source = readlink($node_path);
 838             if (not $source) {
 839                 error("Could not read link $node_path");
 840             }
 841
 842             if (
 843                 not -e join_paths($dir, $source) and  # bad link
 844                 $self->find_stowed_path($node_path, $source) # owned by stow
 845             ){
 846                 debug(3, "--- removing stale link: $node_path => " .
 847                           join_paths($dir, $source));
 848                 $self->do_unlink($node_path);
 849             }
 850         }
 851     }
 852     return;
 853 }
 854
 855
 856 #===== METHOD ===============================================================
 857 # Name      : foldable()
 858 # Purpose   : determine if a tree can be folded
 859 # Parameters: $target => path to a directory
 860 # Returns   : path to the parent dir iff the tree can be safely folded
 861 # Throws    : n/a
 862 # Comments  : the path returned is relative to the parent of $target,
 863 #           : that is, it can be used as the source for a replacement symlink
 864 #============================================================================
 865 sub foldable {
 866     my $self = shift;
 867     my ($target) = @_;
 868
 869     debug(3, "--- Is $target foldable?");
 870
 871     opendir my $DIR, $target
 872         or error(qq{Cannot read directory "$target" ($!)\n});
 873     my @listing = readdir $DIR;
 874     closedir $DIR;
 875
 876     my $parent = '';
 877     NODE:
 878     for my $node (@listing) {
 879
 880         next NODE if $node eq '.';
 881         next NODE if $node eq '..';
 882
 883         my $path =  join_paths($target, $node);
 884
 885         # Skip nodes scheduled for removal
 886         next NODE if not $self->is_a_node($path);
 887
 888         # If it's not a link then we can't fold its parent
 889         return '' if not $self->is_a_link($path);
 890
 891         # Where is the link pointing?
 892         my $source = $self->read_a_link($path);
 893         if (not $source) {
 894             error("Could not read link $path");
 895         }
 896         if ($parent eq '') {
 897             $parent = parent($source)
 898         }
 899         elsif ($parent ne parent($source)) {
 900             return '';
 901         }
 902     }
 903     return '' if not $parent;
 904
 905     # If we get here then all nodes inside $target are links, and those links
 906     # point to nodes inside the same directory.
 907
 908     # chop of leading '..' to get the path to the common parent directory
 909     # relative to the parent of our $target
 910     $parent =~ s{\A\.\./}{};
 911
 912     # If the resulting path is owned by stow, we can fold it
 913     if ($self->find_stowed_path($target, $parent)) {
 914         debug(3, "--- $target is foldable");
 915         return $parent;
 916     }
 917     else {
 918         return '';
 919     }
 920 }
 921
 922 #===== METHOD ===============================================================
 923 # Name      : fold_tree()
 924 # Purpose   : fold the given tree
 925 # Parameters: $source  => link to the folded tree source
 926 #           : $target => directory that we will replace with a link to $source
 927 # Returns   : n/a
 928 # Throws    : none
 929 # Comments  : only called iff foldable() is true so we can remove some checks
 930 #============================================================================
 931 sub fold_tree {
 932     my $self = shift;
 933     my ($target, $source) = @_;
 934
 935     debug(3, "--- Folding tree: $target => $source");
 936
 937     opendir my $DIR, $target
 938         or error(qq{Cannot read directory "$target" ($!)\n});
 939     my @listing = readdir $DIR;
 940     closedir $DIR;
 941
 942     NODE:
 943     for my $node (@listing) {
 944         next NODE if $node eq '.';
 945         next NODE if $node eq '..';
 946         next NODE if not $self->is_a_node(join_paths($target, $node));
 947         $self->do_unlink(join_paths($target, $node));
 948     }
 949     $self->do_rmdir($target);
 950     $self->do_link($source, $target);
 951     return;
 952 }
 953
 954
 955 #===== METHOD ===============================================================
 956 # Name      : conflict()
 957 # Purpose   : handle conflicts in stow operations
 958 # Parameters: $format => message printf format
 959 #           : @args   => paths that conflict
 960 # Returns   : n/a
 961 # Throws    : fatal exception unless 'conflicts' option is set
 962 # Comments  : indicates what type of conflict it is
 963 #============================================================================
 964 sub conflict {
 965     my $self = shift;
 966     my ($format, @args) = @_;
 967
 968     my $message = sprintf($format, @args);
 969
 970     debug(1, "CONFLICT: $message");
 971     push @{ $self->{conflicts} }, "CONFLICT: $message\n";
 972     return;
 973 }
 974
 975 =head2 get_conflicts()
 976
 977 Returns a list of all potential conflicts discovered.
 978
 979 =cut
 980
 981 sub get_conflicts {
 982     my $self = shift;
 983     return @{ $self->{conflicts} };
 984 }
 985
 986 =head2 get_tasks()
 987
 988 Returns a list of all symlink/directory creation/removal tasks.
 989
 990 =cut
 991
 992 sub get_tasks {
 993     my $self = shift;
 994     return @{ $self->{tasks} };
 995 }
 996
 997 #===== METHOD ================================================================
 998 # Name      : ignore
 999 # Purpose   : determine if the given path matches a regex in our ignore list
1000 # Parameters: $path
1001 # Returns   : Boolean
1002 # Throws    : no exceptions
1003 # Comments  : none
1004 #=============================================================================
1005 sub ignore {
1006     my $self = shift;
1007     my ($path) = @_;
1008
1009     for my $suffix (@{$self->{'ignore'}}) {
1010         return 1 if $path =~ m/$suffix/;
1011     }
1012     return 0;
1013 }
1014
1015 #===== METHOD ================================================================
1016 # Name      : defer
1017 # Purpose   : determine if the given path matches a regex in our defer list
1018 # Parameters: $path
1019 # Returns   : Boolean
1020 # Throws    : no exceptions
1021 # Comments  : none
1022 #=============================================================================
1023 sub defer {
1024     my $self = shift;
1025     my ($path) = @_;
1026
1027     for my $prefix (@{$self->{'defer'}}) {
1028         return 1 if $path =~ m/$prefix/;
1029     }
1030     return 0;
1031 }
1032
1033 #===== METHOD ================================================================
1034 # Name      : override
1035 # Purpose   : determine if the given path matches a regex in our override list
1036 # Parameters: $path
1037 # Returns   : Boolean
1038 # Throws    : no exceptions
1039 # Comments  : none
1040 #=============================================================================
1041 sub override {
1042     my $self = shift;
1043     my ($path) = @_;
1044
1045     for my $regex (@{$self->{'override'}}) {
1046         return 1 if $path =~ m/$regex/;
1047     }
1048     return 0;
1049 }
1050
1051 ##############################################################################
1052 #
1053 # The following code provides the abstractions that allow us to defer operating
1054 # on the filesystem until after all potential conflcits have been assessed.
1055 #
1056 ##############################################################################
1057
1058 #===== METHOD ===============================================================
1059 # Name      : process_tasks()
1060 # Purpose   : process each task in the tasks list
1061 # Parameters: none
1062 # Returns   : n/a
1063 # Throws    : fatal error if tasks list is corrupted or a task fails
1064 # Comments  : none
1065 #============================================================================
1066 sub process_tasks {
1067     my $self = shift;
1068
1069     debug(2, "Processing tasks...");
1070
1071     if ($self->{'simulate'}) {
1072         warn "WARNING: simulating so all operations are deferred.\n";
1073         return;
1074     }
1075
1076     # Strip out all tasks with a skip action
1077     $self->{tasks} = [ grep { $_->{'action'} ne 'skip' } @{ $self->{tasks} } ];
1078
1079     if (not @{ $self->{tasks} }) {
1080         warn "There are no outstanding operations to perform.\n";
1081         return;
1082     }
1083
1084     $self->within_target_do(sub {
1085         for my $task (@{ $self->{tasks} }) {
1086             $self->process_task($task);
1087         }
1088     });
1089
1090     debug(2, "Processing tasks... done");
1091 }
1092
1093 #===== METHOD ===============================================================
1094 # Name      : process_task()
1095 # Purpose   : process a single task
1096 # Parameters: $task => the task to process
1097 # Returns   : n/a
1098 # Throws    : fatal error if task fails
1099 # Comments  : Must run from within target directory.
1100 #           : Task involve either creating or deleting dirs and symlinks
1101 #           : an action is set to 'skip' if it is found to be redundant
1102 #============================================================================
1103 sub process_task {
1104     my $self = shift;
1105     my ($task) = @_;
1106
1107     if ($task->{'action'} eq 'create') {
1108         if ($task->{'type'} eq 'dir') {
1109             mkdir($task->{'path'}, 0777)
1110                 or error(qq(Could not create directory: $task->{'path'}));
1111         }
1112         elsif ($task->{'type'} eq 'link') {
1113             symlink $task->{'source'}, $task->{'path'}
1114                 or error(
1115                     q(Could not create symlink: %s => %s),
1116                     $task->{'path'},
1117                     $task->{'source'}
1118             );
1119         }
1120         else {
1121             internal_error(qq(bad task type: $task->{'type'}));
1122         }
1123     }
1124     elsif ($task->{'action'} eq 'remove') {
1125         if ($task->{'type'} eq 'dir') {
1126             rmdir $task->{'path'}
1127                 or error(qq(Could not remove directory: $task->{'path'}));
1128         }
1129         elsif ($task->{'type'} eq 'link') {
1130             unlink $task->{'path'}
1131                 or error(qq(Could not remove link: $task->{'path'}));
1132         }
1133         else {
1134             internal_error(qq(bad task type: $task->{'type'}));
1135         }
1136     }
1137     else {
1138         internal_error(qq(bad task action: $task->{'action'}));
1139     }
1140 }
1141
1142 #===== METHOD ===============================================================
1143 # Name      : link_task_action()
1144 # Purpose   : finds the link task action for the given path, if there is one
1145 # Parameters: $path
1146 # Returns   : 'remove', 'create', or '' if there is no action
1147 # Throws    : a fatal exception if an invalid action is found
1148 # Comments  : none
1149 #============================================================================
1150 sub link_task_action {
1151     my $self = shift;
1152     my ($path) = @_;
1153
1154     if (! exists $self->{link_task_for}{$path}) {
1155         debug(4, "  link_task_action($path): no task");
1156         return '';
1157     }
1158
1159     my $action = $self->{link_task_for}{$path}->{'action'};
1160     internal_error("bad task action: $action")
1161         unless $action eq 'remove' or $action eq 'create';
1162
1163     debug(4, "  link_task_action($path): link task exists with action $action");
1164     return $action;
1165 }
1166
1167 #===== METHOD ===============================================================
1168 # Name      : dir_task_action()
1169 # Purpose   : finds the dir task action for the given path, if there is one
1170 # Parameters: $path
1171 # Returns   : 'remove', 'create', or '' if there is no action
1172 # Throws    : a fatal exception if an invalid action is found
1173 # Comments  : none
1174 #============================================================================
1175 sub dir_task_action {
1176     my $self = shift;
1177     my ($path) = @_;
1178
1179     if (! exists $self->{dir_task_for}{$path}) {
1180         debug(4, "  dir_task_action($path): no task");
1181         return '';
1182     }
1183
1184     my $action = $self->{dir_task_for}{$path}->{'action'};
1185     internal_error("bad task action: $action")
1186         unless $action eq 'remove' or $action eq 'create';
1187
1188     debug(4, "  dir_task_action($path): dir task exists with action $action");
1189     return $action;
1190 }
1191
1192 #===== METHOD ===============================================================
1193 # Name      : parent_link_scheduled_for_removal()
1194 # Purpose   : determines whether the given path or any parent thereof
1195 #           : is a link scheduled for removal
1196 # Parameters: $path
1197 # Returns   : Boolean
1198 # Throws    : none
1199 # Comments  : none
1200 #============================================================================
1201 sub parent_link_scheduled_for_removal {
1202     my $self = shift;
1203     my ($path) = @_;
1204
1205     my $prefix = '';
1206     for my $part (split m{/+}, $path) {
1207         $prefix = join_paths($prefix, $part);
1208         debug(4, "    parent_link_scheduled_for_removal($path): prefix $prefix");
1209         if (exists $self->{link_task_for}{$prefix} and
1210              $self->{link_task_for}{$prefix}->{'action'} eq 'remove') {
1211             debug(4, "    parent_link_scheduled_for_removal($path): link scheduled for removal");
1212             return 1;
1213         }
1214     }
1215
1216     debug(4, "    parent_link_scheduled_for_removal($path): returning false");
1217     return 0;
1218 }
1219
1220 #===== METHOD ===============================================================
1221 # Name      : is_a_link()
1222 # Purpose   : is the given path a current or planned link
1223 # Parameters: $path
1224 # Returns   : Boolean
1225 # Throws    : none
1226 # Comments  : returns false if an existing link is scheduled for removal
1227 #           : and true if a non-existent link is scheduled for creation
1228 #============================================================================
1229 sub is_a_link {
1230     my $self = shift;
1231     my ($path) = @_;
1232     debug(4, "  is_a_link($path)");
1233
1234     if (my $action = $self->link_task_action($path)) {
1235         if ($action eq 'remove') {
1236             return 0;
1237         }
1238         elsif ($action eq 'create') {
1239             return 1;
1240         }
1241     }
1242
1243     if (-l $path) {
1244         # Check if any of its parent are links scheduled for removal
1245         # (need this for edge case during unfolding)
1246         debug(4, "  is_a_link($path): is a real link");
1247         return $self->parent_link_scheduled_for_removal($path) ? 0 : 1;
1248     }
1249
1250     debug(4, "  is_a_link($path): returning false");
1251     return 0;
1252 }
1253
1254 #===== METHOD ===============================================================
1255 # Name      : is_a_dir()
1256 # Purpose   : is the given path a current or planned directory
1257 # Parameters: $path
1258 # Returns   : Boolean
1259 # Throws    : none
1260 # Comments  : returns false if an existing directory is scheduled for removal
1261 #           : and true if a non-existent directory is scheduled for creation
1262 #           : we also need to be sure we are not just following a link
1263 #============================================================================
1264 sub is_a_dir {
1265     my $self = shift;
1266     my ($path) = @_;
1267     debug(4, "  is_a_dir($path)");
1268
1269     if (my $action = $self->dir_task_action($path)) {
1270         if ($action eq 'remove') {
1271             return 0;
1272         }
1273         elsif ($action eq 'create') {
1274             return 1;
1275         }
1276     }
1277
1278     return 0 if $self->parent_link_scheduled_for_removal($path);
1279
1280     if (-d $path) {
1281         debug(4, "  is_a_dir($path): real dir");
1282         return 1;
1283     }
1284
1285     debug(4, "  is_a_dir($path): returning false");
1286     return 0;
1287 }
1288
1289 #===== METHOD ===============================================================
1290 # Name      : is_a_node()
1291 # Purpose   : is the given path a current or planned node
1292 # Parameters: $path
1293 # Returns   : Boolean
1294 # Throws    : none
1295 # Comments  : returns false if an existing node is scheduled for removal
1296 #           : true if a non-existent node is scheduled for creation
1297 #           : we also need to be sure we are not just following a link
1298 #============================================================================
1299 sub is_a_node {
1300     my $self = shift;
1301     my ($path) = @_;
1302     debug(4, "  is_a_node($path)");
1303
1304     my $laction = $self->link_task_action($path);
1305     my $daction = $self->dir_task_action($path);
1306
1307     if ($laction eq 'remove') {
1308         if ($daction eq 'remove') {
1309             internal_error("removing link and dir: $path");
1310             return 0;
1311         }
1312         elsif ($daction eq 'create') {
1313             # Assume that we're unfolding $path, and that the link
1314             # removal action is earlier than the dir creation action
1315             # in the task queue.  FIXME: is this a safe assumption?
1316             return 1;
1317         }
1318         else { # no dir action
1319             return 0;
1320         }
1321     }
1322     elsif ($laction eq 'create') {
1323         if ($daction eq 'remove') {
1324             # Assume that we're folding $path, and that the dir
1325             # removal action is earlier than the link creation action
1326             # in the task queue.  FIXME: is this a safe assumption?
1327             return 1;
1328         }
1329         elsif ($daction eq 'create') {
1330             internal_error("creating link and dir: $path");
1331             return 1;
1332         }
1333         else { # no dir action
1334             return 1;
1335         }
1336     }
1337     else {
1338         # No link action
1339         if ($daction eq 'remove') {
1340             return 0;
1341         }
1342         elsif ($daction eq 'create') {
1343             return 1;
1344         }
1345         else { # no dir action
1346             # fall through to below
1347         }
1348     }
1349
1350     return 0 if $self->parent_link_scheduled_for_removal($path);
1351
1352     if (-e $path) {
1353         debug(4, "  is_a_node($path): really exists");
1354         return 1;
1355     }
1356
1357     debug(4, "  is_a_node($path): returning false");
1358     return 0;
1359 }
1360
1361 #===== METHOD ===============================================================
1362 # Name      : read_a_link()
1363 # Purpose   : return the source of a current or planned link
1364 # Parameters: $path => path to the link target
1365 # Returns   : a string
1366 # Throws    : fatal exception if the given path is not a current or planned
1367 #           : link
1368 # Comments  : none
1369 #============================================================================
1370 sub read_a_link {
1371     my $self = shift;
1372     my ($path) = @_;
1373
1374     if (my $action = $self->link_task_action($path)) {
1375         debug(4, "  read_a_link($path): task exists with action $action");
1376
1377         if ($action eq 'create') {
1378             return $self->{link_task_for}{$path}->{'source'};
1379         }
1380         elsif ($action eq 'remove') {
1381             internal_error(
1382                 "read_a_link() passed a path that is scheduled for removal: $path"
1383             );
1384         }
1385     }
1386     elsif (-l $path) {
1387         debug(4, "  read_a_link($path): real link");
1388         return readlink $path
1389             or error("Could not read link: $path");
1390     }
1391     internal_error("read_a_link() passed a non link path: $path\n");
1392 }
1393
1394 #===== METHOD ===============================================================
1395 # Name      : do_link()
1396 # Purpose   : wrap 'link' operation for later processing
1397 # Parameters: $oldfile => the existing file to link to
1398 #           : $newfile => the file to link
1399 # Returns   : n/a
1400 # Throws    : error if this clashes with an existing planned operation
1401 # Comments  : cleans up operations that undo previous operations
1402 #============================================================================
1403 sub do_link {
1404     my $self = shift;
1405     my ($oldfile, $newfile) = @_;
1406
1407     if (exists $self->{dir_task_for}{$newfile}) {
1408         my $task_ref = $self->{dir_task_for}{$newfile};
1409
1410         if ($task_ref->{'action'} eq 'create') {
1411             if ($task_ref->{'type'} eq 'dir') {
1412                 internal_error(
1413                     "new link (%s => %s) clashes with planned new directory",
1414                     $newfile,
1415                     $oldfile,
1416                 );
1417             }
1418         }
1419         elsif ($task_ref->{'action'} eq 'remove') {
1420             # We may need to remove a directory before creating a link so continue.
1421         }
1422         else {
1423             internal_error("bad task action: $task_ref->{'action'}");
1424         }
1425     }
1426
1427     if (exists $self->{link_task_for}{$newfile}) {
1428         my $task_ref = $self->{link_task_for}{$newfile};
1429
1430         if ($task_ref->{'action'} eq 'create') {
1431             if ($task_ref->{'source'} ne $oldfile) {
1432                 internal_error(
1433                     "new link clashes with planned new link: %s => %s",
1434                     $task_ref->{'path'},
1435                     $task_ref->{'source'},
1436                 )
1437             }
1438             else {
1439                 debug(1, "LINK: $newfile => $oldfile (duplicates previous action)");
1440                 return;
1441             }
1442         }
1443         elsif ($task_ref->{'action'} eq 'remove') {
1444             if ($task_ref->{'source'} eq $oldfile) {
1445                 # No need to remove a link we are going to recreate
1446                 debug(1, "LINK: $newfile => $oldfile (reverts previous action)");
1447                 $self->{link_task_for}{$newfile}->{'action'} = 'skip';
1448                 delete $self->{link_task_for}{$newfile};
1449                 return;
1450             }
1451             # We may need to remove a link to replace it so continue
1452         }
1453         else {
1454             internal_error("bad task action: $task_ref->{'action'}");
1455         }
1456     }
1457
1458     # Creating a new link
1459     debug(1, "LINK: $newfile => $oldfile");
1460     my $task = {
1461         action  => 'create',
1462         type    => 'link',
1463         path    => $newfile,
1464         source  => $oldfile,
1465     };
1466     push @{ $self->{tasks} }, $task;
1467     $self->{link_task_for}{$newfile} = $task;
1468
1469     return;
1470 }
1471
1472 #===== METHOD ===============================================================
1473 # Name      : do_unlink()
1474 # Purpose   : wrap 'unlink' operation for later processing
1475 # Parameters: $file => the file to unlink
1476 # Returns   : n/a
1477 # Throws    : error if this clashes with an existing planned operation
1478 # Comments  : will remove an existing planned link
1479 #============================================================================
1480 sub do_unlink {
1481     my $self = shift;
1482     my ($file) = @_;
1483
1484     if (exists $self->{link_task_for}{$file}) {
1485         my $task_ref = $self->{link_task_for}{$file};
1486         if ($task_ref->{'action'} eq 'remove') {
1487             debug(1, "UNLINK: $file (duplicates previous action)");
1488             return;
1489         }
1490         elsif ($task_ref->{'action'} eq 'create') {
1491             # Do need to create a link then remove it
1492             debug(1, "UNLINK: $file (reverts previous action)");
1493             $self->{link_task_for}{$file}->{'action'} = 'skip';
1494             delete $self->{link_task_for}{$file};
1495             return;
1496         }
1497         else {
1498             internal_error("bad task action: $task_ref->{'action'}");
1499         }
1500     }
1501
1502     if (exists $self->{dir_task_for}{$file} and $self->{dir_task_for}{$file} eq 'create') {
1503         internal_error(
1504             "new unlink operation clashes with planned operation: %s dir %s",
1505             $self->{dir_task_for}{$file}->{'action'},
1506             $file
1507         );
1508     }
1509
1510     # Remove the link
1511     debug(1, "UNLINK: $file");
1512
1513     my $source = readlink $file or error("could not readlink $file");
1514
1515     my $task = {
1516         action  => 'remove',
1517         type    => 'link',
1518         path    => $file,
1519         source  => $source,
1520     };
1521     push @{ $self->{tasks} }, $task;
1522     $self->{link_task_for}{$file} = $task;
1523
1524     return;
1525 }
1526
1527 #===== METHOD ===============================================================
1528 # Name      : do_mkdir()
1529 # Purpose   : wrap 'mkdir' operation
1530 # Parameters: $dir => the directory to remove
1531 # Returns   : n/a
1532 # Throws    : fatal exception if operation fails
1533 # Comments  : outputs a message if 'verbose' option is set
1534 #           : does not perform operation if 'simulate' option is set
1535 # Comments  : cleans up operations that undo previous operations
1536 #============================================================================
1537 sub do_mkdir {
1538     my $self = shift;
1539     my ($dir) = @_;
1540
1541     if (exists $self->{link_task_for}{$dir}) {
1542         my $task_ref = $self->{link_task_for}{$dir};
1543
1544         if ($task_ref->{'action'} eq 'create') {
1545             internal_error(
1546                 "new dir clashes with planned new link (%s => %s)",
1547                 $task_ref->{'path'},
1548                 $task_ref->{'source'},
1549             );
1550         }
1551         elsif ($task_ref->{'action'} eq 'remove') {
1552             # May need to remove a link before creating a directory so continue
1553         }
1554         else {
1555             internal_error("bad task action: $task_ref->{'action'}");
1556         }
1557     }
1558
1559     if (exists $self->{dir_task_for}{$dir}) {
1560         my $task_ref = $self->{dir_task_for}{$dir};
1561
1562         if ($task_ref->{'action'} eq 'create') {
1563             debug(1, "MKDIR: $dir (duplicates previous action)");
1564             return;
1565         }
1566         elsif ($task_ref->{'action'} eq 'remove') {
1567             debug(1, "MKDIR: $dir (reverts previous action)");
1568             $self->{dir_task_for}{$dir}->{'action'} = 'skip';
1569             delete $self->{dir_task_for}{$dir};
1570             return;
1571         }
1572         else {
1573             internal_error("bad task action: $task_ref->{'action'}");
1574         }
1575     }
1576
1577     debug(1, "MKDIR: $dir");
1578     my $task = {
1579         action  => 'create',
1580         type    => 'dir',
1581         path    => $dir,
1582         source  => undef,
1583     };
1584     push @{ $self->{tasks} }, $task;
1585     $self->{dir_task_for}{$dir} = $task;
1586
1587     return;
1588 }
1589
1590 #===== METHOD ===============================================================
1591 # Name      : do_rmdir()
1592 # Purpose   : wrap 'rmdir' operation
1593 # Parameters: $dir => the directory to remove
1594 # Returns   : n/a
1595 # Throws    : fatal exception if operation fails
1596 # Comments  : outputs a message if 'verbose' option is set
1597 #           : does not perform operation if 'simulate' option is set
1598 #============================================================================
1599 sub do_rmdir {
1600     my $self = shift;
1601     my ($dir) = @_;
1602
1603     if (exists $self->{link_task_for}{$dir}) {
1604         my $task_ref = $self->{link_task_for}{$dir};
1605         internal_error(
1606             "rmdir clashes with planned operation: %s link %s => %s",
1607             $task_ref->{'action'},
1608             $task_ref->{'path'},
1609             $task_ref->{'source'}
1610         );
1611     }
1612
1613     if (exists $self->{dir_task_for}{$dir}) {
1614         my $task_ref = $self->{link_task_for}{$dir};
1615
1616         if ($task_ref->{'action'} eq 'remove') {
1617             debug(1, "RMDIR $dir (duplicates previous action)");
1618             return;
1619         }
1620         elsif ($task_ref->{'action'} eq 'create') {
1621             debug(1, "MKDIR $dir (reverts previous action)");
1622             $self->{link_task_for}{$dir}->{'action'} = 'skip';
1623             delete $self->{link_task_for}{$dir};
1624             return;
1625         }
1626         else {
1627             internal_error("bad task action: $task_ref->{'action'}");
1628         }
1629     }
1630
1631     debug(1, "RMDIR $dir");
1632     my $task = {
1633         action  => 'remove',
1634         type    => 'dir',
1635         path    => $dir,
1636         source  => '',
1637     };
1638     push @{ $self->{tasks} }, $task;
1639     $self->{dir_task_for}{$dir} = $task;
1640
1641     return;
1642 }
1643
1644
1645 #############################################################################
1646 #
1647 # End of methods; subroutines follow.
1648 # FIXME: Ideally these should be in a separate module.
1649
1650
1651 #===== PRIVATE SUBROUTINE ===================================================
1652 # Name      : internal_error()
1653 # Purpose   : output internal error message in a consistent form and die
1654 # Parameters: $message => error message to output
1655 # Returns   : n/a
1656 # Throws    : n/a
1657 # Comments  : none
1658 #============================================================================
1659 sub internal_error {
1660     my ($format, @args) = @_;
1661     die "$ProgramName: INTERNAL ERROR: " . sprintf($format, @args) . "\n",
1662         "This _is_ a bug. Please submit a bug report so we can fix it:-)\n";
1663 }
1664
1665 =head1 BUGS
1666
1667 =head1 SEE ALSO
1668
1669 =cut
1670
1671 1;
1672
1673 # Local variables:
1674 # mode: perl
1675 # cperl-indent-level: 4
1676 # end:
1677 # vim: ft=perl