Commit | Line | Data |
3fea05b9 |
1 | package Module::Install::Admin::Manifest; |
2 | |
3 | use strict; |
4 | use Module::Install::Base; |
5 | |
6 | use vars qw{$VERSION @ISA}; |
7 | BEGIN { |
8 | $VERSION = '0.91';; |
9 | @ISA = qw{Module::Install::Base}; |
10 | } |
11 | |
12 | use Cwd; |
13 | use File::Spec; |
14 | |
15 | # XXX I really want this method in Module::Install::Admin::Makefile |
16 | # But you can't call across Admin modules. Audrey?? |
17 | sub dist_preop { |
18 | my ($self, $distdir) = @_; |
19 | return if $self->check_manifest; |
20 | print <<"END_MESSAGE"; |
21 | |
22 | It appears that your MANIFEST does not contain the same components that |
23 | are currently in the 'inc' directory. |
24 | |
25 | Please try running 'make manifest' and then run 'make dist' again. |
26 | |
27 | Remember to use the MANIFEST.SKIP file to control things that should not |
28 | end up in your MANIFEST. See 'perldoc ExtUtils::Manifest' for details. |
29 | |
30 | END_MESSAGE |
31 | return if $self->prompt( |
32 | 'Do you *really* want to continue making a distribution?', 'n' |
33 | ) =~ /^[Yy]/; |
34 | |
35 | if ( -d $distdir ) { |
36 | require File::Path; |
37 | File::Path::rmtree($distdir); |
38 | } |
39 | |
40 | exit(1); |
41 | } |
42 | |
43 | # XXX Needs a refactoring. |
44 | sub check_manifest { |
45 | my $self = shift; |
46 | my $prefix = $self->_top->{prefix}; |
47 | my ($manifest, $manifest_path, $relative_path) = $self->_read_manifest or return; |
48 | my $manifest_skip = "$manifest_path.SKIP"; |
49 | my @skip; |
50 | |
51 | if ( -f "$manifest_path.SKIP" ) { |
52 | open SKIP, $manifest_skip |
53 | or die "Can't open $manifest_skip for input:\n$!"; |
54 | @skip = map {chomp; $_} <SKIP>; |
55 | close SKIP; |
56 | } |
57 | |
58 | my %manifest; |
59 | for ( my $i = 0; $i < @$manifest; $i++ ) { |
60 | my $path = $manifest->[$i]; |
61 | $path =~ s/\s.*//; |
62 | $path =~ s/^\.[\\\/]//; |
63 | $path =~ s/[\\\/]/\//g; |
64 | next unless $path =~ m/^\Q$prefix\E\b/i; |
65 | $manifest{$path} = \$manifest->[$i]; |
66 | } |
67 | |
68 | ADDLOOP: |
69 | for my $pathname ( sort $self->_find_files($prefix) ) { |
70 | $pathname = "$relative_path/$pathname" if length($relative_path); |
71 | $pathname =~ s!//+!/!g; |
72 | next unless -f $pathname; |
73 | if ( defined $manifest{$pathname} ) { |
74 | delete $manifest{$pathname}; |
75 | } else { |
76 | for ( @skip ) { |
77 | next ADDLOOP if $pathname =~ /$_/; |
78 | } |
79 | return 0; |
80 | } |
81 | } |
82 | if ( keys %manifest ) { |
83 | foreach ( keys %manifest ) { |
84 | print "Found extra file $_\n"; |
85 | } |
86 | return 0; |
87 | } |
88 | return 1; |
89 | } |
90 | |
91 | sub _read_manifest { |
92 | my $manifest = []; |
93 | my $manifest_path = ''; |
94 | my $relative_path = ''; |
95 | my @relative_dirs = (); |
96 | my $cwd = Cwd::cwd(); |
97 | my @cwd_dirs = File::Spec->splitdir($cwd); |
98 | while ( @cwd_dirs ) { |
99 | last unless -f File::Spec->catfile(@cwd_dirs, 'Makefile.PL'); |
100 | my $path = File::Spec->catfile(@cwd_dirs, 'MANIFEST'); |
101 | if ( -f $path ) { |
102 | $manifest_path = $path; |
103 | last; |
104 | } |
105 | unshift @relative_dirs, pop(@cwd_dirs); |
106 | } |
107 | |
108 | unless ( length($manifest_path) ) { |
109 | warn "Can't locate the MANIFEST file for '$cwd'\n"; |
110 | return; |
111 | } |
112 | |
113 | $relative_path = join '/', @relative_dirs if @relative_dirs; |
114 | |
115 | local *MANIFEST; |
116 | open MANIFEST, $manifest_path |
117 | or die "Can't open $manifest_path for input:\n$!"; |
118 | @$manifest = map { chomp; $_ } <MANIFEST>; |
119 | close MANIFEST; |
120 | |
121 | return ($manifest, $manifest_path, $relative_path); |
122 | } |
123 | |
124 | # XXX I copied this from M::I::A::Find because I can't call that one. Please |
125 | # refactor/fix. |
126 | sub _find_files { |
127 | my ($self, $file, $path) = @_; |
128 | $path = '' if not defined $path; |
129 | $file = "$path/$file" if length($path); |
130 | if ( -f $file ) { |
131 | return ( $file ); |
132 | } elsif ( -d $file ) { |
133 | my @files = (); |
134 | local *DIR; |
135 | opendir(DIR, $file) or die "Can't opendir $file"; |
136 | while (defined(my $new_file = readdir(DIR))) { |
137 | next if $new_file =~ /^(\.|\.\.)$/; |
138 | push @files, $self->_find_files($new_file, $file); |
139 | } |
140 | return @files; |
141 | } |
142 | return (); |
143 | } |
144 | |
145 | 1; |
146 | |
147 | __END__ |
148 | |
149 | =pod |
150 | |
151 | =head1 COPYRIGHT |
152 | |
153 | Copyright 2003, 2004 by |
154 | Audrey Tang E<lt>autrijus@autrijus.orgE<gt>, |
155 | Brian Ingerson E<lt>ingy@cpan.orgE<gt> |
156 | |
157 | This program is free software; you can redistribute it and/or modify it |
158 | under the same terms as Perl itself. |
159 | |
160 | See L<http://www.perl.com/perl/misc/Artistic.html> |
161 | |
162 | =cut |