00dani/stow
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Initial Import

Browse source
This commit is contained in:
Troy Will 2009-04-12 20:38:34 -07:00
commit 38dcdcb08c
42 changed files with 24923 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

115
t/chkstow.t Executable file
View file

@ -0,0 +1,115 @@
#!/usr/local/bin/perl
#
# Testing cleanup_invalid_links()
#
# load as a library
BEGIN {
use lib qw(.);
require "t/util.pm";
require "chkstow";
}
use Test::More tests => 7;
use Test::Output;
use English qw(-no_match_vars);
### setup
eval { remove_dir('t/target'); };
make_dir('t/target');
chdir 't/target';
# setup stow directory
make_dir('stow');
make_file('stow/.stow');
# perl
make_dir('stow/perl/bin');
make_file('stow/perl/bin/perl');
make_file('stow/perl/bin/a2p');
make_dir('stow/perl/info');
make_file('stow/perl/info/perl');
make_dir('stow/perl/lib/perl');
make_dir('stow/perl/man/man1');
make_file('stow/perl/man/man1/perl.1');
# emacs
make_dir('stow/emacs/bin');
make_file('stow/emacs/bin/emacs');
make_file('stow/emacs/bin/etags');
make_dir('stow/emacs/info');
make_file('stow/emacs/info/emacs');
make_dir('stow/emacs/libexec/emacs');
make_dir('stow/emacs/man/man1');
make_file('stow/emacs/man/man1/emacs.1');
#setup target directory
make_dir('bin');
make_link('bin/a2p', '../stow/perl/bin/a2p');
make_link('bin/emacs', '../stow/emacs/bin/emacs');
make_link('bin/etags', '../stow/emacs/bin/etags');
make_link('bin/perl', '../stow/perl/bin/perl');
make_dir('info');
make_link('info/emacs', '../stow/emacs/info/emacs');
make_link('info/perl', '../stow/perl/info/perl');
make_link('lib', 'stow/perl/lib');
make_link('libexec', 'stow/emacs/libexec');
make_dir('man');
make_dir('man/man1');
make_link('man/man1/emacs', '../../stow/emacs/man/man1/emacs.1');
make_link('man/man1/perl', '../../stow/perl/man/man1/perl.1');
sub run_chkstow() {
process_options();
check_stow();
}
local @ARGV = ('-t', '.', '-b',);
stderr_like(
\&run_chkstow,
qr{\Askipping .*stow.*\z}xms,
"Skip directories containing .stow");
# squelch warn so that check_stow doesn't carp about skipping .stow all the time
$SIG{'__WARN__'} = sub { };
@ARGV = ('-t', '.', '-l',);
stdout_like(
\&run_chkstow,
qr{emacs$perl$stow}xms,
"List packages");
@ARGV = ('-t', '.', '-b',);
stdout_like(
\&run_chkstow,
qr{\A\z}xms,
"No bogus links exist");
@ARGV = ('-t', '.', '-a',);
stdout_like(
\&run_chkstow,
qr{\A\z}xms,
"No aliens exist");
# Create an alien
make_file('bin/alien');
@ARGV = ('-t', '.', '-a',);
stdout_like(
\&run_chkstow,
qr{Unstowed\ file:\ ./bin/alien}xms,
"Aliens exist");
make_link('bin/link', 'ireallyhopethisfiledoesn/t.exist');
@ARGV = ('-t', '.', '-b',);
stdout_like(
\&run_chkstow,
qr{Bogus\ link:\ ./bin/link}xms,
"Bogus links exist");
@ARGV = ('-b',);
process_options();
ok($Target == q{/usr/local},
"Default target is /usr/local/");

92
t/cleanup_invalid_links.t Normal file
View file

@ -0,0 +1,92 @@
#!/usr/local/bin/perl
#
# Testing cleanup_invalid_links()
#
# load as a library
BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; }
use Test::More tests => 3;
use English qw(-no_match_vars);
# local utility
sub reset_state {
@Tasks = ();
@Conflicts = ();
%Link_Task_For = ();
%Dir_Task_For = ();
%Options = ();
return;
}
### setup
eval { remove_dir('t/target'); };
eval { remove_dir('t/stow'); };
make_dir('t/target');
make_dir('t/stow');
chdir 't/target';
$Stow_Path= '../stow';
# Note that each of the following tests use a distinct set of files
#
# nothing to clean in a simple tree
#
reset_state();
$Option{'verbose'} = 1;
make_dir('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1');
make_link('bin1','../stow/pkg1/bin1');
cleanup_invalid_links('./');
is(
scalar @Tasks, 0
=> 'nothing to clean'
);
#
# cleanup a bad link in a simple tree
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin2');
make_dir('../stow/pkg2/bin2');
make_file('../stow/pkg2/bin2/file2a');
make_link('bin2/file2a','../../stow/pkg2/bin2/file2a');
make_link('bin2/file2b','../../stow/pkg2/bin2/file2b');
cleanup_invalid_links('bin2');
ok(
scalar(@Conflicts) == 0 &&
scalar @Tasks == 1 &&
$Link_Task_For{'bin2/file2b'}->{'action'} eq 'remove'
=> 'cleanup a bad link'
);
#use Data::Dumper;
#print Dumper(\@Tasks,\%Link_Task_For,\%Dir_Task_For);
#
# dont cleanup a bad link not owned by stow
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin3');
make_dir('../stow/pkg3/bin3');
make_file('../stow/pkg3/bin3/file3a');
make_link('bin3/file3a','../../stow/pkg3/bin3/file3a');
make_link('bin3/file3b','../../empty');
cleanup_invalid_links('bin3');
ok(
scalar(@Conflicts) == 0 &&
scalar @Tasks == 0
=> 'dont cleanup a bad link not owned by stow'
);

22
t/defer.t Normal file
View file

