lib/Stow.pm.in

   1 #!/usr/bin/perl
   2 #
   3 # This file is part of GNU Stow.
   4 #
   5 # GNU Stow is free software: you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # GNU Stow is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program. If not, see https://www.gnu.org/licenses/.
  17
  18 package Stow;
  19
  20 =head1 NAME
  21
  22 Stow - manage farms of symbolic links
  23
  24 =head1 SYNOPSIS
  25
  26     my $stow = new Stow(%$options);
  27
  28     $stow->plan_unstow(@pkgs_to_unstow);
  29     $stow->plan_stow  (@pkgs_to_stow);
  30
  31     my %conflicts = $stow->get_conflicts;
  32     $stow->process_tasks() unless %conflicts;
  33
  34 =head1 DESCRIPTION
  35
  36 This is the backend Perl module for GNU Stow, a program for managing
  37 the installation of software packages, keeping them separate
  38 (C</usr/local/stow/emacs> vs. C</usr/local/stow/perl>, for example)
  39 while making them appear to be installed in the same place
  40 (C</usr/local>).
  41
  42 Stow doesn't store an extra state between runs, so there's no danger
  43 of mangling directories when file hierarchies don't match the
  44 database. Also, stow will never delete any files, directories, or
  45 links that appear in a stow directory, so it is always possible to
  46 rebuild the target tree.
  47
  48 =cut
  49
  50 use strict;
  51 use warnings;
  52
  53 use Carp qw(carp cluck croak confess longmess);
  54 use File::Copy qw(move);
  55 use File::Spec;
  56 use POSIX qw(getcwd);
  57
  58 use Stow::Util qw(set_debug_level debug error set_test_mode
  59                   join_paths restore_cwd canon_path parent adjust_dotfile);
  60
  61 our $ProgramName = 'stow';
  62 our $VERSION = '@VERSION@';
  63
  64 our $LOCAL_IGNORE_FILE  = '.stow-local-ignore';
  65 our $GLOBAL_IGNORE_FILE = '.stow-global-ignore';
  66
  67 our @default_global_ignore_regexps =
  68     __PACKAGE__->get_default_global_ignore_regexps();
  69
  70 # These are the default options for each Stow instance.
  71 our %DEFAULT_OPTIONS = (
  72     conflicts    => 0,
  73     simulate     => 0,
  74     verbose      => 0,
  75     paranoid     => 0,
  76     compat       => 0,
  77     test_mode    => 0,
  78     dotfiles     => 0,
  79     adopt        => 0,
  80     'no-folding' => 0,
  81     ignore       => [],
  82     override     => [],
  83     defer        => [],
  84 );
  85
  86 =head1 CONSTRUCTORS
  87
  88 =head2 new(%options)
  89
  90 =head3 Required options
  91
  92 =over 4
  93
  94 =item * dir - the stow directory
  95
  96 =item * target - the target directory
  97
  98 =back
  99
 100 =head3 Non-mandatory options
 101
 102 See the documentation for the F<stow> CLI front-end for information on these.
 103
 104 =over 4
 105
 106 =item * conflicts
 107
 108 =item * simulate
 109
 110 =item * verbose
 111
 112 =item * paranoid
 113
 114 =item * compat
 115
 116 =item * test_mode
 117
 118 =item * adopt
 119
 120 =item * no-folding
 121
 122 =item * ignore
 123
 124 =item * override
 125
 126 =item * defer
 127
 128 =back
 129
 130 N.B. This sets the current working directory to the target directory.
 131
 132 =cut
 133
 134 sub new {
 135     my $self = shift;
 136     my $class = ref($self) || $self;
 137     my %opts = @_;
 138
 139     my $new = bless { }, $class;
 140
 141     $new->{action_count} = 0;
 142
 143     for my $required_arg (qw(dir target)) {
 144         croak "$class->new() called without '$required_arg' parameter\n"
 145             unless exists $opts{$required_arg};
 146         $new->{$required_arg} = delete $opts{$required_arg};
 147     }
 148
 149     for my $opt (keys %DEFAULT_OPTIONS) {
 150         $new->{$opt} = exists $opts{$opt} ? delete $opts{$opt}
 151                                           : $DEFAULT_OPTIONS{$opt};
 152     }
 153
 154     if (%opts) {
 155         croak "$class->new() called with unrecognised parameter(s): ",
 156             join(", ", keys %opts), "\n";
 157     }
 158
 159     set_debug_level($new->get_verbosity());
 160     set_test_mode($new->{test_mode});
 161     $new->set_stow_dir();
 162     $new->init_state();
 163
 164     return $new;
 165 }
 166
 167 sub get_verbosity {
 168     my $self = shift;
 169
 170     return $self->{verbose} unless $self->{test_mode};
 171
 172     return 0 unless exists $ENV{TEST_VERBOSE};
 173     return 0 unless length $ENV{TEST_VERBOSE};
 174
 175     # Convert TEST_VERBOSE=y into numeric value
 176     $ENV{TEST_VERBOSE} = 3 if $ENV{TEST_VERBOSE} !~ /^\d+$/;
 177
 178     return $ENV{TEST_VERBOSE};
 179 }
 180
 181 =head2 set_stow_dir([$dir])
 182
 183 Sets a new stow directory.  This allows the use of multiple stow
 184 directories within one Stow instance, e.g.
 185
 186     $stow->plan_stow('foo');
 187     $stow->set_stow_dir('/different/stow/dir');
 188     $stow->plan_stow('bar');
 189     $stow->process_tasks;
 190
 191 If C<$dir> is omitted, uses the value of the C<dir> parameter passed
 192 to the L<new()> constructor.
 193
 194 =cut
 195
 196 sub set_stow_dir {
 197     my $self = shift;
 198     my ($dir) = @_;
 199     if (defined $dir) {
 200         $self->{dir} = $dir;
 201     }
 202
 203     my $stow_dir = canon_path($self->{dir});
 204     my $target = canon_path($self->{target});
 205
 206     # Calculate relative path from target directory to stow directory.
 207     # This will be commonly used as a prefix for constructing and
 208     # recognising symlinks "installed" in the target directory which
 209     # point to package files under the stow directory.
 210     $self->{stow_path} = File::Spec->abs2rel($stow_dir, $target);
 211
 212     debug(2, 0, "stow dir is $stow_dir");
 213     debug(2, 0, "stow dir path relative to target $target is $self->{stow_path}");
 214 }
 215
 216 sub init_state {
 217     my $self = shift;
 218
 219     # Store conflicts during pre-processing
 220     $self->{conflicts}      = {};
 221     $self->{conflict_count} = 0;
 222
 223     # Store command line packages to stow (-S and -R)
 224     $self->{pkgs_to_stow}   = [];
 225
 226     # Store command line packages to unstow (-D and -R)
 227     $self->{pkgs_to_delete} = [];
 228
 229     # The following structures are used by the abstractions that allow us to
 230     # defer operating on the filesystem until after all potential conflicts have
 231     # been assessed.
 232
 233     # $self->{tasks}:  list of operations to be performed (in order)
 234     # each element is a hash ref of the form
 235     #   {
 236     #       action => ...  ('create' or 'remove' or 'move')
 237     #       type   => ...  ('link' or 'dir' or 'file')
 238     #       path   => ...  (unique)
 239     #       source => ...  (only for links)
 240     #       dest   => ...  (only for moving files)
 241     #   }
 242     $self->{tasks} = [];
 243
 244     # $self->{dir_task_for}: map a path to the corresponding directory task reference
 245     # This structure allows us to quickly determine if a path has an existing
 246     # directory task associated with it.
 247     $self->{dir_task_for} = {};
 248
 249     # $self->{link_task_for}: map a path to the corresponding directory task reference
 250     # This structure allows us to quickly determine if a path has an existing
 251     # directory task associated with it.
 252     $self->{link_task_for} = {};
 253
 254     # N.B.: directory tasks and link tasks are NOT mutually exclusive due
 255     # to tree splitting (which involves a remove link task followed by
 256     # a create directory task).
 257 }
 258
 259 =head1 METHODS
 260
 261 =head2 plan_unstow(@packages)
 262
 263 Plan which symlink/directory creation/removal tasks need to be executed
 264 in order to unstow the given packages.  Any potential conflicts are then
 265 accessible via L<get_conflicts()>.
 266
 267 =cut
 268
 269 sub plan_unstow {
 270     my $self = shift;
 271     my @packages = @_;
 272
 273     return unless @packages;
 274
 275     debug(2, 0, "Planning unstow of: @packages ...");
 276
 277     $self->within_target_do(sub {
 278         for my $package (@packages) {
 279             my $pkg_path = join_paths($self->{stow_path}, $package);
 280             if (not -d $pkg_path) {
 281                 error("The stow directory $self->{stow_path} does not contain package $package");
 282             }
 283             debug(2, 0, "Planning unstow of package $package...");
 284             $self->unstow_contents(
 285                 $package,
 286                 '.',
 287                 $pkg_path,
 288             );
 289             debug(2, 0, "Planning unstow of package $package... done");
 290             $self->{action_count}++;
 291         }
 292     });
 293 }
 294
 295 =head2 plan_stow(@packages)
 296
 297 Plan which symlink/directory creation/removal tasks need to be executed
 298 in order to stow the given packages.  Any potential conflicts are then
 299 accessible via L<get_conflicts()>.
 300
 301 =cut
 302
 303 sub plan_stow {
 304     my $self = shift;
 305     my @packages = @_;
 306
 307     return unless @packages;
 308
 309     debug(2, 0, "Planning stow of: @packages ...");
 310
 311     $self->within_target_do(sub {
 312         for my $package (@packages) {
 313             my $pkg_path = join_paths($self->{stow_path}, $package);
 314             if (not -d $pkg_path) {
 315                 error("The stow directory $self->{stow_path} does not contain package $package");
 316             }
 317             debug(2, 0, "Planning stow of package $package...");
 318             $self->stow_contents(
 319                 $self->{stow_path},
 320                 $package,
 321                 '.',
 322                 $pkg_path, # source from target
 323                 0,
 324             );
 325             debug(2, 0, "Planning stow of package $package... done");
 326             $self->{action_count}++;
 327         }
 328     });
 329 }
 330
 331 =head2 within_target_do($code)
 332
 333 Execute code within target directory, preserving cwd.
 334
 335 =over 4
 336
 337 =item $code
 338
 339 Anonymous subroutine to execute within target dir.
 340
 341 =back
 342
 343 This is done to ensure that the consumer of the Stow interface doesn't
 344 have to worry about (a) what their cwd is, and (b) that their cwd
 345 might change.
 346
 347 =cut
 348
 349 sub within_target_do {
 350     my $self = shift;
 351     my ($code) = @_;
 352
 353     my $cwd = getcwd();
 354     chdir($self->{target})
 355         or error("Cannot chdir to target tree: $self->{target} ($!)");
 356     debug(3, 0, "cwd now $self->{target}");
 357
 358     $self->$code();
 359
 360     restore_cwd($cwd);
 361     debug(3, 0, "cwd restored to $cwd");
 362 }
 363
 364 =head2 stow_contents($stow_path, $package, $target_subdir, $source)
 365
 366 Stow the contents of the given directory.
 367
 368 =over 4
 369
 370 =item $stow_path
 371
 372 Relative path from current (i.e. target) directory to the stow dir
 373 containing the package to be stowed.  This can differ from
 374 C<$self->{stow_path}> when unfolding a (sub)tree which is already
 375 stowed from a package in a different stow directory (see the "Multiple
 376 Stow Directories" section of the manual).
 377
 378 =item $package
 379
 380 The package whose contents are being stowed.
 381
 382 =item $target_subdir
 383
 384 Subpath relative to package directory which needs stowing as a symlink
 385 at subpath relative to target directory.
 386
 387 =item $source
 388
 389 Relative path from the (sub)dir of target to symlink source.
 390
 391 =back
 392
 393 C<stow_node()> and C<stow_contents()> are mutually recursive.
 394 C<$source> and C<$target_subdir> are used for creating the symlink.
 395
 396 =cut
 397
 398 sub stow_contents {
 399     my $self = shift;
 400     my ($stow_path, $package, $target_subdir, $source, $level) = @_;
 401
 402     # Calculate the path to the package directory or sub-directory
 403     # whose contents need to be stowed, relative to the current
 404     # (target directory).  This is needed so that we can check it's a
 405     # valid directory, and can read its contents to iterate over them.
 406     #
 407     # Note that $source refers to the same package (sub-)directory,
 408     # but instead it's relative to the target directory or
 409     # sub-directory where the symlink will be installed when the plans
 410     # are executed.
 411
 412     # Remove leading $level times .. from $source
 413     my $n = 0;
 414     my $path = join '/', map { (++$n <= $level) ? ( ) : $_ } (split m{/+}, $source);
 415
 416     return if $self->should_skip_target($target_subdir);
 417
 418     my $cwd = getcwd();
 419     my $msg = "Stowing contents of $path (cwd=$cwd)";
 420     $msg =~ s!$ENV{HOME}(/|$)!~$1!g;
 421     debug(3, 0, $msg);
 422     debug(4, 1, "=> $source");
 423
 424     error("stow_contents() called with non-directory package path: $path")
 425         unless -d $path;
 426     error("stow_contents() called with non-directory target: $target_subdir")
 427         unless $self->is_a_node($target_subdir);
 428
 429     opendir my $DIR, $path
 430         or error("cannot read directory: $path ($!)");
 431     my @listing = readdir $DIR;
 432     closedir $DIR;
 433
 434     NODE:
 435     for my $node (@listing) {
 436         next NODE if $node eq '.';
 437         next NODE if $node eq '..';
 438         my $node_target = join_paths($target_subdir, $node);
 439         next NODE if $self->ignore($stow_path, $package, $node_target);
 440
 441         if ($self->{dotfiles}) {
 442             my $adj_node_target = adjust_dotfile($node_target);
 443             debug(4, 1, "Adjusting: $node_target => $adj_node_target");
 444             $node_target = $adj_node_target;
 445         }
 446
 447         $self->stow_node(
 448             $stow_path,
 449             $package,
 450             $node_target,  # target, potentially adjusted for dot- prefix
 451             join_paths($source, $node),   # source
 452             $level
 453         );
 454     }
 455 }
 456
 457 =head2 stow_node($stow_path, $package, $target_subpath, $source)
 458
 459 Stow the given node
 460
 461 =over 4
 462
 463 =item $stow_path
 464
 465 Relative path from current (i.e. target) directory to the stow dir
 466 containing the node to be stowed.  This can differ from
 467 C<$self->{stow_path}> when unfolding a (sub)tree which is already
 468 stowed from a package in a different stow directory (see the "Multiple
 469 Stow Directories" section of the manual).
 470
 471 =item $package
 472
 473 The package containing the node being stowed
 474
 475 =item $target_subpath
 476
 477 Subpath relative to package directory of node which needs stowing as a
 478 symlink at subpath relative to target directory.
 479
 480 =item $source
 481
 482 Relative path to symlink source from the dir of target.
 483
 484 =back
 485
 486 C<stow_node()> and C<stow_contents()> are mutually recursive.
 487 C<$source> and C<$target_subpath> are used for creating the symlink.
 488 C<$target_subpath> is used for folding/unfolding trees as necessary.
 489
 490 =cut
 491
 492 sub stow_node {
 493     my $self = shift;
 494     my ($stow_path, $package, $target_subpath, $source, $level) = @_;
 495
 496     my $path = join_paths($stow_path, $package, $target_subpath);
 497
 498     debug(3, 0, "Stowing entry $stow_path / $package / $target_subpath");
 499     debug(4, 1, "=> $source");
 500
 501     # Don't try to stow absolute symlinks (they can't be unstowed)
 502     if (-l $source) {
 503         my $second_source = $self->read_a_link($source);
 504         if ($second_source =~ m{\A/}) {
 505             $self->conflict(
 506                 'stow',
 507                 $package,
 508                 "source is an absolute symlink $source => $second_source"
 509             );
 510             debug(3, 0, "Absolute symlinks cannot be unstowed");
 511             return;
 512         }
 513     }
 514
 515     # Does the target already exist?
 516     if ($self->is_a_link($target_subpath)) {
 517         # Where is the link pointing?
 518         my $existing_link_dest = $self->read_a_link($target_subpath);
 519         if (not $existing_link_dest) {
 520             error("Could not read link: $target_subpath");
 521         }
 522         debug(4, 1, "Evaluate existing link: $target_subpath => $existing_link_dest");
 523
 524         # Does it point to a node under any stow directory?
 525         my ($existing_path, $existing_stow_path, $existing_package) =
 526             $self->find_stowed_path($target_subpath, $existing_link_dest);
 527         if (not $existing_path) {
 528             $self->conflict(
 529                 'stow',
 530                 $package,
 531                 "existing target is not owned by stow: $target_subpath"
 532             );
 533             return; # XXX #
 534         }
 535
 536         # Does the existing $target_subpath actually point to anything?
 537         if ($self->is_a_node($existing_path)) {
 538             if ($existing_link_dest eq $source) {
 539                 debug(2, 0, "--- Skipping $target_subpath as it already points to $source");
 540             }
 541             elsif ($self->defer($target_subpath)) {
 542                 debug(2, 0, "--- Deferring installation of: $target_subpath");
 543             }
 544             elsif ($self->override($target_subpath)) {
 545                 debug(2, 0, "--- Overriding installation of: $target_subpath");
 546                 $self->do_unlink($target_subpath);
 547                 $self->do_link($source, $target_subpath);
 548             }
 549             elsif ($self->is_a_dir(join_paths(parent($target_subpath), $existing_link_dest)) &&
 550                    $self->is_a_dir(join_paths(parent($target_subpath), $source)))
 551             {
 552
 553                 # If the existing link points to a directory,
 554                 # and the proposed new link points to a directory,
 555                 # then we can unfold (split open) the tree at that point
 556
 557                 debug(2, 0, "--- Unfolding $target_subpath which was already owned by $existing_package");
 558                 $self->do_unlink($target_subpath);
 559                 $self->do_mkdir($target_subpath);
 560                 $self->stow_contents(
 561                     $existing_stow_path,
 562                     $existing_package,
 563                     $target_subpath,
 564                     join_paths('..', $existing_link_dest),
 565                     $level + 1,
 566                 );
 567                 $self->stow_contents(
 568                     $self->{stow_path},
 569                     $package,
 570                     $target_subpath,
 571                     join_paths('..', $source),
 572                     $level + 1,
 573                 );
 574             }
 575             else {
 576                 $self->conflict(
 577                     'stow',
 578                     $package,
 579                     "existing target is stowed to a different package: "
 580                     . "$target_subpath => $existing_link_dest"
 581                 );
 582             }
 583         }
 584         else {
 585             # The existing link is invalid, so replace it with a good link
 586             debug(2, 0, "--- replacing invalid link: $path");
 587             $self->do_unlink($target_subpath);
 588             $self->do_link($source, $target_subpath);
 589         }
 590     }
 591     elsif ($self->is_a_node($target_subpath)) {
 592         debug(4, 1, "Evaluate existing node: $target_subpath");
 593         if ($self->is_a_dir($target_subpath)) {
 594             $self->stow_contents(
 595                 $self->{stow_path},
 596                 $package,
 597                 $target_subpath,
 598                 join_paths('..', $source),
 599                 $level + 1,
 600             );
 601         }
 602         else {
 603             if ($self->{adopt}) {
 604                 $self->do_mv($target_subpath, $path);
 605                 $self->do_link($source, $target_subpath);
 606             }
 607             else {
 608                 $self->conflict(
 609                     'stow',
 610                     $package,
 611                     "existing target is neither a link nor a directory: $target_subpath"
 612                 );
 613             }
 614         }
 615     }
 616     elsif ($self->{'no-folding'} && -d $path && ! -l $path) {
 617         $self->do_mkdir($target_subpath);
 618         $self->stow_contents(
 619             $self->{stow_path},
 620             $package,
 621             $target_subpath,
 622             join_paths('..', $source),
 623             $level + 1,
 624         );
 625     }
 626     else {
 627         $self->do_link($source, $target_subpath);
 628     }
 629     return;
 630 }
 631
 632 =head2 should_skip_target($target_subdir)
 633
 634 Determine whether C<$target_subdir> is a stow directory which should
 635 not be stowed to or unstowed from.  This mechanism protects stow
 636 directories from being altered by stow, and is a necessary safety
 637 check because the stow directory could live beneath the target
 638 directory.
 639
 640 =over 4
 641
 642 =item $target_subdir => relative path to symlink target from the current directory
 643
 644 =back
 645
 646 Returns true iff target is a stow directory
 647
 648 cwd must be the top-level target directory, otherwise
 649 C<marked_stow_dir()> won't work.
 650
 651 =cut
 652
 653 sub should_skip_target {
 654     my $self = shift;
 655     my ($target) = @_;
 656
 657     # Don't try to remove anything under a stow directory
 658     if ($target eq $self->{stow_path}) {
 659         warn "WARNING: skipping target which was current stow directory $target\n";
 660         return 1;
 661     }
 662
 663     if ($self->marked_stow_dir($target)) {
 664         warn "WARNING: skipping marked Stow directory $target\n";
 665         return 1;
 666     }
 667
 668     if (-e join_paths($target, ".nonstow")) {
 669         warn "WARNING: skipping protected directory $target\n";
 670         return 1;
 671     }
 672
 673     debug(4, 1, "$target not protected; shouldn't skip");
 674     return 0;
 675 }
 676
 677 # cwd must be the top-level target directory, otherwise
 678 # marked_stow_dir() won't work.
 679 sub marked_stow_dir {
 680     my $self = shift;
 681     my ($dir) = @_;
 682     if (-e join_paths($dir, ".stow")) {
 683         debug(5, 5, "> $dir contained .stow");
 684         return 1;
 685     }
 686     return 0;
 687 }
 688
 689 =head2 unstow_contents($package, $target)
 690
 691 Unstow the contents of the given directory
 692
 693 =over 4
 694
 695 =item $package
 696
 697 The package whose contents are being unstowed.
 698
 699 =item $target
 700
 701 Relative path to symlink target from the current directory.
 702
 703 =back
 704
 705 C<unstow_node()> and C<unstow_contents()> are mutually recursive.
 706 Here we traverse the source tree, rather than the target tree.
 707
 708 =cut
 709
 710 sub unstow_contents {
 711     my $self = shift;
 712     my ($package, $target_subdir, $path) = @_;
 713
 714     return if $self->should_skip_target($target_subdir);
 715
 716     my $cwd = getcwd();
 717     my $msg = "Unstowing from $target_subdir (cwd=$cwd, stow dir=$self->{stow_path})";
 718     $msg =~ s!$ENV{HOME}/!~/!g;
 719     debug(3, 0, $msg);
 720     debug(4, 1, "source path is $path");
 721
 722     if ($self->{compat}) {
 723         # In compat mode we traverse the target tree not the source tree,
 724         # so we're unstowing the contents of /target/foo, there's no
 725         # guarantee that the corresponding /stow/mypkg/foo exists.
 726         error("unstow_contents() in compat mode called with non-directory target: $target_subdir")
 727             unless -d $target_subdir;
 728     }
 729     else {
 730         # We traverse the source tree not the target tree, so $path must exist.
 731         error("unstow_contents() called with non-directory path: $path")
 732             unless -d $path;
 733
 734         # When called at the top level, $target_subdir should exist.  And
 735         # unstow_node() should only call this via mutual recursion if
 736         # $target_subdir exists.
 737         error("unstow_contents() called with invalid target: $target_subdir")
 738             unless $self->is_a_node($target_subdir);
 739     }
 740
 741     my $dir = $self->{compat} ? $target_subdir : $path;
 742     opendir my $DIR, $dir
 743         or error("cannot read directory: $dir ($!)");
 744     my @listing = readdir $DIR;
 745     closedir $DIR;
 746
 747     NODE:
 748     for my $node (@listing) {
 749         next NODE if $node eq '.';
 750         next NODE if $node eq '..';
 751         my $node_target = join_paths($target_subdir, $node);
 752         next NODE if $self->ignore($self->{stow_path}, $package, $node_target);
 753
 754         if ($self->{dotfiles}) {
 755             my $adj_node_target = adjust_dotfile($node_target);
 756             debug(4, 1, "Adjusting: $node_target => $adj_node_target");
 757             $node_target = $adj_node_target;
 758         }
 759
 760         $self->unstow_node($package, $node_target, join_paths($path, $node));
 761     }
 762
 763     if (! $self->{compat} && -d $target_subdir) {
 764         $self->cleanup_invalid_links($target_subdir);
 765     }
 766 }
 767
 768 =head2 unstow_node($package, $target_subpath)
 769
 770 Unstow the given node.
 771
 772 =over 4
 773
 774 =item $package
 775
 776 The package containing the node being unstowed.
 777
 778 =item $target_subpath
 779
 780 Relative path to symlink target from the current directory.
 781
 782 =back
 783
 784 C<unstow_node()> and C<unstow_contents()> are mutually recursive.
 785
 786 =cut
 787
 788 sub unstow_node {
 789     my $self = shift;
 790     my ($package, $target_subpath, $source) = @_;
 791
 792     my $pkg_path_from_cwd = join_paths($self->{stow_path}, $package, $target_subpath);
 793
 794     debug(3, 1, "Unstowing $pkg_path_from_cwd");
 795     debug(4, 2, "target is $target_subpath");
 796
 797     # Does the target exist?
 798     if ($self->is_a_link($target_subpath)) {
 799         $self->unstow_link_node($package, $target_subpath, $pkg_path_from_cwd);
 800     }
 801     elsif ($self->{compat} && -d $target_subpath) {
 802         $self->unstow_contents($package, $target_subpath, $pkg_path_from_cwd);
 803
 804         # This action may have made the parent directory foldable
 805         if (my $parent = $self->foldable($target_subpath)) {
 806             $self->fold_tree($target_subpath, $parent);
 807         }
 808     }
 809     elsif (-e $target_subpath) {
 810         if ($self->{compat}) {
 811             $self->conflict(
 812                 'unstow',
 813                 $package,
 814                 "existing target is neither a link nor a directory: $target_subpath",
 815             );
 816         }
 817         else {
 818             $self->unstow_existing_node($package, $target_subpath, $source);
 819         }
 820     }
 821     else {
 822         debug(2, 1, "$target_subpath did not exist to be unstowed");
 823     }
 824     return;
 825 }
 826
 827 sub unstow_link_node {
 828     my $self = shift;
 829     my ($package, $target_subpath, $pkg_path_from_cwd) = @_;
 830     debug(4, 2, "Evaluate existing link: $target_subpath");
 831
 832     # Where is the link pointing?
 833     my $existing_source = $self->read_a_link($target_subpath);
 834     if (not $existing_source) {
 835         error("Could not read link: $target_subpath");
 836     }
 837
 838     if ($existing_source =~ m{\A/}) {
 839         warn "Ignoring an absolute symlink: $target_subpath => $existing_source\n";
 840         return; # XXX #
 841     }
 842
 843     # Does it point to a node under any stow directory?
 844     my ($existing_path, $existing_stow_path, $existing_package) =
 845         $self->find_stowed_path($target_subpath, $existing_source);
 846     if (not $existing_path) {
 847         if ($self->{compat}) {
 848             # We're traversing the target tree not the package tree,
 849             # so we definitely expect to find stuff not owned by stow.
 850             # Therefore we can't flag a conflict.
 851             return;
 852         }
 853         else {
 854             $self->conflict(
 855                 'unstow',
 856                 $package,
 857                 "existing target is not owned by stow: $target_subpath => $existing_source"
 858             );
 859         }
 860         return;
 861     }
 862
 863     # Does the existing $target_subpath actually point to anything?
 864     if (-e $existing_path) {
 865         $self->unstow_valid_link($pkg_path_from_cwd, $target_subpath, $existing_path);
 866     }
 867     else {
 868         debug(2, 0, "--- removing invalid link into a stow directory: $pkg_path_from_cwd");
 869         $self->do_unlink($target_subpath);
 870     }
 871 }
 872
 873 sub unstow_valid_link {
 874     my $self = shift;
 875     my ($pkg_path_from_cwd, $target_subpath, $existing_path) = @_;
 876     # Does link points to the right place?
 877
 878     # Adjust for dotfile if necessary.
 879     if ($self->{dotfiles}) {
 880         $existing_path = adjust_dotfile($existing_path);
 881     }
 882
 883     if ($existing_path eq $pkg_path_from_cwd) {
 884         $self->do_unlink($target_subpath);
 885     }
 886
 887     # XXX we quietly ignore links that are stowed to a different
 888     # package.
 889
 890     #elsif (defer($target_subpath)) {
 891     #    debug(2, 0, "--- deferring to installation of: $target_subpath");
 892     #}
 893     #elsif ($self->override($target_subpath)) {
 894     #    debug(2, 0, "--- overriding installation of: $target_subpath");
 895     #    $self->do_unlink($target_subpath);
 896     #}
 897     #else {
 898     #    $self->conflict(
 899     #        'unstow',
 900     #        $package,
 901     #        "existing target is stowed to a different package: "
 902     #        . "$target_subpath => $existing_source"
 903     #    );
 904     #}
 905 }
 906
 907 sub unstow_existing_node {
 908     my $self = shift;
 909     my ($package, $target_subpath, $source) = @_;
 910     debug(4, 2, "Evaluate existing node: $target_subpath");
 911     if (-d $target_subpath) {
 912         $self->unstow_contents($package, $target_subpath, $source);
 913
 914         # This action may have made the parent directory foldable
 915         if (my $parent = $self->foldable($target_subpath)) {
 916             $self->fold_tree($target_subpath, $parent);
 917         }
 918     }
 919     else {
 920         $self->conflict(
 921             'unstow',
 922             $package,
 923             "existing target is neither a link nor a directory: $target_subpath",
 924           );
 925     }
 926 }
 927
 928 =head2 link_owned_by_package($target_subpath, $source)
 929
 930 Determine whether the given link points to a member of a stowed
 931 package.
 932
 933 =over 4
 934
 935 =item $target_subpath
 936
 937 Path to a symbolic link under current directory.
 938
 939 =item $source
 940
 941 Where that link points to.
 942
 943 =back
 944
 945 Lossy wrapper around find_stowed_path().
 946
 947 Returns the package iff link is owned by stow, otherwise ''.
 948
 949 =cut
 950
 951 sub link_owned_by_package {
 952     my $self = shift;
 953     my ($target_subpath, $source) = @_;
 954
 955     my ($pkg_path_from_cwd, $stow_path, $package) =
 956         $self->find_stowed_path($target_subpath, $source);
 957     return $package;
 958 }
 959
 960 =head2 find_stowed_path($target_subpath, $link_dest)
 961
 962 Determine whether the given symlink within the target directory is a
 963 stowed path pointing to a member of a package under the stow dir, and
 964 if so, obtain a breakdown of information about this stowed path.
 965
 966 =over 4
 967
 968 =item $target_subpath
 969
 970 Path to a symbolic link somewhere under the target directory, relative
 971 to the top-level target directory (which is also expected to be the
 972 current directory).
 973
 974 =item $link_dest
 975
 976 Where that link points to (needed because link might not exist yet due
 977 to two-phase approach, so we can't just call C<readlink()>).  If this
 978 is owned by Stow, it will be expressed relative to (the directory
 979 containing) C<$target_subpath>.  However if it's not, it could of course be
 980 relative or absolute, point absolutely anywhere, and could even be
 981 dangling.
 982
 983 =back
 984
 985 Returns C<($path, $stow_path, $package)> where C<$path> and
 986 C<$stow_path> are relative from the top-level target directory.
 987 C<$path> is the full relative path to the member of the package
 988 pointed to by C<$link_dest>; C<$stow_path> is the relative path to the
 989 stow directory; and C<$package> is the name of the package; or C<('',
 990 '', '')> if link is not owned by stow.
 991
 992 cwd must be the top-level target directory, otherwise
 993 C<find_containing_marked_stow_dir()> won't work.  Allow for stow dir
 994 not being under target dir.
 995
 996 =cut
 997
 998 sub find_stowed_path {
 999     my $self = shift;
1000     my ($target_subpath, $link_dest) = @_;
1001
1002     if (substr($link_dest, 0, 1) eq '/') {
1003         # Symlink points to an absolute path, therefore it cannot be
1004         # owned by Stow.
1005         return ('', '', '');
1006     }
1007
1008     # Evaluate softlink relative to its target, without relying on
1009     # what's actually on the filesystem, since the link might not
1010     # exist yet.
1011     debug(4, 2, "find_stowed_path(target=$target_subpath; source=$link_dest)");
1012     my $dest = join_paths(parent($target_subpath), $link_dest);
1013     debug(4, 3, "is symlink destination $dest owned by stow?");
1014
1015     # First check whether the link is owned by the current stow
1016     # directory, in which case $dest will be a prefix of
1017     # $self->{stow_path}.
1018     my ($package, $path) = $self->link_dest_within_stow_dir($dest);
1019     if (length $package) {
1020         debug(4, 3, "yes - package $package in $self->{stow_path} may contain $path");
1021         return ($dest, $self->{stow_path}, $package);
1022     }
1023
1024     # If no .stow file was found, we need to find out whether it's
1025     # owned by the current stow directory, in which case $path will be
1026     # a prefix of $self->{stow_path}.
1027     my ($stow_path, $ext_package) = $self->find_containing_marked_stow_dir($dest);
1028     if (length $stow_path) {
1029         debug(5, 5, "yes - $stow_path in $dest was marked as a stow dir; package=$ext_package");
1030         return ($dest, $stow_path, $ext_package);
1031     }
1032
1033     return ('', '', '');
1034 }
1035
1036 =head2 link_dest_within_stow_dir($link_dest)
1037
1038 Detect whether symlink destination is within current stow dir
1039
1040 =over 4
1041
1042 =item $link_dest - destination of the symlink relative
1043
1044 =back
1045
1046 Returns C<($package, $pkg_subpath)> - package within the current stow
1047 dir and subpath within that package which the symlink points to.
1048
1049 =cut
1050
1051 sub link_dest_within_stow_dir {
1052     my $self = shift;
1053     my ($link_dest) = @_;
1054
1055     debug(4, 4, "common prefix? link_dest=$link_dest; stow_path=$self->{stow_path}");
1056
1057     my $removed = $link_dest =~ s,^\Q$self->{stow_path}/,,;
1058     if (! $removed) {
1059         debug(4, 3, "no - $link_dest not under $self->{stow_path}");
1060         return ('', '');
1061     }
1062
1063     debug(4, 4, "remaining after removing $self->{stow_path}: $link_dest");
1064     my @dirs = File::Spec->splitdir($link_dest);
1065     my $package = shift @dirs;
1066     my $pkg_subpath = File::Spec->catdir(@dirs);
1067     return ($package, $pkg_subpath);
1068 }
1069
1070 =head2 find_containing_marked_stow_dir($pkg_path_from_cwd)
1071
1072 Detect whether path is within a marked stow directory
1073
1074 =over 4
1075
1076 =item $pkg_path_from_cwd => path to directory to check
1077
1078 =back
1079
1080 Returns C<($stow_path, $package)> where C<$stow_path> is the highest
1081 directory (relative from the top-level target directory) which is
1082 marked as a Stow directory, and C<$package> is the containing package;
1083 or C<('', '')> if no containing directory is marked as a stow
1084 directory.
1085
1086 cwd must be the top-level target directory, otherwise
1087 C<marked_stow_dir()> won't work.
1088
1089 =cut
1090
1091 sub find_containing_marked_stow_dir {
1092     my $self = shift;
1093     my ($pkg_path_from_cwd) = @_;
1094
1095     # Search for .stow files - this allows us to detect links
1096     # owned by stow directories other than the current one.
1097     my @segments = File::Spec->splitdir($pkg_path_from_cwd);
1098     for my $last_segment (0 .. $#segments) {
1099         my $pkg_path_from_cwd = join_paths(@segments[0 .. $last_segment]);
1100         debug(5, 5, "is $pkg_path_from_cwd marked stow dir?");
1101         if ($self->marked_stow_dir($pkg_path_from_cwd)) {
1102             if ($last_segment == $#segments) {
1103                 # This should probably never happen.  Even if it did,
1104                 # there would be no way of calculating $package.
1105                 internal_error("find_stowed_path() called directly on stow dir");
1106             }
1107
1108             my $package = $segments[$last_segment + 1];
1109             return ($pkg_path_from_cwd, $package);
1110         }
1111     }
1112     return ('', '');
1113 }
1114
1115 =head2 cleanup_invalid_links($dir)
1116
1117 Clean up orphaned links that may block folding
1118
1119 =over 4
1120
1121 =item $dir
1122
1123 Path to directory to check
1124
1125 =back
1126
1127 This is invoked by C<unstow_contents()>.  We only clean up links which
1128 are both orphaned and owned by Stow, i.e. they point to a non-existent
1129 location within a Stow package.  These can block tree folding, and
1130 they can easily occur when a file in Stow package is renamed or
1131 removed, so the benefit should outweigh the low risk of actually
1132 someone wanting to keep an orphaned link to within a Stow package.
1133
1134 =cut
1135
1136 sub cleanup_invalid_links {
1137     my $self = shift;
1138     my ($dir) = @_;
1139
1140     my $cwd = getcwd();
1141     debug(2, 0, "Cleaning up any invalid links in $dir (pwd=$cwd)");
1142
1143     if (not -d $dir) {
1144         internal_error("cleanup_invalid_links() called with a non-directory: $dir");
1145     }
1146
1147     opendir my $DIR, $dir
1148         or error("cannot read directory: $dir ($!)");
1149     my @listing = readdir $DIR;
1150     closedir $DIR;
1151
1152     NODE:
1153     for my $node (@listing) {
1154         next NODE if $node eq '.';
1155         next NODE if $node eq '..';
1156
1157         my $node_path = join_paths($dir, $node);
1158
1159         next unless -l $node_path;
1160
1161         debug(4, 1, "Checking validity of link $node_path");
1162
1163         if (exists $self->{link_task_for}{$node_path}) {
1164             my $action = $self->{link_task_for}{$node_path}{action};
1165             if ($action ne 'remove') {
1166                 warn "Unexpected action $action scheduled for $node_path; skipping clean-up\n";
1167             }
1168             else {
1169                 debug(4, 2, "$node_path scheduled for removal; skipping clean-up");
1170             }
1171             next;
1172         }
1173
1174         # Where is the link pointing?
1175         # (don't use read_a_link() here)
1176         my $link_dest = readlink($node_path);
1177         if (not $link_dest) {
1178             error("Could not read link $node_path");
1179         }
1180
1181         my $target_subpath = join_paths($dir, $link_dest);
1182         debug(4, 2, "join $dir $link_dest");
1183         if (-e $target_subpath) {
1184             debug(4, 2, "Link target $link_dest exists at $target_subpath; skipping clean up");
1185             next;
1186         }
1187         else {
1188             debug(4, 2, "Link target $link_dest doesn't exist at $target_subpath");
1189         }
1190
1191         debug(3, 1,
1192               "Checking whether valid link $node_path -> $link_dest is " .
1193               "owned by stow");
1194
1195         my $owner = $self->link_owned_by_package($node_path, $link_dest);
1196         if ($owner) {
1197             # owned by stow
1198             debug(2, 0, "--- removing link owned by $owner: $node_path => " .
1199                   join_paths($dir, $link_dest));
1200             $self->do_unlink($node_path);
1201         }
1202     }
1203     return;
1204 }
1205
1206
1207 =head2 foldable($target)
1208
1209 Determine whether a tree can be folded
1210
1211 =over 4
1212
1213 =item $target
1214
1215 path to a directory
1216
1217 =back
1218
1219 Returns path to the parent dir iff the tree can be safely folded.  The
1220 path returned is relative to the parent of $target, i.e. it can be
1221 used as the source for a replacement symlink.
1222
1223 =cut
1224
1225 sub foldable {
1226     my $self = shift;
1227     my ($target) = @_;
1228
1229     debug(3, 2, "Is $target foldable?");
1230     if ($self->{'no-folding'}) {
1231         debug(3, 3, "no because --no-folding enabled");
1232         return '';
1233     }
1234
1235     opendir my $DIR, $target
1236         or error(qq{Cannot read directory "$target" ($!)\n});
1237     my @listing = readdir $DIR;
1238     closedir $DIR;
1239
1240     my $parent = '';
1241     NODE:
1242     for my $node (@listing) {
1243
1244         next NODE if $node eq '.';
1245         next NODE if $node eq '..';
1246
1247         my $path =  join_paths($target, $node);
1248
1249         # Skip nodes scheduled for removal
1250         next NODE if not $self->is_a_node($path);
1251
1252         # If it's not a link then we can't fold its parent
1253         return '' if not $self->is_a_link($path);
1254
1255         # Where is the link pointing?
1256         my $source = $self->read_a_link($path);
1257         if (not $source) {
1258             error("Could not read link $path");
1259         }
1260         if ($parent eq '') {
1261             $parent = parent($source)
1262         }
1263         elsif ($parent ne parent($source)) {
1264             return '';
1265         }
1266     }
1267     return '' if not $parent;
1268
1269     # If we get here then all nodes inside $target are links, and those links
1270     # point to nodes inside the same directory.
1271
1272     # chop of leading '..' to get the path to the common parent directory
1273     # relative to the parent of our $target
1274     $parent =~ s{\A\.\./}{};
1275
1276     # If the resulting path is owned by stow, we can fold it
1277     if ($self->link_owned_by_package($target, $parent)) {
1278         debug(3, 3, "$target is foldable");
1279         return $parent;
1280     }
1281     else {
1282         return '';
1283     }
1284 }
1285
1286 =head2 fold_tree($target, source)
1287
1288 Fold the given tree
1289
1290 =over 4
1291
1292 =item $target
1293
1294 directory that we will replace with a link to $source
1295
1296 =item $source
1297
1298 link to the folded tree source
1299
1300 =back
1301
1302 Only called iff foldable() is true so we can remove some checks.
1303
1304 =cut
1305
1306 sub fold_tree {
1307     my $self = shift;
1308     my ($target, $source) = @_;
1309
1310     debug(3, 0, "--- Folding tree: $target => $source");
1311
1312     opendir my $DIR, $target
1313         or error(qq{Cannot read directory "$target" ($!)\n});
1314     my @listing = readdir $DIR;
1315     closedir $DIR;
1316
1317     NODE:
1318     for my $node (@listing) {
1319         next NODE if $node eq '.';
1320         next NODE if $node eq '..';
1321         next NODE if not $self->is_a_node(join_paths($target, $node));
1322         $self->do_unlink(join_paths($target, $node));
1323     }
1324     $self->do_rmdir($target);
1325     $self->do_link($source, $target);
1326     return;
1327 }
1328
1329
1330 =head2 conflict($package, $message)
1331
1332 Handle conflicts in stow operations
1333
1334 =over 4
1335
1336 =item $package
1337
1338 the package involved with the conflicting operation
1339
1340 =item $message
1341
1342 a description of the conflict
1343
1344 =back
1345
1346 =cut
1347
1348 sub conflict {
1349     my $self = shift;
1350     my ($action, $package, $message) = @_;
1351
1352     debug(2, 0, "CONFLICT when ${action}ing $package: $message");
1353     $self->{conflicts}{$action}{$package} ||= [];
1354     push @{ $self->{conflicts}{$action}{$package} }, $message;
1355     $self->{conflict_count}++;
1356
1357     return;
1358 }
1359
1360 =head2 get_conflicts()
1361
1362 Returns a nested hash of all potential conflicts discovered: the keys
1363 are actions ('stow' or 'unstow'), and the values are hashrefs whose
1364 keys are stow package names and whose values are conflict
1365 descriptions, e.g.:
1366
1367     (
1368         stow => {
1369             perl => [
1370                 "existing target is not owned by stow: bin/a2p"
1371                 "existing target is neither a link nor a directory: bin/perl"
1372             ]
1373         }
1374     )
1375
1376 =cut
1377
1378 sub get_conflicts {
1379     my $self = shift;
1380     return %{ $self->{conflicts} };
1381 }
1382
1383 =head2 get_conflict_count()
1384
1385 Returns the number of conflicts found.
1386
1387 =cut
1388
1389 sub get_conflict_count {
1390     my $self = shift;
1391     return $self->{conflict_count};
1392 }
1393
1394 =head2 get_tasks()
1395
1396 Returns a list of all symlink/directory creation/removal tasks.
1397
1398 =cut
1399
1400 sub get_tasks {
1401     my $self = shift;
1402     return @{ $self->{tasks} };
1403 }
1404
1405 =head2 get_action_count()
1406
1407 Returns the number of actions planned for this Stow instance.
1408
1409 =cut
1410
1411 sub get_action_count {
1412     my $self = shift;
1413     return $self->{action_count};
1414 }
1415
1416 =head2 ignore($stow_path, $package, $target)
1417
1418 Determine if the given path matches a regex in our ignore list.
1419
1420 =over 4
1421
1422 =item $stow_path
1423
1424 the stow directory containing the package
1425
1426 =item $package
1427
1428 the package containing the path
1429
1430 =item $target
1431
1432 the path to check against the ignore list relative to its package
1433 directory
1434
1435 =back
1436
1437 Returns true iff the path should be ignored.
1438
1439 =cut
1440
1441 sub ignore {
1442     my $self = shift;
1443     my ($stow_path, $package, $target) = @_;
1444
1445     internal_error(__PACKAGE__ . "::ignore() called with empty target")
1446         unless length $target;
1447
1448     for my $suffix (@{ $self->{ignore} }) {
1449         if ($target =~ m/$suffix/) {
1450             debug(4, 1, "Ignoring path $target due to --ignore=$suffix");
1451             return 1;
1452         }
1453     }
1454
1455     my $package_dir = join_paths($stow_path, $package);
1456     my ($path_regexp, $segment_regexp) =
1457         $self->get_ignore_regexps($package_dir);
1458     debug(5, 2, "Ignore list regexp for paths:    " .
1459              (defined $path_regexp ? "/$path_regexp/" : "none"));
1460     debug(5, 2, "Ignore list regexp for segments: " .
1461              (defined $segment_regexp ? "/$segment_regexp/" : "none"));
1462
1463     if (defined $path_regexp and "/$target" =~ $path_regexp) {
1464         debug(4, 1, "Ignoring path /$target");
1465         return 1;
1466     }
1467
1468     (my $basename = $target) =~ s!.+/!!;
1469     if (defined $segment_regexp and $basename =~ $segment_regexp) {
1470         debug(4, 1, "Ignoring path segment $basename");
1471         return 1;
1472     }
1473
1474     debug(5, 1, "Not ignoring $target");
1475     return 0;
1476 }
1477
1478 sub get_ignore_regexps {
1479     my $self = shift;
1480     my ($dir) = @_;
1481
1482     # N.B. the local and global stow ignore files have to have different
1483     # names so that:
1484     #   1. the global one can be a symlink to within a stow
1485     #      package, managed by stow itself, and
1486     #   2. the local ones can be ignored via hardcoded logic in
1487     #      GlobsToRegexp(), so that they always stay within their stow packages.
1488
1489     my $local_stow_ignore  = join_paths($dir,       $LOCAL_IGNORE_FILE);
1490     my $global_stow_ignore = join_paths($ENV{HOME}, $GLOBAL_IGNORE_FILE);
1491
1492     for my $file ($local_stow_ignore, $global_stow_ignore) {
1493         if (-e $file) {
1494             debug(5, 1, "Using ignore file: $file");
1495             return $self->get_ignore_regexps_from_file($file);
1496         }
1497         else {
1498             debug(5, 1, "$file didn't exist");
1499         }
1500     }
1501
1502     debug(4, 1, "Using built-in ignore list");
1503     return @default_global_ignore_regexps;
1504 }
1505
1506 my %ignore_file_regexps;
1507
1508 sub get_ignore_regexps_from_file {
1509     my $self = shift;
1510     my ($file) = @_;
1511
1512     if (exists $ignore_file_regexps{$file}) {
1513         debug(4, 2, "Using memoized regexps from $file");
1514         return @{ $ignore_file_regexps{$file} };
1515     }
1516
1517     if (! open(REGEXPS, $file)) {
1518         debug(4, 2, "Failed to open $file: $!");
1519         return undef;
1520     }
1521
1522     my @regexps = $self->get_ignore_regexps_from_fh(\*REGEXPS);
1523     close(REGEXPS);
1524
1525     $ignore_file_regexps{$file} = [ @regexps ];
1526     return @regexps;
1527 }
1528
1529 =head2 invalidate_memoized_regexp($file)
1530
1531 For efficiency of performance, regular expressions are compiled from
1532 each ignore list file the first time it is used by the Stow process,
1533 and then memoized for future use.  If you expect the contents of these
1534 files to change during a single run, you will need to invalidate the
1535 memoized value from this cache.  This method allows you to do that.
1536
1537 =cut
1538
1539 sub invalidate_memoized_regexp {
1540     my $self = shift;
1541     my ($file) = @_;
1542     if (exists $ignore_file_regexps{$file}) {
1543         debug(4, 2, "Invalidated memoized regexp for $file");
1544         delete $ignore_file_regexps{$file};
1545     }
1546     else {
1547         debug(2, 1, "WARNING: no memoized regexp for $file to invalidate");
1548     }
1549 }
1550
1551 sub get_ignore_regexps_from_fh {
1552     my $self = shift;
1553     my ($fh) = @_;
1554     my %regexps;
1555     while (<$fh>) {
1556         chomp;
1557         s/^\s+//;
1558         s/\s+$//;
1559         next if /^#/ or length($_) == 0;
1560         s/\s+#.+//; # strip comments to right of pattern
1561         s/\\#/#/g;
1562         $regexps{$_}++;
1563     }
1564
1565     # Local ignore lists should *always* stay within the stow directory,
1566     # because this is the only place stow looks for them.
1567     $regexps{"^/\Q$LOCAL_IGNORE_FILE\E\$"}++;
1568
1569     return $self->compile_ignore_regexps(%regexps);
1570 }
1571
1572 sub compile_ignore_regexps {
1573     my $self = shift;
1574     my (%regexps) = @_;
1575
1576     my @segment_regexps;
1577     my @path_regexps;
1578     for my $regexp (keys %regexps) {
1579         if (index($regexp, '/') < 0) {
1580             # No / found in regexp, so use it for matching against basename
1581             push @segment_regexps, $regexp;
1582         }
1583         else {
1584             # / found in regexp, so use it for matching against full path
1585             push @path_regexps, $regexp;
1586         }
1587     }
1588
1589     my $segment_regexp = join '|', @segment_regexps;
1590     my $path_regexp    = join '|', @path_regexps;
1591     $segment_regexp = @segment_regexps ?
1592         $self->compile_regexp("^($segment_regexp)\$") : undef;
1593     $path_regexp    = @path_regexps    ?
1594         $self->compile_regexp("(^|/)($path_regexp)(/|\$)") : undef;
1595
1596     return ($path_regexp, $segment_regexp);
1597 }
1598
1599 sub compile_regexp {
1600     my $self = shift;
1601     my ($regexp) = @_;
1602     my $compiled = eval { qr/$regexp/ };
1603     die "Failed to compile regexp: $@\n" if $@;
1604     return $compiled;
1605 }
1606
1607 sub get_default_global_ignore_regexps {
1608     my $class = shift;
1609     # Bootstrap issue - first time we stow, we will be stowing
1610     # .cvsignore so it might not exist in ~ yet, or if it does, it could
1611     # be an old version missing the entries we need.  So we make sure
1612     # they are there by hardcoding some crucial entries.
1613     return $class->get_ignore_regexps_from_fh(\*DATA);
1614 }
1615
1616 =head2 defer($path)
1617
1618 Determine if the given path matches a regex in our C<defer> list
1619
1620 =over 4
1621
1622 =item $path
1623
1624 =back
1625
1626 Returns boolean.
1627
1628 =cut
1629
1630 sub defer {
1631     my $self = shift;
1632     my ($path) = @_;
1633
1634     for my $prefix (@{ $self->{defer} }) {
1635         return 1 if $path =~ m/$prefix/;
1636     }
1637     return 0;
1638 }
1639
1640 =head2 override($path)
1641
1642 Determine if the given path matches a regex in our C<override> list
1643
1644 =over 4
1645
1646 =item $path
1647
1648 =back
1649
1650 Returns boolean
1651
1652 =cut
1653
1654 sub override {
1655     my $self = shift;
1656     my ($path) = @_;
1657
1658     for my $regex (@{ $self->{override} }) {
1659         return 1 if $path =~ m/$regex/;
1660     }
1661     return 0;
1662 }
1663
1664 ##############################################################################
1665 #
1666 # The following code provides the abstractions that allow us to defer operating
1667 # on the filesystem until after all potential conflcits have been assessed.
1668 #
1669 ##############################################################################
1670
1671 =head2 process_tasks()
1672
1673 Process each task in the tasks list
1674
1675 =over 4
1676
1677 =item none
1678
1679 =back
1680
1681 Returns : n/a
1682 Throws    : fatal error if tasks list is corrupted or a task fails
1683
1684 =cut
1685
1686 sub process_tasks {
1687     my $self = shift;
1688
1689     debug(2, 0, "Processing tasks...");
1690
1691     # Strip out all tasks with a skip action
1692     $self->{tasks} = [ grep { $_->{action} ne 'skip' } @{ $self->{tasks} } ];
1693
1694     if (not @{ $self->{tasks} }) {
1695         return;
1696     }
1697
1698     $self->within_target_do(sub {
1699         for my $task (@{ $self->{tasks} }) {
1700             $self->process_task($task);
1701         }
1702     });
1703
1704     debug(2, 0, "Processing tasks... done");
1705 }
1706
1707 =head2 process_task($task)
1708
1709 Process a single task.
1710
1711 =over 4
1712
1713 =item $task => the task to process
1714
1715 =back
1716
1717 Returns : n/a
1718 Throws    : fatal error if task fails
1719 # #
1720 Must run from within target directory.  Task involve either creating
1721 or deleting dirs and symlinks an action is set to 'skip' if it is
1722 found to be redundant
1723
1724 =cut
1725
1726 sub process_task {
1727     my $self = shift;
1728     my ($task) = @_;
1729
1730     if ($task->{action} eq 'create') {
1731         if ($task->{type} eq 'dir') {
1732             mkdir($task->{path}, 0777)
1733                 or error("Could not create directory: $task->{path} ($!)");
1734             return;
1735         }
1736         elsif ($task->{type} eq 'link') {
1737             symlink $task->{source}, $task->{path}
1738                 or error(
1739                     "Could not create symlink: %s => %s ($!)",
1740                     $task->{path},
1741                     $task->{source}
1742             );
1743             return;
1744         }
1745     }
1746     elsif ($task->{action} eq 'remove') {
1747         if ($task->{type} eq 'dir') {
1748             rmdir $task->{path}
1749                 or error("Could not remove directory: $task->{path} ($!)");
1750             return;
1751         }
1752         elsif ($task->{type} eq 'link') {
1753             unlink $task->{path}
1754                 or error("Could not remove link: $task->{path} ($!)");
1755             return;
1756         }
1757     }
1758     elsif ($task->{action} eq 'move') {
1759         if ($task->{type} eq 'file') {
1760             # rename() not good enough, since the stow directory
1761             # might be on a different filesystem to the target.
1762             move $task->{path}, $task->{dest}
1763                 or error("Could not move $task->{path} -> $task->{dest} ($!)");
1764             return;
1765         }
1766     }
1767
1768     # Should never happen.
1769     internal_error("bad task action: $task->{action}");
1770 }
1771
1772 =head2 link_task_action($path)
1773
1774 Finds the link task action for the given path, if there is one
1775
1776 =over 4
1777
1778 =item $path
1779
1780 =back
1781
1782 Returns C<'remove'>, C<'create'>, or C<''> if there is no action.
1783 Throws a fatal exception if an invalid action is found.
1784
1785 =cut
1786
1787 sub link_task_action {
1788     my $self = shift;
1789     my ($path) = @_;
1790
1791     if (! exists $self->{link_task_for}{$path}) {
1792         debug(4, 1, "link_task_action($path): no task");
1793         return '';
1794     }
1795
1796     my $action = $self->{link_task_for}{$path}->{action};
1797     internal_error("bad task action: $action")
1798         unless $action eq 'remove' or $action eq 'create';
1799
1800     debug(4, 1, "link_task_action($path): link task exists with action $action");
1801     return $action;
1802 }
1803
1804 =head2 dir_task_action($path)
1805
1806 Finds the dir task action for the given path, if there is one.
1807
1808 =over 4
1809
1810 =item $path
1811
1812 =back
1813
1814 Returns C<'remove'>, C<'create'>, or C<''> if there is no action.
1815 Throws a fatal exception if an invalid action is found.
1816
1817 =cut
1818
1819 sub dir_task_action {
1820     my $self = shift;
1821     my ($path) = @_;
1822
1823     if (! exists $self->{dir_task_for}{$path}) {
1824         debug(4, 1, "dir_task_action($path): no task");
1825         return '';
1826     }
1827
1828     my $action = $self->{dir_task_for}{$path}->{action};
1829     internal_error("bad task action: $action")
1830         unless $action eq 'remove' or $action eq 'create';
1831
1832     debug(4, 1, "dir_task_action($path): dir task exists with action $action");
1833     return $action;
1834 }
1835
1836 =head2 parent_link_scheduled_for_removal($path)
1837
1838 Determine whether the given path or any parent thereof is a link
1839 scheduled for removal
1840
1841 =over 4
1842
1843 =item $path
1844
1845 =back
1846
1847 Returns boolean
1848
1849 =cut
1850
1851 sub parent_link_scheduled_for_removal {
1852     my $self = shift;
1853     my ($path) = @_;
1854
1855     my $prefix = '';
1856     for my $part (split m{/+}, $path) {
1857         $prefix = join_paths($prefix, $part);
1858         debug(4, 2, "parent_link_scheduled_for_removal($path): prefix $prefix");
1859         if (exists $self->{link_task_for}{$prefix} and
1860              $self->{link_task_for}{$prefix}->{action} eq 'remove') {
1861             debug(4, 2, "parent_link_scheduled_for_removal($path): link scheduled for removal");
1862             return 1;
1863         }
1864     }
1865
1866     debug(4, 2, "parent_link_scheduled_for_removal($path): returning false");
1867     return 0;
1868 }
1869
1870 =head2 is_a_link($path)
1871
1872 Determine if the given path is a current or planned link.
1873
1874 =over 4
1875
1876 =item $path
1877
1878 =back
1879
1880 Returns false if an existing link is scheduled for removal and true if
1881 a non-existent link is scheduled for creation.
1882
1883 =cut
1884
1885 sub is_a_link {
1886     my $self = shift;
1887     my ($path) = @_;
1888     debug(4, 1, "is_a_link($path)");
1889
1890     if (my $action = $self->link_task_action($path)) {
1891         if ($action eq 'remove') {
1892             debug(4, 1, "is_a_link($path): returning 0 (remove action found)");
1893             return 0;
1894         }
1895         elsif ($action eq 'create') {
1896             debug(4, 1, "is_a_link($path): returning 1 (create action found)");
1897             return 1;
1898         }
1899     }
1900
1901     if (-l $path) {
1902         # Check if any of its parent are links scheduled for removal
1903         # (need this for edge case during unfolding)
1904         debug(4, 1, "is_a_link($path): is a real link");
1905         return $self->parent_link_scheduled_for_removal($path) ? 0 : 1;
1906     }
1907
1908     debug(4, 1, "is_a_link($path): returning 0");
1909     return 0;
1910 }
1911
1912 =head2 is_a_dir($path)
1913
1914 Determine if the given path is a current or planned directory
1915
1916 =over 4
1917
1918 =item $path
1919
1920 =back
1921
1922 Returns false if an existing directory is scheduled for removal and
1923 true if a non-existent directory is scheduled for creation.  We also
1924 need to be sure we are not just following a link.
1925
1926 =cut
1927
1928 sub is_a_dir {
1929     my $self = shift;
1930     my ($path) = @_;
1931     debug(4, 1, "is_a_dir($path)");
1932
1933     if (my $action = $self->dir_task_action($path)) {
1934         if ($action eq 'remove') {
1935             return 0;
1936         }
1937         elsif ($action eq 'create') {
1938             return 1;
1939         }
1940     }
1941
1942     return 0 if $self->parent_link_scheduled_for_removal($path);
1943
1944     if (-d $path) {
1945         debug(4, 1, "is_a_dir($path): real dir");
1946         return 1;
1947     }
1948
1949     debug(4, 1, "is_a_dir($path): returning false");
1950     return 0;
1951 }
1952
1953 =head2 is_a_node($path)
1954
1955 Determine whether the given path is a current or planned node.
1956
1957 =over 4
1958
1959 =item $path
1960
1961 =back
1962
1963 Returns false if an existing node is scheduled for removal, or true if
1964 a non-existent node is scheduled for creation.  We also need to be
1965 sure we are not just following a link.
1966
1967 =cut
1968
1969 sub is_a_node {
1970     my $self = shift;
1971     my ($path) = @_;
1972     debug(4, 1, "Checking whether $path is a current/planned node");
1973
1974     my $laction = $self->link_task_action($path);
1975     my $daction = $self->dir_task_action($path);
1976
1977     if ($laction eq 'remove') {
1978         if ($daction eq 'remove') {
1979             internal_error("removing link and dir: $path");
1980             return 0;
1981         }
1982         elsif ($daction eq 'create') {
1983             # Assume that we're unfolding $path, and that the link
1984             # removal action is earlier than the dir creation action
1985             # in the task queue.  FIXME: is this a safe assumption?
1986             return 1;
1987         }
1988         else { # no dir action
1989             return 0;
1990         }
1991     }
1992     elsif ($laction eq 'create') {
1993         if ($daction eq 'remove') {
1994             # Assume that we're folding $path, and that the dir
1995             # removal action is earlier than the link creation action
1996             # in the task queue.  FIXME: is this a safe assumption?
1997             return 1;
1998         }
1999         elsif ($daction eq 'create') {
2000             internal_error("creating link and dir: $path");
2001             return 1;
2002         }
2003         else { # no dir action
2004             return 1;
2005         }
2006     }
2007     else {
2008         # No link action
2009         if ($daction eq 'remove') {
2010             return 0;
2011         }
2012         elsif ($daction eq 'create') {
2013             return 1;
2014         }
2015         else { # no dir action
2016             # fall through to below
2017         }
2018     }
2019
2020     return 0 if $self->parent_link_scheduled_for_removal($path);
2021
2022     if (-e $path) {
2023         debug(4, 1, "is_a_node($path): really exists");
2024         return 1;
2025     }
2026
2027     debug(4, 1, "is_a_node($path): returning false");
2028     return 0;
2029 }
2030
2031 =head2 read_a_link($path)
2032
2033 Return the source of a current or planned link
2034
2035 =over 4
2036
2037 =item $path
2038
2039 path to the link target
2040
2041 =back
2042
2043 Returns a string.  Throws a fatal exception if the given path is not a
2044 current or planned link.
2045
2046 =cut
2047
2048 sub read_a_link {
2049     my $self = shift;
2050     my ($path) = @_;
2051
2052     if (my $action = $self->link_task_action($path)) {
2053         debug(4, 1, "read_a_link($path): task exists with action $action");
2054
2055         if ($action eq 'create') {
2056             return $self->{link_task_for}{$path}->{source};
2057         }
2058         elsif ($action eq 'remove') {
2059             internal_error(
2060                 "read_a_link() passed a path that is scheduled for removal: $path"
2061             );
2062         }
2063     }
2064     elsif (-l $path) {
2065         debug(4, 1, "read_a_link($path): real link");
2066         my $target = readlink $path or error("Could not read link: $path ($!)");
2067         return $target;
2068     }
2069     internal_error("read_a_link() passed a non link path: $path\n");
2070 }
2071
2072 =head2 do_link($link_dest, $link_src)
2073
2074 Wrap 'link' operation for later processing
2075
2076 =over 4
2077
2078 =item $link_dest
2079
2080 the existing file to link to
2081
2082 =item $link_src
2083
2084 the file to link
2085
2086 =back
2087
2088 Throws an error if this clashes with an existing planned operation.
2089 Cleans up operations that undo previous operations.
2090
2091 =cut
2092
2093 sub do_link {
2094     my $self = shift;
2095     my ($link_dest, $link_src) = @_;
2096
2097     if (exists $self->{dir_task_for}{$link_src}) {
2098         my $task_ref = $self->{dir_task_for}{$link_src};
2099
2100         if ($task_ref->{action} eq 'create') {
2101             if ($task_ref->{type} eq 'dir') {
2102                 internal_error(
2103                     "new link (%s => %s) clashes with planned new directory",
2104                     $link_src,
2105                     $link_dest,
2106                 );
2107             }
2108         }
2109         elsif ($task_ref->{action} eq 'remove') {
2110             # We may need to remove a directory before creating a link so continue.
2111         }
2112         else {
2113             internal_error("bad task action: $task_ref->{action}");
2114         }
2115     }
2116
2117     if (exists $self->{link_task_for}{$link_src}) {
2118         my $task_ref = $self->{link_task_for}{$link_src};
2119
2120         if ($task_ref->{action} eq 'create') {
2121             if ($task_ref->{source} ne $link_dest) {
2122                 internal_error(
2123                     "new link clashes with planned new link: %s => %s",
2124                     $task_ref->{path},
2125                     $task_ref->{source},
2126                 )
2127             }
2128             else {
2129                 debug(1, 0, "LINK: $link_src => $link_dest (duplicates previous action)");
2130                 return;
2131             }
2132         }
2133         elsif ($task_ref->{action} eq 'remove') {
2134             if ($task_ref->{source} eq $link_dest) {
2135                 # No need to remove a link we are going to recreate
2136                 debug(1, 0, "LINK: $link_src => $link_dest (reverts previous action)");
2137                 $self->{link_task_for}{$link_src}->{action} = 'skip';
2138                 delete $self->{link_task_for}{$link_src};
2139                 return;
2140             }
2141             # We may need to remove a link to replace it so continue
2142         }
2143         else {
2144             internal_error("bad task action: $task_ref->{action}");
2145         }
2146     }
2147
2148     # Creating a new link
2149     debug(1, 0, "LINK: $link_src => $link_dest");
2150     my $task = {
2151         action  => 'create',
2152         type    => 'link',
2153         path    => $link_src,
2154         source  => $link_dest,
2155     };
2156     push @{ $self->{tasks} }, $task;
2157     $self->{link_task_for}{$link_src} = $task;
2158
2159     return;
2160 }
2161
2162 =head2 do_unlink($file)
2163
2164 Wrap 'unlink' operation for later processing
2165
2166 =over 4
2167
2168 =item $file
2169
2170 the file to unlink
2171
2172 =back
2173
2174 Throws an error if this clashes with an existing planned operation.
2175 Will remove an existing planned link.
2176
2177 =cut
2178
2179 sub do_unlink {
2180     my $self = shift;
2181     my ($file) = @_;
2182
2183     if (exists $self->{link_task_for}{$file}) {
2184         my $task_ref = $self->{link_task_for}{$file};
2185         if ($task_ref->{action} eq 'remove') {
2186             debug(1, 0, "UNLINK: $file (duplicates previous action)");
2187             return;
2188         }
2189         elsif ($task_ref->{action} eq 'create') {
2190             # Do need to create a link then remove it
2191             debug(1, 0, "UNLINK: $file (reverts previous action)");
2192             $self->{link_task_for}{$file}->{action} = 'skip';
2193             delete $self->{link_task_for}{$file};
2194             return;
2195         }
2196         else {
2197             internal_error("bad task action: $task_ref->{action}");
2198         }
2199     }
2200
2201     if (exists $self->{dir_task_for}{$file} and $self->{dir_task_for}{$file} eq 'create') {
2202         internal_error(
2203             "new unlink operation clashes with planned operation: %s dir %s",
2204             $self->{dir_task_for}{$file}->{action},
2205             $file
2206         );
2207     }
2208
2209     # Remove the link
2210     debug(1, 0, "UNLINK: $file");
2211
2212     my $source = readlink $file or error("could not readlink $file ($!)");
2213
2214     my $task = {
2215         action  => 'remove',
2216         type    => 'link',
2217         path    => $file,
2218         source  => $source,
2219     };
2220     push @{ $self->{tasks} }, $task;
2221     $self->{link_task_for}{$file} = $task;
2222
2223     return;
2224 }
2225
2226 =head2 do_mkdir($dir)
2227
2228 Wrap 'mkdir' operation
2229
2230 =over 4
2231
2232 =item $dir
2233
2234 the directory to remove
2235
2236 =back
2237
2238 Throws a fatal exception if operation fails.  Outputs a message if
2239 'verbose' option is set.  Does not perform operation if 'simulate'
2240 option is set.  Cleans up operations that undo previous operations.
2241
2242 =cut
2243
2244 sub do_mkdir {
2245     my $self = shift;
2246     my ($dir) = @_;
2247
2248     if (exists $self->{link_task_for}{$dir}) {
2249         my $task_ref = $self->{link_task_for}{$dir};
2250
2251         if ($task_ref->{action} eq 'create') {
2252             internal_error(
2253                 "new dir clashes with planned new link (%s => %s)",
2254                 $task_ref->{path},
2255                 $task_ref->{source},
2256             );
2257         }
2258         elsif ($task_ref->{action} eq 'remove') {
2259             # May need to remove a link before creating a directory so continue
2260         }
2261         else {
2262             internal_error("bad task action: $task_ref->{action}");
2263         }
2264     }
2265
2266     if (exists $self->{dir_task_for}{$dir}) {
2267         my $task_ref = $self->{dir_task_for}{$dir};
2268
2269         if ($task_ref->{action} eq 'create') {
2270             debug(1, 0, "MKDIR: $dir (duplicates previous action)");
2271             return;
2272         }
2273         elsif ($task_ref->{action} eq 'remove') {
2274             debug(1, 0, "MKDIR: $dir (reverts previous action)");
2275             $self->{dir_task_for}{$dir}->{action} = 'skip';
2276             delete $self->{dir_task_for}{$dir};
2277             return;
2278         }
2279         else {
2280             internal_error("bad task action: $task_ref->{action}");
2281         }
2282     }
2283
2284     debug(1, 0, "MKDIR: $dir");
2285     my $task = {
2286         action  => 'create',
2287         type    => 'dir',
2288         path    => $dir,
2289         source  => undef,
2290     };
2291     push @{ $self->{tasks} }, $task;
2292     $self->{dir_task_for}{$dir} = $task;
2293
2294     return;
2295 }
2296
2297 =head2 do_rmdir($dir)
2298
2299 Wrap 'rmdir' operation
2300
2301 =over 4
2302
2303 =item $dir
2304
2305 the directory to remove
2306
2307 =back
2308
2309 Throws a fatal exception if operation fails.  Outputs a message if
2310 'verbose' option is set.  Does not perform operation if 'simulate'
2311 option is set.
2312
2313 =cut
2314
2315 sub do_rmdir {
2316     my $self = shift;
2317     my ($dir) = @_;
2318
2319     if (exists $self->{link_task_for}{$dir}) {
2320         my $task_ref = $self->{link_task_for}{$dir};
2321         internal_error(
2322             "rmdir clashes with planned operation: %s link %s => %s",
2323             $task_ref->{action},
2324             $task_ref->{path},
2325             $task_ref->{source}
2326         );
2327     }
2328
2329     if (exists $self->{dir_task_for}{$dir}) {
2330         my $task_ref = $self->{link_task_for}{$dir};
2331
2332         if ($task_ref->{action} eq 'remove') {
2333             debug(1, 0, "RMDIR $dir (duplicates previous action)");
2334             return;
2335         }
2336         elsif ($task_ref->{action} eq 'create') {
2337             debug(1, 0, "MKDIR $dir (reverts previous action)");
2338             $self->{link_task_for}{$dir}->{action} = 'skip';
2339             delete $self->{link_task_for}{$dir};
2340             return;
2341         }
2342         else {
2343             internal_error("bad task action: $task_ref->{action}");
2344         }
2345     }
2346
2347     debug(1, 0, "RMDIR $dir");
2348     my $task = {
2349         action  => 'remove',
2350         type    => 'dir',
2351         path    => $dir,
2352         source  => '',
2353     };
2354     push @{ $self->{tasks} }, $task;
2355     $self->{dir_task_for}{$dir} = $task;
2356
2357     return;
2358 }
2359
2360 =head2 do_mv($src, $dst)
2361
2362 Wrap 'move' operation for later processing.
2363
2364 =over 4
2365
2366 =item $src
2367
2368 the file to move
2369
2370 =item $dst
2371
2372 the path to move it to
2373
2374 =back
2375
2376 Throws an error if this clashes with an existing planned operation.
2377 Alters contents of package installation image in stow dir.
2378
2379 =cut
2380
2381 sub do_mv {
2382     my $self = shift;
2383     my ($src, $dst) = @_;
2384
2385     if (exists $self->{link_task_for}{$src}) {
2386         # I don't *think* this should ever happen, but I'm not
2387         # 100% sure.
2388         my $task_ref = $self->{link_task_for}{$src};
2389         internal_error(
2390             "do_mv: pre-existing link task for $src; action: %s, source: %s",
2391             $task_ref->{action}, $task_ref->{source}
2392         );
2393     }
2394     elsif (exists $self->{dir_task_for}{$src}) {
2395         my $task_ref = $self->{dir_task_for}{$src};
2396         internal_error(
2397             "do_mv: pre-existing dir task for %s?! action: %s",
2398             $src, $task_ref->{action}
2399         );
2400     }
2401
2402     # Remove the link
2403     debug(1, 0, "MV: $src -> $dst");
2404
2405     my $task = {
2406         action  => 'move',
2407         type    => 'file',
2408         path    => $src,
2409         dest    => $dst,
2410     };
2411     push @{ $self->{tasks} }, $task;
2412
2413     # FIXME: do we need this for anything?
2414     #$self->{mv_task_for}{$file} = $task;
2415
2416     return;
2417 }
2418
2419
2420 #############################################################################
2421 #
2422 # End of methods; subroutines follow.
2423 # FIXME: Ideally these should be in a separate module.
2424
2425
2426 # ===== PRIVATE SUBROUTINE ===================================================
2427 # Name      : internal_error()
2428 # Purpose   : output internal error message in a consistent form and die
2429 =over 4
2430
2431 =item $message => error message to output
2432
2433 =back
2434
2435 Returns : n/a
2436 Throws    : n/a
2437
2438 =cut
2439
2440 sub internal_error {
2441     my ($format, @args) = @_;
2442     my $error = sprintf($format, @args);
2443     my $stacktrace = Carp::longmess();
2444     die <<EOF;
2445
2446 $ProgramName: INTERNAL ERROR: $error$stacktrace
2447
2448 This _is_ a bug. Please submit a bug report so we can fix it! :-)
2449 See http://www.gnu.org/software/stow/ for how to do this.
2450 EOF
2451 }
2452
2453 =head1 BUGS
2454
2455 =head1 SEE ALSO
2456
2457 =cut
2458
2459 1;
2460
2461 # Local variables:
2462 # mode: perl
2463 # end:
2464 # vim: ft=perl
2465
2466 #############################################################################
2467 # Default global list of ignore regexps follows
2468 # (automatically appended by the Makefile)
2469
2470 __DATA__