Category: Miscellaenous
Author/Contact Info Michael K. Neylon [mailto://mneylon-pm@masemware.com]
Description: Allows one to tie a hash to a stack of hashes, for situations where one has data that is collected in consecutive stages with the possibility of moving backwards in the data collection process. 
#!/usr/bin/perl -w

package Tie::Hash::Stack;

######################
#
# Tie::Hash::Stack;
# v0.03
# Michael K. Neylon
# mneylon-pm@masemware.com
# June 21, 2001
#
# Creates and maintains a 'stacked' hash, see documentation
# for more details
#
# Suggestions/Comments/Ideas are highly desired and can be 
# sent to the eamil address above.
#
# Change History:
#
# v0.03 - June 21, 2001
# - Added merge_hash, shift_hash, and unshift_hash functions
# - Added optional values for TIEHASH, push_hash, and unshift_hash
# - Improved croak messages
# - Added minor protection for pop_hash'ing or shift'ing too far
#       (array is resetted to a blank holding in this case.)
#
# v0.02 - June 20, 2001
# - Cleaned up CLEAR function
# - Used shift and unshift instead of pop and push to make FETCH
#       work faster
# - Adjusted workings of push_/pop_hash
#
# v0.01 - June 19, 2001
# - Initial Release
#
######################

use strict;
use Carp;

BEGIN {
    use Exporter   ();
    use vars       qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION     = 0.02;
    @ISA         = qw(Exporter);
    @EXPORT      = qw(push_hash pop_hash);
    %EXPORT_TAGS = ( );
    @EXPORT_OK   = qw();
}

use vars @EXPORT_OK;


sub TIEHASH {
    my $self = shift;
    my $newhash = shift || {};
    croak "Argument must be a hashref in Tie::Hash::Stack constructor"
        unless UNIVERSAL::isa( $newhash, 'HASH' );
    my $hash_array = [ $newhash ];         # Create array, with one bl
+ank hash
    return bless $hash_array, $self;
}

sub FETCH {
    my $self = shift;
    my $key = shift;

    foreach ( @$self ) {
        # $_ is a hashref!
        return $_->{ $key } if ( exists $_->{ $key } );
    }
    return undef;
}

sub STORE {
    my $self = shift;
    my $key = shift;
    my $value = shift;

    $self->[0]->{ $key } = $value;
}

sub DELETE {
    my $self = shift;
    my $key = shift;
    my $return = $self->FETCH( $key );
    foreach ( @$self ) {
        delete $_->{ $key } if ( exists $_->{ $key } );
    }
    return $return;
}


sub CLEAR {
    my $self = shift;
    @$self = ( { } );
}

sub EXISTS {
    my $self = shift;
    my $key = shift;
    foreach ( @$self ) {
        return 1 if exists $_->{ $key };
    }
    return undef;
}

sub FIRSTKEY {
    my $self = shift;
    my %hash;
    foreach ( @$self ) {
        foreach my $key ( keys %$_ ) { 
            $hash{ $key } = 1;
        }
    }
    my @keys = sort keys %hash;
    return $keys[ 0 ];
}

sub NEXTKEY {
    my $self = shift;
    my $lastkey = shift;
    my %hash;
    foreach ( @$self ) {
        foreach my $key ( keys %$_ ) { 
            $hash{ $key } = 1;
        }
    }
    my @keys = sort keys %hash;
    my $i = 0;
    $i++ while ( ( $lastkey ne $keys[ $i ] ) 
               && ( $i < @keys - 1 ) ) ;
    if ( $i == @keys - 1 ) {
        return ();
    } else {
        return $keys[ $i+1 ];
    }
}

sub DESTROY {
}

sub merge_hash (\%) {
    my $href = shift;
    my $obj = tied %$href;
    croak "must be a Tie::Hash::Stack tied hash"
        unless $obj and $obj->isa('Tie::Hash::Stack');
    my %hash;
    foreach ( @$obj ) {
        foreach my $key ( keys %$_ ) { 
            $hash{ $key } = $_{ $key };
        }
    }
    return %hash;
}

sub push_hash (\%;\%) {
    my $href = shift;
    my $obj = tied %$href;
    my $addhash = shift || {};
    croak "First argument must be a Tie::Hash::Stack tied hash in push
+_hash"
        unless $obj and $obj->isa('Tie::Hash::Stack');
    croak "Second argument must be a hashref in push_hash"
        unless UNIVERSAL::isa( $addhash, 'HASH' );
    unshift @$obj, $addhash;
}

sub pop_hash (\%) {
    my $href = shift;
    my $obj = tied %$href;
    croak "First argument must be a Tie::Hash::Stack tied hash in pop_
+hash"
        unless $obj and $obj->isa('Tie::Hash::Stack');
    shift @$obj;
    @$obj = ( { } ) if !@$obj;
}

sub unshift_hash (\%;\%) {
    my $href = shift;
    my $obj = tied %$href;
    my $addhash = shift || {};
    croak "First argument must be a Tie::Hash::Stack tied hash in unsh
+ift_hash"
        unless $obj and $obj->isa('Tie::Hash::Stack');
    croak "Second argument must be a hashref in unshift_hash"
        unless UNIVERSAL::isa( $addhash, 'HASH' );
    push @$obj, $addhash;
}

sub shift_hash (\%) {
    my $href = shift;
    my $obj = tied %$href;
    croak "First argument must be a Tie::Hash::Stack tied hash in shif
+t_hash"
        unless $obj and $obj->isa('Tie::Hash::Stack');
    pop @$obj;
    @$obj = ( { } ) if !@$obj;
}


=head1 NAME

    Tie::Stack::Hash;

=head1 SYNOPSIS

    use Tie::Hash::Stack qw(pop_hash push_hash);

    my %hash;
    tie( %hash, "Tie::Hash::Stack" );   # Ties the hash

    $hash{ 1 } = "one";
    $hash{ 2 } = "two";
    $hash{ 3 } = "three";

    push_hash %hash;               # Pushes a new hash on the stack

    $hash{ 2 } = "II";             # $hash{ 2 } now 'II'
    $hash{ 4 } = "IV";

    push_hash %hash;

    $hash{ 3 } = "9/3";            # $hash{ 3 } now '9/3'
    $hash{ 5 } = "10/2";

    pop_hash %hash;                # $hash{ 3 } now 'three';

    delete $hash{ 2 };             # $hash{ 2 } now undef'ed;

    my %merged = merge_hash %hash; # ( 1=>one, 3=>three, 4=>IV ) 

=head1 DESCRIPTION

    C<Tie::Hash::Stack> allows one to tie a hash to a data structure
    that is composed of an ordered (FILO) sequence of hashes; hash 
    values are always set on the newest hash of the stack, and are
    retrieved from the hash that contains the requested that is newest
    on the stack.  The stack can be manipulated to add or remove these
    hashes.  This type of structure is good when on is collecting data
    in stages with the possibility of having to "back up" to previous
    stages.

    In cases where the same key is in two or more hashes on the stack,
+ 
    the value from the most recent hash containing that key will 
    be returned.

    When C<tie>'d, the new hash will already have one hash on the
    stack, so that it can be used without any extra code.  Optionally,
    a hash reference may be passed which will be used as the initial
    hash within the array.

    Besides the standard hash functions, there are two functions that
    can be accessed through the tie'd hash variable.

    C<push_hash> - Pushes an empty hash onto the hash; any further 
    hash assignments will be placed into this hash until it is removed
+,
    or a new hash pushed onto the stack.  A optional second argument 
    may be a reference to a hash which will be pushed onto the stack 
    instead of an empty one.

    C<pop_hash> - Removes the last hash on the stack after deleting th
+e
    values from it.  If all hashes are removed, the stack is reset wit
+h
    an empty hash.

    C<shift_hash>, C<unshift_hash> - Complimentary functions of 
    C<pop_hash> and C<push_hash>; removes the hash at the front of the
+ 
    stack, or adds a new hash to the front of the stack.  C<unshift_ha
+sh>
    also takes a similar optional second arguement as with C<push_hash
+>.
    
    C<merge_hash> - Merges all the hashes into one and returns this
    new (untied) hash; duplicated keys are treated as described above.

=head1 HISTORY

    Revision 0.03  2001/06/21   Michael K. Neylon
    Added merge_hash, shift_hash, and unshift_hash functions
    Added optional values for TIEHASH, push_hash, and unshift_hash
    Improved croak messages
    Added minor protection for pop_hash'ing or shift'ing too far
      (array is resetted to a blank holding in this case.)

    Revision 0.02  2001/06/20   Michael K. Neylon
    Cleaned up CLEAR function
    Used shift/unshift instead of pop/push to improve FETCH speed
    Converted push_hash and pop_hash to exported functions.
      (Thanks to Jeff 'japhy' Pinyan)

    Revision 0.01  2001/06/19   Michael K. Neylon
    Initial revision

=head1 AUTHOR

This package was written by Michael K. Neylon

=head1 COPYRIGHT

Copyright 2001 by Michael K. Neylon

=head1 LICENSE

Permission is hereby granted, free of charge, to any person obtaining 
+a
copy of this software and associated documentation files (the "Softwar
+e"),
to deal in the Software without restriction, including without limitat
+ion
the rights to use, copy, modify, merge, publish, distribute, sublicens
+e,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be include
+d
in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRES
+S OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILIT
+Y,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHAL
+L
THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT
OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.

=cut

1;
Replies are listed 'Best First'.
Re: Tie::Hash::Stack
by japhy (Canon) on Jun 20, 2001 at 08:42 UTC
    Your CLEAR function does too much work, and has a misleading statement. 
    sub CLEAR {
    my $self = shift;
    foreach ( @$self ) {
        foreach my $key ( keys %$_ ) {
            delete $_->{ $key }
        }
    }
    $self = [ { } ];
}

    [download]
    I would just write: 
    sub CLEAR {
  my $self = shift;
  @$self = ( {} );
}

    [download]
    or the more terse 
    sub CLEAR {
  $_[0] = [ {} ];
}

    [download]
    The problem with assigning to just $self is that it doesn't modify the data referred to by $self. And you're taking a long and arduous approach to clearing those hashes.

    My other remark is about your push_hash() and pop_hash() functions. Why not prototype them as (\%), and then export them? This will allow you to do: 
    use Carp;

sub push_hash (\%) {
  my $href = shift;
  my $obj = tied %$href;

  croak "must be a Tie::Hash::Stack tied hash"
    unless $obj and $obj->isa('Tie::Hash::Stack');

  push @$obj, {};
}


sub pop_hash (\%) {
  my $href = shift;
  my $obj = tied %$href;

  croak "must be a Tie::Hash::Stack tied hash"
    unless $obj and $obj->isa('Tie::Hash::Stack');

  pop @$obj;
}


# and in your program...

tie my(%stash), 'Tie::Hash::Stack';

# ...
push_hash %stash;
# ...

    [download]
    Update: Hmm... in retrospect, why not push the new hash to the front of the stack? This would make your FETCH faster, so that it can return as soon as a key-value pair is found. Modify code as needed.

    japhy -- Perl and Regex Hacker
[reply]
[d/l]
[select]
      Yea, I don't know why I didn't think of 'reversing' the stack, maybe just got too tied up in keeping to the spirit of the stack. When I wrote this, I was more concerned with handling FIRSTKEY/NEXTKEY, since that's the tricky tie part for this class (and some of the docs and examples are misleading on how this works!) In any case, I've updated the code with your suggestions to 0.02.

      Dr. Michael K. Neylon - mneylon-pm@masemware.com || "You've left the lens cap of your mind on again, Pinky" - The Brain
[reply]

Back to Code Catacombs