1#!/usr/bin/perl -w 2 3# 4# cmpVERSION - compare the current Perl source tree and a given tag 5# for modules that have identical version numbers but different contents. 6# 7# with -d option, output the diffs too 8# with -x option, exclude files from modules where blead is not upstream 9# 10# (after all, there are tools like core-cpan-diff that can already deal with 11# them) 12# 13# Original by slaven@rezic.de, modified by jhi and matt.w.johnson@gmail.com. 14# Adaptation to produce TAP by Abigail, folded back into this file by Nicholas 15 16use strict; 17use 5.006; 18 19use ExtUtils::MakeMaker; 20use File::Spec::Functions qw(devnull); 21use Getopt::Long; 22 23my ($diffs, $exclude_upstream, $tag_to_compare, $tap); 24unless (GetOptions('diffs' => \$diffs, 25 'exclude|x' => \$exclude_upstream, 26 'tag=s' => \$tag_to_compare, 27 'tap' => \$tap, 28 ) && @ARGV == 0) { 29 die "usage: $0 [ -d -x --tag TAG --tap]"; 30} 31 32die "$0: This does not look like a Perl directory\n" 33 unless -f "perl.h" && -d "Porting"; 34die "$0: 'This is a Perl directory but does not look like Git working directory\n" 35 unless (-d ".git" || (exists $ENV{GIT_DIR} && -d $ENV{GIT_DIR})); 36 37my $null = devnull(); 38 39unless (defined $tag_to_compare) { 40 my $check = 'HEAD'; 41 while(1) { 42 $check = `git describe --abbrev=0 $check 2>$null`; 43 chomp $check; 44 last unless $check =~ /-RC/; 45 $check .= '^'; 46 } 47 $tag_to_compare = $check; 48 # Thanks to David Golden for this suggestion. 49 50} 51 52unless (length $tag_to_compare) { 53 die "$0: Git found, but no Git tags found\n" 54 unless $tap; 55 print "1..0 # SKIP: Git found, but no Git tags found\n"; 56 exit 0; 57} 58 59my $tag_exists = `git --no-pager tag -l $tag_to_compare 2>$null`; 60chomp $tag_exists; 61 62unless ($tag_exists eq $tag_to_compare) { 63 die "$0: '$tag_to_compare' is not a known Git tag\n" unless $tap; 64 print "1..0 # SKIP: '$tag_to_compare' is not a known Git tag\n"; 65 exit 0; 66} 67 68my %upstream_files; 69if ($exclude_upstream) { 70 unshift @INC, 'Porting'; 71 require Maintainers; 72 73 for my $m (grep {!defined $Maintainers::Modules{$_}{UPSTREAM} 74 or $Maintainers::Modules{$_}{UPSTREAM} ne 'blead'} 75 keys %Maintainers::Modules) { 76 $upstream_files{$_} = 1 for Maintainers::get_module_files($m); 77 } 78} 79 80# Files to skip from the check for one reason or another, 81# usually because they pull in their version from some other file. 82my %skip; 83@skip{ 84 'cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm', # just a test module 85 'cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/XS.pm', # just a test module 86 'cpan/Module-Build/t/lib/DistGen.pm', # just a test module 87 'cpan/Module-Build/t/lib/MBTest.pm', # just a test module 88 'cpan/Module-Metadata/t/lib/DistGen.pm', # just a test module 89 'cpan/Module-Metadata/t/lib/MBTest.pm', # just a test module 90 'cpan/Module-Metadata/t/lib/Tie/CPHash.pm', # just a test module 91 'dist/Attribute-Handlers/demo/MyClass.pm', # it's just demonstration code 92 'dist/Exporter/lib/Exporter/Heavy.pm', 93 'lib/Carp/Heavy.pm', 94 'lib/Config.pm', # no version number but contents will vary 95 'win32/FindExt.pm', 96} = (); 97 98# Files to skip just for particular version(s), 99# usually due to some # mix-up 100 101my %skip_versions = ( 102 # 'some/sample/file.pm' => [ '1.23', '1.24' ], 103 'dist/threads/lib/threads.pm' => [ '1.83' ], 104 ); 105 106my $skip_dirs = qr|^t/lib|; 107 108sub pm_file_from_xs { 109 my $xs = shift; 110 111 foreach my $try (sub { 112 # First try a .pm at the same level as the .xs file 113 # with the same basename 114 return shift =~ s/\.xs\z//r; 115 }, 116 sub { 117 # Try for a (different) .pm at the same level, based 118 # on the directory name: 119 my ($path) = shift =~ m!^(.*)/!; 120 my ($last) = $path =~ m!([^-/]+)\z!; 121 return "$path/$last"; 122 }, 123 sub { 124 # Try to work out the extension's full package, and 125 # look for a .pm in lib/ based on that: 126 my ($path) = shift =~ m!^(.*)/!; 127 my ($last) = $path =~ m!([^/]+)\z!; 128 $last = 'List-Util' if $last eq 'Scalar-List-Utils'; 129 $last =~ tr !-!/!; 130 return "$path/lib/$last"; 131 }) { 132 # For all cases, first look to see if the .pm file is generated. 133 my $base = $try->($xs); 134 return "${base}_pm.PL" if -f "${base}_pm.PL"; 135 return "${base}.pm" if -f "${base}.pm"; 136 } 137 138 die "No idea which .pm file corresponds to '$xs', so aborting"; 139} 140 141# Key is the .pm file from which we check the version. 142# Value is a reference to an array of files to check for differences 143# The trivial case is a pure perl module, where the array holds one element, 144# the perl module's file. The "fun" comes with XS modules, and the real fun 145# with XS modules with more than one XS file, and "interesting" layouts. 146 147my %module_diffs; 148 149foreach (`git --no-pager diff --name-only $tag_to_compare --diff-filter=ACMRTUXB`) { 150 chomp; 151 next unless m/^(.*)\//; 152 my $this_dir = $1; 153 next if $this_dir =~ $skip_dirs || exists $skip{$_}; 154 next if exists $upstream_files{$_}; 155 if (/\.pm\z/ || m|^lib/.*\.pl\z| || /_pm\.PL\z/) { 156 push @{$module_diffs{$_}}, $_; 157 } elsif (/\.xs\z/ && !/\bt\b/) { 158 push @{$module_diffs{pm_file_from_xs($_)}}, $_; 159 } 160} 161 162unless (%module_diffs) { 163 print "1..1\nok 1 - No difference found\n" if $tap; 164 exit; 165} 166 167printf "1..%d\n" => scalar keys %module_diffs if $tap; 168 169my $count; 170my $diff_cmd = "git --no-pager diff $tag_to_compare "; 171my $q = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? '"' : "'"; 172my (@diff); 173 174foreach my $pm_file (sort keys %module_diffs) { 175 # git has already told us that the files differ, so no need to grab each as 176 # a blob from git, and do the comparison ourselves. 177 my $pm_version = eval {MM->parse_version($pm_file)}; 178 my $orig_pm_content = get_file_from_git($pm_file, $tag_to_compare); 179 my $orig_pm_version = eval {MM->parse_version(\$orig_pm_content)}; 180 ++$count; 181 182 if (!defined $orig_pm_version || $orig_pm_version eq 'undef') { # sigh 183 print "ok $count - SKIP Can't parse \$VERSION in $pm_file\n" 184 if $tap; 185 } elsif (!defined $pm_version || $pm_version eq 'undef') { 186 print "not ok $count - in $pm_file version was $orig_pm_version, now unparsable\n" if $tap; 187 } elsif ($pm_version ne $orig_pm_version) { # good 188 print "ok $count - $pm_file\n" if $tap; 189 } else { 190 if ($tap) { 191 foreach (sort @{$module_diffs{$pm_file}}) { 192 print "# $_" for `$diff_cmd $q$_$q`; 193 } 194 if (exists $skip_versions{$pm_file} 195 and grep $pm_version eq $_, @{$skip_versions{$pm_file}}) { 196 print "ok $count - SKIP $pm_file version $pm_version\n"; 197 } else { 198 print "not ok $count - $pm_file version $pm_version\n"; 199 } 200 } else { 201 push @diff, @{$module_diffs{$pm_file}}; 202 print "$pm_file version $pm_version\n"; 203 } 204 } 205} 206 207sub get_file_from_git { 208 my ($file, $tag) = @_; 209 local $/; 210 211 use open IN => ':raw'; 212 return scalar `git --no-pager show $tag:$file 2>$null`; 213} 214 215if ($diffs) { 216 for (sort @diff) { 217 print "\n"; 218 system "$diff_cmd $q$_$q"; 219 } 220} 221