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