corelist.pl - Apply BinGOs's commit "Two" at updating Utils.pm
authorSteve Hay <steve.m.hay@googlemail.com>
Thu, 19 Sep 2013 22:39:38 +0000 (23:39 +0100)
committerSteve Hay <steve.m.hay@googlemail.com>
Thu, 19 Sep 2013 23:28:59 +0000 (00:28 +0100)
This is commit 402e920b67.

Porting/corelist.pl

index 6dab514..da4de64 100755 (executable)
@@ -316,7 +316,7 @@ open( my $utils_fh, '<', $utils_file );
 my $utils = join( '', <$utils_fh> );
 close $utils_fh;
 
-my $delta_utils = make_corelist_delta($perl_vnum, \%utils);
+my $delta_utils = make_coreutils_delta($perl_vnum, \%utils);
 
 use Data::Dumper; local $Data::Dumper::Indent=1;
 warn Dumper( $delta_utils );
@@ -378,6 +378,39 @@ sub make_corelist_delta {
   }
 }
 
+sub make_coreutils_delta {
+  my($version, $lines) = @_;
+  # Trust core perl, if someone does use a weird version number the worst that
+  # can happen is an extra delta entry for a module.
+  my %versions = map { $_ => eval $lines->{$_} } keys %$lines;
+
+  # Ensure we have the corelist data loaded from this perl checkout, not the system one.
+  require $corelist_file;
+
+  my %deltas;
+  # Search for the release with the least amount of changes (this avoids having
+  # to ask for where this perl was branched from).
+  for my $previous(reverse sort keys %Module::CoreList::version) {
+    # Shouldn't happen, but ensure we don't load weird data...
+    next if $previous > $version || $previous == $version && $previous eq $version;
+
+    my $delta = $deltas{$previous} = {};
+    ($delta->{changed}, $delta->{removed}) = calculate_delta(
+      $Module::CoreList::version{$previous}, \%versions);
+  }
+
+  my $smallest = (sort {
+      (keys($deltas{$a}->{changed}) + keys($deltas{$a}->{removed})) <=>
+      (keys($deltas{$b}->{changed})+ keys($deltas{$b}->{removed}))
+    } keys %deltas)[0];
+
+  return {
+    delta_from => $smallest,
+    changed => $deltas{$smallest}{changed},
+    removed => $deltas{$smallest}{removed},
+  }
+}
+
 # Calculate (changed, removed) modules between two versions.
 sub calculate_delta {
   my($from, $to) = @_;