summaryrefslogtreecommitdiffstats
path: root/linux-x86/lib/perl-base/Hash/Util.pm
diff options
context:
space:
mode:
Diffstat (limited to 'linux-x86/lib/perl-base/Hash/Util.pm')
-rw-r--r--linux-x86/lib/perl-base/Hash/Util.pm300
1 files changed, 0 insertions, 300 deletions
diff --git a/linux-x86/lib/perl-base/Hash/Util.pm b/linux-x86/lib/perl-base/Hash/Util.pm
deleted file mode 100644
index 38eee5a..0000000
--- a/linux-x86/lib/perl-base/Hash/Util.pm
+++ /dev/null
@@ -1,300 +0,0 @@
-package Hash::Util;
-
-require 5.007003;
-use strict;
-use Carp;
-use warnings;
-no warnings 'uninitialized';
-use warnings::register;
-use Scalar::Util qw(reftype);
-
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(
- fieldhash fieldhashes
-
- all_keys
- lock_keys unlock_keys
- lock_value unlock_value
- lock_hash unlock_hash
- lock_keys_plus
- hash_locked hash_unlocked
- hashref_locked hashref_unlocked
- hidden_keys legal_keys
-
- lock_ref_keys unlock_ref_keys
- lock_ref_value unlock_ref_value
- lock_hashref unlock_hashref
- lock_ref_keys_plus
- hidden_ref_keys legal_ref_keys
-
- hash_seed hash_value hv_store
- bucket_stats bucket_stats_formatted bucket_info bucket_array
- lock_hash_recurse unlock_hash_recurse
- lock_hashref_recurse unlock_hashref_recurse
-
- hash_traversal_mask
-
- bucket_ratio
- used_buckets
- num_buckets
- );
-BEGIN {
- # make sure all our XS routines are available early so their prototypes
- # are correctly applied in the following code.
- our $VERSION = '0.22';
- require XSLoader;
- XSLoader::load();
-}
-
-sub import {
- my $class = shift;
- if ( grep /fieldhash/, @_ ) {
- require Hash::Util::FieldHash;
- Hash::Util::FieldHash->import(':all'); # for re-export
- }
- unshift @_, $class;
- goto &Exporter::import;
-}
-
-sub lock_ref_keys {
- my($hash, @keys) = @_;
-
- _clear_placeholders(%$hash);
- if( @keys ) {
- my %keys = map { ($_ => 1) } @keys;
- my %original_keys = map { ($_ => 1) } keys %$hash;
- foreach my $k (keys %original_keys) {
- croak "Hash has key '$k' which is not in the new key set"
- unless $keys{$k};
- }
-
- foreach my $k (@keys) {
- $hash->{$k} = undef unless exists $hash->{$k};
- }
- Internals::SvREADONLY %$hash, 1;
-
- foreach my $k (@keys) {
- delete $hash->{$k} unless $original_keys{$k};
- }
- }
- else {
- Internals::SvREADONLY %$hash, 1;
- }
-
- return $hash;
-}
-
-sub unlock_ref_keys {
- my $hash = shift;
-
- Internals::SvREADONLY %$hash, 0;
- return $hash;
-}
-
-sub lock_keys (\%;@) { lock_ref_keys(@_) }
-sub unlock_keys (\%) { unlock_ref_keys(@_) }
-
-#=item B<_clear_placeholders>
-#
-# This function removes any placeholder keys from a hash. See Perl_hv_clear_placeholders()
-# in hv.c for what it does exactly. It is currently exposed as XS by universal.c and
-# injected into the Hash::Util namespace.
-#
-# It is not intended for use outside of this module, and may be changed
-# or removed without notice or deprecation cycle.
-#
-#=cut
-#
-# sub _clear_placeholders {} # just in case someone searches...
-
-sub lock_ref_keys_plus {
- my ($hash,@keys) = @_;
- my @delete;
- _clear_placeholders(%$hash);
- foreach my $key (@keys) {
- unless (exists($hash->{$key})) {
- $hash->{$key}=undef;
- push @delete,$key;
- }
- }
- Internals::SvREADONLY(%$hash,1);
- delete @{$hash}{@delete};
- return $hash
-}
-
-sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
-
-sub lock_ref_value {
- my($hash, $key) = @_;
- # I'm doubtful about this warning, as it seems not to be true.
- # Marking a value in the hash as RO is useful, regardless
- # of the status of the hash itself.
- carp "Cannot usefully lock values in an unlocked hash"
- if !Internals::SvREADONLY(%$hash) && warnings::enabled;
- Internals::SvREADONLY $hash->{$key}, 1;
- return $hash
-}
-
-sub unlock_ref_value {
- my($hash, $key) = @_;
- Internals::SvREADONLY $hash->{$key}, 0;
- return $hash
-}
-
-sub lock_value (\%$) { lock_ref_value(@_) }
-sub unlock_value (\%$) { unlock_ref_value(@_) }
-
-sub lock_hashref {
- my $hash = shift;
-
- lock_ref_keys($hash);
-
- foreach my $value (values %$hash) {
- Internals::SvREADONLY($value,1);
- }
-
- return $hash;
-}
-
-sub unlock_hashref {
- my $hash = shift;
-
- foreach my $value (values %$hash) {
- Internals::SvREADONLY($value, 0);
- }
-
- unlock_ref_keys($hash);
-
- return $hash;
-}
-
-sub lock_hash (\%) { lock_hashref(@_) }
-sub unlock_hash (\%) { unlock_hashref(@_) }
-
-sub lock_hashref_recurse {
- my $hash = shift;
-
- lock_ref_keys($hash);
- foreach my $value (values %$hash) {
- my $type = reftype($value);
- if (defined($type) and $type eq 'HASH') {
- lock_hashref_recurse($value);
- }
- Internals::SvREADONLY($value,1);
- }
- return $hash
-}
-
-sub unlock_hashref_recurse {
- my $hash = shift;
-
- foreach my $value (values %$hash) {
- my $type = reftype($value);
- if (defined($type) and $type eq 'HASH') {
- unlock_hashref_recurse($value);
- }
- Internals::SvREADONLY($value,0);
- }
- unlock_ref_keys($hash);
- return $hash;
-}
-
-sub lock_hash_recurse (\%) { lock_hashref_recurse(@_) }
-sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
-
-sub hashref_locked {
- my $hash=shift;
- Internals::SvREADONLY(%$hash);
-}
-
-sub hash_locked(\%) { hashref_locked(@_) }
-
-sub hashref_unlocked {
- my $hash=shift;
- !Internals::SvREADONLY(%$hash);
-}
-
-sub hash_unlocked(\%) { hashref_unlocked(@_) }
-
-sub legal_keys(\%) { legal_ref_keys(@_) }
-sub hidden_keys(\%){ hidden_ref_keys(@_) }
-
-sub bucket_stats {
- my ($hash) = @_;
- my ($keys, $buckets, $used, @length_counts) = bucket_info($hash);
- my $sum;
- my $score;
- for (1 .. $#length_counts) {
- $sum += ($length_counts[$_] * $_);
- $score += $length_counts[$_] * ( $_ * ($_ + 1 ) / 2 );
- }
- $score = $score /
- (( $keys / (2 * $buckets )) * ( $keys + ( 2 * $buckets ) - 1 ))
- if $keys;
- my ($mean, $stddev)= (0, 0);
- if ($used) {
- $mean= $sum / $used;
- $sum= 0;
- $sum += ($length_counts[$_] * (($_-$mean)**2)) for 1 .. $#length_counts;
-
- $stddev= sqrt($sum/$used);
- }
- return $keys, $buckets, $used, $keys ? ($score, $used/$buckets, ($keys-$used)/$keys, $mean, $stddev, @length_counts) : ();
-}
-
-sub _bucket_stats_formatted_bars {
- my ($total, $ary, $start_idx, $title, $row_title)= @_;
-
- my $return = "";
- my $max_width= $total > 64 ? 64 : $total;
- my $bar_width= $max_width / $total;
-
- my $str= "";
- if ( @$ary < 10) {
- for my $idx ($start_idx .. $#$ary) {
- $str .= $idx x sprintf("%.0f", ($ary->[$idx] * $bar_width));
- }
- } else {
- $str= "-" x $max_width;
- }
- $return .= sprintf "%-7s %6d [%s]\n",$title, $total, $str;
-
- foreach my $idx ($start_idx .. $#$ary) {
- $return .= sprintf "%-.3s %3d %6.2f%% %6d [%s]\n",
- $row_title,
- $idx,
- $ary->[$idx] / $total * 100,
- $ary->[$idx],
- "#" x sprintf("%.0f", ($ary->[$idx] * $bar_width)),
- ;
- }
- return $return;
-}
-
-sub bucket_stats_formatted {
- my ($hashref)= @_;
- my ($keys, $buckets, $used, $score, $utilization_ratio, $collision_pct,
- $mean, $stddev, @length_counts) = bucket_stats($hashref);
-
- my $return= sprintf "Keys: %d Buckets: %d/%d Quality-Score: %.2f (%s)\n"
- . "Utilized Buckets: %.2f%% Optimal: %.2f%% Keys In Collision: %.2f%%\n"
- . "Chain Length - mean: %.2f stddev: %.2f\n",
- $keys, $used, $buckets, $score, $score <= 1.05 ? "Good" : $score < 1.2 ? "Poor" : "Bad",
- $utilization_ratio * 100,
- $keys/$buckets * 100,
- $collision_pct * 100,
- $mean, $stddev;
-
- my @key_depth;
- $key_depth[$_]= $length_counts[$_] + ( $key_depth[$_+1] || 0 )
- for reverse 1 .. $#length_counts;
-
- if ($keys) {
- $return .= _bucket_stats_formatted_bars($buckets, \@length_counts, 0, "Buckets", "Len");
- $return .= _bucket_stats_formatted_bars($keys, \@key_depth, 1, "Keys", "Pos");
- }
- return $return
-}
-
-1;
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-07 14:46:01 +0000