File Coverage

blib/lib/ExtUtils/Packlist.pm
Criterion Covered Total %
statement 92 117 78.6
branch 22 36 61.1
condition 12 24 50.0
subroutine 19 21 90.4
pod 6 6 100.0
total 151 204 74.0


line stmt bran cond sub pod time code
1             package ExtUtils::Packlist;
2 4     4   73403 use strict;
  4         16  
  4         135  
3              
4 4     4   23 use Carp qw();
  4         8  
  4         82  
5 4     4   21 use Config;
  4         17  
  4         376  
6             our $Relocations;
7             our $VERSION = '2.20';
8             $VERSION = eval $VERSION;
9              
10             # Used for generating filehandle globs. IO::File might not be available!
11             my $fhname = "FH1";
12              
13             =begin _undocumented
14              
15             =over
16              
17             =item mkfh()
18              
19             Make a filehandle. Same kind of idea as Symbol::gensym().
20              
21             =cut
22              
23             sub mkfh()
24             {
25 4     4   38 no strict;
  4         10  
  4         233  
26 333     333 1 4154 local $^W;
27 333         527 my $fh = \*{$fhname++};
  333         2647  
28 4     4   25 use strict;
  4         8  
  4         6347  
29 333         2711 return($fh);
30             }
31              
32             =item __find_relocations
33              
34             Works out what absolute paths in the configuration have been located at run
35             time relative to $^X, and generates a regexp that matches them
36              
37             =back
38              
39             =end _undocumented
40              
41             =cut
42              
43             sub __find_relocations
44             {
45 0     0   0 my %paths;
46 0         0 while (my ($raw_key, $raw_val) = each %Config) {
47 0         0 my $exp_key = $raw_key . "exp";
48 0 0       0 next unless exists $Config{$exp_key};
49 0 0       0 next unless $raw_val =~ m!\.\.\./!;
50 0         0 $paths{$Config{$exp_key}}++;
51             }
52             # Longest prefixes go first in the alternatives
53 0         0 my $alternations = join "|", map {quotemeta $_}
54 0         0 sort {length $b <=> length $a} keys %paths;
  0         0  
55 0         0 qr/^($alternations)/o;
56             }
57              
58             sub new($$)
59             {
60 326     326 1 708 my ($class, $packfile) = @_;
61 326   33     1195 $class = ref($class) || $class;
62 326         520 my %self;
63 326         1193 tie(%self, $class, $packfile);
64 326         2908 return(bless(\%self, $class));
65             }
66              
67             sub TIEHASH
68             {
69 327     327   1862 my ($class, $packfile) = @_;
70 327         944 my $self = { packfile => $packfile };
71 327         614 bless($self, $class);
72 327 100 100     8685 $self->read($packfile) if (defined($packfile) && -f $packfile);
73 327         1217 return($self);
74             }
75              
76             sub STORE
77             {
78 18     18   1500 $_[0]->{data}->{$_[1]} = $_[2];
79             }
80              
81             sub FETCH
82             {
83 18     18   841 return($_[0]->{data}->{$_[1]});
84             }
85              
86             sub FIRSTKEY
87             {
88 1     1   2 my $reset = scalar(keys(%{$_[0]->{data}}));
  1         4  
89 1         2 return(each(%{$_[0]->{data}}));
  1         6  
90             }
91              
92             sub NEXTKEY
93             {
94 1     1   7 return(each(%{$_[0]->{data}}));
  1         6  
95             }
96              
97             sub EXISTS
98             {
99 300     300   2078 return(exists($_[0]->{data}->{$_[1]}));
100             }
101              
102             sub DELETE
103             {
104 1     1   7 return(delete($_[0]->{data}->{$_[1]}));
105             }
106              
107             sub CLEAR
108             {
109 1     1   2 %{$_[0]->{data}} = ();
  1         6  
110             }
111              
112             sub DESTROY
113       0     {
114             }
115              
116             sub read($;$)
117             {
118 315     315 1 6511 my ($self, $packfile) = @_;
119 315   66     1074 $self = tied(%$self) || $self;
120              
121 315 100       720 if (defined($packfile)) { $self->{packfile} = $packfile; }
  314         717  
122 1         3 else { $packfile = $self->{packfile}; }
123 315 100       689 Carp::croak("No packlist filename specified") if (! defined($packfile));
124 314         658 my $fh = mkfh();
125 314 100       11712 open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
126 313         1836 $self->{data} = {};
127 313         556 my ($line);
128 313         5002 while (defined($line = <$fh>))
129             {
130 4246         6505 chomp $line;
131 4246         7214 my ($key, $data) = $line;
132 4246 100       11305 if ($key =~ /^(.*?)( \w+=.*)$/)
133             {
134 1600         3056 $key = $1;
135 1600         3329 $data = { map { split('=', $_) } split(' ', $2)};
  1604         5215  
136              
137 1600 0 33     7692 if ($Config{userelocatableinc} && $data->{relocate_as})
138             {
139 0         0 require File::Spec;
140 0         0 require Cwd;
141 0         0 my ($vol, $dir) = File::Spec->splitpath($packfile);
142 0         0 my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
143 0         0 $key = Cwd::realpath($newpath);
144             }
145             }
146 4246         7686 $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths
147 4246         22237 $self->{data}->{$key} = $data;
148             }
149 313         3349 close($fh);
150             }
151              
152             sub write($;$)
153             {
154 18     18 1 2185 my ($self, $packfile) = @_;
155 18   66     103 $self = tied(%$self) || $self;
156 18 100       63 if (defined($packfile)) { $self->{packfile} = $packfile; }
  17         101  
157 1         4 else { $packfile = $self->{packfile}; }
158 18 100       260 Carp::croak("No packlist filename specified") if (! defined($packfile));
159 17         117 my $fh = mkfh();
160 17 50       9793 open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
161 17         87 foreach my $key (sort(keys(%{$self->{data}})))
  17         275  
162             {
163 28         221 my $data = $self->{data}->{$key};
164 28 50       368 if ($Config{userelocatableinc}) {
165 0   0     0 $Relocations ||= __find_relocations();
166 0 0       0 if ($packfile =~ $Relocations) {
167             # We are writing into a subdirectory of a run-time relocated
168             # path. Figure out if the this file is also within a subdir.
169 0         0 my $prefix = $1;
170 0 0       0 if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
171             {
172             # The relocated path is within the found prefix
173 0         0 my $packfile_prefix;
174 0         0 (undef, $packfile_prefix)
175             = File::Spec->splitpath($packfile);
176              
177 0         0 my $relocate_as
178             = File::Spec->abs2rel($key, $packfile_prefix);
179              
180 0 0       0 if (!ref $data) {
181 0         0 $data = {};
182             }
183 0         0 $data->{relocate_as} = $relocate_as;
184             }
185             }
186             }
187 28         203 print $fh ("$key");
188 28 100       73 if (ref($data))
189             {
190 1         20 foreach my $k (sort(keys(%$data)))
191             {
192 2         7 print $fh (" $k=$data->{$k}");
193             }
194             }
195 28         98 print $fh ("\n");
196             }
197 17         1328 close($fh);
198             }
199              
200             sub validate($;$)
201             {
202 2     2 1 2781 my ($self, $remove) = @_;
203 2   33     33 $self = tied(%$self) || $self;
204 2         6 my @missing;
205 2         4 foreach my $key (sort(keys(%{$self->{data}})))
  2         19  
206             {
207 4 100       92 if (! -e $key)
208             {
209 2         9 push(@missing, $key);
210 2 100       11 delete($self->{data}{$key}) if ($remove);
211             }
212             }
213 2         10 return(@missing);
214             }
215              
216             sub packlist_file($)
217             {
218 2     2 1 11 my ($self) = @_;
219 2   66     9 $self = tied(%$self) || $self;
220 2         10 return($self->{packfile});
221             }
222              
223             1;
224              
225             __END__