ext/Compress/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     my $postamble = '
  53
  54 MyTrebleCheck:
  55         @echo Checking for $$^W in files: '. "@files" . '
  56         @perl -ne \'                                            \
  57             exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;           \
  58          \' ' . " @files || " . '                               \
  59         (echo found unexpected $$^W ; exit 1)
  60         @echo All is ok.
  61
  62 ';
  63
  64     return $postamble;
  65 }
  66
  67 sub getPerlFiles
  68 {
  69     my @manifests = @_ ;
  70
  71     my @files = ();
  72
  73     for my $manifest (@manifests)
  74     {
  75         my $prefix = './';
  76
  77         $prefix = $1
  78             if $manifest =~ m#^(.*/)#;
  79
  80         open M, "<$manifest"
  81             or die "Cannot open '$manifest': $!\n";
  82         while (<M>)
  83         {
  84             chomp ;
  85             next if /^\s*#/ || /^\s*$/ ;
  86
  87             s/^\s+//;
  88             s/\s+$//;
  89
  90             /^(\S+)\s*(.*)$/;
  91
  92             my ($file, $rest) = ($1, $2);
  93
  94             if ($file =~ /\.(pm|pl|t)$/ and $file !~ /MakeUtil.pm/)
  95             {
  96                 push @files, "$prefix$file";
  97             }
  98             elsif ($rest =~ /perl/i)
  99             {
 100                 push @files, "$prefix$file";
 101             }
 102
 103         }
 104         close M;
 105     }
 106
 107     return @files;
 108 }
 109
 110 sub UpDowngrade
 111 {
 112     return if defined $ENV{TipTop};
 113
 114     my @files = @_ ;
 115
 116     # our and use bytes/utf8 is stable from 5.6.0 onward
 117     # warnings is stable from 5.6.1 onward
 118
 119     # Note: this code assumes that each statement it modifies is not
 120     #       split across multiple lines.
 121
 122
 123     my $warn_sub = '';
 124     my $our_sub = '' ;
 125
 126     my $upgrade ;
 127     my $downgrade ;
 128     my $do_downgrade ;
 129
 130     my $caller = (caller(1))[3] || '';
 131
 132     if ($caller =~ /downgrade/)
 133     {
 134         $downgrade = 1;
 135     }
 136     elsif ($caller =~ /upgrade/)
 137     {
 138         $upgrade = 1;
 139     }
 140     else
 141     {
 142         $do_downgrade = 1
 143             if $] < 5.006001 ;
 144     }
 145
 146 #    else
 147 #    {
 148 #        my $opt = shift @ARGV || '' ;
 149 #        $upgrade = ($opt =~ /^-upgrade/i);
 150 #        $downgrade = ($opt =~ /^-downgrade/i);
 151 #        push @ARGV, $opt unless $downgrade || $upgrade;
 152 #    }
 153
 154
 155     if ($downgrade || $do_downgrade) {
 156         # From: use|no warnings "blah"
 157         # To:   local ($^W) = 1; # use|no warnings "blah"
 158         $warn_sub = sub {
 159                             s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
 160                             s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
 161                         };
 162     }
 163     #elsif ($] >= 5.006001 || $upgrade) {
 164     elsif ($upgrade) {
 165         # From: local ($^W) = 1; # use|no warnings "blah"
 166         # To:   use|no warnings "blah"
 167         $warn_sub = sub {
 168             s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
 169           };
 170     }
 171
 172     if ($downgrade || $do_downgrade) {
 173         $our_sub = sub {
 174             if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
 175                 my $indent = $1;
 176                 my $vars = join ' ', split /\s*,\s*/, $2;
 177                 $_ = "${indent}use vars qw($vars);\n";
 178             }
 179             elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/)
 180             {
 181                 $_ = "$1# $2\n";
 182             }
 183           };
 184     }
 185     #elsif ($] >= 5.006000 || $upgrade) {
 186     elsif ($upgrade) {
 187         $our_sub = sub {
 188             if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
 189                 my $indent = $1;
 190                 my $vars = join ', ', split ' ', $2;
 191                 $_ = "${indent}our ($vars);\n";
 192             }
 193             elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/)
 194             {
 195                 $_ = "$1$2\n";
 196             }
 197           };
 198     }
 199
 200     if (! $our_sub && ! $warn_sub) {
 201         warn "Up/Downgrade not needed.\n";
 202         if ($upgrade || $downgrade)
 203           { exit 0 }
 204         else
 205           { return }
 206     }
 207
 208     foreach (@files) {
 209         #if (-l $_ )
 210           { doUpDown($our_sub, $warn_sub, $_) }
 211           #else
 212           #{ doUpDownViaCopy($our_sub, $warn_sub, $_) }
 213     }
 214
 215     warn "Up/Downgrade complete.\n" ;
 216     exit 0 if $upgrade || $downgrade;
 217
 218 }
 219
 220
 221 sub doUpDown
 222 {
 223     my $our_sub = shift;
 224     my $warn_sub = shift;
 225
 226     return if -d $_[0];
 227
 228     local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak";
 229     local (@ARGV) = shift;
 230
 231     while (<>)
 232     {
 233         print, last if /^__(END|DATA)__/ ;
 234
 235         &{ $our_sub }() if $our_sub ;
 236         &{ $warn_sub }() if $warn_sub ;
 237         print ;
 238     }
 239
 240     return if eof ;
 241
 242     while (<>)
 243       { print }
 244 }
 245
 246 sub doUpDownViaCopy
 247 {
 248     my $our_sub = shift;
 249     my $warn_sub = shift;
 250     my $file     = shift ;
 251
 252     use File::Copy ;
 253
 254     return if -d $file ;
 255
 256     my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak";
 257
 258     copy($file, $backup)
 259         or die "Cannot copy $file to $backup: $!";
 260
 261     my @keep = ();
 262
 263     {
 264         open F, "<$file"
 265             or die "Cannot open $file: $!\n" ;
 266         while (<F>)
 267         {
 268             if (/^__(END|DATA)__/)
 269             {
 270                 push @keep, $_;
 271                 last ;
 272             }
 273
 274             &{ $our_sub }() if $our_sub ;
 275             &{ $warn_sub }() if $warn_sub ;
 276             push @keep, $_;
 277         }
 278
 279         if (! eof F)
 280         {
 281             while (<F>)
 282               { push @keep, $_ }
 283         }
 284         close F;
 285     }
 286
 287     {
 288         open F, ">$file"
 289             or die "Cannot open $file: $!\n";
 290         print F @keep ;
 291         close F;
 292     }
 293 }
 294
 295 package MakeUtil ;
 296
 297 1;
 298
 299