1 files changed, 126 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm
new file mode 100755
index 00000000000..26b7de36fdb
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Test/Deep/HashKeysOnly.pm
@@ -0,0 +1,126 @@
+use strict;
+use warnings;
+
+package Test::Deep::HashKeysOnly;
+
+use Test::Deep::Ref;
+
+sub init
+{
+	my $self = shift;
+
+	my %keys;
+	@keys{@_} = ();
+	$self->{val} = \%keys;
+	$self->{keys} = [sort @_];
+}
+
+sub descend
+{
+	my $self = shift;
+	my $hash = shift;
+
+	my $data = $self->data;
+	my $exp = $self->{val};
+	my %got;
+	@got{keys %$hash} = ();
+
+	my @missing;
+	my @extra;
+
+	while (my ($key, $value) = each %$exp)
+	{
+		if (exists $got{$key})
+		{
+			delete $got{$key};
+		}
+		else
+		{
+			push(@missing, $key);
+		}
+	}
+
+	my @diags;
+	if (@missing and (not $self->ignoreMissing))
+	{
+		push(@diags, "Missing: ".nice_list(\@missing));
+	}
+
+	if (%got and (not $self->ignoreExtra))
+	{
+		push(@diags, "Extra: ".nice_list([keys %got]));
+	}
+
+	if (@diags)
+	{
+		$data->{diag} = join("\n", @diags);
+		return 0;
+	}
+
+	return 1;
+}
+
+sub diagnostics
+{
+	my $self = shift;
+	my ($where, $last) = @_;
+
+	my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
+
+	my $error = $last->{diag};
+	my $diag = <<EOM;
+Comparing hash keys of $where
+$error
+EOM
+
+	return $diag;
+}
+
+sub nice_list
+{
+	my $list = shift;
+
+	return join(", ",
+		(map {"'$_'"} sort @$list),
+	);
+}
+
+sub ignoreMissing
+{
+	return 0;
+}
+
+sub ignoreExtra
+{
+	return 0;
+}
+
+package Test::Deep::SuperHashKeysOnly;
+
+use base 'Test::Deep::HashKeysOnly';
+
+sub ignoreMissing
+{
+	return 0;
+}
+
+sub ignoreExtra
+{
+	return 1;
+}
+
+package Test::Deep::SubHashKeysOnly;
+
+use base 'Test::Deep::HashKeysOnly';
+
+sub ignoreMissing
+{
+	return 1;
+}
+
+sub ignoreExtra
+{
+	return 0;
+}
+
+1;