ext/Compress/IO/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     my $do_downgrade ;
 127
 128     my $caller = (caller(1))[3] || '';
 129
 130     if ($caller =~ /downgrade/)
 131     {
 132         $downgrade = 1;
 133     }
 134     elsif ($caller =~ /upgrade/)
 135     {
 136         $upgrade = 1;
 137     }
 138     else
 139     {
 140         $do_downgrade = 1
 141             if $] < 5.006001 ;
 142     }
 143
 144 #    else
 145 #    {
 146 #        my $opt = shift @ARGV || '' ;
 147 #        $upgrade = ($opt =~ /^-upgrade/i);
 148 #        $downgrade = ($opt =~ /^-downgrade/i);
 149 #        push @ARGV, $opt unless $downgrade || $upgrade;
 150 #    }
 151
 152
 153     if ($downgrade || $do_downgrade) {
 154         # From: use|no warnings "blah"
 155         # To:   local ($^W) = 1; # use|no warnings "blah"
 156         $warn_sub = sub {
 157                             s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
 158                             s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
 159                         };
 160     }
 161     #elsif ($] >= 5.006001 || $upgrade) {
 162     elsif ($upgrade) {
 163         # From: local ($^W) = 1; # use|no warnings "blah"
 164         # To:   use|no warnings "blah"
 165         $warn_sub = sub {
 166             s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
 167           };
 168     }
 169
 170     if ($downgrade || $do_downgrade) {
 171         $our_sub = sub {
 172             if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) {
 173                 my $indent = $1;
 174                 my $vars = join ' ', split /\s*,\s*/, $2;
 175                 $_ = "${indent}use vars qw($vars);\n";
 176             }
 177             elsif ( /^(\s*)((use|no)\s+(bytes|utf8)\s*;.*)$/)
 178             {
 179                 $_ = "$1# $2\n";
 180             }
 181           };
 182     }
 183     #elsif ($] >= 5.006000 || $upgrade) {
 184     elsif ($upgrade) {
 185         $our_sub = sub {
 186             if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) {
 187                 my $indent = $1;
 188                 my $vars = join ', ', split ' ', $2;
 189                 $_ = "${indent}our ($vars);\n";
 190             }
 191             elsif ( /^(\s*)#\s*((use|no)\s+(bytes|utf8)\s*;.*)$/)
 192             {
 193                 $_ = "$1$2\n";
 194             }
 195           };
 196     }
 197
 198     if (! $our_sub && ! $warn_sub) {
 199         warn "Up/Downgrade not needed.\n";
 200         if ($upgrade || $downgrade)
 201           { exit 0 }
 202         else
 203           { return }
 204     }
 205
 206     foreach (@files) {
 207         #if (-l $_ )
 208           { doUpDown($our_sub, $warn_sub, $_) }
 209           #else
 210           #{ doUpDownViaCopy($our_sub, $warn_sub, $_) }
 211     }
 212
 213     warn "Up/Downgrade complete.\n" ;
 214     exit 0 if $upgrade || $downgrade;
 215
 216 }
 217
 218
 219 sub doUpDown
 220 {
 221     my $our_sub = shift;
 222     my $warn_sub = shift;
 223
 224     return if -d $_[0];
 225
 226     local ($^I) = ($^O eq 'VMS') ? "_bak" : ".bak";
 227     local (@ARGV) = shift;
 228
 229     while (<>)
 230     {
 231         print, last if /^__(END|DATA)__/ ;
 232
 233         &{ $our_sub }() if $our_sub ;
 234         &{ $warn_sub }() if $warn_sub ;
 235         print ;
 236     }
 237
 238     return if eof ;
 239
 240     while (<>)
 241       { print }
 242 }
 243
 244 sub doUpDownViaCopy
 245 {
 246     my $our_sub = shift;
 247     my $warn_sub = shift;
 248     my $file     = shift ;
 249
 250     use File::Copy ;
 251
 252     return if -d $file ;
 253
 254     my $backup = $file . ($^O eq 'VMS') ? "_bak" : ".bak";
 255
 256     copy($file, $backup)
 257         or die "Cannot copy $file to $backup: $!";
 258
 259     my @keep = ();
 260
 261     {
 262         open F, "<$file"
 263             or die "Cannot open $file: $!\n" ;
 264         while (<F>)
 265         {
 266             if (/^__(END|DATA)__/)
 267             {
 268                 push @keep, $_;
 269                 last ;
 270             }
 271
 272             &{ $our_sub }() if $our_sub ;
 273             &{ $warn_sub }() if $warn_sub ;
 274             push @keep, $_;
 275         }
 276
 277         if (! eof F)
 278         {
 279             while (<F>)
 280               { push @keep, $_ }
 281         }
 282         close F;
 283     }
 284
 285     {
 286         open F, ">$file"
 287             or die "Cannot open $file: $!\n";
 288         print F @keep ;
 289         close F;
 290     }
 291 }
 292
 293 package MakeUtil ;
 294
 295 1;
 296
 297