File Coverage

blib/lib/HTML/Widgets/NavMenu.pm

Criterion	Covered	Total	%
statement	254	257	98.8
branch	75	82	91.4
condition	33	37	89.1
subroutine	40	40	100.0
pod	4	4	100.0
total	406	420	96.6

package HTML::Widgets::NavMenu;
$HTML::Widgets::NavMenu::VERSION = '1.1000';
use strict;
use warnings;

use HTML::Widgets::NavMenu::Error                        ();
use HTML::Widgets::NavMenu::Error::Redirect              ();
use HTML::Widgets::NavMenu::NodeDescription              ();
use HTML::Widgets::NavMenu::LeadingPath::Component       ();
use HTML::Widgets::NavMenu::Iterator::GetCurrentlyActive ();

use parent '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
            coords_stop
            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 );

    $self->coords_stop( $args{coords_stop} || 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;
        }
    }

    return \@dest_coords;
}

sub _get_prev_coords
{
    my $self = shift;

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

    if ( scalar(@coords) == 0 )
    {
        return;
    }
    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;
    }
    else
    {
        if ( ( @coords == 1 ) && ( $coords[0] > 0 ) )
        {
            my $coords_stop = $self->coords_stop();
            my $ret         = [0];
            if ($coords_stop)
            {
                $ret = [];
            }
            return $ret;
        }
        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;
    }
    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;

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

    if ( !$coords_stop )
    {
        if ( !@$coords )
        {
            $coords = [0];
        }
    }
    if (0)    # ( $coords->[0] == 0 )
    {
        $coords = [ @$coords[ 1 .. $#$coords ] ];
    }

    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 (
            $coords_stop
            ? ( scalar(@$coords) == 0 )
            : ( ( scalar(@$coords) == 1 ) && ( $coords->[0] == 0 ) )
            )
        {
            last COORDS_LOOP;
        }
    }
    continue
    {
        $coords = $self->_get_up_coords($coords);
    }

    my $p = [ reverse(@leading_path) ];
    if ($coords_stop)
    {
        while ( ( @$p > 1 and $p->[0]->host_url eq $p->[1]->host_url ) )
        {
            shift @$p;
        }
    }
    return $p;
}

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 _is_top_coords
{
    my ( $self, $coords, $only_empty, ) = @_;

    return (
        defined($coords)
        ? (
              ( @$coords == 0 ) ? 1
            : $only_empty       ? ''
            : ( @$coords == 1 ) ? ( $coords->[0] == 0 )
            :                     ''
            )
        : 1
    );
}

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' => scalar(
            $self->_get_coords_while_skipping_skips( \&_get_prev_coords )
        ),
        'next' => scalar(
            $self->_get_coords_while_skipping_skips( \&_get_next_coords )
        ),
        'up'  => scalar( $self->_get_up_coords() ),
        'top' => scalar( $self->_get_top_coords() ),
    );
    my $IS_TOP =
        $self->_is_top_coords( $self->_current_coords(), $self->coords_stop(),
        );

    while ( my ( $link_rel, $coords ) = each(%links_proto) )
    {
        # This is so we would avoid coordinates that point to the
        # root ($coords == []).
        if ( $IS_TOP
            and ( $link_rel =~ /\A(?:prev|top|up)\z/ms )
            )    # $self->_is_top_coords( $coords, 1 ) )
        {
            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__