HTML::Widgets::NavMenu - A Perl Module for Generating HTML Navigation Menus

    use HTML::Widgets::NavMenu;

    my $nav_menu =
        HTML::Widgets::NavMenu->new(
            'path_info' => "/me/",
            'current_host' => "default",
            'hosts' =>
            {
                'default' =>
                {
                    'base_url' => "http://www.hello.com/"
                },
            },
            'tree_contents' =>
            {
                'host' => "default",
                'text' => "Top 1",
                'title' => "T1 Title",
                'expand_re' => "",
                'subs' =>
                [
                    {
                        'text' => "Home",
                        'url' => "",
                    },
                    {
                        'text' => "About Me",
                        'title' => "About Myself",
                        'url' => "me/",
                    },
                ],
            },
        );

    my $results = $nav_menu->render();

    my $nav_menu_html = join("\n", @{$results->{'html'}});

    # Always expand.
    'expand' => { 'bool' => 1, };

    # Never expand.
    'expand' => { 'bool' => 0, };

    # Expand under home/
    'expand' => { 're' => "^home/" },

    # Expand under home/ when the current host is "foo"
    sub expand_path_home_host_foo
    {
        my %args = (@_);
        my $host = $args{'current_host'};
        my $path = $args{'path_info'};
        return (($host eq "foo") && ($path =~ m!^home/!));
    }

    'expand' => { 'cb' => \&expand_path_home_host_foo, },

use strict;
use warnings;

package HTML::Widgets::NavMenu;

our $VERSION = '1.0600';

package HTML::Widgets::NavMenu::Error;

use base "HTML::Widgets::NavMenu::Object";

package HTML::Widgets::NavMenu::Error::Redirect;

use strict;
use vars qw(@ISA);
@ISA=("HTML::Widgets::NavMenu::Error");

sub CGIpm_perform_redirect
{
    my $self = shift;

    my $cgi = shift;

    print $cgi->redirect($cgi->script_name() . $self->{-redirect_path});
    exit;
}

package HTML::Widgets::NavMenu::NodeDescription;

use strict;

use base qw(HTML::Widgets::NavMenu::Object);

__PACKAGE__->mk_acc_ref([
    qw(host host_url title label direct_url url_type)]
    );

sub _init
{
    my ($self, $args) = @_;

    while (my ($k, $v) = each(%$args))
    {
        $self->$k($v);
    }
    
    return 0;
}

1;

package HTML::Widgets::NavMenu::LeadingPath::Component;

use vars qw(@ISA);

@ISA = (qw(HTML::Widgets::NavMenu::NodeDescription));

package HTML::Widgets::NavMenu::Iterator::GetCurrentlyActive;

use base 'HTML::Widgets::NavMenu::Iterator::Base';

__PACKAGE__->mk_acc_ref([qw(
    _item_found
    _leading_path_coords
    _ret_coords
    _temp_coords
    _tree
    )]);

sub _init
{
    my $self = shift;
    my $args = shift;

    $self->SUPER::_init($args);

    $self->_tree($args->{'tree'});

    $self->_item_found(0);
    
    return 0;
}

sub get_initial_node
{
    my $self = shift;

    return $self->_tree;
}

sub item_matches
{
    my $self = shift;
    my $item = $self->top();
    my $url = $item->_node()->url();
    my $nav_menu = $self->nav_menu();
    return
        (
            ($item->_accum_state()->{'host'} eq $nav_menu->current_host()) &&
            (defined($url) && ($url eq $nav_menu->path_info()))
        );
}

sub does_item_expand
{
    my $self = shift;
    my $item = $self->top();
    return $item->_node()->capture_expanded();
}

sub node_start
{
    my $self = shift;

    if ($self->item_matches())
    {
        my @coords = @{$self->get_coords()};
        $self->_ret_coords([ @coords ]);
        $self->_temp_coords([ @coords, (-1) ]);
        $self->top()->_node()->mark_as_current();
        $self->_item_found(1);
    }
    elsif ($self->does_item_expand())
    {
        my @coords = @{$self->get_coords()};
        $self->_leading_path_coords([ @coords]);
    }
}

