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