1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
########################################################################
# housekeeping
########################################################################
package Testophile;
use strict;
use Test::More;
use Symbol qw( qualify_to_ref );
require_ok qw( Cwd );
require_ok qw( File::Spec::Functions );
########################################################################
# sanity check whether Cwd has working subs
########################################################################
sub sanity
{
my $handler = shift
or return;
eval
{
$handler->( '//' );
$handler->( 'cwd' );
1
}
}
my $abs = Cwd->can( 'abs_path' );
my $rel = File::Spec::Functions->can( 'rel2abs' );
$abs || $rel
or BAIL_OUT "Cwd lacks 'abs_path' and F::S::F lacks 'rel2abs'";
sanity $abs
or
sanity $rel
or
BAIL_OUT "Neither abs_path nor rel2abs handle '//' and 'cwd'";
my $ref = *{ qualify_to_ref 'abs_path', __PACKAGE__ };
undef &{ *$ref };
*{ $ref } = $abs || $rel;
__PACKAGE__->can( 'abs_path' )
or BAIL_OUT "Failed installing 'abs_path'";
pass 'Functinal abs_path installed';
done_testing
__END__
BEGIN
{
# however... there have been complaints of
# places where abs_path does not work.
#
# if abs_path fails on the working directory
# then replace it with rel2abs and live with
# possibly slower, redundant directories.
#
# the abs_path '//' hack allows for testing
# broken abs_path on primitive systems that
# cannot handle the rooted system being linked
# back to itself.
use Cwd qw( &cwd );
my $abs = Cwd->can( 'abs_path' )
or die "Odd: Cwd cannot 'abs_path'\n";
if
(
eval { $abs->( '//' ); $abs->( cwd ); 1 }
)
{
# nothing more to do: abs_path works.
}
elsif
(
$abs = Cwd->can( 'rel2abs' )
)
{
# ok, we have a substitute
}
else
{
die "Cwd fails abs_path test && lacks 'rel2abs'\n";
}
my $ref = *{ qualify_to_ref 'abs_path', __PACKAGE__ };
undef &{ *$ref };
*{ $ref } = $abs;
}
|
