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