File Coverage

blib/lib/Tie/Hash/Stack.pm

Criterion	Covered	Total	%
statement	90	102	88.2
branch	20	34	58.8
condition	16	33	48.4
subroutine	18	21	85.7
pod	8	8	100.0
total	152	198	76.7

package Tie::Hash::Stack;

#=============================================================================
#
# $Id: Stack.pm,v 0.9 2001/06/30 12:13:46 mneylon Exp $
# $Revision: 0.9 $
# $Author: mneylon $
# $Date: 2001/06/30 12:13:46 $
# $Log: Stack.pm,v $
# Revision 0.9  2001/06/30 12:13:46  mneylon
#
# Initial Release (based on www.perlmonks.org code with some additional
# changes)
#
#
#=============================================================================

use strict;
use Carp;

use Exporter   ();
use vars       qw($VERSION @ISA @EXPORT %EXPORT_TAGS);

$VERSION     = "0.100";
@ISA         = qw(Exporter);
@EXPORT      = qw(push_hash pop_hash shift_hash unshift_hash
		  reverse_hash merge_hash flatten_hash get_depth);
%EXPORT_TAGS = ( );

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 blank 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 ( reverse @$obj ) {
	foreach my $key ( keys %$_ ) {
	    $hash{ $key } = $_->{ $key };
	}
    }
    return %hash;
}

sub flatten_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 = merge_hash %$href;
    @$obj = ( \%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 unshift_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 shift_hash"
      unless $obj and $obj->isa('Tie::Hash::Stack');
    pop @$obj;
    @$obj = ( { } ) if !@$obj;
}

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

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

42;

__END__