@ -0,0 +1,22 @@
#!/usr/local/bin/perl
#
# Testing defer().
#
# load as a library
BEGIN { use lib qw(. ..); require "stow"; }
use Test::More tests => 4;
$Option{'defer'} = [ 'man' ];
ok(defer('man/man1/file.1') => 'simple success');
$Option{'defer'} = [ 'lib' ];
ok(!defer('man/man1/file.1') => 'simple failure');
$Option{'defer'} = [ 'lib', 'man', 'share' ];
ok(defer('man/man1/file.1') => 'complex success');
$Option{'defer'} = [ 'lib', 'man', 'share' ];
ok(!defer('bin/file') => 'complex failure');

204
t/examples.t Normal file
View file

@ -0,0 +1,204 @@
#!/usr/local/bin/perl
#
# Testing examples from the documentation
#
# load as a library
BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; }
use Test::More tests => 4;
use English qw(-no_match_vars);
# local utility
sub reset_state {
@Tasks = ();
@Conflicts = ();
%Link_Task_For = ();
%Dir_Task_For = ();
%Options = ();
return;
}
### setup
eval { remove_dir('t/target'); };
make_dir('t/target/stow');
chdir 't/target';
$Stow_Path= 'stow';
## set up some fake packages to stow
# perl
make_dir('stow/perl/bin');
make_file('stow/perl/bin/perl');
make_file('stow/perl/bin/a2p');
make_dir('stow/perl/info');
make_file('stow/perl/info/perl');
make_dir('stow/perl/lib/perl');
make_dir('stow/perl/man/man1');
make_file('stow/perl/man/man1/perl.1');
# emacs
make_dir('stow/emacs/bin');
make_file('stow/emacs/bin/emacs');
make_file('stow/emacs/bin/etags');
make_dir('stow/emacs/info');
make_file('stow/emacs/info/emacs');
make_dir('stow/emacs/libexec/emacs');
make_dir('stow/emacs/man/man1');
make_file('stow/emacs/man/man1/emacs.1');
#
# stow perl into an empty target
#
reset_state();
$Option{'verbose'} = 0;
make_dir('stow/perl/bin');
make_file('stow/perl/bin/perl');
make_file('stow/perl/bin/a2p');
make_dir('stow/perl/info');
make_dir('stow/perl/lib/perl');
make_dir('stow/perl/man/man1');
make_file('stow/perl/man/man1/perl.1');
stow_contents('stow/perl','./','stow/perl');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-l 'bin' && -l 'info' && -l 'lib' && -l 'man' &&
readlink('bin') eq 'stow/perl/bin' &&
readlink('info') eq 'stow/perl/info' &&
readlink('lib') eq 'stow/perl/lib' &&
readlink('man') eq 'stow/perl/man'
=> 'stow perl into an empty target'
);
#
# stow perl into a non-empty target
#
reset_state();
$Option{'verbose'} = 0;
# clean up previous stow
remove_link('bin');
remove_link('info');
remove_link('lib');
remove_link('man');
make_dir('bin');
make_dir('lib');
make_dir('man/man1');
stow_contents('stow/perl','./','stow/perl');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-d 'bin' && -d 'lib' && -d 'man' && -d 'man/man1' &&
-l 'info' && -l 'bin/perl' && -l 'bin/a2p' &&
-l 'lib/perl' && -l 'man/man1/perl.1' &&
readlink('info') eq 'stow/perl/info' &&
readlink('bin/perl') eq '../stow/perl/bin/perl' &&
readlink('bin/a2p') eq '../stow/perl/bin/a2p' &&
readlink('lib/perl') eq '../stow/perl/lib/perl' &&
readlink('man/man1/perl.1') eq '../../stow/perl/man/man1/perl.1'
=> 'stow perl into a non-empty target'
);
#
# Install perl into an empty target and then install emacs
#
reset_state();
$Option{'verbose'} = 0;
# clean up previous stow
remove_link('info');
remove_dir('bin');
remove_dir('lib');
remove_dir('man');
stow_contents('stow/perl', './','stow/perl');
stow_contents('stow/emacs','./','stow/emacs');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-d 'bin' &&
-l 'bin/perl' &&
-l 'bin/emacs' &&
-l 'bin/a2p' &&
-l 'bin/etags' &&
readlink('bin/perl') eq '../stow/perl/bin/perl' &&
readlink('bin/a2p') eq '../stow/perl/bin/a2p' &&
readlink('bin/emacs') eq '../stow/emacs/bin/emacs' &&
readlink('bin/etags') eq '../stow/emacs/bin/etags' &&
-d 'info' &&
-l 'info/perl' &&
-l 'info/emacs' &&
readlink('info/perl') eq '../stow/perl/info/perl' &&
readlink('info/emacs') eq '../stow/emacs/info/emacs' &&
-d 'man' &&
-d 'man/man1' &&
-l 'man/man1/perl.1' &&
-l 'man/man1/emacs.1' &&
readlink('man/man1/perl.1') eq '../../stow/perl/man/man1/perl.1' &&
readlink('man/man1/emacs.1') eq '../../stow/emacs/man/man1/emacs.1' &&
-l 'lib' &&
-l 'libexec' &&
readlink('lib') eq 'stow/perl/lib' &&
readlink('libexec') eq 'stow/emacs/libexec' &&
1
=> 'stow perl into an empty target, then stow emacs'
);
#
# BUG 1:
# 1. stowing a package with an empty directory
# 2. stow another package with the same directory but non empty
# 3. unstow the second package
# Q. the original empty directory should remain
# behaviour is the same as if the empty directory had nothing to do with stow
#
reset_state();
$Option{'verbose'} = 0;
make_dir('stow/pkg1a/bin1');
make_dir('stow/pkg1b/bin1');
make_file('stow/pkg1b/bin1/file1b');
stow_contents('stow/pkg1a', './', 'stow/pkg1a');
stow_contents('stow/pkg1b', './', 'stow/pkg1b');
unstow_contents('stow/pkg1b', './', 'stow/pkg1b');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-d 'bin1'
=> 'bug 1: stowing empty dirs'
);
#
# BUG 2: split open tree-folding symlinks pointing inside different stow
# directories
#
reset_state();
$Option{'verbose'} = 0;
make_dir('stow2a/pkg2a/bin2');
make_file('stow2a/pkg2a/bin2/file2a');
make_file('stow2a/.stow');
make_dir('stow2b/pkg2b/bin2');
make_file('stow2b/pkg2b/bin2/file2b');
make_file('stow2b/.stow');
stow_contents('stow2a/pkg2a','./', 'stow2a/pkg2a');
stow_contents('stow2b/pkg2b','./', 'stow2b/pkg2b');
process_tasks();
## Finish this test

