Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

Re: Any Point in Uploading Tie::SortedHash

by Limbic~Region (Chancellor)
on Sep 06, 2003 at 02:35 UTC ( [id://289406]=note: print w/replies, xml ) Need Help??


in reply to Any Point in Uploading Tie::SortedHash

All:
After Abigail's response, I realized that of my 3 optimization methods, only 1 of them worked correctly according to the docs for each. perldoc -f each says that it is safe to delete the last key visited while iterating over the keys in an each loop.

It was easy to go from 1/3 to 2/3 working by simply changing the "optimization" for delete. This only left the exponential loop to deal with. The reason for this optimization was to save memory (an extra array and hash).

Since the foreach loop constructs a list the same size as the array anyway, the only real saving of this method was not using the lookup hash. I figured out a way to:

  • Drop the (n2 + n)/2 loop by avoiding the lookup hash
  • Make the code cleaner
  • Function properly (I hope)
  • Be more memory/speed efficient
    #!/usr/bin/perl -w package Tie::SortedHash; use strict; use Carp; use constant HASH => 0; use constant INDEX => 1; use constant ARRAY => 2; use constant SORT => 3; use constant CHANGED => 4; use constant OPT => 5; our $VERSION = '1.00'; sub TIEHASH { my $class = shift; croak "Incorrect number of parameters" if @_ % 2; my %options = @_; my $self = bless [], $class; $self->_Build(\%options); return $self; } sub FETCH { my($self, $key) = @_; $self->[HASH]{$key}; } sub STORE { my($self, $key, $value) = @_; $self->[HASH]{$key} = $value; $self->[CHANGED] = 1; } sub EXISTS { my($self, $key) = @_; exists $self->[HASH]{$key}; } sub DELETE { my($self, $key) = @_; delete $self->[HASH]{$key}; $self->[CHANGED] = 1; } sub FIRSTKEY { my $self = shift; $self->_ReOrder if ! $self->[OPT] || $self->[CHANGED]; $self->[INDEX] = -1; $self->_Iterate; } sub NEXTKEY { my ($self, $lastkey) = @_; $self->_Iterate($lastkey); } sub CLEAR { my $self = shift; $self->[HASH] = {}; $self->[CHANGED] = 1; } sub DESTROY { } sub _Build { my ($self, $opt) = @_; my $sort = exists $opt->{SORT} ? $opt->{SORT} : sub { my $hash = shift; sort {$a cmp $b || $a <=> $b} keys %$hash; }; $self->sortroutine($sort); my $hash = exists $opt->{HASH} ? $opt->{HASH} : {}; croak "$hash is not a hash ref" if ref $hash ne 'HASH'; @{$self->[HASH]}{keys %$hash} = values %$hash; $self->[OPT] = $opt->{OPT} if exists $opt->{OPT}; } sub _ReOrder { my $self = shift; @{$self->[ARRAY]} = $self->[SORT]($self->[HASH]); $self->[CHANGED] = 0; } sub _Iterate { my ($self, $lastkey) = @_; $self->[INDEX]++; $self->[ARRAY][$self->[INDEX]]; } sub sortroutine { my($self, $sort) = @_; croak "$sort is not a code ref" if ref $sort ne 'CODE'; $self->[SORT] = $sort; $self->[CHANGED] = 1; } 1; __END__ =head1 NAME Tie::HashSort - Perl module to get hash keys in a sorted order =head1 SYNOPSIS use Tie::HashSort; my %hash = ( 'John' => 33, 'Jacob' => 29, 'Jingle' => 15, 'Heimer' => 48, 'Smitz' => 12, ); my $sort = sub { my $hash = shift; sort {$hash->{$b} <=> $hash->{$a}} keys %$hash; }; tie my %sorted_hash, 'Tie::SortedHash', 'HASH' => \%hash, 'SORT' = +> $sort, 'OPT' => 1; for my $name ( keys %sorted_hash ) { print "$name is $hash{$name} ears old.\n"; } ### OUTPUT ### Heimer is 48 ears old. John is 33 ears old. Jacob is 29 ears old. Jingle is 15 ears old. Smitz is 12 ears old. =head1 DESCRIPTION This module is a designed to retrieve hash keys in a pre-defined sorte +d order. It is often frustrating to have a hash return elements in a seemingly +random order when using C<keys()>, C<values()> or C<each()>.

    Cheers - L~R

  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Domain Nodelet?
    Node Status?
    node history
    Node Type: note [id://289406]
    help
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this?Last hourOther CB clients
    Other Users?
    Others having an uproarious good time at the Monastery: (2)
    As of 2024-06-20 07:02 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      No recent polls found

      Notices?
      erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.