47aebd60743798974990a5149c7ee0ed8794b374
[perl.git] / ext / Compress-Raw-Bzip2 / private / MakeUtil.pm
1 package MakeUtil ;
2 package main ;
3
4 use strict ;
5
6 use Config qw(%Config);
7 use File::Copy;
8
9 my $VERSION = '1.0';
10
11
12 BEGIN
13 {
14     eval { require File::Spec::Functions ; File::Spec::Functions->import() } ;
15     if ($@)
16     {
17         *catfile = sub { return "$_[0]/$_[1]" }
18     }
19 }
20
21 require VMS::Filespec if $^O eq 'VMS';
22
23
24 unless($ENV{PERL_CORE}) {
25     $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV;
26 }
27
28 $ENV{SKIP_FOR_CORE} = 1 if $ENV{PERL_CORE} || $ENV{MY_PERL_CORE} ;
29
30
31
32 sub MY::libscan
33 {
34     my $self = shift;
35     my $path = shift;
36
37     return undef
38         if $path =~ /(~|\.bak|_bak)$/ ||
39            $path =~ /\..*\.sw(o|p)$/  ||
40            $path =~ /\B\.svn\b/;
41
42     return $path;
43 }
44
45 sub MY::postamble 
46 {
47     return ''
48         if $ENV{PERL_CORE} ;
49
50     my @files = getPerlFiles('MANIFEST');
51
52     # Note: Once you remove all the layers of shell/makefile escaping 
53     # the regular expression below reads
54     #
55     #    /^\s*local\s*\(\s*\$^W\s*\)/
56     #
57     my $postamble = '
58
59 MyTrebleCheck:
60         @echo Checking for $$^W in files: '. "@files" . '
61         perl -ne \'                                             \
62             exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \'                \
63          ' . " @files || " . '                          \
64         (echo found unexpected $$^W ; exit 1)
65         @echo All is ok.
66
67 ';
68
69     return $postamble;
70 }
71
72 sub getPerlFiles
73 {
74     my @manifests = @_ ;
75
76     my @files = ();
77
78     for my $manifest (@manifests)
79     {
80         my $prefix = './';
81
82         $prefix = $1
83             if $manifest =~ m#^(.*/)#;
84
85         open M, "<$manifest"
86             or die "Cannot open '$manifest': $!\n";
87         while (<M>)
88         {
89             chomp ;
90             next if /^\s*#/ || /^\s*$/ ;
91
92             s/^\s+//;
93             s/\s+$//;
94
95             /^(\S+)\s*(.*)$/;
96
97             my ($file, $rest) = ($1, $2);
98
99             if ($file =~ /\.(pm|pl|t)$/ and $file !~ /MakeUtil.pm/)
100             {
101                 push @files, "$prefix$file";
102             }
103             elsif ($rest =~ /perl/i)
104             {
105                 push @files, "$prefix$file";
106             }
107
108         }
109         close M;
110     }
111
112     return @files;
113 }
114
115 sub UpDowngrade
116 {
117     return if defined $ENV{TipTop};
118
119     my @files = @_ ;
120
121     # our and use bytes/utf8 is stable from 5.6.0 onward
122     # warnings is stable from 5.6.1 onward
123
124     # Note: this code assumes that each statement it modifies is not
125     #       split across multiple lines.
126
127
128     my $warn_sub = '';
129     my $our_sub = '' ;
130
131     my $upgrade ;
132     my $downgrade ;
133     my $do_downgrade ;
134
135     my $caller = (caller(1))[3] || '';
136
137     if ($caller =~ /downgrade/)
138     {
139         $downgrade = 1;
140     }
141     elsif ($caller =~ /upgrade/)
142     {
143         $upgrade = 1;
144     }
145     else
146     {
147         $do_downgrade = 1
148             if $] < 5.006001 ;
149     }
150
151 #    else
152 #    {
153 #        my $opt = shift @ARGV || '' ;
154 #        $upgrade = ($opt =~ /^-upgrade/i);
155 #        $downgrade = ($opt =~ /^-downgrade/i);
156 #        push @ARGV, $opt unless $downgrade || $upgrade;
157 #    }
158
159
160     if ($downgrade || $do_downgrade) {
161         # From: use|no warnings "blah"
162         # To:   local ($^W) = 1; # use|no warnings "blah"
163         $warn_sub = sub {
164                             s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
165                             s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
166                         };
167     }
168     #elsif ($] >= 5.006001 || $upgrade) {
169     elsif ($upgrade) {
170         # From: local ($^W) = 1; # use|no warnings "blah"
171         # To:   use|no warnings "blah"
172         $warn_sub = sub {
173             s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
174           };
175     }
176
177     if ($downgrade || $do_downgrade) {
178         $our_sub = sub {
179             if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
180                 my $indent = $1;
181                 my $vars = join ' ', split /\s*,\s*/, $2;
182                 $_ = "${indent}use vars qw($vars);\n";
183             }
184             elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/)
185             {
186                 $_ = "$1# $2\n";
187             }
188           };
189     }
190     #elsif ($] >= 5.006000 || $upgrade) {
191     elsif ($upgrade) {
192         $our_sub = sub {
193             if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
194                 my $indent = $1;
195                 my $vars = join ', ', split ' ', $2;
196                 $_ = "${indent}our ($vars);\n";
197             }
198             elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/)
199             {
200                 $_ = "$1$2\n";
201             }
202           };
203     }
204
205     if (! $our_sub && ! $warn_sub) {
206         warn "Up/Downgrade not needed.\n";
207         if ($upgrade || $downgrade)
208           { exit 0 }
209         else
210           { return }
211     }
212
213     foreach (@files) {
214         #if (-l $_ )
215           { doUpDown($our_sub, $warn_sub, $_) }
216           #else  
217           #{ doUpDownViaCopy($our_sub, $warn_sub, $_) }
218     }
219
220     warn "Up/Downgrade complete.\n" ;
221     exit 0 if $upgrade || $downgrade;
222
223 }
224
225
226 sub doUpDown
227 {
228     my $our_sub = shift;
229     my $warn_sub = shift;
230
231     return if -d $_[0];
232
233     local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak";
234     local (@ARGV) = shift;
235  
236     while (<>)
237     {
238         print, last if /^__(END|DATA)__/ ;
239
240         &{ $our_sub }() if $our_sub ;
241         &{ $warn_sub }() if $warn_sub ;
242         print ;
243     }
244
245     return if eof ;
246
247     while (<>)
248       { print }
249 }
250
251 sub doUpDownViaCopy
252 {
253     my $our_sub = shift;
254     my $warn_sub = shift;
255     my $file     = shift ;
256
257     use File::Copy ;
258
259     return if -d $file ;
260
261     my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak";
262
263     copy($file, $backup)
264         or die "Cannot copy $file to $backup: $!";
265
266     my @keep = ();
267
268     {
269         open F, "<$file"
270             or die "Cannot open $file: $!\n" ;
271         while (<F>)
272         {
273             if (/^__(END|DATA)__/)
274             {
275                 push @keep, $_;
276                 last ;
277             }
278             
279             &{ $our_sub }() if $our_sub ;
280             &{ $warn_sub }() if $warn_sub ;
281             push @keep, $_;
282         }
283
284         if (! eof F)
285         {
286             while (<F>)
287               { push @keep, $_ }
288         }
289         close F;
290     }
291
292     {
293         open F, ">$file"
294             or die "Cannot open $file: $!\n";
295         print F @keep ;
296         close F;
297     }
298 }
299
300
301 sub FindBrokenDependencies
302 {
303     my $version = shift ;
304     my %thisModule = map { $_ => 1} @_;
305
306     my @modules = qw(
307                     IO::Compress::Base
308                     IO::Compress::Base::Common
309                     IO::Uncompress::Base
310
311                     Compress::Raw::Zlib
312                     Compress::Raw::Bzip2
313
314                     IO::Compress::RawDeflate
315                     IO::Uncompress::RawInflate
316                     IO::Compress::Deflate
317                     IO::Uncompress::Inflate
318                     IO::Compress::Gzip
319                     IO::Compress::Gzip::Constants
320                     IO::Uncompress::Gunzip
321                     IO::Compress::Zip
322                     IO::Uncompress::Unzip
323
324                     IO::Compress::Bzip2
325                     IO::Uncompress::Bunzip2
326
327                     IO::Compress::Lzf
328                     IO::Uncompress::UnLzf
329
330                     IO::Compress::Lzop
331                     IO::Uncompress::UnLzop
332
333                     Compress::Zlib
334                     );
335     
336     my @broken = ();
337
338     foreach my $module ( grep { ! $thisModule{$_} } @modules)
339     {
340         my $hasVersion = getInstalledVersion($module);
341
342         # No need to upgrade if the module isn't installed at all
343         next 
344             if ! defined $hasVersion;
345
346         # If already have C::Z version 1, then an upgrade to any of the
347         # IO::Compress modules will not break it.
348         next 
349             if $module eq 'Compress::Zlib' && $hasVersion < 2;
350
351         if ($hasVersion < $version)
352         {
353             push @broken, $module
354         }
355     }
356
357     return @broken;
358 }
359
360 sub getInstalledVersion
361 {
362     my $module = shift;
363     my $version;
364
365     eval " require $module; ";
366
367     if ($@ eq '')
368     {
369         no strict 'refs';
370         $version = ${ $module . "::VERSION" };
371         $version = 0 
372     }
373     
374     return $version;
375 }
376
377 package MakeUtil ;
378
379 1;
380
381