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; 22use Time::Local qw(timelocal_posix); 23 24my ($diffs, $exclude_upstream, $tag_to_compare, $tap); 25unless (GetOptions('diffs' => \$diffs, 26 'exclude|x' => \$exclude_upstream, 27 'tag=s' => \$tag_to_compare, 28 'tap' => \$tap, 29 ) && @ARGV == 0) { 30 die "usage: $0 [ -d -x --tag TAG --tap]"; 31} 32 33die "$0: This does not look like a Perl directory\n" 34 unless -f "perl.h" && -d "Porting"; 35 36if (-d ".git" || (exists $ENV{GIT_DIR} && -d $ENV{GIT_DIR})) { 37 # Looks good 38} else { 39 # Also handle linked worktrees created by git-worktree: 40 my $found; 41 if (-f '.git') { 42 # the hash of the initial commit in perl.git (perl-1.0) 43 my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; 44 my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; 45 chomp $out; 46 if($out eq $commit) { 47 ++$found; 48 } 49 } 50 51 die "$0: This is a Perl directory but does not look like Git working directory\n" 52 unless $found; 53} 54 55my $null = devnull(); 56 57unless (defined $tag_to_compare) { 58 my $check = 'HEAD'; 59 while(1) { 60 $check = `git describe --abbrev=0 $check 2>$null`; 61 chomp $check; 62 last unless $check =~ /-RC/; 63 $check .= '~1'; 64 } 65 $tag_to_compare = $check; 66 # Thanks to David Golden for this suggestion. 67 68} 69 70unless (length $tag_to_compare) { 71 die "$0: Git found, but no Git tags found\n" 72 unless $tap; 73 print "1..0 # SKIP: Git found, but no Git tags found\n"; 74 exit 0; 75} 76 77my $tag_exists = `git --no-pager tag -l $tag_to_compare 2>$null`; 78chomp $tag_exists; 79 80unless ($tag_exists eq $tag_to_compare) { 81 die "$0: '$tag_to_compare' is not a known Git tag\n" unless $tap; 82 print "1..0 # SKIP: '$tag_to_compare' is not a known Git tag\n"; 83 exit 0; 84} 85 86my $commit_epoch = `git log -1 --format="%ct"`; 87chomp($commit_epoch); 88# old git versions dont support taggerdate:unix. so use :iso8601 and then 89# use timelocal_posix() to convert to an epoch. 90my $tag_date = `git for-each-ref --format="%(taggerdate:iso8601)" refs/tags/$tag_to_compare`; 91chomp($tag_date); 92my $tag_epoch= do { 93 my ($Y,$M,$D,$h,$m,$s) = split /[- :]/, $tag_date; # 2023-03-20 22:49:09 94 timelocal_posix($s,$m,$h,$D,$M-1,$Y-1900); 95}; 96 97if ($commit_epoch - $tag_epoch > 60 * 24 * 60 * 60) { 98 my $months = sprintf "%.2f", ($commit_epoch - $tag_epoch) / (30 * 24 * 60 * 60); 99 my $message= 100 "Tag '$tag_to_compare' is very old compared to the most recent commit.\n" 101 . "We normally release a new version every month, and this one is $months months\n" 102 . "older than the current commit. You probably have not synchronized your tags.\n" 103 . "This is common with github clones. You can try the following:\n" 104 . "\n" 105 . " git remote add -f upstream git\@github.com:Perl/perl5.git\n" 106 . "\n" 107 . "to fix your checkout.\n"; 108 die "$0: $message" unless $tap; 109 $message= "$message"; 110 $message=~s/^/# /mg; 111 print STDERR "\n$message"; 112 print "1..0 # SKIP: Tag '$tag_to_compare' is $months months old. Update your tags!\n"; 113 exit 0; 114} 115 116my %upstream_files; 117if ($exclude_upstream) { 118 unshift @INC, 'Porting'; 119 require Maintainers; 120 121 for my $m (grep {!defined $Maintainers::Modules{$_}{UPSTREAM} 122 or $Maintainers::Modules{$_}{UPSTREAM} ne 'blead'} 123 keys %Maintainers::Modules) { 124 $upstream_files{$_} = 1 for Maintainers::get_module_files($m); 125 } 126} 127 128# Files to skip from the check for one reason or another, 129# usually because they pull in their version from some other file. 130my %skip; 131@skip{ 132 'cpan/Digest/t/lib/Digest/Dummy.pm', # just a test module 133 'cpan/ExtUtils-Install/t/lib/MakeMaker/Test/Setup/BFD.pm', # just a test module 134 'cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm', # just a test module 135 'cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/XS.pm', # just a test module 136 'cpan/IO-Compress/lib/File/GlobMapper.pm', # upstream needs to supply $VERSION 137 'cpan/Math-BigInt/t/Math/BigFloat/Subclass.pm', # just a test module 138 'cpan/Math-BigInt/t/Math/BigInt/BareCalc.pm', # just a test module 139 'cpan/Math-BigInt/t/Math/BigInt/Scalar.pm', # just a test module 140 'cpan/Math-BigInt/t/Math/BigInt/Subclass.pm', # just a test module 141 'cpan/Math-BigRat/t/Math/BigRat/Test.pm', # just a test module 142 'cpan/Module-Load/t/to_load/LoadIt.pm', # just a test module 143 'cpan/Module-Load/t/to_load/Must/Be/Loaded.pm', # just a test module 144 'cpan/Module-Load-Conditional/t/test_lib/a/X.pm', # just a test module 145 'cpan/Module-Load-Conditional/t/test_lib/b/X.pm', # just a test module 146 'cpan/Module-Load-Conditional/t/to_load/Commented.pm', # just a test module 147 'cpan/Module-Load-Conditional/t/to_load/HereDoc.pm', # just a test module 148 'cpan/Module-Load-Conditional/t/to_load/InPod.pm', # just a test module 149 'cpan/Module-Load-Conditional/t/to_load/LoadIt.pm', # just a test module 150 'cpan/Module-Load-Conditional/t/to_load/MustBe/Loaded.pm', # just a test module 151 'cpan/Module-Load-Conditional/t/to_load/NotMain.pm', # just a test module 152 'cpan/Module-Load-Conditional/t/to_load/NotX.pm', # just a test module 153 'cpan/Pod-Usage/t/inc/Pod/InputObjects.pm', # just a test module 154 'cpan/Pod-Usage/t/inc/Pod/Parser.pm', # just a test module 155 'cpan/Pod-Usage/t/inc/Pod/PlainText.pm', # just a test module 156 'cpan/Pod-Usage/t/inc/Pod/Select.pm', # just a test module 157 'cpan/podlators/t/lib/Test/Podlators.pm', # just a test module 158 'cpan/podlators/t/lib/Test/RRA.pm', # just a test module 159 'cpan/podlators/t/lib/Test/RRA/Config.pm', # just a test module 160 'cpan/version/t/coretests.pm', # just a test module 161 'dist/Attribute-Handlers/demo/MyClass.pm', # it's just demonstration code 162 'dist/Exporter/lib/Exporter/Heavy.pm', 163 'dist/Module-CoreList/lib/Module/CoreList.pm', 164 'dist/Module-CoreList/lib/Module/CoreList/Utils.pm', 165 'lib/Carp/Heavy.pm', 166 'lib/Config.pm', # no version number but contents will vary 167 'win32/FindExt.pm', 168} = (); 169 170# Files to skip just for particular version(s), 171# usually due to some # mix-up 172 173my %skip_versions = ( 174 # 'some/sample/file.pm' => [ '1.23', '1.24' ], 175); 176 177my $skip_dirs = qr|^t/lib|; 178 179sub pm_file_from_xs { 180 my $xs = shift; 181 182 foreach my $try (sub { 183 # First try a .pm at the same level as the .xs file 184 # with the same basename 185 return shift =~ s/\.xs\z//r; 186 }, 187 sub { 188 # Try for a (different) .pm at the same level, based 189 # on the directory name: 190 my ($path) = shift =~ m!^(.*)/!; 191 my ($last) = $path =~ m!([^-/]+)\z!; 192 return "$path/$last"; 193 }, 194 sub { 195 # Try to work out the extension's full package, and 196 # look for a .pm in lib/ based on that: 197 my ($path) = shift =~ m!^(.*)/!; 198 my ($last) = $path =~ m!([^/]+)\z!; 199 $last = 'List-Util' if $last eq 'Scalar-List-Utils'; 200 $last =~ tr !-!/!; 201 return "$path/lib/$last"; 202 }) { 203 # For all cases, first look to see if the .pm file is generated. 204 my $base = $try->($xs); 205 return "${base}_pm.PL" if -f "${base}_pm.PL"; 206 return "${base}.pm" if -f "${base}.pm"; 207 } 208 209 die "No idea which .pm file corresponds to '$xs', so aborting"; 210} 211 212# .c files that correspond directly to a perl module 213# universal.c is not here, since it powers many different modules, 214# so we can't know which one would need its version bumped 215my %c_mod = ( 216 "builtin.c" => "lib/builtin.pm", 217); 218 219# Key is the .pm file from which we check the version. 220# Value is a reference to an array of files to check for differences 221# The trivial case is a pure perl module, where the array holds one element, 222# the perl module's file. The "fun" comes with XS modules, and the real fun 223# with XS modules with more than one XS file, and "interesting" layouts. 224 225my %module_diffs; 226my %dist_diffs; 227 228foreach (`git --no-pager diff --name-only $tag_to_compare --diff-filter=ACMRTUXB`) { 229 chomp; 230 next unless m/^(.*)\//; 231 my $this_dir = $1; 232 next if $this_dir =~ $skip_dirs || exists $skip{$_}; 233 next if exists $upstream_files{$_}; 234 if (/\.pm\z/ || m|^lib/.*\.pl\z| || /_pm\.PL\z/) { 235 push @{$module_diffs{$_}}, $_; 236 } elsif (/\.xs\z/ && !/\bt\b/) { 237 push @{$module_diffs{pm_file_from_xs($_)}}, $_; 238 } elsif (my $mod = $c_mod{$_}) { 239 push @{$module_diffs{$mod}}, $_; 240 } elsif (!/\bt\b/ && /\.[ch]\z/ && m!^((?:dist|ext|cpan)/[^/]+)/!) { 241 push @{ $dist_diffs{$1} }, $_; 242 } 243} 244 245unless (%module_diffs || %dist_diffs) { 246 print "1..1\nok 1 - No difference found\n" if $tap; 247 exit; 248} 249 250printf "1..%d\n" => (keys(%module_diffs) + keys (%dist_diffs)) if $tap; 251print "#\n# Comparing against $tag_to_compare ....\n#\n" if $tap; 252 253my $count; 254my $diff_cmd = "git --no-pager diff $tag_to_compare "; 255my $q = ($^O eq 'MSWin32' || $^O eq 'VMS') ? '"' : "'"; 256my (@diff); 257my %dist_bumped; 258 259foreach my $pm_file (sort keys %module_diffs) { 260 # git has already told us that the files differ, so no need to grab each as 261 # a blob from git, and do the comparison ourselves. 262 my $pm_version = eval {MM->parse_version($pm_file)}; 263 my $orig_pm_content = get_file_from_git($pm_file, $tag_to_compare); 264 my $orig_pm_version = eval {MM->parse_version(\$orig_pm_content)}; 265 ++$count; 266 267 if (!defined $orig_pm_version || $orig_pm_version eq 'undef') { # sigh 268 print "ok $count - SKIP Can't parse \$VERSION in $pm_file\n" 269 if $tap; 270 271 # Behave like a version bump if the orig version could not be parsed, 272 # but the current file could 273 if (defined $pm_version && $pm_version ne 'undef' && $pm_file =~ m!^((?:dist|ext|cpan)/[^/]+)/!) { 274 $dist_bumped{$1}++; 275 } 276 } elsif (!defined $pm_version || $pm_version eq 'undef') { 277 my $nok = "not ok $count - in $pm_file version was $orig_pm_version, now unparsable\n"; 278 print $nok if $tap; 279 print STDERR "# $nok\n"; 280 } elsif ($pm_version ne $orig_pm_version) { # good 281 print "ok $count - $pm_file\n" if $tap; 282 if ($pm_file =~ m!^((?:dist|ext|cpan)/[^/]+)/!) { 283 $dist_bumped{$1}++; 284 } 285 } else { 286 if ($tap) { 287 print "#\n# " . '-' x 75 . "\n" 288 . "# Version number ($pm_version) unchanged since" 289 . " $tag_to_compare, but contents have changed:\n#\n"; 290 foreach (sort @{$module_diffs{$pm_file}}) { 291 print "# $_" for `$diff_cmd $q$_$q`; 292 } 293 print "# " . '-' x 75 . "\n"; 294 295 if (exists $skip_versions{$pm_file} 296 and grep $pm_version eq $_, @{$skip_versions{$pm_file}}) { 297 print "ok $count - SKIP $pm_file version $pm_version\n"; 298 } else { 299 my $nok = "not ok $count - $pm_file version $pm_version\n"; 300 print $nok; 301 print STDERR "# $nok"; 302 } 303 } else { 304 push @diff, @{$module_diffs{$pm_file}}; 305 print "$pm_file version $pm_version\n"; 306 } 307 } 308} 309 310foreach my $dist (sort keys %dist_diffs) { 311 my $file_count = @{ $dist_diffs{$dist} }; 312 my $msg = $file_count == 1 ? "file was" : "files were"; 313 ++$count; 314 315 if ($dist_bumped{$dist}) { 316 print "ok $count - in $dist $file_count $msg modified and a version was bumped\n"; 317 } else { 318 my $nok = "not ok $count - in $dist $file_count $msg modified but no versions were bumped\n"; 319 print "# No versions bumped in $dist but $file_count $msg modified\n"; 320 print "# $_\n" for (sort @{$dist_diffs{$dist}}); 321 print $nok if $tap; 322 print STDERR "# $nok\n"; 323 } 324} 325 326sub get_file_from_git { 327 my ($file, $tag) = @_; 328 local $/; 329 330 use open IN => ':raw'; 331 return scalar `git --no-pager show $tag:$file 2>$null`; 332} 333 334if ($diffs) { 335 for (sort @diff) { 336 print "\n"; 337 system "$diff_cmd $q$_$q"; 338 } 339} 340