Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Tie::HashTree

by jryan (Vicar)
on Sep 11, 2001 at 03:06 UTC ( #111623=sourcecode: print w/ replies, xml ) Need Help??

Category: Text Processing
Author/Contact Info Joseph F. Ryan, 580ryan@erienet.net (or ryan.306@osu.edu after 9/17/2001)
Description: Someone in the chatterbox the other day wanted an easier way to create a tree construct without emedding hashes up the wazoo, so here is my solution: Tie::HashTree. You can create a new tree from scratch, or convert an old hash into a Tree, whatever floats your boat. You can climb up and down the branches, or jump to a level from the base. Its up to you. The pod tells all that you need to know (I think), and I put it at the top for your convienience :) If you have any comments/flames, please feel free to reply.
package Tie::HashTree;
use Exporter;
@ISA       = qw(Exporter);
@EXPORT_OK = qw(hash_to_tree);

require 5.000;
use strict;
use warnings;

=head1 NAME

Tie::Tree - class definition for creating a Tree data type by tieing a
+ hash

=head1 SYNOPSIS

use Tie::Tree;

# create a new tree
my $new_tree = tie my %new_hash, 'Tree';

# turn an existing hash into a tree
my $converted_tree = tie my %tree_with_values, 'Tie::HashTree';
($converted_tree, %tree_with_values) = hash_to_tree(%hash_with_values)
+;

=head1 DESCRIPTION

Tie::HashTree allows you to create a tree data structure by tieing a h
+ash.
You can access (and assign) values to the Tree through the hash.  For 
instance, to access a node on the branch foo, which branches off of br
+anch
bar, which branches off of branch baz, in the tree quux, you would use
+ 
$quux{"baz->bar->foo"}. (or, if you need visual stimulation:
     quux
        \
        baz
         \
         bar
          \
          foo     
).  You can move up and down the tree with move_down() and move_up(), 
+move to a branch
with move_to, dump the tree in a nice indented format with dump_tree()
+, or even convert
a hash to a tree with hash_to_tree().  Tie::HashTree handles anyonomou
+s arrays and hashes 
very nicely, so it would be a handy tool to create linked lists, or st
+ore directory info,
etc.

=over 5

=item move_to path
    move down the path starting from the root level to the specified l
+evel.

=item move_up
    move up one level in the tree.

=item move_down path
    if the path exists in the current path, move down to that level.

=item dump_tree level
    dumps the tree in a nice indented format.  you may specify a sub-b
+ranch via
    the lone argument 

=item convert_hash hash
    the lone exported function.  it takes one argument: a hash.  the h
+ash is then
    trasformed into a HashTree Object.  The funtion returns the object
+.

=back

=head1 EXAMPLES

# Tieing the hash.  Don't forget -w and strict; :)
    #!/usr/bin/perl -w
    use strict;
    use Tie::HashTree qw(hash_to_tree);
    my $tree = tie my %x, 'Tie::HashTree';

# Creating branches and assigning values.
    $x{"item->narf"}="narf1";
    $x{"item->meep"}="meep1";
    $x{"item->foo"} ="foo1";
    $x{"item->bar"} ="bar1";
    $x{"item->baz"} ="baz1";
    $x{"item->bleh->quux"} = "quux1";
    $x{"item->bleh->blah"} = "blah1";
    $x{"item1->meep"}="meep2";
    $x{"item1->narf"}="narf2";
    $x{"item1->arg->foo"}="foo2";
    $x{"item1->arg->zoom"}=["zoom1", "zoom2", "zoom3"];
    $x{"item1->arg->beep"}={beepk1=>"beekv1", beepk2=>"beekv2", beepk3
+=>"beepv3", beepk4=>{beepk5=>"beepv5", beepk6=>"beepv6"}};
    $tree->dump_tree;    

# Test for a branch's existance.
    print "blah\n" if (exists($x{"item->blah"}));
    print "narf\n" if (exists($x{"item->narf"}));

# deleting a branch
    delete($x{"item->narf"});

# Looping throuhg a branch.
    while (my($key,$value) = each %{$x{"item->bleh"}})
    {
        print "$key=$value\n";
    }

# Using move_down and move_up to move through the tree
    print $x{"item1->arg->zoom->[0]"};
    $tree->move_down("item1");
    print "\n";
    print $x{"arg->zoom->[0]"}, "\n";
    $tree->move_up;
    print $x{"item1->arg->zoom->[0]"};    

# Using move_to to move through the tree from the base level
    print $x{"item1->arg->zoom->[0]"};
    $tree->move_to("item1->arg->zoom");
    print "\n";
    print $x{"[0]"}, "\n";
    $tree->move_to("");
    print $x{"item1->arg->zoom->[0]"};

# Creating a HashTree out of an existing hash.
    my %temp;
    $temp{blah} = "meep1";
    $temp{zarg} = "zimzum";
    $temp{meep} = {};
    $temp{meep}->{narf} = "foo";
    $temp{meep}->{broohaha} = "bar";
    $temp{baz} = ["baz1", "baz2", "baz3"];
    my $tree2 = tie my %new_temp, 'Tie::HashTree';
    ($tree2, %new_temp) = hash_to_tree(%temp);
    $tree2->dump_tree;

=head1 AUTHOR

Joseph F. Ryan, 580ryan@erienet.net (or ryan.306@osu.edu after 9/17/20
+01)

