File Coverage

blib/lib/Test/Smoke/SourceTree.pm
Criterion Covered Total %
statement 133 156 85.2
branch 37 58 63.7
condition 8 16 50.0
subroutine 21 22 95.4
pod 12 12 100.0
total 211 264 79.9


line stmt bran cond sub pod time code
1             package Test::Smoke::SourceTree;
2 18     18   117360 use strict;
  18         43  
  18         668  
3              
4 18     18   88 use vars qw( $VERSION @EXPORT_OK %EXPORT_TAGS $NOCASE );
  18         33  
  18         1339  
5             $VERSION = '0.008';
6              
7 18     18   97 use File::Spec;
  18         32  
  18         406  
8 18     18   119 use File::Find;
  18         37  
  18         1119  
9 18     18   100 use Cwd 'abs_path';
  18         32  
  18         735  
10 18     18   102 use Carp;
  18         38  
  18         1111  
11 18     18   485 use Test::Smoke::LogMixin;
  18         33  
  18         988  
12              
13 18     18   102 use base 'Exporter';
  18         33  
  18         33830  
14             %EXPORT_TAGS = (
15             mani_const => [qw( &ST_MISSING &ST_UNDECLARED )],
16             const => [qw( &ST_MISSING &ST_UNDECLARED )],
17             );
18             @EXPORT_OK = @{ $EXPORT_TAGS{mani_const} };
19              
20             $NOCASE = $^O eq 'MSWin32' || $^O eq 'VMS';
21              
22             =head1 NAME
23              
24             Test::Smoke::SourceTree - Manipulate the perl source-tree
25              
26             =head1 SYNOPSIS
27              
28             use Test::Smoke::SourceTree qw( :mani_const );
29              
30             my $tree = Test::Smoke::SourceTree->new( $tree_dir );
31              
32             my $mani_check = $tree->check_MANIFEST;
33             foreach my $file ( sort keys %$mani_check ) {
34             if ( $mani_check->{ $file } == ST_MISSING ) {
35             print "MANIFEST declared '$file' but it is missing\n";
36             } elsif ( $mani_check->{ $file } == ST_UNDECLARED ) {
37             print "MANIFEST did not declare '$file'\n";
38             }
39             }
40              
41             $tree->clean_from_MANIFEST;
42              
43             =head1 CONSTANTS
44              
45             =over
46              
47             =item ST_MISSING
48              
49             =item ST_UNDECLARED
50              
51             =back
52              
53             =cut
54              
55             # Define some constants
56             sub ST_MISSING() { 1 }
57             sub ST_UNDECLARED() { 0 }
58              
59             =head1 DESCRIPTION
60              
61             =head2 Test::Smoke::SourceTree->new( $tree_dir[, $verbose] )
62              
63             C creates a new object, this is a simple scalar containing
64             C<< File::Spec->rel2abs( $tree_dir) >>.
65              
66             =cut
67              
68             sub new {
69 34     34 1 11594 my $proto = shift;
70 34 100       112 my $class = ref $proto ? ref $proto : $proto;
71 34         156 my ($dir, $verbose) = @_;
72              
73 34 100       337 croak sprintf "Usage: my \$tree = %s->new( )", __PACKAGE__
74             unless @_;
75              
76             # it should be a directory!
77 33         534 my $cwd = abs_path(File::Spec->curdir);
78 33 50       350 chdir $dir or croak "Cannot chdir($dir): $!";
79             # try not to trip over an absolute-path to something that somehow is a
80             # symlink. abs_path('.') will give you the real-path; that will fail...
81 33 100       371 my $tree_dir = File::Spec->file_name_is_absolute($dir)
82             ? $dir
83             : abs_path(File::Spec->curdir);
84 33   100     292 my $self = {
85             tree_dir => $tree_dir,
86             verbose => $verbose || 0,
87             };
88 33         245 chdir $cwd;
89              
90 33         173 return bless $self, $class;
91             }
92              
93             =head2 $tree->tree_dir
94              
95             Get the directory.
96              
97             =cut
98              
99 281     281 1 4405 sub tree_dir { return $_[0]->{tree_dir} }
100              
101             =head2 $tree->verbose
102              
103             Get verbosity.
104              
105             =cut
106              
107 372     372 1 4655 sub verbose { return $_[0]->{verbose} }
108              
109             =head2 $tree->canonpath( )
110              
111             C returns the canonical name for the path,
112             see L.
113              
114             =cut
115              
116             sub canonpath {
117 5     5 1 8996 my $self = shift;
118 5         20 return File::Spec->canonpath( $self->tree_dir );
119             }
120              
121             =head2 $tree->rel2abs( [$base_dir] )
122              
123             C returns the absolute path, see L.
124              
125             =cut
126              
127             sub rel2abs {
128 1     1 1 3 my $self = shift;
129 1         3 return File::Spec->rel2abs( $self->tree_dir, @_ );
130             }
131              
132             =head2 $tree->abs2rel( [$base_dir] )
133              
134             C returns a relative path,
135             see L.
136              
137             =cut
138              
139             sub abs2rel {
140 1     1 1 3 my $self = shift;
141 1         3 return File::Spec->abs2rel( $self->tree_dir, @_ );
142             }
143              
144             =head2 $tree->mani2abs( $file[, $base_path] )
145              
146             C returns the absolute filename of C<$file>, which should
147             be in "MANIFEST" format (i.e. using '/' as directory separator).
148              
149             =cut
150              
151             sub mani2abs {
152 200     200 1 290 my $self = shift;
153              
154 200         262 my $path = shift;
155 200         823 my @dirs = split m{/+}, $path;
156 200         392 my $file = pop @dirs;
157 200 50       536 if ( $^O eq 'VMS' ) {
158 0         0 my @parts = split m/\./, $file;
159 0         0 my $last = pop @parts;
160             @parts and
161 0 0       0 $file = join( "_", map { s/[^\w-]/_/g; $_ } @parts ) . ".$last";
  0         0  
  0         0  
162             }
163 200 100       418 @dirs and $file = join '/', @dirs, $file;
164 200         374 my @split_path = split m|/|, $file;
165 200         350 my $base_path = File::Spec->rel2abs( $self->tree_dir, @_ );
166 200         1475 return File::Spec->catfile( $base_path, @split_path );
167             }
168              
169             =head2 $tree->mani2absdir( $dir[, $base_path] )
170              
171             C returns the absolute dirname of C<$dir>, which should
172             be in "MANIFEST" format (i.e. using '/' as directory separator).
173              
174             =cut
175              
176             sub mani2absdir {
177 0     0 1 0 my $self = shift;
178              
179 0         0 my @split_path = split m|/|, shift;
180 0         0 my $base_path = File::Spec->rel2abs( $self->tree_dir, @_ );
181 0         0 return File::Spec->catdir( $base_path, @split_path );
182             }
183              
184             =head2 $tree->abs2mani( $file )
185              
186             C returns the MANIFEST style filename.
187              
188             =cut
189              
190             sub abs2mani {
191 62     62 1 99 my $self = shift;
192 62         108 my ($source_file) = @_;
193              
194 62         278 my $relfile = File::Spec->abs2rel(
195             File::Spec->canonpath( $source_file ), $self->tree_dir
196             );
197 62         283 $self->log_debug("[abs2mani($source_file)] $relfile");
198              
199 62         544 my( undef, $directories, $file ) = File::Spec->splitpath( $relfile );
200 62   66     270 my @dirs = grep $_ && length $_ => File::Spec->splitdir( $directories );
201 62         105 push @dirs, $file;
202 62         190 return join '/', @dirs;
203             }
204              
205             =head2 $tree->check_MANIFEST( @ignore )
206              
207             C reads the B file from C<< $self->tree_dir >> and
208             compares it with the actual contents of C<< $self->tree_dir >>.
209              
210             Returns a hashref with suspicious entries (if any) as keys that have a
211             value of either B (not in directory) or B
212             (not in MANIFEST).
213              
214             =cut
215              
216             sub check_MANIFEST {
217 12     12 1 897 my $self = shift;
218              
219 12         33 my %manifest = %{ $self->_read_mani_file( 'MANIFEST' ) };
  12         59  
220 12         156 $self->log_debug("Found %d entries in MANIFEST", scalar(keys %manifest));
221              
222             my %ignore = map {
223 70 50       158 my $entry = $NOCASE ? uc $_ : $_;
224 70         172 $entry => undef
225             } ( ".patch", "MANIFEST.SKIP", '.git', '.gitignore', '.mailmap', @_ ),
226 12         43 keys %{ $self->_read_mani_file( 'MANIFEST.SKIP', 1 ) };
  12         32  
227 12         89 $self->log_debug("Found %d entries in MANIFEST.SKIP", scalar(keys %ignore));
228              
229             # Walk the tree, remove all found files from %manifest
230             # and add other files to %manifest
231             # unless they are in the ignore list
232 12         146 my $cwd = abs_path(File::Spec->curdir);
233 12 50       47 chdir $self->tree_dir or die "Cannot chdir($self->tree_dir): $!";
234 12         120 require File::Find;
235             File::Find::find(
236             sub {
237 262 100   262   8754 -f or return;
238 164         726 my $cpath = File::Spec->canonpath($File::Find::name);
239 164         1622 my (undef, $dirs, $file) = File::Spec->splitpath($cpath);
240 164   66     948 my @dirs = grep $_ && length $_ => File::Spec->splitdir($dirs);
241 164 50       449 $^O eq 'VMS' and $file =~ s/\.$//;
242 164         334 my $mani_name = join '/', @dirs, $file;
243 164 50       262 $NOCASE and $mani_name = uc $mani_name;
244 164 100       326 if (exists $manifest{$mani_name}) {
245 154         526 $self->log_debug("[manicheck] Matched $mani_name");
246 154         2397 delete $manifest{$mani_name};
247             }
248             else {
249 10 100       974 if (!grep $mani_name =~ /$_/, keys %ignore) {
250 2         11 $self->log_debug("[manicheck] Undeclared $mani_name");
251 2         15 $manifest{$mani_name} = ST_UNDECLARED;
252             }
253             else {
254 8         47 $self->log_debug("[manicheck] Skipped $mani_name");
255             }
256             }
257             },
258 12         1124 '.'
259             );
260 12         195 chdir $cwd;
261 12         75 $self->log_debug("[manicheck] %d entries missing", scalar(keys %manifest));
262              
263 12         74 return \%manifest;
264             }
265              
266             =head2 $self->_read_mani_file( $path[, $no_croak] )
267              
268             C<_read_mani_file()> reads the contents of C<$path> like it is a
269             MANIFEST typeof file and returns a ref to hash with all values set
270             C.
271              
272             =cut
273              
274             sub _read_mani_file {
275 25     25   408 my $self = shift;
276 25         100 my( $path, $no_croak ) = @_;
277              
278 25         82 my $manifile = $self->mani2abs( $path );
279 25         82 local *MANIFEST;
280 25 100       962 open MANIFEST, "< $manifile" or do {
281 12 50       151 $no_croak and return { };
282 0         0 croak( "Can't open '$manifile': $!" );
283             };
284              
285             my %manifest = map {
286 13         341 m|(\S+)|;
  157         335  
287 157 50       315 my $entry = $NOCASE ? uc $1 : $1;
288 157 50       301 if ( $^O eq 'VMS' ) {
289 0         0 my @dirs = split m|/|, $entry;
290 0         0 my $file = pop @dirs;
291 0         0 my @parts = split /[.@#]/, $file;
292 0 0       0 if ( @parts > 1 ) {
293 0   0     0 my $ext = ( pop @parts ) || '';
294 0         0 $file = join( "_", @parts ) . ".$ext";
295             }
296 0 0       0 $entry = @dirs ? join( "/", @dirs, $file ) : $file;
297             }
298 157         396 ( $entry => ST_MISSING );
299             } ;
300 13         154 close MANIFEST;
301              
302 13         156 return \%manifest;
303             }
304              
305             =head2 $tree->clean_from_MANIFEST( )
306              
307             C removes all files from the source-tree that are
308             not declared in the B file.
309              
310             =cut
311              
312             sub clean_from_MANIFEST {
313 4     4 1 10 my $self = shift;
314              
315 4         18 my $mani_check = $self->check_MANIFEST( @_ );
316             my @to_remove = grep {
317 4         16 $mani_check->{ $_ } == ST_UNDECLARED
  0         0  
318             } keys %$mani_check;
319              
320 4         16 foreach my $entry ( @to_remove ) {
321 0         0 my $file = $self->mani2abs( $entry );
322 0         0 1 while unlink $file;
323             }
324             }
325              
326             =head2 copy_from_MANIFEST( $dest_dir )
327              
328             C<_copy_from_MANIFEST()> uses the B file from C<$self->tree_dir>
329             to copy a source-tree to C<< $dest_dir >>.
330              
331             =cut
332              
333             sub copy_from_MANIFEST {
334 4     4 1 13 my ($self, $dest_dir) = @_;
335              
336 4         14 my $manifest = $self->mani2abs( 'MANIFEST' );
337              
338 4         18 local *MANIFEST;
339 4 50       152 open MANIFEST, "< $manifest" or do {
340 0         0 carp "Can't open '$manifest': $!\n";
341 0         0 return undef;
342             };
343              
344 4         39 $self->log_info("Reading from '%s'", $manifest);
345             my @manifest_files = map {
346 4 50       162 /^([^\s]+)/ ? $1 : $_
  82         348  
347             } ;
348 4         54 close MANIFEST;
349 4         18 my $dot_patch = $self->mani2abs( '.patch' );
350 4 100       94 -f $dot_patch and push @manifest_files, '.patch';
351              
352 4         24 $self->log_info("%s: %d items OK", $manifest, scalar @manifest_files);
353              
354 4 100       82 File::Path::mkpath( $dest_dir, $self->verbose ) unless -d $dest_dir;
355 4         20 my $dest = $self->new( $dest_dir );
356              
357 4         34 require File::Basename;
358 4         1298 require File::Copy;
359 4         6317 foreach my $file ( @manifest_files ) {
360 83 50       159 $file or next;
361              
362 83         131 my $dest_name = $dest->mani2abs( $file );
363 83         1960 my $dest_path = File::Basename::dirname( $dest_name );
364              
365 83 100       1184 File::Path::mkpath( $dest_path, $self->verbose ) unless -d $dest_path;
366              
367 83         280 my $abs_file = $self->mani2abs( $file );
368 83         1046 my $mode = ( stat $abs_file )[2] & 07777;
369 83   33     1308 -f $dest_name and 1 while unlink $dest_name;
370 83         283 my $ok = File::Copy::syscopy( $abs_file, $dest_name );
371 83 50 33     20950 $ok and $ok &&= chmod $mode, $dest_name;
372 83 50       166 if ($ok) {
373 83 50       304 $self->log_debug("%s -> %s: %sOK", $abs_file, $dest_name, ($ok ? "" : "NOT "));
374             }
375             else {
376 0           $self->log_warn("copy '$file' ($dest_path): $!");
377             }
378             }
379             }
380              
381             1;
382              
383             =head1 COPYRIGHT
384              
385             (c) 2002-2015, All rights reserved.
386              
387             * Abe Timmerman
388              
389             This library is free software; you can redistribute it and/or modify
390             it under the same terms as Perl itself.
391              
392             See:
393              
394             =over 4
395              
396             =item * L
397              
398             =item * L
399              
400             =back
401              
402             This program is distributed in the hope that it will be useful,
403             but WITHOUT ANY WARRANTY; without even the implied warranty of
404             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
405              
406             =cut