Revert "win32: define HAS_BUILTIN_EXPECT on MinGW"
[perl.git] / cpan / Compress-Raw-Zlib / 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             #next if m#t/Test/More\.pm$# or m#t/Test/Builder\.pm$#;
96
97             /^(\S+)\s*(.*)$/;
98
99             my ($file, $rest) = ($1, $2);
100
101             if ($file =~ /\.(pm|pl|t)$/ and $file !~ /MakeUtil.pm/)
102             {
103                 push @files, "$prefix$file";
104             }
105             elsif ($rest =~ /perl/i)
106             {
107                 push @files, "$prefix$file";
108             }
109
110         }
111         close M;
112     }
113
114     return @files;
115 }
116
117 sub UpDowngrade
118 {
119     return if defined $ENV{TipTop};
120
121     my @files = @_ ;
122
123     # our and use bytes/utf8 is stable from 5.6.0 onward
124     # warnings is stable from 5.6.1 onward
125
126     # Note: this code assumes that each statement it modifies is not
127     #       split across multiple lines.
128
129
130     my $warn_sub = '';
131     my $our_sub = '' ;
132
133     my $upgrade ;
134     my $downgrade ;
135     my $do_downgrade ;
136
137     my $caller = (caller(1))[3] || '';
138
139     if ($caller =~ /downgrade/)
140     {
141         $downgrade = 1;
142     }
143     elsif ($caller =~ /upgrade/)
144     {
145         $upgrade = 1;
146     }
147     else
148     {
149         $do_downgrade = 1
150             if $] < 5.006001 ;
151     }
152
153 #    else
154 #    {
155 #        my $opt = shift @ARGV || '' ;
156 #        $upgrade = ($opt =~ /^-upgrade/i);
157 #        $downgrade = ($opt =~ /^-downgrade/i);
158 #        push @ARGV, $opt unless $downgrade || $upgrade;
159 #    }
160
161
162     if ($downgrade || $do_downgrade) {
163         # From: use|no warnings "blah"
164         # To:   local ($^W) = 1; # use|no warnings "blah"
165         $warn_sub = sub {
166                             s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
167                             s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
168                         };
169     }
170     #elsif ($] >= 5.006001 || $upgrade) {
171     elsif ($upgrade) {
172         # From: local ($^W) = 1; # use|no warnings "blah"
173         # To:   use|no warnings "blah"
174         $warn_sub = sub {
175             s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
176           };
177     }
178
179     if ($downgrade || $do_downgrade) {
180         $our_sub = sub {
181             if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
182                 my $indent = $1;
183                 my $vars = join ' ', split /\s*,\s*/, $2;
184                 $_ = "${indent}use vars qw($vars);\n";
185             }
186             elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/)
187             {
188                 $_ = "$1# $2\n";
189             }
190           };
191     }
192     #elsif ($] >= 5.006000 || $upgrade) {
193     elsif ($upgrade) {
194         $our_sub = sub {
195             if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
196                 my $indent = $1;
197                 my $vars = join ', ', split ' ', $2;
198                 $_ = "${indent}our ($vars);\n";
199             }
200             elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/)
201             {
202                 $_ = "$1$2\n";
203             }
204           };
205     }
206
207     if (! $our_sub && ! $warn_sub) {
208         warn "Up/Downgrade not needed.\n";
209         if ($upgrade || $downgrade)
210           { exit 0 }
211         else
212           { return }
213     }
214
215     foreach (@files) {
216         #if (-l $_ )
217           { doUpDown($our_sub, $warn_sub, $_) }
218           #else  
219           #{ doUpDownViaCopy($our_sub, $warn_sub, $_) }
220     }
221
222     warn "Up/Downgrade complete.\n" ;
223     exit 0 if $upgrade || $downgrade;
224
225 }
226
227
228 sub doUpDown
229 {
230     my $our_sub = shift;
231     my $warn_sub = shift;
232
233     return if -d $_[0];
234
235     local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak";
236     local (@ARGV) = shift;
237  
238     while (<>)
239     {
240         print, last if /^__(END|DATA)__/ ;
241
242         &{ $our_sub }() if $our_sub ;
243         &{ $warn_sub }() if $warn_sub ;
244         print ;
245     }
246
247     return if eof ;
248
249     while (<>)
250       { print }
251 }
252
253 sub doUpDownViaCopy
254 {
255     my $our_sub = shift;
256     my $warn_sub = shift;
257     my $file     = shift ;
258
259     use File::Copy ;
260
261     return if -d $file ;
262
263     my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak";
264
265     copy($file, $backup)
266         or die "Cannot copy $file to $backup: $!";
267
268     my @keep = ();
269
270     {
271         open F, "<$file"
272             or die "Cannot open $file: $!\n" ;
273         while (<F>)
274         {
275             if (/^__(END|DATA)__/)
276             {
277                 push @keep, $_;
278                 last ;
279             }
280             
281             &{ $our_sub }() if $our_sub ;
282             &{ $warn_sub }() if $warn_sub ;
283             push @keep, $_;
284         }
285
286         if (! eof F)
287         {
288             while (<F>)
289               { push @keep, $_ }
290         }
291         close F;
292     }
293
294     {
295         open F, ">$file"
296             or die "Cannot open $file: $!\n";
297         print F @keep ;
298         close F;
299     }
300 }
301
302
303 sub FindBrokenDependencies
304 {
305     my $version = shift ;
306     my %thisModule = map { $_ => 1} @_;
307
308     my @modules = qw(
309                     IO::Compress::Base
310                     IO::Compress::Base::Common
311                     IO::Uncompress::Base
312
313                     Compress::Raw::Zlib
314                     Compress::Raw::Bzip2
315
316                     IO::Compress::RawDeflate
317                     IO::Uncompress::RawInflate
318                     IO::Compress::Deflate
319                     IO::Uncompress::Inflate
320                     IO::Compress::Gzip
321                     IO::Compress::Gzip::Constants
322                     IO::Uncompress::Gunzip
323                     IO::Compress::Zip
324                     IO::Uncompress::Unzip
325
326                     IO::Compress::Bzip2
327                     IO::Uncompress::Bunzip2
328
329                     IO::Compress::Lzf
330                     IO::Uncompress::UnLzf
331
332                     IO::Compress::Lzop
333                     IO::Uncompress::UnLzop
334
335                     Compress::Zlib
336                     );
337     
338     my @broken = ();
339
340     foreach my $module ( grep { ! $thisModule{$_} } @modules)
341     {
342         my $hasVersion = getInstalledVersion($module);
343
344         # No need to upgrade if the module isn't installed at all
345         next 
346             if ! defined $hasVersion;
347
348         # If already have C::Z version 1, then an upgrade to any of the
349         # IO::Compress modules will not break it.
350         next 
351             if $module eq 'Compress::Zlib' && $hasVersion < 2;
352
353         if ($hasVersion < $version)
354         {
355             push @broken, $module
356         }
357     }
358
359     return @broken;
360 }
361
362 sub getInstalledVersion
363 {
364     my $module = shift;
365     my $version;
366
367     eval " require $module; ";
368
369     if ($@ eq '')
370     {
371         no strict 'refs';
372         $version = ${ $module . "::VERSION" };
373         $version = 0 
374     }
375     
376     return $version;
377 }
378
379 package MakeUtil ;
380
381 1;
382
383