51
t/find_stowed_path.t Normal file
View file

@ -0,0 +1,51 @@
#!/usr/local/bin/perl
#
# Testing find_stowed_path()
#
BEGIN { require "t/util.pm"; require "stow"; }
use Test::More tests => 5;
eval { remove_dir('t/target'); };
eval { remove_dir('t/stow'); };
make_dir('t/target');
make_dir('t/stow');
$Stow_Path = 't/stow';
is(
find_stowed_path('t/target/a/b/c', '../../../stow/a/b/c'),
't/stow/a/b/c',
=> 'from root'
);
$Stow_Path = '../stow';
is(
find_stowed_path('a/b/c','../../../stow/a/b/c'),
'../stow/a/b/c',
=> 'from target directory'
);
$Stow_Path = 't/target/stow';
is(
find_stowed_path('t/target/a/b/c', '../../stow/a/b/c'),
't/target/stow/a/b/c',
=> 'stow is subdir of target directory'
);
is(
find_stowed_path('t/target/a/b/c','../../empty'),
'',
=> 'target is not stowed'
);
make_dir('t/target/stow2');
make_file('t/target/stow2/.stow');
is(
find_stowed_path('t/target/a/b/c','../../stow2/a/b/c'),
't/target/stow2/a/b/c'
=> q(detect alternate stow directory)
);

74
t/foldable.t Normal file
View file

