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";
[download]