sub node_end
{
    my $self = shift;
    if ($self->_item_found())
    {
        # Skip the first node, because the coords refer
        # to the nodes below it.
        my $idx = pop(@{$self->_temp_coords()});
        if ($idx >= 0)
        {
            my $node = $self->top()->_node();
            $node->update_based_on_sub(
                $node->get_nth_sub(
                    $idx
                )
            );
        }
    }
}

sub node_should_recurse
{
    my $self = shift;
    return (! $self->_item_found());
}

sub get_final_coords
{
    my $self = shift;

    return $self->_ret_coords();
}

sub _get_leading_path_coords
{
    my $self = shift;

    return ($self->_ret_coords() || $self->_leading_path_coords());
}

package HTML::Widgets::NavMenu;

use base 'HTML::Widgets::NavMenu::Object';

use HTML::Widgets::NavMenu::Url;

require HTML::Widgets::NavMenu::Iterator::NavMenu;
require HTML::Widgets::NavMenu::Iterator::SiteMap;
require HTML::Widgets::NavMenu::Tree::Node;
require HTML::Widgets::NavMenu::Predicate;

__PACKAGE__->mk_acc_ref([qw(
    _current_coords
    current_host
    _hosts
    _no_leading_dot
    _leading_path_coords
    path_info
    _traversed_tree
    _tree_contents
    _ul_classes
    )]);

sub _init
{
    my $self = shift;

    my %args = (@_);

    $self->_register_path_info(\%args);

    $self->_hosts($args{hosts});
    $self->_tree_contents($args{tree_contents});

    $self->current_host($args{current_host})
        or die "Current host was not specified.";

    $self->_ul_classes($args{'ul_classes'} || []);

    $self->_no_leading_dot(
        exists($args{'no_leading_dot'}) ? $args{'no_leading_dot'} : 0
    );

    return 0;
}

sub _get_nav_menu_traverser_args
{
    my $self = shift;

    return
    {
        'nav_menu' => $self,
        'ul_classes' => $self->_ul_classes(),
    };
}

sub _get_nav_menu_traverser
{
    my $self = shift;

    return
        HTML::Widgets::NavMenu::Iterator::NavMenu->new(
            $self->_get_nav_menu_traverser_args()
        );
}

sub _get_current_coords
{
    my $self = shift;

    # This is to make sure $self->_current_coords() is generated.
    $self->_get_traversed_tree();

    return [ @{$self->_current_coords()} ];
}

sub _register_path_info
{
    my $self = shift;
    my $args = shift;

    my $path_info = $args->{path_info};

    my $redir_path = undef;

    if ($path_info eq "")
    {
        $redir_path = "";
    }
    elsif ($path_info =~ m/\/\/$/)
    {
        my $path = $path_info;
        $path =~ s{\/+$}{};
        $redir_path = $path;
    }

    if (defined($redir_path))
    {
        my $error = HTML::Widgets::NavMenu::Error::Redirect->new();

        $error->{'-redirect_path'} = ($redir_path."/");
        $error->{'msg'} = "Need to redirect";

        die $error;
    }

    $path_info =~ s!^\/!!;

    $self->path_info($path_info);

    return 0;
}

sub _is_slash_terminated
{
    my $string = shift;
    return (($string =~ /\/$/) ? 1 : 0);
}

sub _text_to_url_obj
{
    my $text = shift;
    my $url = 
        HTML::Widgets::NavMenu::Url->new(
            $text,
            (_is_slash_terminated($text) || ($text eq "")),
            "server",
        );
    return $url;
}

