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, "Unstowing 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, "Unstowing 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, "Stowing 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, "Stowing 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_stow_dir_target($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_stow_dir_target()
 459 # Purpose   : determine whether target is a stow directory and should be skipped
 460 # Parameters: $target => relative path to symlink target from the current directory
 461 # Returns   : true iff target is a stow directory
 462 # Throws    : n/a
 463 # Comments  : none
 464 #============================================================================
 465 sub should_skip_stow_dir_target {
 466     my $self = shift;
 467     my ($target) = @_;
 468
 469     # Don't try to remove anything under a stow directory
 470     if ($target eq $self->{stow_path}) {
 471         debug(2, "Skipping target which was current stow directory $target");
 472         return 1;
 473     }
 474
 475     if ($self->protected_dir($target)) {
 476         debug(2, "Skipping protected directory $target");
 477         return 1;
 478     }
 479
 480     debug (4, "$target not protected");
 481     return 0;
 482 }
 483
 484 sub protected_dir {
 485     my $self = shift;
 486     my ($target) = @_;
 487     for my $f (".stow", ".nonstow") {
 488         if (-e join_paths($target, $f)) {
 489             debug(4, "$target contained $f");
 490             return 1;
 491         }
 492     }
 493     return 0;
 494 }
 495
 496 #===== METHOD ===============================================================
 497 # Name      : unstow_contents_orig()
 498 # Purpose   : unstow the contents of the given directory
 499 # Parameters: $path   => relative path to source dir from current directory
 500 #           : $target => relative path to symlink target from the current directory
 501 # Returns   : n/a
 502 # Throws    : a fatal error if directory cannot be read
 503 # Comments  : unstow_node_orig() and unstow_contents_orig() are mutually recursive
 504 #           : Here we traverse the target tree, rather than the source tree.
 505 #============================================================================
 506 sub unstow_contents_orig {
 507     my $self = shift;
 508     my ($path, $target) = @_;
 509
 510     return if $self->should_skip_stow_dir_target($target);
 511
 512     my $cwd = getcwd();
 513     my $msg = "Unstowing from $target (compat mode, cwd=$cwd, stow dir=$self->{stow_path})";
 514     $msg =~ s!$ENV{HOME}/!~/!g;
 515     debug(2, $msg);
 516     debug(3, "--- source path is $path");
 517     # In compat mode we traverse the target tree not the source tree,
 518     # so we're unstowing the contents of /target/foo, there's no
 519     # guarantee that the corresponding /stow/mypkg/foo exists.
 520     error("unstow_contents_orig() called with non-directory target: $target")
 521         unless -d $target;
 522
 523     opendir my $DIR, $target
 524         or error("cannot read directory: $target");
 525     my @listing = readdir $DIR;
 526     closedir $DIR;
 527
 528     NODE:
 529     for my $node (@listing) {
 530         next NODE if $node eq '.';
 531         next NODE if $node eq '..';
 532         next NODE if $self->ignore($node);
 533         $self->unstow_node_orig(
 534             join_paths($path,   $node), # path
 535             join_paths($target, $node), # target
 536         );
 537     }
 538 }
 539
 540 #===== METHOD ===============================================================
 541 # Name      : unstow_node_orig()
 542 # Purpose   : unstow the given node
 543 # Parameters: $path   => relative path to source node from the current directory
 544 #           : $target => relative path to symlink target from the current directory
 545 # Returns   : n/a
 546 # Throws    : fatal error if a conflict arises
 547 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 548 #============================================================================
 549 sub unstow_node_orig {
 550     my $self = shift;
 551     my ($path, $target) = @_;
 552
 553     debug(2, "Unstowing $target (compat mode)");
 554     debug(3, "--- source path is $path");
 555
 556     # Does the target exist?
 557     if ($self->is_a_link($target)) {
 558         debug(3, "Evaluate existing link: $target");
 559
 560         # Where is the link pointing?
 561         my $old_source = $self->read_a_link($target);
 562         if (not $old_source) {
 563             error("Could not read link: $target");
 564         }
 565
 566         # Does it point to a node under our stow directory?
 567         my $old_path = $self->find_stowed_path($target, $old_source);
 568         if (not $old_path) {
 569             # skip links not owned by stow
 570             return; # XXX #
 571         }
 572
 573         # Does the existing $target actually point to anything?
 574         if (-e $old_path) {
 575             # Does link point to the right place?
 576             if ($old_path eq $path) {
 577                 $self->do_unlink($target);
 578             }
 579             elsif ($self->override($target)) {
 580                 debug(3, "--- overriding installation of: $target");
 581                 $self->do_unlink($target);
 582             }
 583             # else leave it alone
 584         }
 585         else {
 586             debug(3, "--- removing invalid link into a stow directory: $path");
 587             $self->do_unlink($target);
 588         }
 589     }
 590     elsif (-d $target) {
 591         $self->unstow_contents_orig($path, $target);
 592
 593         # This action may have made the parent directory foldable
 594         if (my $parent = $self->foldable($target)) {
 595             $self->fold_tree($target, $parent);
 596         }
 597     }
 598     elsif (-e $target) {
 599         $self->conflict(
 600             qq{existing target is neither a link nor a directory: $target},
 601         );
 602     }
 603     else {
 604         debug(3, "$target did not exist to be unstowed");
 605     }
 606     return;
 607 }
 608
 609 #===== METHOD ===============================================================
 610 # Name      : unstow_contents()
 611 # Purpose   : unstow the contents of the given directory
 612 # Parameters: $path   => relative path to source dir from current directory
 613 #           : $target => relative path to symlink target from the current directory
 614 # Returns   : n/a
 615 # Throws    : a fatal error if directory cannot be read
 616 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 617 #           : Here we traverse the source tree, rather than the target tree.
 618 #============================================================================
 619 sub unstow_contents {
 620     my $self = shift;
 621     my ($path, $target) = @_;
 622
 623     return if $self->should_skip_stow_dir_target($target);
 624
 625     my $cwd = getcwd();
 626     my $msg = "Unstowing from $target (cwd=$cwd, stow dir=$self->{stow_path})";
 627     $msg =~ s!$ENV{HOME}/!~/!g;
 628     debug(2, $msg);
 629     debug(3, "--- source path is $path");
 630     # We traverse the source tree not the target tree, so $path must exist.
 631     error("unstow_contents() called with non-directory path: $path")
 632         unless -d $path;
 633     # When called at the top level, $target should exist.  And
 634     # unstow_node() should only call this via mutual recursion if
 635     # $target exists.
 636     error("unstow_contents() called with invalid target: $target")
 637         unless $self->is_a_node($target);
 638
 639     opendir my $DIR, $path
 640         or error("cannot read directory: $path");
 641     my @listing = readdir $DIR;
 642     closedir $DIR;
 643
 644     NODE:
 645     for my $node (@listing) {
 646         next NODE if $node eq '.';
 647         next NODE if $node eq '..';
 648         next NODE if $self->ignore($node);
 649         $self->unstow_node(
 650             join_paths($path,   $node), # path
 651             join_paths($target, $node), # target
 652         );
 653     }
 654     if (-d $target) {
 655         $self->cleanup_invalid_links($target);
 656     }
 657 }
 658
 659 #===== METHOD ===============================================================
 660 # Name      : unstow_node()
 661 # Purpose   : unstow the given node
 662 # Parameters: $path   => relative path to source node from the current directory
 663 #           : $target => relative path to symlink target from the current directory
 664 # Returns   : n/a
 665 # Throws    : fatal error if a conflict arises
 666 # Comments  : unstow_node() and unstow_contents() are mutually recursive
 667 #============================================================================
 668 sub unstow_node {
 669     my $self = shift;
 670     my ($path, $target) = @_;
 671
 672     debug(2, "Unstowing $path");
 673     debug(3, "--- target is $target");
 674
 675     # Does the target exist?
 676     if ($self->is_a_link($target)) {
 677         debug(3, "Evaluate existing link: $target");
 678
 679         # Where is the link pointing?
 680         my $old_source = $self->read_a_link($target);
 681         if (not $old_source) {
 682             error("Could not read link: $target");
 683         }
 684
 685         if ($old_source =~ m{\A/}) {
 686             warn "ignoring an absolute symlink: $target => $old_source\n";
 687             return; # XXX #
 688         }
 689
 690         # Does it point to a node under our stow directory?
 691         my $old_path = $self->find_stowed_path($target, $old_source);
 692         if (not $old_path) {
 693              $self->conflict(
 694                  qq{existing target is not owned by stow: $target => $old_source}
 695              );
 696             return; # XXX #
 697         }
 698
 699         # Does the existing $target actually point to anything?
 700         if (-e $old_path) {
 701             # Does link points to the right place?
 702             if ($old_path eq $path) {
 703                 $self->do_unlink($target);
 704             }
 705
 706             # XXX we quietly ignore links that are stowed to a different
 707             # package.
 708
 709             #elsif (defer($target)) {
 710             #    debug(3, "--- deferring to installation of: $target");
 711             #}
 712             #elsif ($self->override($target)) {
 713             #    debug(3, "--- overriding installation of: $target");
 714             #    $self->do_unlink($target);
 715             #}
 716             #else {
 717             #    $self->conflict(
 718             #        q{existing target is stowed to a different package: %s => %s},
 719             #        $target,
 720             #        $old_source
 721             #    );
 722             #}
 723         }
 724         else {
 725             debug(3, "--- removing invalid link into a stow directory: $path");
 726             $self->do_unlink($target);
 727         }
 728     }
 729     elsif (-e $target) {
 730         debug(3, "Evaluate existing node: $target");
 731         if (-d $target) {
 732             $self->unstow_contents($path, $target);
 733
 734             # This action may have made the parent directory foldable
 735             if (my $parent = $self->foldable($target)) {
 736                 $self->fold_tree($target, $parent);
 737             }
 738         }
 739         else {
 740             $self->conflict(
 741                 qq{existing target is neither a link nor a directory: $target},
 742             );
 743         }
 744     }
 745     else {
 746         debug(3, "$target did not exist to be unstowed");
 747     }
 748     return;
 749 }
 750
 751 #===== METHOD ===============================================================
 752 # Name      : find_stowed_path()
 753 # Purpose   : determine if the given link points to a member of a
 754 #           : stowed package
 755 # Parameters: $target => path to a symbolic link under current directory
 756 #           : $source => where that link points to
 757 # Returns   : relative path to stowed node (from the current directory)
 758 #           : or '' if link is not owned by stow
 759 # Throws    : fatal exception if link is unreadable
 760 # Comments  : allow for stow dir not being under target dir
 761 #           : we could put more logic under here for multiple stow dirs
 762 #============================================================================
 763 sub find_stowed_path {
 764     my $self = shift;
 765     my ($target, $source) = @_;
 766
 767     # Evaluate softlink relative to its target
 768     my $path = join_paths(parent($target), $source);
 769     debug(4, "  is path $path under $self->{stow_path} ?");
 770
 771     # Search for .stow files
 772     my $dir = '';
 773     for my $part (split m{/+}, $path) {
 774         $dir = join_paths($dir, $part);
 775         return $path if $self->protected_dir($dir);
 776     }
 777
 778     # Compare with $self->{stow_path}
 779     my @path = split m{/+}, $path;
 780     my @stow_path = split m{/+}, $self->{stow_path};
 781
 782     # Strip off common prefixes until one is empty
 783     while (@path && @stow_path) {
 784         if ((shift @path) ne (shift @stow_path)) {
 785             debug(4, "    no - either $path not under $self->{stow_path} or vice-versa");
 786             return '';
 787         }
 788     }
 789
 790     if (@stow_path) { # @path must be empty
 791         debug(4, "    no - $path is not under $self->{stow_path}");
 792         return '';
 793     }
 794
 795     debug(4, "    yes - in " . join_paths(@path));
 796     return $path;
 797 }
 798
 799 #===== METHOD ================================================================
 800 # Name      : cleanup_invalid_links()
 801 # Purpose   : clean up invalid links that may block folding
 802 # Parameters: $dir => path to directory to check
 803 # Returns   : n/a
 804 # Throws    : no exceptions
 805 # Comments  : removing files from a stowed package is probably a bad practice
 806 #           : so this kind of clean up is not _really_ stow's responsibility;
 807 #           : however, failing to clean up can block tree folding, so we'll do
 808 #           : it anyway
 809 #=============================================================================
 810 sub cleanup_invalid_links {
 811     my $self = shift;
 812     my ($dir) = @_;
 813
 814     if (not -d $dir) {
 815         error("cleanup_invalid_links() called with a non-directory: $dir");
 816     }
 817
 818     opendir my $DIR, $dir
 819         or error("cannot read directory: $dir");
 820     my @listing = readdir $DIR;
 821     closedir $DIR;
 822
 823     NODE:
 824     for my $node (@listing) {
 825         next NODE if $node eq '.';
 826         next NODE if $node eq '..';
 827
 828         my $node_path = join_paths($dir, $node);
 829
 830         if (-l $node_path and not exists $self->{link_task_for}{$node_path}) {
 831
 832             # Where is the link pointing?
 833             # (don't use read_a_link() here)
 834             my $source = readlink($node_path);
 835             if (not $source) {
 836                 error("Could not read link $node_path");
 837             }
 838
 839             if (
 840                 not -e join_paths($dir, $source) and  # bad link
 841                 $self->find_stowed_path($node_path, $source) # owned by stow
 842             ){
 843                 debug(3, "--- removing stale link: $node_path => " .
 844                           join_paths($dir, $source));
 845                 $self->do_unlink($node_path);
 846             }
 847         }
 848     }
 849     return;
 850 }
 851
 852
 853 #===== METHOD ===============================================================
 854 # Name      : foldable()
 855 # Purpose   : determine if a tree can be folded
 856 # Parameters: $target => path to a directory
 857 # Returns   : path to the parent dir iff the tree can be safely folded
 858 # Throws    : n/a
 859 # Comments  : the path returned is relative to the parent of $target,
 860 #           : that is, it can be used as the source for a replacement symlink
 861 #============================================================================
 862 sub foldable {
 863     my $self = shift;
 864     my ($target) = @_;
 865
 866     debug(3, "--- Is $target foldable?");
 867
 868     opendir my $DIR, $target
 869         or error(qq{Cannot read directory "$target" ($!)\n});
 870     my @listing = readdir $DIR;
 871     closedir $DIR;
 872
 873     my $parent = '';
 874     NODE:
 875     for my $node (@listing) {
 876
 877         next NODE if $node eq '.';
 878         next NODE if $node eq '..';
 879
 880         my $path =  join_paths($target, $node);
 881
 882         # Skip nodes scheduled for removal
 883         next NODE if not $self->is_a_node($path);
 884
 885         # If it's not a link then we can't fold its parent
 886         return '' if not $self->is_a_link($path);
 887
 888         # Where is the link pointing?
 889         my $source = $self->read_a_link($path);
 890         if (not $source) {
 891             error("Could not read link $path");
 892         }
 893         if ($parent eq '') {
 894             $parent = parent($source)
 895         }
 896         elsif ($parent ne parent($source)) {
 897             return '';
 898         }
 899     }
 900     return '' if not $parent;
 901
 902     # If we get here then all nodes inside $target are links, and those links
 903     # point to nodes inside the same directory.
 904
 905     # chop of leading '..' to get the path to the common parent directory
 906     # relative to the parent of our $target
 907     $parent =~ s{\A\.\./}{};
 908
 909     # If the resulting path is owned by stow, we can fold it
 910     if ($self->find_stowed_path($target, $parent)) {
 911         debug(3, "--- $target is foldable");
 912         return $parent;
 913     }
 914     else {
 915         return '';
 916     }
 917 }
 918
 919 #===== METHOD ===============================================================
 920 # Name      : fold_tree()
 921 # Purpose   : fold the given tree
 922 # Parameters: $source  => link to the folded tree source
 923 #           : $target => directory that we will replace with a link to $source
 924 # Returns   : n/a
 925 # Throws    : none
 926 # Comments  : only called iff foldable() is true so we can remove some checks
 927 #============================================================================
 928 sub fold_tree {
 929     my $self = shift;
 930     my ($target, $source) = @_;
 931
 932     debug(3, "--- Folding tree: $target => $source");
 933
 934     opendir my $DIR, $target
 935         or error(qq{Cannot read directory "$target" ($!)\n});
 936     my @listing = readdir $DIR;
 937     closedir $DIR;
 938
 939     NODE:
 940     for my $node (@listing) {
 941         next NODE if $node eq '.';
 942         next NODE if $node eq '..';
 943         next NODE if not $self->is_a_node(join_paths($target, $node));
 944         $self->do_unlink(join_paths($target, $node));
 945     }
 946     $self->do_rmdir($target);
 947     $self->do_link($source, $target);
 948     return;
 949 }
 950
 951
 952 #===== METHOD ===============================================================
 953 # Name      : conflict()
 954 # Purpose   : handle conflicts in stow operations
 955 # Parameters: $format => message printf format
 956 #           : @args   => paths that conflict
 957 # Returns   : n/a
 958 # Throws    : fatal exception unless 'conflicts' option is set
 959 # Comments  : indicates what type of conflict it is
 960 #============================================================================
 961 sub conflict {
 962     my $self = shift;
 963     my ($format, @args) = @_;
 964
 965     my $message = sprintf($format, @args);
 966
 967     debug(1, "CONFLICT: $message");
 968     push @{ $self->{conflicts} }, "CONFLICT: $message\n";
 969     return;
 970 }
 971
 972 =head2 get_conflicts()
 973
 974 Returns a list of all potential conflicts discovered.
 975
 976 =cut
 977
 978 sub get_conflicts {
 979     my $self = shift;
 980     return @{ $self->{conflicts} };
 981 }
 982
 983 =head2 get_tasks()
 984
 985 Returns a list of all symlink/directory creation/removal tasks.
 986
 987 =cut
 988
 989 sub get_tasks {
 990     my $self = shift;
 991     return @{ $self->{tasks} };
 992 }
 993
 994 #===== METHOD ================================================================
 995 # Name      : ignore
 996 # Purpose   : determine if the given path matches a regex in our ignore list
 997 # Parameters: $path
 998 # Returns   : Boolean
 999 # Throws    : no exceptions
1000 # Comments  : none
1001 #=============================================================================
1002 sub ignore {
1003     my $self = shift;
1004     my ($path) = @_;
1005
1006     for my $suffix (@{$self->{'ignore'}}) {
1007         return 1 if $path =~ m/$suffix/;
1008     }
1009     return 0;
1010 }
1011
1012 #===== METHOD ================================================================
1013 # Name      : defer
1014 # Purpose   : determine if the given path matches a regex in our defer list
1015 # Parameters: $path
1016 # Returns   : Boolean
1017 # Throws    : no exceptions
1018 # Comments  : none
1019 #=============================================================================
1020 sub defer {
1021     my $self = shift;
1022     my ($path) = @_;
1023
1024     for my $prefix (@{$self->{'defer'}}) {
1025         return 1 if $path =~ m/$prefix/;
1026     }
1027     return 0;
1028 }
1029
1030 #===== METHOD ================================================================
1031 # Name      : override
1032 # Purpose   : determine if the given path matches a regex in our override list
1033 # Parameters: $path
1034 # Returns   : Boolean
1035 # Throws    : no exceptions
1036 # Comments  : none
1037 #=============================================================================
1038 sub override {
1039     my $self = shift;
1040     my ($path) = @_;
1041
1042     for my $regex (@{$self->{'override'}}) {
1043         return 1 if $path =~ m/$regex/;
1044     }
1045     return 0;
1046 }
1047
1048 ##############################################################################
1049 #
1050 # The following code provides the abstractions that allow us to defer operating
1051 # on the filesystem until after all potential conflcits have been assessed.
1052 #
1053 ##############################################################################
1054
1055 #===== METHOD ===============================================================
1056 # Name      : process_tasks()
1057 # Purpose   : process each task in the tasks list
1058 # Parameters: none
1059 # Returns   : n/a
1060 # Throws    : fatal error if tasks list is corrupted or a task fails
1061 # Comments  : none
1062 #============================================================================
1063 sub process_tasks {
1064     my $self = shift;
1065
1066     debug(2, "Processing tasks...");
1067
1068     if ($self->{'simulate'}) {
1069         warn "WARNING: simulating so all operations are deferred.\n";
1070         return;
1071     }
1072
1073     # Strip out all tasks with a skip action
1074     $self->{tasks} = [ grep { $_->{'action'} ne 'skip' } @{ $self->{tasks} } ];
1075
1076     if (not @{ $self->{tasks} }) {
1077         warn "There are no outstanding operations to perform.\n";
1078         return;
1079     }
1080
1081     $self->within_target_do(sub {
1082         for my $task (@{ $self->{tasks} }) {
1083             $self->process_task($task);
1084         }
1085     });
1086
1087     debug(2, "Processing tasks... done");
1088 }
1089
1090 #===== METHOD ===============================================================
1091 # Name      : process_task()
1092 # Purpose   : process a single task
1093 # Parameters: $task => the task to process
1094 # Returns   : n/a
1095 # Throws    : fatal error if task fails
1096 # Comments  : Must run from within target directory.
1097 #           : Task involve either creating or deleting dirs and symlinks
1098 #           : an action is set to 'skip' if it is found to be redundant
1099 #============================================================================
1100 sub process_task {
1101     my $self = shift;
1102     my ($task) = @_;
1103
1104     if ($task->{'action'} eq 'create') {
1105         if ($task->{'type'} eq 'dir') {
1106             mkdir($task->{'path'}, 0777)
1107                 or error(qq(Could not create directory: $task->{'path'}));
1108         }
1109         elsif ($task->{'type'} eq 'link') {
1110             symlink $task->{'source'}, $task->{'path'}
1111                 or error(
1112                     q(Could not create symlink: %s => %s),
1113                     $task->{'path'},
1114                     $task->{'source'}
1115             );
1116         }
1117         else {
1118             internal_error(qq(bad task type: $task->{'type'}));
1119         }
1120     }
1121     elsif ($task->{'action'} eq 'remove') {
1122         if ($task->{'type'} eq 'dir') {
1123             rmdir $task->{'path'}
1124                 or error(qq(Could not remove directory: $task->{'path'}));
1125         }
1126         elsif ($task->{'type'} eq 'link') {
1127             unlink $task->{'path'}
1128                 or error(qq(Could not remove link: $task->{'path'}));
1129         }
1130         else {
1131             internal_error(qq(bad task type: $task->{'type'}));
1132         }
1133     }
1134     else {
1135         internal_error(qq(bad task action: $task->{'action'}));
1136     }
1137 }
1138
1139 #===== METHOD ===============================================================
1140 # Name      : link_task_action()
1141 # Purpose   : finds the link task action for the given path, if there is one
1142 # Parameters: $path
1143 # Returns   : 'remove', 'create', or '' if there is no action
1144 # Throws    : a fatal exception if an invalid action is found
1145 # Comments  : none
1146 #============================================================================
1147 sub link_task_action {
1148     my $self = shift;
1149     my ($path) = @_;
1150
1151     if (! exists $self->{link_task_for}{$path}) {
1152         debug(4, "  link_task_action($path): no task");
1153         return '';
1154     }
1155
1156     my $action = $self->{link_task_for}{$path}->{'action'};
1157     internal_error("bad task action: $action")
1158         unless $action eq 'remove' or $action eq 'create';
1159
1160     debug(4, "  link_task_action($path): link task exists with action $action");
1161     return $action;
1162 }
1163
1164 #===== METHOD ===============================================================
1165 # Name      : dir_task_action()
1166 # Purpose   : finds the dir task action for the given path, if there is one
1167 # Parameters: $path
1168 # Returns   : 'remove', 'create', or '' if there is no action
1169 # Throws    : a fatal exception if an invalid action is found
1170 # Comments  : none
1171 #============================================================================
1172 sub dir_task_action {
1173     my $self = shift;
1174     my ($path) = @_;
1175
1176     if (! exists $self->{dir_task_for}{$path}) {
1177         debug(4, "  dir_task_action($path): no task");
1178         return '';
1179     }
1180
1181     my $action = $self->{dir_task_for}{$path}->{'action'};
1182     internal_error("bad task action: $action")
1183         unless $action eq 'remove' or $action eq 'create';
1184
1185     debug(4, "  dir_task_action($path): dir task exists with action $action");
1186     return $action;
1187 }
1188
1189 #===== METHOD ===============================================================
1190 # Name      : parent_link_scheduled_for_removal()
1191 # Purpose   : determines whether the given path or any parent thereof
1192 #           : is a link scheduled for removal
1193 # Parameters: $path
1194 # Returns   : Boolean
1195 # Throws    : none
1196 # Comments  : none
1197 #============================================================================
1198 sub parent_link_scheduled_for_removal {
1199     my $self = shift;
1200     my ($path) = @_;
1201
1202     my $prefix = '';
1203     for my $part (split m{/+}, $path) {
1204         $prefix = join_paths($prefix, $part);
1205         debug(4, "    parent_link_scheduled_for_removal($path): prefix $prefix");
1206         if (exists $self->{link_task_for}{$prefix} and
1207              $self->{link_task_for}{$prefix}->{'action'} eq 'remove') {
1208             debug(4, "    parent_link_scheduled_for_removal($path): link scheduled for removal");
1209             return 1;
1210         }
1211     }
1212
1213     debug(4, "    parent_link_scheduled_for_removal($path): returning false");
1214     return 0;
1215 }
1216
1217 #===== METHOD ===============================================================
1218 # Name      : is_a_link()
1219 # Purpose   : is the given path a current or planned link
1220 # Parameters: $path
1221 # Returns   : Boolean
1222 # Throws    : none
1223 # Comments  : returns false if an existing link is scheduled for removal
1224 #           : and true if a non-existent link is scheduled for creation
1225 #============================================================================
1226 sub is_a_link {
1227     my $self = shift;
1228     my ($path) = @_;
1229     debug(4, "  is_a_link($path)");
1230
1231     if (my $action = $self->link_task_action($path)) {
1232         if ($action eq 'remove') {
1233             return 0;
1234         }
1235         elsif ($action eq 'create') {
1236             return 1;
1237         }
1238     }
1239
1240     if (-l $path) {
1241         # Check if any of its parent are links scheduled for removal
1242         # (need this for edge case during unfolding)
1243         debug(4, "  is_a_link($path): is a real link");
1244         return $self->parent_link_scheduled_for_removal($path) ? 0 : 1;
1245     }
1246
1247     debug(4, "  is_a_link($path): returning false");
1248     return 0;
1249 }
1250
1251 #===== METHOD ===============================================================
1252 # Name      : is_a_dir()
1253 # Purpose   : is the given path a current or planned directory
1254 # Parameters: $path
1255 # Returns   : Boolean
1256 # Throws    : none
1257 # Comments  : returns false if an existing directory is scheduled for removal
1258 #           : and true if a non-existent directory is scheduled for creation
1259 #           : we also need to be sure we are not just following a link
1260 #============================================================================
1261 sub is_a_dir {
1262     my $self = shift;
1263     my ($path) = @_;
1264     debug(4, "  is_a_dir($path)");
1265
1266     if (my $action = $self->dir_task_action($path)) {
1267         if ($action eq 'remove') {
1268             return 0;
1269         }
1270         elsif ($action eq 'create') {
1271             return 1;
1272         }
1273     }
1274
1275     return 0 if $self->parent_link_scheduled_for_removal($path);
1276
1277     if (-d $path) {
1278         debug(4, "  is_a_dir($path): real dir");
1279         return 1;
1280     }
1281
1282     debug(4, "  is_a_dir($path): returning false");
1283     return 0;
1284 }
1285
1286 #===== METHOD ===============================================================
1287 # Name      : is_a_node()
1288 # Purpose   : is the given path a current or planned node
1289 # Parameters: $path
1290 # Returns   : Boolean
1291 # Throws    : none
1292 # Comments  : returns false if an existing node is scheduled for removal
1293 #           : true if a non-existent node is scheduled for creation
1294 #           : we also need to be sure we are not just following a link
1295 #============================================================================
1296 sub is_a_node {
1297     my $self = shift;
1298     my ($path) = @_;
1299     debug(4, "  is_a_node($path)");
1300
1301     my $laction = $self->link_task_action($path);
1302     my $daction = $self->dir_task_action($path);
1303
1304     if ($laction eq 'remove') {
1305         if ($daction eq 'remove') {
1306             internal_error("removing link and dir: $path");
1307             return 0;
1308         }
1309         elsif ($daction eq 'create') {
1310             # Assume that we're unfolding $path, and that the link
1311             # removal action is earlier than the dir creation action
1312             # in the task queue.  FIXME: is this a safe assumption?
1313             return 1;
1314         }
1315         else { # no dir action
1316             return 0;
1317         }
1318     }
1319     elsif ($laction eq 'create') {
1320         if ($daction eq 'remove') {
1321             # Assume that we're folding $path, and that the dir
1322             # removal action is earlier than the link creation action
1323             # in the task queue.  FIXME: is this a safe assumption?
1324             return 1;
1325         }
1326         elsif ($daction eq 'create') {
1327             internal_error("creating link and dir: $path");
1328             return 1;
1329         }
1330         else { # no dir action
1331             return 1;
1332         }
1333     }
1334     else {
1335         # No link action
1336         if ($daction eq 'remove') {
1337             return 0;
1338         }
1339         elsif ($daction eq 'create') {
1340             return 1;
1341         }
1342         else { # no dir action
1343             # fall through to below
1344         }
1345     }
1346
1347     return 0 if $self->parent_link_scheduled_for_removal($path);
1348
1349     if (-e $path) {
1350         debug(4, "  is_a_node($path): really exists");
1351         return 1;
1352     }
1353
1354     debug(4, "  is_a_node($path): returning false");
1355     return 0;
1356 }
1357
1358 #===== METHOD ===============================================================
1359 # Name      : read_a_link()
1360 # Purpose   : return the source of a current or planned link
1361 # Parameters: $path => path to the link target
1362 # Returns   : a string
1363 # Throws    : fatal exception if the given path is not a current or planned
1364 #           : link
1365 # Comments  : none
1366 #============================================================================
1367 sub read_a_link {
1368     my $self = shift;
1369     my ($path) = @_;
1370
1371     if (my $action = $self->link_task_action($path)) {
1372         debug(4, "  read_a_link($path): task exists with action $action");
1373
1374         if ($action eq 'create') {
1375             return $self->{link_task_for}{$path}->{'source'};
1376         }
1377         elsif ($action eq 'remove') {
1378             internal_error(
1379                 "read_a_link() passed a path that is scheduled for removal: $path"
1380             );
1381         }
1382     }
1383     elsif (-l $path) {
1384         debug(4, "  read_a_link($path): real link");
1385         return readlink $path
1386             or error("Could not read link: $path");
1387     }
1388     internal_error("read_a_link() passed a non link path: $path\n");
1389 }
1390
1391 #===== METHOD ===============================================================
1392 # Name      : do_link()
1393 # Purpose   : wrap 'link' operation for later processing
1394 # Parameters: $oldfile => the existing file to link to
1395 #           : $newfile => the file to link
1396 # Returns   : n/a
1397 # Throws    : error if this clashes with an existing planned operation
1398 # Comments  : cleans up operations that undo previous operations
1399 #============================================================================
1400 sub do_link {
1401     my $self = shift;
1402     my ($oldfile, $newfile) = @_;
1403
1404     if (exists $self->{dir_task_for}{$newfile}) {
1405         my $task_ref = $self->{dir_task_for}{$newfile};
1406
1407         if ($task_ref->{'action'} eq 'create') {
1408             if ($task_ref->{'type'} eq 'dir') {
1409                 internal_error(
1410                     "new link (%s => %s) clashes with planned new directory",
1411                     $newfile,
1412                     $oldfile,
1413                 );
1414             }
1415         }
1416         elsif ($task_ref->{'action'} eq 'remove') {
1417             # We may need to remove a directory before creating a link so continue.
1418         }
1419         else {
1420             internal_error("bad task action: $task_ref->{'action'}");
1421         }
1422     }
1423
1424     if (exists $self->{link_task_for}{$newfile}) {
1425         my $task_ref = $self->{link_task_for}{$newfile};
1426
1427         if ($task_ref->{'action'} eq 'create') {
1428             if ($task_ref->{'source'} ne $oldfile) {
1429                 internal_error(
1430                     "new link clashes with planned new link: %s => %s",
1431                     $task_ref->{'path'},
1432                     $task_ref->{'source'},
1433                 )
1434             }
1435             else {
1436                 debug(1, "LINK: $newfile => $oldfile (duplicates previous action)");
1437                 return;
1438             }
1439         }
1440         elsif ($task_ref->{'action'} eq 'remove') {
1441             if ($task_ref->{'source'} eq $oldfile) {
1442                 # No need to remove a link we are going to recreate
1443                 debug(1, "LINK: $newfile => $oldfile (reverts previous action)");
1444                 $self->{link_task_for}{$newfile}->{'action'} = 'skip';
1445                 delete $self->{link_task_for}{$newfile};
1446                 return;
1447             }
1448             # We may need to remove a link to replace it so continue
1449         }
1450         else {
1451             internal_error("bad task action: $task_ref->{'action'}");
1452         }
1453     }
1454
1455     # Creating a new link
1456     debug(1, "LINK: $newfile => $oldfile");
1457     my $task = {
1458         action  => 'create',
1459         type    => 'link',
1460         path    => $newfile,
1461         source  => $oldfile,
1462     };
1463     push @{ $self->{tasks} }, $task;
1464     $self->{link_task_for}{$newfile} = $task;
1465
1466     return;
1467 }
1468
1469 #===== METHOD ===============================================================
1470 # Name      : do_unlink()
1471 # Purpose   : wrap 'unlink' operation for later processing
1472 # Parameters: $file => the file to unlink
1473 # Returns   : n/a
1474 # Throws    : error if this clashes with an existing planned operation
1475 # Comments  : will remove an existing planned link
1476 #============================================================================
1477 sub do_unlink {
1478     my $self = shift;
1479     my ($file) = @_;
1480
1481     if (exists $self->{link_task_for}{$file}) {
1482         my $task_ref = $self->{link_task_for}{$file};
1483         if ($task_ref->{'action'} eq 'remove') {
1484             debug(1, "UNLINK: $file (duplicates previous action)");
1485             return;
1486         }
1487         elsif ($task_ref->{'action'} eq 'create') {
1488             # Do need to create a link then remove it
1489             debug(1, "UNLINK: $file (reverts previous action)");
1490             $self->{link_task_for}{$file}->{'action'} = 'skip';
1491             delete $self->{link_task_for}{$file};
1492             return;
1493         }
1494         else {
1495             internal_error("bad task action: $task_ref->{'action'}");
1496         }
1497     }
1498
1499     if (exists $self->{dir_task_for}{$file} and $self->{dir_task_for}{$file} eq 'create') {
1500         internal_error(
1501             "new unlink operation clashes with planned operation: %s dir %s",
1502             $self->{dir_task_for}{$file}->{'action'},
1503             $file
1504         );
1505     }
1506
1507     # Remove the link
1508     debug(1, "UNLINK: $file");
1509
1510     my $source = readlink $file or error("could not readlink $file");
1511
1512     my $task = {
1513         action  => 'remove',
1514         type    => 'link',
1515         path    => $file,
1516         source  => $source,
1517     };
1518     push @{ $self->{tasks} }, $task;
1519     $self->{link_task_for}{$file} = $task;
1520
1521     return;
1522 }
1523
1524 #===== METHOD ===============================================================
1525 # Name      : do_mkdir()
1526 # Purpose   : wrap 'mkdir' operation
1527 # Parameters: $dir => the directory to remove
1528 # Returns   : n/a
1529 # Throws    : fatal exception if operation fails
1530 # Comments  : outputs a message if 'verbose' option is set
1531 #           : does not perform operation if 'simulate' option is set
1532 # Comments  : cleans up operations that undo previous operations
1533 #============================================================================
1534 sub do_mkdir {
1535     my $self = shift;
1536     my ($dir) = @_;
1537
1538     if (exists $self->{link_task_for}{$dir}) {
1539         my $task_ref = $self->{link_task_for}{$dir};
1540
1541         if ($task_ref->{'action'} eq 'create') {
1542             internal_error(
1543                 "new dir clashes with planned new link (%s => %s)",
1544                 $task_ref->{'path'},
1545                 $task_ref->{'source'},
1546             );
1547         }
1548         elsif ($task_ref->{'action'} eq 'remove') {
1549             # May need to remove a link before creating a directory so continue
1550         }
1551         else {
1552             internal_error("bad task action: $task_ref->{'action'}");
1553         }
1554     }
1555
1556     if (exists $self->{dir_task_for}{$dir}) {
1557         my $task_ref = $self->{dir_task_for}{$dir};
1558
1559         if ($task_ref->{'action'} eq 'create') {
1560             debug(1, "MKDIR: $dir (duplicates previous action)");
1561             return;
1562         }
1563         elsif ($task_ref->{'action'} eq 'remove') {
1564             debug(1, "MKDIR: $dir (reverts previous action)");
1565             $self->{dir_task_for}{$dir}->{'action'} = 'skip';
1566             delete $self->{dir_task_for}{$dir};
1567             return;
1568         }
1569         else {
1570             internal_error("bad task action: $task_ref->{'action'}");
1571         }
1572     }
1573
1574     debug(1, "MKDIR: $dir");
1575     my $task = {
1576         action  => 'create',
1577         type    => 'dir',
1578         path    => $dir,
1579         source  => undef,
1580     };
1581     push @{ $self->{tasks} }, $task;
1582     $self->{dir_task_for}{$dir} = $task;
1583
1584     return;
1585 }
1586
1587 #===== METHOD ===============================================================
1588 # Name      : do_rmdir()
1589 # Purpose   : wrap 'rmdir' operation
1590 # Parameters: $dir => the directory to remove
1591 # Returns   : n/a
1592 # Throws    : fatal exception if operation fails
1593 # Comments  : outputs a message if 'verbose' option is set
1594 #           : does not perform operation if 'simulate' option is set
1595 #============================================================================
1596 sub do_rmdir {
1597     my $self = shift;
1598     my ($dir) = @_;
1599
1600     if (exists $self->{link_task_for}{$dir}) {
1601         my $task_ref = $self->{link_task_for}{$dir};
1602         internal_error(
1603             "rmdir clashes with planned operation: %s link %s => %s",
1604             $task_ref->{'action'},
1605             $task_ref->{'path'},
1606             $task_ref->{'source'}
1607         );
1608     }
1609
1610     if (exists $self->{dir_task_for}{$dir}) {
1611         my $task_ref = $self->{link_task_for}{$dir};
1612
1613         if ($task_ref->{'action'} eq 'remove') {
1614             debug(1, "RMDIR $dir (duplicates previous action)");
1615             return;
1616         }
1617         elsif ($task_ref->{'action'} eq 'create') {
1618             debug(1, "MKDIR $dir (reverts previous action)");
1619             $self->{link_task_for}{$dir}->{'action'} = 'skip';
1620             delete $self->{link_task_for}{$dir};
1621             return;
1622         }
1623         else {
1624             internal_error("bad task action: $task_ref->{'action'}");
1625         }
1626     }
1627
1628     debug(1, "RMDIR $dir");
1629     my $task = {
1630         action  => 'remove',
1631         type    => 'dir',
1632         path    => $dir,
1633         source  => '',
1634     };
1635     push @{ $self->{tasks} }, $task;
1636     $self->{dir_task_for}{$dir} = $task;
1637
1638     return;
1639 }
1640
1641
1642 #############################################################################
1643 #
1644 # End of methods; subroutines follow.
1645 # FIXME: Ideally these should be in a separate module.
1646
1647
1648 #===== PRIVATE SUBROUTINE ===================================================
1649 # Name      : internal_error()
1650 # Purpose   : output internal error message in a consistent form and die
1651 # Parameters: $message => error message to output
1652 # Returns   : n/a
1653 # Throws    : n/a
1654 # Comments  : none
1655 #============================================================================
1656 sub internal_error {
1657     my ($format, @args) = @_;
1658     die "$ProgramName: INTERNAL ERROR: " . sprintf($format, @args) . "\n",
1659         "This _is_ a bug. Please submit a bug report so we can fix it:-)\n";
1660 }
1661
1662 =head1 BUGS
1663
1664 =head1 SEE ALSO
1665
1666 =cut
1667
1668 1;
1669
1670 # Local variables:
1671 # mode: perl
1672 # cperl-indent-level: 4
1673 # end:
1674 # vim: ft=perl