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