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 =~ /(~|\.bak|_bak)$/ || 39 $path =~ /\..*\.sw(o|p)$/ || 40 $path =~ /\B\.svn\b/; 41 42 return $path; 43} 44 45sub 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 59MyTrebleCheck: 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 72sub 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 115sub 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 226sub 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 251sub 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 301sub 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 360sub 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 377package MakeUtil ; 378 3791; 380 381 382