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