=cut

sub TIEHASH
{
    my ($class, $self) = @_;
    $self->{level}     = "";
    $self->{name}      = $class;
    $self->{top}       = {};
    bless ($self, $class);
}

sub STORE
{
    my($self,$key,$value) = @_;
    my @values =  ($value) unless (ref($value));
    @values    =  @$value if (ref($value) eq "ARRAY");
    my %values =  %$value if (ref($value) eq "HASH");
    $key       =~ tr/ //d;
    my @levels =  split(/\->/, $key);
    $key       =  build_string($self->{level}, $key);
    if (%values){$key.="={\%values}"}
    else
    {
        $key .= "=\"$values[0]\"" unless (scalar(@values) > 1);
        $key .= "=\[\@values\]" if (scalar(@values) > 1);
    }
    eval($key);
}
sub FETCH
{
    my($self, $key) = @_;
    $key = build_string($self->{level}, $key);
    return eval($key);
}
sub EXISTS
{
    my($self, $key) = @_;
    $key = build_string($self->{level}, $key);
    eval($key);
}
sub CLEAR
{
    my($self, $key) = @_;
    delete ($self->{top});
    $self->{top} = {};
}
sub DELETE
{
    my($self, $key) = @_;
    $key = build_string($self->{level}, $key);
    eval("delete($key)");
}
sub FIRSTKEY
{
    my $self = shift;
    my $key  = build_string($self->{level}, $self->{level}, 1);
    each %{eval($key)}
}
sub NEXTKEY
{
    my($self, $key) = @_;
    $key = build_string($self->{level}, $key, 1);
    each %{eval($key)};
}
sub build_string
{
    my $level  =  shift;
    my $key    =  shift;
    my $offset =  shift || 0;
    $key       =  $level.$key;
    $key       =~ tr/ //d;
    my @levels =  split(/\->/, $key);
    $key       =  "\$self->{top}";
    for (my $i=0; $i<(@levels-$offset); $i++)
    {
        $key .= "->{$levels[$i]}" unless ($levels[$i] =~ /^\[\d+\]$/);
        $key .= "->$levels[$i]" if ($levels[$i] =~ /^\[\d+\]$/);
    }
    return $key;
}
sub dump_tree
{
    my $self  = shift;
    my $item1 = shift || "";
    my $layer = shift || 1;
    my $item  = build_string($self->{level}, $item1);
    my @items = split(/\->/, $item1);
    $item     = eval($item);
    print "$items[$#items]\n" if ($layer==1 && $item1 ne "");
    print "$self->{name}\n" if ($item1 eq "" && $self->{level} eq "");
    if ($self->{level} ne "")
    {
        @items = split(/\->/, $self->{level});
        print "$items[$#items]\n";
    }
    while (my($key,$value) = each %{$item})
    {
        print " " x ($layer*3);
        print "$key\n", " " x (($layer+1)*3), "$value\n" unless ref(ev
+al("\$item->{$key}"));
        if (ref(eval("\$item->{$key}")) eq "HASH")
        {
            print "$key\n";
            $item1 = "$item1->" unless $item1 eq "";
            $item1 = "" if $item1 eq "";
            dump_tree($self, "$item1$key", $layer+1);
        }
        if (ref(eval("\$item->{$key}")) eq "ARRAY")
        {
            print "$key\n";
            my @temp = eval("\@{\$item\->{$key}}");
            foreach my $item (@temp)
            {
                print " " x (($layer+1)*3);
                print "$item\n";
            }
        }
    }
}
sub move_to
{
    my($self, $level) = @_;
    $self->{level}    = $level;
    $self->{level}   .= "->" if $level ne "";
}
sub move_up
{
    my $self   = shift;
    my @levels = split(/\->/, $self->{level});
    $self->{level} = "";
    for(my $i=0; $i<@levels-2; $i++){$self->{level} .= $levels[$i]."->
+"}
    $self->{level} .= $levels[$#levels-1] if (scalar(@levels) > 1);
}
sub move_down
{
    my $self = shift;
    my $path = shift;
    $self->{level} .= "$path\->";
}
sub hash_to_tree
{
    my($self, $state, $level, %old, %new);
    if (scalar(@_) % 2 == 1)
    {
        $self   =  shift;
        $state  =  shift;
        $level  =  shift;
        $state .= "->";
    }
    else
    {
        $self  = tie %new, 'Tie::HashTree';
        $state = "";
        $level = 0;
    }
    %old = @_;
    while (my($key,$value) = each %old)
    {
        my $item = build_string($self->{level}, "$state$key");
        $new{"$state$key"} = $value unless ref($old{$key});
        eval("$item=\"$value\"") unless ref($old{$key});
        if (ref($old{$key}) eq "HASH")
        {
            $state = "$state\->" unless $state eq "";
            ($self, %new) = hash_to_tree($self, "$state$key", $level+1
+, %{$old{$key}});
        }
        if (ref($old{$key}) eq "ARRAY")
        {
            my @values = @{$old{$key}};
            $key  = "$item";
            $key .= "=\[\@values\]";
            eval($key);
            $new{"$state$key"} = [@values];
        }
    }
    my @return_values = ($self, %new);
    return @return_values;
}

"JAPH";

Comment on Tie::HashTree
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (4)
As of 2015-07-30 04:44 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (270 votes), past polls