@ -0,0 +1,74 @@
#!/usr/local/bin/perl
#
# Testing foldable()
#
# load as a library
BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; }
use Test::More tests => 4;
use English qw(-no_match_vars);
### setup
# be very careful with these
eval { remove_dir('t/target'); };
eval { remove_dir('t/stow'); };
make_dir('t/target');
make_dir('t/stow');
chdir 't/target';
$Stow_Path= '../stow';
# Note that each of the following tests use a distinct set of files
#
# can fold a simple tree
#
$Option{'verbose'} = 0;
make_dir('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1');
make_dir('bin1');
make_link('bin1/file1','../../stow/pkg1/bin1/file1');
is( foldable('bin1'), '../stow/pkg1/bin1' => q(can fold a simple tree) );
#
# can't fold an empty directory
#
$Option{'verbose'} = 0;
make_dir('../stow/pkg2/bin2');
make_file('../stow/pkg2/bin2/file2');
make_dir('bin2');
is( foldable('bin2'), '' => q(can't fold an empty directory) );
#
# can't fold if dir contains a non-link
#
$Option{'verbose'} = 0;
make_dir('../stow/pkg3/bin3');
make_file('../stow/pkg3/bin3/file3');
make_dir('bin3');
make_link('bin3/file3','../../stow/pkg3/bin3/file3');
make_file('bin3/non-link');
is( foldable('bin3'), '' => q(can't fold a dir containing non-links) );
#
# can't fold if links point to different directories
#
$Option{'verbose'} = 0;
make_dir('bin4');
make_dir('../stow/pkg4a/bin4');
make_file('../stow/pkg4a/bin4/file4a');
make_link('bin4/file4a','../../stow/pkg4a/bin4/file4a');
make_dir('../stow/pkg4b/bin4');
make_file('../stow/pkg4b/bin4/file4b');
make_link('bin4/file4b','../../stow/pkg4b/bin4/file4b');
is( foldable('bin4'), '' => q(can't fold if links point to different dirs) );

89
t/join_paths.t Normal file
View file

@ -0,0 +1,89 @@
#!/usr/local/bin/perl
#
# Testing join_paths();
#
# load as a library
BEGIN { use lib qw(. ..); require "stow"; }
use Test::More tests => 13;
is(
join_paths('a/b/c', 'd/e/f'),
'a/b/c/d/e/f',
=> 'simple'
);
is(
join_paths('/a/b/c', '/d/e/f'),
'/a/b/c/d/e/f',
=> 'leading /'
);
is(
join_paths('/a/b/c/', '/d/e/f/'),
'/a/b/c/d/e/f',
=> 'trailing /'
);
is(
join_paths('///a/b///c//', '/d///////e/f'),
'/a/b/c/d/e/f',
=> 'mltiple /\'s'
);
is(
join_paths('', 'a/b/c'),
'a/b/c',
=> 'first empty'
);
is(
join_paths('a/b/c', ''),
'a/b/c',
=> 'second empty'
);
is(
join_paths('/', 'a/b/c'),
'/a/b/c',
=> 'first is /'
);
is(
join_paths('a/b/c', '/'),
'a/b/c',
=> 'second is /'
);
is(
join_paths('///a/b///c//', '/d///////e/f'),
'/a/b/c/d/e/f',
=> 'multiple /\'s'
);
is(
join_paths('../a1/b1/../c1/', '/a2/../b2/e2'),
'../a1/c1/b2/e2',
=> 'simple deref ".."'
);
is(
join_paths('../a1/b1/../c1/d1/e1', '../a2/../b2/c2/d2/../e2'),
'../a1/c1/d1/b2/c2/e2',
=> 'complex deref ".."'
);
is(
join_paths('../a1/../../c1', 'a2/../../'),
'../..',
=> 'too many ".."'
);
is(
join_paths('./a1', '../../a2'),
'../a2',
=> 'drop any "./"'
);

41
t/parent.t Normal file
View file

@ -0,0 +1,41 @@
#!/usr/local/bin/perl
#
# Testing parent()
#
# load as a library
BEGIN { use lib qw(. ..); require "stow"; }
use Test::More tests => 5;
is(
parent('a/b/c'),
'a/b',
=> 'no leading or trailing /'
);
is(
parent('/a/b/c'),
'/a/b',
=> 'leading /'
);
is(
parent('a/b/c/'),
'a/b',
=> 'trailing /'
);
is(
parent('/////a///b///c///'),
'/a/b',
=> 'multiple /'
);
is (
parent('a'),
''
=> 'empty parent'
);

41
t/relative_path.t Normal file
View file

@ -0,0 +1,41 @@
#!/usr/local/bin/perl
#
# Testing relative_path();
#
# load as a library
BEGIN { use lib qw(. ..); require "stow"; }
use Test::More tests => 5;
is(
relative_path('a/b/c', 'a/b/d'),
'../d',
=> 'diferent branches'
);
is(
relative_path('/a/b/c', '/a/b/c/d'),
'd',
=> 'lower same branch'
);
is(
relative_path('a/b/c', 'a/b'),
'..',
=> 'higher, same branch'
);
is(
relative_path('/a/b/c', '/d/e/f'),
'../../../d/e/f',
=> 'common parent is /'
);
is(
relative_path('///a//b//c////', '/a////b/c/d////'),
'd',
=> 'extra /\'s '
);

97
t/stow.t Normal file
View file

@ -0,0 +1,97 @@
#!/usr/local/bin/perl
#
# Testing core application
#
# load as a library
BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; }
use Test::More tests => 10;
local @ARGV = (
'-v',
'-d t/stow',
'-t t/target',
'dummy'
);
### setup
eval { remove_dir('t/target'); };
eval { remove_dir('t/stow'); };
make_dir('t/target');
make_dir('t/stow');
ok eval {process_options(); 1} => 'process options';
ok eval {set_stow_path(); 1} => 'set stow path';
is($Stow_Path,"../stow" => 'stow dir');
is_deeply(\@Pkgs_To_Stow, [ 'dummy' ] => 'default to stow');
#
# Check mixed up package options
#
%Option=();
local @ARGV = (
'-v',
'-D', 'd1', 'd2',
'-S', 's1',
'-R', 'r1',
'-D', 'd3',
'-S', 's2', 's3',
'-R', 'r2',
);
@Pkgs_To_Stow = ();
@Pkgs_To_Delete = ();
process_options();
is_deeply(\@Pkgs_To_Delete, [ 'd1', 'd2', 'r1', 'd3', 'r2' ] => 'mixed deletes');
is_deeply(\@Pkgs_To_Stow, [ 's1', 'r1', 's2', 's3', 'r2' ] => 'mixed stows');
#
# Check setting defered paths
#
%Option=();
local @ARGV = (
'--defer=man',
'--defer=info'
);
process_options();
is_deeply($Option{'defer'}, [ qr(\Aman), qr(\Ainfo) ] => 'defer man and info');
#
# Check setting override paths
#
%Option=();
local @ARGV = (
'--override=man',
'--override=info'
);
process_options();
is_deeply($Option{'override'}, [qr(\Aman), qr(\Ainfo)] => 'override man and info');
#
# Check stripping any matched quotes
#
%Option=();
local @ARGV = (
"--override='man'",
'--override="info"',
);
process_options();
is_deeply($Option{'override'}, [qr(\Aman), qr(\Ainfo)] => 'strip shell quoting');
#
# Check setting ignored paths
#
%Option=();
local @ARGV = (
'--ignore="~"',
'--ignore="\.#.*'
);
process_options();
is_deeply($Option{'ignore'}, [ qr(~\z), qr(\.#.*\z) ] => 'ignore temp files');
# vim:ft=perl

283
t/stow_contents.t Normal file
View file

@ -0,0 +1,283 @@
#!/usr/local/bin/perl
#
# Testing
#
# load as a library
BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; }
use Test::More tests => 13;
use English qw(-no_match_vars);
# local utility
sub reset_state {
@Tasks = ();
@Conflicts = ();
%Link_Task_For = ();
%Dir_Task_For = ();
%Options = ();
return;
}
### setup
eval { remove_dir('t/target'); };
eval { remove_dir('t/stow'); };
make_dir('t/target');
make_dir('t/stow');
chdir 't/target';
$Stow_Path= '../stow';
# Note that each of the following tests use a distinct set of files
#
# stow a simple tree minimally
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1');
stow_contents('../stow/pkg1', './', '../stow/pkg1');
process_tasks();
is(
readlink('bin1'),
'../stow/pkg1/bin1',
=> 'minimal stow of a simple tree'
);
#
# stow a simple tree into an existing directory
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg2/lib2');
make_file('../stow/pkg2/lib2/file2');
make_dir('lib2');
stow_contents('../stow/pkg2', './', '../stow/pkg2');
process_tasks();
is(
readlink('lib2/file2'),
'../../stow/pkg2/lib2/file2',
=> 'stow simple tree to existing directory'
);
#
# unfold existing tree
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg3a/bin3');
make_file('../stow/pkg3a/bin3/file3a');
make_link('bin3' => '../stow/pkg3a/bin3'); # emulate stow
make_dir('../stow/pkg3b/bin3');
make_file('../stow/pkg3b/bin3/file3b');
stow_contents('../stow/pkg3b', './', '../stow/pkg3b');
process_tasks();
ok(
-d 'bin3' &&
readlink('bin3/file3a') eq '../../stow/pkg3a/bin3/file3a' &&
readlink('bin3/file3b') eq '../../stow/pkg3b/bin3/file3b'
=> 'target already has 1 stowed package'
);
#
# Link to a new dir conflicts with existing non-dir (can't unfold)
#
reset_state();
$Option{'verbose'} = 0;
make_file('bin4'); # this is a file but named like a directory
make_dir('../stow/pkg4/bin4');
make_file('../stow/pkg4/bin4/file4');
stow_contents('../stow/pkg4', './', '../stow/pkg4');
like(
$Conflicts[-1], qr(CONFLICT:.*existing target is neither a link nor a directory)
=> 'link to new dir conflicts with existing non-directory'
);
#
# Target already exists but is not owned by stow
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin5');
make_link('bin5/file5','../../empty');
make_dir('../stow/pkg5/bin5/file5');
stow_contents('../stow/pkg5', './', '../stow/pkg5');
like(
$Conflicts[-1], qr(CONFLICT:.*not owned by stow)
=> 'target already exists but is not owned by stow'
);
#
# Replace existing but invalid target
#
reset_state();
$Option{'verbose'} = 0;
make_link('file6','../stow/path-does-not-exist');
make_dir('../stow/pkg6');
make_file('../stow/pkg6/file6');
eval{ stow_contents('../stow/pkg6', './', '../stow/pkg6'); process_tasks() };
is(
readlink('file6'),
'../stow/pkg6/file6'
=> 'replace existing but invalid target'
);
#
# Target already exists, is owned by stow, but points to a non-directory
# (can't unfold)
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin7');
make_dir('../stow/pkg7a/bin7');
make_file('../stow/pkg7a/bin7/node7');
make_link('bin7/node7','../../stow/pkg7a/bin7/node7');
make_dir('../stow/pkg7b/bin7/node7');
make_file('../stow/pkg7b/bin7/node7/file7');
stow_contents('../stow/pkg7b', './', '../stow/pkg7b');
like(
$Conflicts[-1], qr(CONFLICT:.*existing target is stowed to a different package)
=> 'link to new dir conflicts with existing stowed non-directory'
);
#
# stowing directories named 0
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg8a/0');
make_file('../stow/pkg8a/0/file8a');
make_link('0' => '../stow/pkg8a/0'); # emulate stow
make_dir('../stow/pkg8b/0');
make_file('../stow/pkg8b/0/file8b');
stow_contents('../stow/pkg8b', './', '../stow/pkg8b');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-d '0' &&
readlink('0/file8a') eq '../../stow/pkg8a/0/file8a' &&
readlink('0/file8b') eq '../../stow/pkg8b/0/file8b'
=> 'stowing directories named 0'
);
#
# overriding already stowed documentation
#
reset_state();
$Option{'verbose'} = 0;
$Option{'override'} = ['man9', 'info9'];
make_dir('../stow/pkg9a/man9/man1');
make_file('../stow/pkg9a/man9/man1/file9.1');
make_dir('man9/man1');
make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow
make_dir('../stow/pkg9b/man9/man1');
make_file('../stow/pkg9b/man9/man1/file9.1');
stow_contents('../stow/pkg9b', './', '../stow/pkg9b');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
readlink('man9/man1/file9.1') eq '../../../stow/pkg9b/man9/man1/file9.1'
=> 'overriding existing documentation files'
);
#
# deferring to already stowed documentation
#
reset_state();
$Option{'verbose'} = 0;
$Option{'defer'} = ['man10', 'info10'];
make_dir('../stow/pkg10a/man10/man1');
make_file('../stow/pkg10a/man10/man1/file10.1');
make_dir('man10/man1');
make_link('man10/man1/file10.1' => '../../../stow/pkg10a/man10/man1/file10.1'); # emulate stow
make_dir('../stow/pkg10b/man10/man1');
make_file('../stow/pkg10b/man10/man1/file10.1');
stow_contents('../stow/pkg10b', './', '../stow/pkg10b');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
readlink('man10/man1/file10.1') eq '../../../stow/pkg10a/man10/man1/file10.1'
=> 'defer to existing documentation files'
);
#
# Ignore temp files
#
reset_state();
$Option{'verbose'} = 0;
$Option{'ignore'} = ['~', '\.#.*'];
make_dir('../stow/pkg11/man11/man1');
make_file('../stow/pkg11/man11/man1/file11.1');
make_file('../stow/pkg11/man11/man1/file11.1~');
make_file('../stow/pkg11/man11/man1/.#file11.1');
make_dir('man11/man1');
stow_contents('../stow/pkg11', './', '../stow/pkg11');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
readlink('man11/man1/file11.1') eq '../../../stow/pkg11/man11/man1/file11.1' &&
!-e 'man11/man1/file11.1~' &&
!-e 'man11/man1/.#file11.1'
=> 'ignore temp files'
);
#
# stowing links library files
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg12/lib12/');
make_file('../stow/pkg12/lib12/lib.so');
make_link('../stow/pkg12/lib12/lib.so.1','lib.so');
make_dir('lib12/');
stow_contents('../stow/pkg12', './', '../stow/pkg12');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
readlink('lib12/lib.so.1') eq '../../stow/pkg12/lib12/lib.so.1'
=> 'stow links to libraries'
);
#
# unfolding to stow links to library files
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg13a/lib13/');
make_file('../stow/pkg13a/lib13/liba.so');
make_link('../stow/pkg13a/lib13/liba.so.1', 'liba.so');
make_link('lib13','../stow/pkg13a/lib13');
make_dir('../stow/pkg13b/lib13/');
make_file('../stow/pkg13b/lib13/libb.so');
make_link('../stow/pkg13b/lib13/libb.so.1', 'libb.so');
stow_contents('../stow/pkg13b', './', '../stow/pkg13b');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
readlink('lib13/liba.so.1') eq '../../stow/pkg13a/lib13/liba.so.1' &&
readlink('lib13/libb.so.1') eq '../../stow/pkg13b/lib13/libb.so.1'
=> 'unfolding to stow links to libraries'
);

276
t/unstow_contents.t Normal file
View file

@ -0,0 +1,276 @@
#!/usr/local/bin/perl
#
# Testing unstow_contents()
#
# load as a library
BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; }
use Test::More tests => 11;
use English qw(-no_match_vars);
# local utility
sub reset_state {
@Tasks = ();
@Conflicts = ();
%Link_Task_For = ();
%Dir_Task_For = ();
%Options = ();
return;
}
### setup
eval { remove_dir('t/target'); };
eval { remove_dir('t/stow'); };
make_dir('t/target');
make_dir('t/stow');
chdir 't/target';
$Stow_Path= '../stow';
# Note that each of the following tests use a distinct set of files
#
# unstow a simple tree minimally
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1');
make_link('bin1','../stow/pkg1/bin1');
unstow_contents('../stow/pkg1','./');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-f '../stow/pkg1/bin1/file1' && ! -e 'bin1'
=> 'unstow a simple tree'
);
#
# unstow a simple tree from an existing directory
#
reset_state();
$Option{'verbose'} = 0;
make_dir('lib2');
make_dir('../stow/pkg2/lib2');
make_file('../stow/pkg2/lib2/file2');
make_link('lib2/file2', '../../stow/pkg2/lib2/file2');
unstow_contents('../stow/pkg2','./');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-f '../stow/pkg2/lib2/file2' && -d 'lib2'
=> 'unstow simple tree from a pre-existing directory'
);
#
# fold tree after unstowing
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin3');
make_dir('../stow/pkg3a/bin3');
make_file('../stow/pkg3a/bin3/file3a');
make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow
make_dir('../stow/pkg3b/bin3');
make_file('../stow/pkg3b/bin3/file3b');
make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow
unstow_contents('../stow/pkg3b', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-l 'bin3' &&
readlink('bin3') eq '../stow/pkg3a/bin3'
=> 'fold tree after unstowing'
);
#
# existing link is owned by stow but is invalid so it gets removed anyway
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin4');
make_dir('../stow/pkg4/bin4');
make_file('../stow/pkg4/bin4/file4');
make_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist');
unstow_contents('../stow/pkg4', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
! -e 'bin4/file4'
=> q(remove invalid link owned by stow)
);
#
# Existing link is not owned by stow
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg5/bin5');
make_link('bin5', '../not-stow');
unstow_contents('../stow/pkg5', './');
like(
$Conflicts[-1], qr(CONFLICT:.*existing target is not owned by stow)
=> q(existing link not owned by stow)
);
#
# Target already exists, is owned by stow, but points to a different package
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin6');
make_dir('../stow/pkg6a/bin6');
make_file('../stow/pkg6a/bin6/file6');
make_link('bin6/file6', '../../stow/pkg6a/bin6/file6');
make_dir('../stow/pkg6b/bin6');
make_file('../stow/pkg6b/bin6/file6');
unstow_contents('../stow/pkg6b', './');
ok(
scalar(@Conflicts) == 0 &&
-l 'bin6/file6' &&
readlink('bin6/file6') eq '../../stow/pkg6a/bin6/file6'
=> q(ignore existing link that points to a different package)
);
#
# Don't unlink anything under the stow directory
#
reset_state();
$Option{'verbose'} = 0;
make_dir('stow'); # make out stow dir a subdir of target
$Stow_Path = 'stow';
# emulate stowing into ourself (bizzare corner case or accident)
make_dir('stow/pkg7a/stow/pkg7b');
make_file('stow/pkg7a/stow/pkg7b/file7b');
make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b');
unstow_contents('stow/pkg7b', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-l 'stow/pkg7b' &&
readlink('stow/pkg7b') eq '../stow/pkg7a/stow/pkg7b'
=> q(don't unlink any nodes under the stow directory)
);
#
# Don't unlink any nodes under another stow directory
#
reset_state();
$Option{'verbose'} = 0;
make_dir('stow'); # make out stow dir a subdir of target
$Stow_Path = 'stow';
make_dir('stow2'); # make our alternate stow dir a subdir of target
make_file('stow2/.stow');
# emulate stowing into ourself (bizzare corner case or accident)
make_dir('stow/pkg8a/stow2/pkg8b');
make_file('stow/pkg8a/stow2/pkg8b/file8b');
make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b');
unstow_contents('stow/pkg8a', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-l 'stow2/pkg8b' &&
readlink('stow2/pkg8b') eq '../stow/pkg8a/stow2/pkg8b'
=> q(don't unlink any nodes under another stow directory)
);
#
# overriding already stowed documentation
#
reset_state();
$Stow_Path = '../stow';
$Option{'verbose'} = 0;
$Option{'override'} = ['man9', 'info9'];
make_dir('../stow/pkg9a/man9/man1');
make_file('../stow/pkg9a/man9/man1/file9.1');
make_dir('man9/man1');
make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow
make_dir('../stow/pkg9b/man9/man1');
make_file('../stow/pkg9b/man9/man1/file9.1');
unstow_contents('../stow/pkg9b', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
!-l 'man9/man1/file9.1'
=> 'overriding existing documentation files'
);
#
# deferring to already stowed documentation
#
reset_state();
$Option{'verbose'} = 0;
$Option{'defer'} = ['man10', 'info10'];
make_dir('../stow/pkg10a/man10/man1');
make_file('../stow/pkg10a/man10/man1/file10a.1');
make_dir('man10/man1');
make_link('man10/man1/file10a.1' => '../../../stow/pkg10a/man10/man1/file10a.1');
# need this to block folding
make_dir('../stow/pkg10b/man10/man1');
make_file('../stow/pkg10b/man10/man1/file10b.1');
make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1');
make_dir('../stow/pkg10c/man10/man1');
make_file('../stow/pkg10c/man10/man1/file10a.1');
unstow_contents('../stow/pkg10c', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
readlink('man10/man1/file10a.1') eq '../../../stow/pkg10a/man10/man1/file10a.1'
=> 'defer to existing documentation files'
);
#
# Ignore temp files
#
reset_state();
$Option{'verbose'} = 0;
$Option{'ignore'} = ['~', '\.#.*'];
make_dir('../stow/pkg12/man12/man1');
make_file('../stow/pkg12/man12/man1/file12.1');
make_file('../stow/pkg12/man12/man1/file12.1~');
make_file('../stow/pkg12/man12/man1/.#file12.1');
make_dir('man12/man1');
make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1');
unstow_contents('../stow/pkg12', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
!-e 'man12/man1/file12.1'
=> 'ignore temp files'
);
# Todo
#
# Test cleaning up subdirs with --paranoid option

277
t/unstow_contents_orig.t Normal file
View file

@ -0,0 +1,277 @@
#!/usr/local/bin/perl
#
# Testing unstow_contents_orig()
#
# load as a library
BEGIN { use lib qw(.); require "t/util.pm"; require "stow"; }
use Test::More tests => 11;
use English qw(-no_match_vars);
# local utility
sub reset_state {
@Tasks = ();
@Conflicts = ();
%Link_Task_For = ();
%Dir_Task_For = ();
%Options = ();
return;
}
### setup
eval { remove_dir('t/target'); };
eval { remove_dir('t/stow'); };
make_dir('t/target');
make_dir('t/stow');
chdir 't/target';
$Stow_Path= '../stow';
# Note that each of the following tests use a distinct set of files
#
# unstow a simple tree minimally
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg1/bin1');
make_file('../stow/pkg1/bin1/file1');
make_link('bin1','../stow/pkg1/bin1');
unstow_contents_orig('../stow/pkg1','./');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-f '../stow/pkg1/bin1/file1' && ! -e 'bin1'
=> 'unstow a simple tree'
);
#
# unstow a simple tree from an existing directory
#
reset_state();
$Option{'verbose'} = 0;
make_dir('lib2');
make_dir('../stow/pkg2/lib2');
make_file('../stow/pkg2/lib2/file2');
make_link('lib2/file2', '../../stow/pkg2/lib2/file2');
unstow_contents_orig('../stow/pkg2','./');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-f '../stow/pkg2/lib2/file2' && -d 'lib2'
=> 'unstow simple tree from a pre-existing directory'
);
#
# fold tree after unstowing
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin3');
make_dir('../stow/pkg3a/bin3');
make_file('../stow/pkg3a/bin3/file3a');
make_link('bin3/file3a' => '../../stow/pkg3a/bin3/file3a'); # emulate stow
make_dir('../stow/pkg3b/bin3');
make_file('../stow/pkg3b/bin3/file3b');
make_link('bin3/file3b' => '../../stow/pkg3b/bin3/file3b'); # emulate stow
unstow_contents_orig('../stow/pkg3b', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-l 'bin3' &&
readlink('bin3') eq '../stow/pkg3a/bin3'
=> 'fold tree after unstowing'
);
#
# existing link is owned by stow but is invalid so it gets removed anyway
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin4');
make_dir('../stow/pkg4/bin4');
make_file('../stow/pkg4/bin4/file4');
make_link('bin4/file4', '../../stow/pkg4/bin4/does-not-exist');
unstow_contents_orig('../stow/pkg4', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
! -e 'bin4/file4'
=> q(remove invalid link owned by stow)
);
#
# Existing link is not owned by stow
#
reset_state();
$Option{'verbose'} = 0;
make_dir('../stow/pkg5/bin5');
make_link('bin5', '../not-stow');
unstow_contents_orig('../stow/pkg5', './');
#like(
# $Conflicts[-1], qr(CONFLICT:.*can't unlink.*not owned by stow)
# => q(existing link not owned by stow)
#);
ok(
-l 'bin5' && readlink('bin5') eq '../not-stow'
=> q(existing link not owned by stow)
);
#
# Target already exists, is owned by stow, but points to a different package
#
reset_state();
$Option{'verbose'} = 0;
make_dir('bin6');
make_dir('../stow/pkg6a/bin6');
make_file('../stow/pkg6a/bin6/file6');
make_link('bin6/file6', '../../stow/pkg6a/bin6/file6');
make_dir('../stow/pkg6b/bin6');
make_file('../stow/pkg6b/bin6/file6');
unstow_contents_orig('../stow/pkg6b', './');
ok(
-l 'bin6/file6' && readlink('bin6/file6') eq '../../stow/pkg6a/bin6/file6'
=> q(existing link owned by stow but points to a different package)
);
#
# Don't unlink anything under the stow directory
#
reset_state();
$Option{'verbose'} = 0;
make_dir('stow'); # make out stow dir a subdir of target
$Stow_Path = 'stow';
# emulate stowing into ourself (bizzare corner case or accident)
make_dir('stow/pkg7a/stow/pkg7b');
make_file('stow/pkg7a/stow/pkg7b/file7b');
make_link('stow/pkg7b', '../stow/pkg7a/stow/pkg7b');
unstow_contents_orig('stow/pkg7b', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-l 'stow/pkg7b' &&
readlink('stow/pkg7b') eq '../stow/pkg7a/stow/pkg7b'
=> q(don't unlink any nodes under the stow directory)
);
#
# Don't unlink any nodes under another stow directory
#
reset_state();
$Option{'verbose'} = 0;
make_dir('stow'); # make out stow dir a subdir of target
$Stow_Path = 'stow';
make_dir('stow2'); # make our alternate stow dir a subdir of target
make_file('stow2/.stow');
# emulate stowing into ourself (bizzare corner case or accident)
make_dir('stow/pkg8a/stow2/pkg8b');
make_file('stow/pkg8a/stow2/pkg8b/file8b');
make_link('stow2/pkg8b', '../stow/pkg8a/stow2/pkg8b');
unstow_contents_orig('stow/pkg8a', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
-l 'stow2/pkg8b' &&
readlink('stow2/pkg8b') eq '../stow/pkg8a/stow2/pkg8b'
=> q(don't unlink any nodes under another stow directory)
);
#
# overriding already stowed documentation
#
reset_state();
$Stow_Path = '../stow';
$Option{'verbose'} = 0;
$Option{'override'} = ['man9', 'info9'];
make_dir('../stow/pkg9a/man9/man1');
make_file('../stow/pkg9a/man9/man1/file9.1');
make_dir('man9/man1');
make_link('man9/man1/file9.1' => '../../../stow/pkg9a/man9/man1/file9.1'); # emulate stow
make_dir('../stow/pkg9b/man9/man1');
make_file('../stow/pkg9b/man9/man1/file9.1');
unstow_contents_orig('../stow/pkg9b', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
!-l 'man9/man1/file9.1'
=> 'overriding existing documentation files'
);
#
# deferring to already stowed documentation
#
reset_state();
$Option{'verbose'} = 0;
$Option{'defer'} = ['man10', 'info10'];
make_dir('../stow/pkg10a/man10/man1');
make_file('../stow/pkg10a/man10/man1/file10a.1');
make_dir('man10/man1');
make_link('man10/man1/file10a.1' => '../../../stow/pkg10a/man10/man1/file10a.1');
# need this to block folding
make_dir('../stow/pkg10b/man10/man1');
make_file('../stow/pkg10b/man10/man1/file10b.1');
make_link('man10/man1/file10b.1' => '../../../stow/pkg10b/man10/man1/file10b.1');
make_dir('../stow/pkg10c/man10/man1');
make_file('../stow/pkg10c/man10/man1/file10a.1');
unstow_contents_orig('../stow/pkg10c', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
readlink('man10/man1/file10a.1') eq '../../../stow/pkg10a/man10/man1/file10a.1'
=> 'defer to existing documentation files'
);
#
# Ignore temp files
#
reset_state();
$Option{'verbose'} = 0;
$Option{'ignore'} = ['~', '\.#.*'];
make_dir('../stow/pkg12/man12/man1');
make_file('../stow/pkg12/man12/man1/file12.1');
make_file('../stow/pkg12/man12/man1/file12.1~');
make_file('../stow/pkg12/man12/man1/.#file12.1');
make_dir('man12/man1');
make_link('man12/man1/file12.1' => '../../../stow/pkg12/man12/man1/file12.1');
unstow_contents_orig('../stow/pkg12', './');
process_tasks();
ok(
scalar(@Conflicts) == 0 &&
!-e 'man12/man1/file12.1'
=> 'ignore temp files'
);
# Todo
#
# Test cleaning up subdirs with --paranoid option

157
t/util.pm Normal file
View file

@ -0,0 +1,157 @@
#
# Utilities shared by test scripts
#
use strict;
use warnings;
#===== SUBROUTINE ===========================================================
# Name : make_link()
# Purpose : safely create a link
# Parameters: $target => path to the link
# : $source => where the new link should point
# Returns : n/a
# Throws : fatal error if the link can not be safely created
# Comments : checks for existing nodes
#============================================================================
sub make_link {
my ($target, $source) = @_;
if (-l $target) {
my $old_source = readlink join('/',parent($target),$source)
or die "could not read link $target/$source";
if ($old_source ne $source) {
die "$target already exists but points elsewhere\n";
}
}
elsif (-e $target ) {
die "$target already exists and is not a link\n";
}
else {
symlink $source, $target
or die "could not create link $target => $source ($!)\n";
}
return;
}
#===== SUBROUTINE ===========================================================
# Name : make_dir()
# Purpose : create a directory and any requiste parents
# Parameters: $dir => path to the new directory
# Returns : n/a
# Throws : fatal error if the directory or any of its parents cannot be
# : created
# Comments : none
#============================================================================
sub make_dir {
my ($dir) = @_;
my @parents = ();
for my $part (split '/', $dir) {
my $path = join '/', @parents, $part;
if (not -d $path and not mkdir $path) {
die "could not create directory: $path ($!)\n";
}
push @parents, $part;
}
return;
}
#===== SUBROUTINE ===========================================================
# Name : create_file()
# Purpose : create an empty file
# Parameters: $path => proposed path to the file
# Returns : n/a
# Throws : fatal error if the file could not be created
# Comments : detects clash with an existing non-file
#============================================================================
sub make_file {
my ($path) =@_;
if (not -e $path) {
open my $FILE ,'>', $path
or die "could not create file: $path ($!)\n";
close $FILE;
}
elsif ( not -f $path) {
die "a non-file already exists at $path\n";
}
return;
}
#===== SUBROUTINE ===========================================================
# Name : remove_link()
# Purpose : remove an esiting symbolic link
# Parameters: $path => path to the symbolic link
# Returns : n/a
# Throws : fatal error if the operation fails or if passed the path to a
# : non-link
# Comments : none
#============================================================================
sub remove_link {
my ($path) = @_;
if (not -l $path) {
die qq(remove_link() called with a non-link: $path);
}
unlink $path or die "could not remove link: $path ($!)\n";
return;
}
#===== SUBROUTINE ===========================================================
# Name : remove_file()
# Purpose : remove an existing empty file
# Parameters: $path => the path to the empty file
# Returns : n/a
# Throws : fatal error if given file is non-empty or the operation fails
# Comments : none
#============================================================================
sub remove_file {
my ($path) = @_;
if (-z $path) {
die "file at $path is non-empty\n";
}
unlink $path or die "could not remove empty file: $path ($!)\n";
return;
}
#===== SUBROUTINE ===========================================================
# Name : remove_dir()
# Purpose : safely remove a tree of test files
# Parameters: $dir => path to the top of the tree
# Returns : n/a
# Throws : fatal error if the tree contains a non-link or non-empty file
# Comments : recursively removes directories containing softlinks empty files
#============================================================================
sub remove_dir {
my ($dir) = @_;
if (not -d $dir) {
die "$dir is not a directory";
}
opendir my $DIR, $dir or die "cannot read directory: $dir ($!)\n";
my @listing = readdir $DIR;
closedir $DIR;
NODE:
for my $node (@listing) {
next NODE if $node eq '.';
next NODE if $node eq '..';
my $path = "$dir/$node";
if (-l $path or -z $path) {
unlink $path or die "cannot unlink $path ($!)\n";
}
elsif (-d "$path") {
remove_dir($path);
}
else {
die "$path is not a link, directory, or empty file\n";
}
}
rmdir $dir or die "cannot rmdir $dir ($!)\n";
return;
}
1;