sub _get_relative_url
{
    my $from_text = shift;
    my $to_text = shift(@_);
    my $no_leading_dot = shift;

    my $from_url = _text_to_url_obj($from_text);
    my $to_url = _text_to_url_obj($to_text);
    my $ret = 
        $from_url->_get_relative_url(
            $to_url, 
            _is_slash_terminated($from_text),
            $no_leading_dot,
        );
   return $ret;
}

sub _get_full_abs_url
{
    my ($self, $args) = @_;

    my $host = $args->{host};
    my $host_url = $args->{host_url};
    
    return ($self->_hosts->{$host}->{base_url} . $host_url);
}

sub get_cross_host_rel_url_ref
{
    my ($self, $args) = @_;

    my $host = $args->{host};
    my $host_url = $args->{host_url};
    my $url_type = $args->{url_type};
    my $url_is_abs = $args->{url_is_abs};

    if ($url_is_abs)
    {
        return $host_url;
    }
    elsif (($host ne $self->current_host()) || ($url_type eq "full_abs"))
    {
        return $self->_get_full_abs_url($args);
    }
    elsif ($url_type eq "rel")
    {
        # TODO : convert to a method.
        return _get_relative_url(
            $self->path_info(), $host_url, $self->_no_leading_dot()
        );
    }
    elsif ($url_type eq "site_abs")
    {
        return ($self->_hosts->{$host}->{trailing_url_base} . $host_url);
    }
    else
    {
        die "Unknown url_type \"$url_type\"!\n";
    }
}

sub get_cross_host_rel_url
{
    my $self = shift;

    return $self->get_cross_host_rel_url_ref({@_});
}

sub _get_url_to_item
{
    my $self = shift;
    my $item = shift;

    return $self->get_cross_host_rel_url_ref(
        {
            'host' => $item->_accum_state()->{'host'},
            'host_url' => ($item->_node->url() || ""),
            'url_type' => $item->get_url_type(),
            'url_is_abs' => $item->_node->url_is_abs(),
        }
    );
}

sub _gen_blank_nav_menu_tree_node
{
    my $self = shift;

    return HTML::Widgets::NavMenu::Tree::Node->new();
}

sub _create_predicate
{
    my ($self, $args) = @_;

    return
        HTML::Widgets::NavMenu::Predicate->new(
            'spec' => $args->{'spec'},
        );
}

sub _create_new_nav_menu_item
{
    my ($self, $args) = @_;

    my $sub_contents = $args->{sub_contents};

    my $new_item = $self->_gen_blank_nav_menu_tree_node();

    $new_item->set_values_from_hash_ref($sub_contents);

    if (exists($sub_contents->{'expand'}))
    {
        my $expand_val = 
            $self->_create_predicate(
                {
                    'spec' => $sub_contents->{'expand'},
                }
            )->evaluate(
                'path_info' => $self->path_info(),
                'current_host' => $self->current_host(),
            )
            ;
        if ($expand_val)
        {
            $new_item->expand($expand_val);
        }
    }

    return $new_item;
}

sub _render_tree_contents
{
    my $self = shift;
    my $sub_contents = shift;

    my $path_info = $self->path_info();

    my $new_item =
        $self->_create_new_nav_menu_item(
            { sub_contents => $sub_contents },
        );

    if (exists($sub_contents->{subs}))
    {
        foreach my $sub_contents_sub (@{$sub_contents->{subs}})
        {
            $new_item->add_sub(
                $self->_render_tree_contents(
                    $sub_contents_sub,
                )
            );
        }
    }
    return $new_item;
}

sub gen_site_map
{
    my $self = shift;

    my $iterator = 
        HTML::Widgets::NavMenu::Iterator::SiteMap->new(
            {
               'nav_menu' => $self,
            }
        );

    $iterator->traverse();

    return $iterator->get_results();
}

sub _get_next_coords
{
    my $self = shift;

    my @coords = @{shift || $self->_get_current_coords};

    my @branches = ($self->_get_traversed_tree());

    my @dest_coords;

    my $i;

    for($i=0;$i<scalar(@coords);$i++)
    {
        $branches[$i+1] = $branches[$i]->get_nth_sub($coords[$i]);
    }

    if ($branches[$i]->_num_subs())
    {
        @dest_coords = (@coords,0);
    }
    else
    {
        for($i--;$i>=0;$i--)
        {
            if ($branches[$i]->_num_subs() > ($coords[$i]+1))
            {
                @dest_coords = (@coords[0 .. ($i-1)], $coords[$i]+1);
                last;
            }
        }
        if ($i == -1)
        {
            return undef;
        }
    }

    return \@dest_coords;
}

sub _get_prev_coords
{
    my $self = shift;

    my @coords = @{shift || $self->_get_current_coords()};

    if (scalar(@coords) == 0)
    {
        return undef;
    }
    elsif ($coords[$#coords] > 0)
    {
        # Get the previous leaf
	    my @previous_leaf = 
	        ( 
                @coords[0 .. ($#coords - 1) ] ,
                $coords[$#coords]-1
            );
        # Continue in this leaf to the end.
        my $new_coords = $self->_get_most_advanced_leaf(\@previous_leaf);

        return $new_coords;
    }
    else
    {
        return [ @coords[0 .. ($#coords-1)] ];
    }
}

sub _get_up_coords
{
    my $self = shift;

    my @coords = @{shift || $self->_get_current_coords};

    if (scalar(@coords) == 0)
    {
        return undef;
    }
    else
    {
        if ((@coords == 1) && ($coords[0] > 0))
        {
            return [0];
        }
        pop(@coords);
        return \@coords;
    }
}

sub _get_top_coords
{
    my $self = shift;

    my @coords = @{shift || $self->_get_current_coords()};

    if ((! @coords) || ((@coords == 1) && ($coords[0] == 0)))
    {
        return undef;
    }
    else
    {
        return [0];
    }
}

sub _is_skip
{
    my $self = shift;
    my $coords = shift;

    my $iterator = $self->_get_nav_menu_traverser();

    my $ret = $iterator->find_node_by_coords($coords);

    my $item = $ret->{item};

    return $item->_node()->skip();
}

sub _get_coords_while_skipping_skips
{
    my $self = shift;

    my $callback = shift;
    my $coords = shift(@_);
    if (!$coords)
    {
        $coords = $self->_get_current_coords();
    }

    my $do_once = 1;

    while ($do_once || $self->_is_skip($coords))
    {
        $coords = $callback->($self, $coords);
    }
    continue
    {
        $do_once = 0;
    }

    return $coords;
}

sub _get_most_advanced_leaf
{
    my $self = shift;

    # We accept as a parameter the vector of coordinates
    my $coords_ref = shift;

    my @coords = @{$coords_ref};

    # Get a reference to the contents HDS (= hierarchial data structure)
    my $branch = $self->_get_traversed_tree();

    # Get to the current branch by advancing to the offset 
    foreach my $c (@coords)
    {
        # Advance to the next level which is at index $c
        $branch = $branch->get_nth_sub($c);
    }

    # As long as there is something deeper
    while (my $num_subs = $branch->_num_subs())
    {
        my $index = $num_subs-1;
        # We are going to return it, so store it
        push @coords, $index;
        # Recurse into the sub-branch
        $branch = $branch->get_nth_sub($index);
    }
    
    return \@coords;
}

# The traversed_tree is the tree that is calculated from the tree given
# by the user and some other parameters such as the host and path_info.
# It is passed to the NavMenu::Iterator::* classes as argument.
sub _get_traversed_tree
{
    my $self = shift;

    if (! $self->_traversed_tree())
    {
        my $gen_retval = $self->_gen_traversed_tree();
        $self->_traversed_tree($gen_retval->{'tree'});
        $self->_current_coords($gen_retval->{'current_coords'});
        $self->_leading_path_coords($gen_retval->{'leading_path_coords'});
    }
    return $self->_traversed_tree();
}

sub _gen_traversed_tree
{
    my $self = shift;

    my $tree = 
        $self->_render_tree_contents(
            $self->_tree_contents(),
            );

    my $find_coords_iterator =
        HTML::Widgets::NavMenu::Iterator::GetCurrentlyActive->new(
            {
                'nav_menu' => $self,
                'tree' => $tree,
            }
        );

    $find_coords_iterator->traverse();

    my $current_coords = $find_coords_iterator->get_final_coords() || [];
    my $leading_path_coords = 
        $find_coords_iterator->_get_leading_path_coords() || [];

    # The root should always be expanded because:
    # 1. If one of the leafs was marked as expanded so will its ancestors
    #    and eventually the root.
    # 2. If nothing was marked as expanded, it should still be marked as 
    #    expanded so it will expand.
    $tree->expand();
   
    return 
        {
            'tree' => $tree, 
            'current_coords' => $current_coords, 
            'leading_path_coords' => $leading_path_coords,
        };
}

sub _get_leading_path_of_coords
{
    my $self = shift;
    my $coords = shift;

    if (! @$coords )
    {
        $coords = [ 0 ];
    }

    my @leading_path;
    my $iterator = $self->_get_nav_menu_traverser();

    COORDS_LOOP:
    while (1)
    {
        my $ret = $iterator->find_node_by_coords(
            $coords
        );

        my $item = $ret->{item};

        my $node = $item->_node();
        # This is a workaround for the root link.
        my $host_url = (defined($node->url()) ? ($node->url()) : "");
        my $host = $item->_accum_state()->{'host'};

        my $url_type =
            ($node->url_is_abs() ?
                "full_abs" :
                $item->get_url_type()
            );

        push @leading_path,
            HTML::Widgets::NavMenu::LeadingPath::Component->new(
                {
                    'host' => $host,
                    'host_url' => $host_url,
                    'title' => $node->title(),
                    'label' => $node->text(),
                    'direct_url' => $self->_get_url_to_item($item),
                    'url_type' => $url_type,
                }
            );

        if ((scalar(@$coords) == 1) && ($coords->[0] == 0))
        {
            last COORDS_LOOP;
        }
    }
    continue
    {
        $coords = $self->_get_up_coords($coords);
    }

    return [ reverse(@leading_path) ];
}

sub _get_leading_path
{
    my $self = shift;
    return $self->_get_leading_path_of_coords(
        $self->_leading_path_coords()
    );
}

sub render
{
    my $self = shift;
    my %args = (@_);

    return $self->_render_generic(
        { %args , _iter_method => '_get_nav_menu_traverser',}
    );
}

sub _render_generic
{
    my $self = shift;
    my $args = shift;

    my $method = $args->{_iter_method};

    my $iterator = $self->$method();
    $iterator->traverse();
    my $html = $iterator->get_results();
    
    my %nav_links;
    my %nav_links_obj;

    my %links_proto =
        (
            'prev' => $self->_get_coords_while_skipping_skips(
                        \&_get_prev_coords),
            'next' => $self->_get_coords_while_skipping_skips(
                        \&_get_next_coords),
            'up' => $self->_get_up_coords(),
            'top' => $self->_get_top_coords(),
        );

    while (my ($link_rel, $coords) = each(%links_proto))
    {
        # This is so we would avoid coordinates that point to the 
        # root ($coords == []).
        if (defined($coords) && @$coords == 0)
        {
            undef($coords);
        }
        if (defined($coords))
        {
            my $obj = 
                $self->_get_leading_path_of_coords(
                    $coords
                )->[-1];
            
            $nav_links_obj{$link_rel} = $obj;
            $nav_links{$link_rel} = $obj->direct_url();
        }
    }

    my $js_code = "";
    
    return
        {
            'html' => $html,
            'leading_path' => $self->_get_leading_path(),
            'nav_links' => \%nav_links,
            'nav_links_obj' => \%nav_links_obj,
        };
}

1;

__END__