HTML-Menu-Hierarchical-0.13/ 0000755 0000764 0000764 00000000000 10324035710 015044 5 ustar don don 0000000 0000000 HTML-Menu-Hierarchical-0.13/META.yml 0000644 0000764 0000764 00000000510 10324035710 016311 0 ustar don don 0000000 0000000 # http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: HTML-Menu-Hierarchical
version: 0.13
version_from: lib/HTML/Menu/Hierarchical.pm
installdirs: site
requires:
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.17
HTML-Menu-Hierarchical-0.13/t/ 0000755 0000764 0000764 00000000000 10324035710 015307 5 ustar don don 0000000 0000000 HTML-Menu-Hierarchical-0.13/t/00use.t 0000755 0000764 0000764 00000000572 07631416301 016445 0 ustar don don 0000000 0000000 #!/usr/bin/env perl -w
# Creation date: 2003-03-05 07:42:25
# Authors: Don
# Change log:
# $Id: 00use.t,v 1.1 2003/03/05 15:50:25 don Exp $
use strict;
# main
{
use strict;
use Test;
BEGIN { plan tests => 1 }
use HTML::Menu::Hierarchical; ok(1);
}
exit 0;
###############################################################################
# Subroutines
HTML-Menu-Hierarchical-0.13/examples/ 0000755 0000764 0000764 00000000000 10324035710 016662 5 ustar don don 0000000 0000000 HTML-Menu-Hierarchical-0.13/examples/simple.cgi 0000755 0000764 0000764 00000005751 07630573464 020675 0 ustar don don 0000000 0000000 #!/usr/bin/perl
# Creation date: 2003-02-25 23:10:40
# Authors: Don
# Change log:
# $Id: simple.cgi,v 1.3 2003/03/03 06:33:24 don Exp $
use strict;
use CGI;
use Carp;
# main
{
local($SIG{__DIE__}) = sub { local(*STDERR) = *STDOUT;
print "Content-Type: text/plain\n\n";
&Carp::cluck(); exit 0 };
use HTML::Menu::Hierarchical;
my $cgi = CGI->new;
my $fields = $cgi->Vars;
my $conf = &get_conf();
my $menu_obj = HTML::Menu::Hierarchical->new($conf, \&menu_callback);
# pass in the m_i CGI parameter to tell us which menu item is selected
my $menu = $menu_obj->generateMenu($$fields{m_i});
my $html;
print "Content-Type: text/html\n\n";
$html .= qq{\n};
$html .= $menu;
$html .= qq{
\n};
print $html;
}
exit 0;
###############################################################################
# Subroutines
sub get_conf {
my $script = $ENV{SCRIPT_NAME}; # self referring url
my $conf = [
{ name => 'top_button_1',
info => { text => 'Top Level Button 1',
url => $script
},
children => [
{ name => 'button_1_level_2',
info => { text => "Child 1 of Button 1",
url => $script
},
children => [
{ name => 'button_1_level_2_child1',
info => { text => "Child 1 of level 2 button 1",
url => $script
},
}
],
},
]
},
{ name => 'top_button_2',
info => { text => 'Top Level Button 2',
url => $script
}
},
];
return $conf;
}
sub menu_callback {
my ($info_obj) = @_;
my $info_hash = $info_obj->getInfo;
my $level = $info_obj->getLevel;
my $text = $$info_hash{text};
$text = ' ' if $text eq '';
my $item_arg = $info_obj->getName;
# Add a cgi parameter m_i to url so we know which menu
# item was chosen
my $url = $info_obj->addArgsToUrl($$info_hash{url},
{ m_i => $item_arg });
my $dpy_text = $info_obj->isSelected ? "<$text>" : $text;
my $spacer = ' ' x $level;
my $str = qq{\n};
$str .= qq{| };
$str .= $spacer . $dpy_text;
$str .= qq{ | };
$str .= qq{
\n};
return $str;
}
HTML-Menu-Hierarchical-0.13/examples/color.cgi 0000755 0000764 0000764 00000011626 07630570225 020510 0 ustar don don 0000000 0000000 #!/usr/bin/perl
# Creation date: 2003-02-25 23:10:40
# Authors: Don
# Change log:
# $Id: color.cgi,v 1.1 2003/03/03 06:05:09 don Exp $
use strict;
use CGI;
use Carp;
# main
{
local($SIG{__DIE__}) = sub { local(*STDERR) = *STDOUT;
print "Content-Type: text/plain\n\n";
&Carp::cluck(); exit 0 };
use HTML::Menu::Hierarchical;
my $cgi = CGI->new;
my $fields = $cgi->Vars;
my $conf = &get_conf();
my $menu_obj = HTML::Menu::Hierarchical->new($conf, \&menu_callback);
# pass in the m_i CGI parameter to tell us which menu item is selected
my $menu = $menu_obj->generateMenu($$fields{m_i});
my $html;
print "Content-Type: text/html\n\n";
$html .= qq{\n};
$html .= $menu;
$html .= qq{
\n};
print $html;
}
exit 0;
###############################################################################
# Subroutines
sub get_conf {
my $script = $ENV{SCRIPT_NAME}; # self referring url
my $conf = [
{ name => 'top_button_1',
info => { text => 'Top Level Button 1',
url => $script
},
children => [
{ name => 'button_1_level_2',
info => { text => "Child 1 of Button 1",
url => $script
},
children => [
{ name => 'button_1_level_2_child1',
info => { text => "Child 1 of level 2 button 1",
url => $script
},
}
],
},
]
},
{ name => 'top_button_2',
info => { text => 'Top Level Button 2',
url => $script
}
},
];
return $conf;
}
sub menu_callback {
my ($info_obj) = @_;
my $info_hash = $info_obj->getInfo;
my $level = $info_obj->getLevel;
my $text = $$info_hash{text};
$text = ' ' if $text eq '';
my $url = $$info_hash{url};
my $item_arg = $info_obj->getName;
# Add a cgi parameter m_i to url so we know which menu item was chosen
$url = $info_obj->addArgsToUrl($url, { m_i => $item_arg });
my $str;
my $top_bg_color = "#8888aa";
my $selected_bg_color = "#e2e2e2";
my $child_bg_color = "#a2a2a2";
my $peer_child_bg_color = "#b2b2b2";
my $bg_color = $top_bg_color;
my $next_is_selected;
my $next_obj = $info_obj->getNextItem;
if ($next_obj) {
$next_is_selected = $next_obj->isSelected;
}
my $global_style = qq{text-decoration: none; font-family: Arial, Helvetica, sans-serif;};
$global_style .= qq{ font-size: 12pt; font-weight: normal};
my $style = qq{style="color: #ffffff; $global_style"};
my $top_bottom_color = "#666699";
if ($level == 0) {
my $top = qq{\n};
$top .= qq{| };
$top .= qq{$text | };
$top .= qq{
\n};
$str .= $top;
return $str;
}
my $max_dpy_level = $info_obj->getMaxDisplayedLevel;
my $bg_color;
my $selected_item = $info_obj->getSelectedItem();
if ($level == 1) {
$bg_color = $top_bg_color;
$style = qq{style="color: #ffffff; $global_style"};
} elsif ($max_dpy_level > 2) {
if ($level == $info_obj->getSelectedLevel + 1) {
$bg_color = $peer_child_bg_color;
$style = qq{style="color: #000000; $global_style"};
} elsif ($level == $info_obj->getSelectedLevel and not $selected_item->hasChildren) {
$bg_color = $peer_child_bg_color;
$style = qq{style="color: #000000; $global_style"};
} elsif ($max_dpy_level - $level >= 2) {
$bg_color = $top_bg_color;
$style = qq{style="color: #ffffff; $global_style"};
} else {
$bg_color = $child_bg_color;
$style = qq{style="color: #ffffff; $global_style"};
}
} elsif ($level == 2) {
$bg_color = $child_bg_color;
$style = qq{style="color: #ffffff; $global_style"};
}
if ($info_obj->isSelected) {
$bg_color = $selected_bg_color;
$style = qq{style="color: #000000; $global_style"};
}
$str .= qq{\n};
$str .= qq{| };
$str .= qq{$text | };
$str .= qq{
\n};
return $str;
}
HTML-Menu-Hierarchical-0.13/MANIFEST 0000644 0000764 0000764 00000000414 10324035435 016200 0 ustar don don 0000000 0000000 MANIFEST
README
INSTALL
Makefile.PL
lib/HTML/Menu/Hierarchical.pm
lib/HTML/Menu/Hierarchical/Item.pm
lib/HTML/Menu/Hierarchical/ItemInfo.pm
examples/simple.cgi
examples/color.cgi
t/00use.t
META.yml Module meta-data (added by MakeMaker)
HTML-Menu-Hierarchical-0.13/lib/ 0000755 0000764 0000764 00000000000 10324035710 015612 5 ustar don don 0000000 0000000 HTML-Menu-Hierarchical-0.13/lib/HTML/ 0000755 0000764 0000764 00000000000 10324035710 016356 5 ustar don don 0000000 0000000 HTML-Menu-Hierarchical-0.13/lib/HTML/Menu/ 0000755 0000764 0000764 00000000000 10324035710 017262 5 ustar don don 0000000 0000000 HTML-Menu-Hierarchical-0.13/lib/HTML/Menu/Hierarchical/ 0000755 0000764 0000764 00000000000 10324035710 021640 5 ustar don don 0000000 0000000 HTML-Menu-Hierarchical-0.13/lib/HTML/Menu/Hierarchical/Item.pm 0000644 0000764 0000764 00000005432 10254312244 023102 0 ustar don don 0000000 0000000 # -*-perl-*-
# Creation date: 2003-01-05 20:47:52
# Authors: Don
# Change log:
# $Id: Item.pm,v 1.6 2005/06/16 15:03:00 don Exp $
#
# Copyright (c) Don Owens
#
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
use strict;
use Carp;
{ package HTML::Menu::Hierarchical::Item;
use vars qw($VERSION);
$VERSION = do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
sub new {
my ($proto, $name, $info, $children, $item_hash) = @_;
my $self = bless {}, ref($proto) || $proto;
$self->setName($name);
$self->setInfo($info);
$self->setChildren($children);
my $other_fields = {};
while (my ($field, $value) = each %$item_hash) {
if ($field eq 'name' or $field eq 'info' or $field eq 'children') {
next;
}
$$other_fields{$field} = $value;
}
$self->setOtherFields($other_fields);
return $self;
}
sub hasChildren {
my ($self) = @_;
my $children = $self->getChildren;
if ($children and @$children) {
return 1;
}
return undef;
}
#####################
# getters and setters
sub getName {
my ($self) = @_;
return $$self{_name};
}
sub setName {
my ($self, $name) = @_;
$$self{_name} = $name;
}
sub getInfo {
my ($self) = @_;
return $$self{_info};
}
sub setInfo {
my ($self, $info) = @_;
$$self{_info} = $info;
}
sub getChildren {
my ($self) = @_;
return $$self{_children};
}
sub setChildren {
my ($self, $children) = @_;
$$self{_children} = $children;
}
sub addChild {
my $self = shift;
my $child = shift;
return undef unless $child;
my $children = $self->{_children};
unless ($children and UNIVERSAL::isa($children, 'ARRAY')) {
$children = [];
$self->{_children} = $children;
}
if (UNIVERSAL::isa($child, 'HASH')) {
push @$children, $child;
} elsif (UNIVERSAL::isa($child, 'ARRAY')) {
push @$children, @$child;
}
return 1;
}
sub getOtherFields {
my ($self) = @_;
return $$self{_other_fields};
}
sub setOtherFields {
my ($self, $hash) = @_;
$$self{_other_fields} = $hash;
}
sub getOtherField {
my ($self, $field) = @_;
my $fields = $self->getOtherFields;
return $$fields{$field};
}
}
1;
__END__
=head1 NAME
=head1 SYNOPSIS
=head1 EXAMPLES
=head1 Version
$Id: Item.pm,v 1.6 2005/06/16 15:03:00 don Exp $
=cut
HTML-Menu-Hierarchical-0.13/lib/HTML/Menu/Hierarchical/ItemInfo.pm 0000644 0000764 0000764 00000044617 10254312244 023726 0 ustar don don 0000000 0000000 # -*-perl-*-
# Creation date: 2003-01-05 21:34:34
# Authors: Don
# Change log:
# $Id: ItemInfo.pm,v 1.30 2005/06/16 15:03:00 don Exp $
#
# Copyright (c) 2003 Don Owens
#
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
#
# The underscore separated versions of the methods added for
# version v0_03 by request.
=pod
=head1 NAME
HTML::Menu::Hierarchical::ItemInfo - Used by HTML::Menu::Hierarchical.
Provides information about the menu item being processed.
=head1 SYNOPSIS
Created by HTML::Menu::Hierarchical objects.
=head1 DESCRIPTION
Information holder/gatherer representing one menu item.
=head1 METHODS
=head2 Getting back information
=cut
use strict;
use Carp;
{ package HTML::Menu::Hierarchical::ItemInfo;
use vars qw($VERSION $AUTOLOAD);
$VERSION = do { my @r=(q$Revision: 1.30 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
sub new {
my ($proto, $item, $selected_path, $key, $parent, $params) = @_;
my $self = bless {}, ref($proto) || $proto;
$self->setItem($item);
$self->_setSelectedPath($selected_path);
$self->setKey($key);
$self->setParent($parent);
$self->_setParams($params);
return $self;
}
=pod
=head2 hasChildren()
Returns true if the current item has child items in the
configuration. False otherwise.
=cut
sub hasChildren {
my ($self) = @_;
return $self->getItem()->hasChildren;
}
*has_children = \&hasChildren;
=pod
=head2 isSelected()
Returns true if the current item is the selected one.
=cut
sub isSelected {
my ($self) = @_;
my $key = $self->getKey;
if ($self->getItem()->getName eq $self->getKey) {
return 1;
}
return undef;
}
*is_selected = \&isSelected;
=pod
=head2 isInSelectedPath()
Returns true if the current item is in the path from the root of
the hierarchy to the selected item.
=cut
sub isInSelectedPath {
my ($self) = @_;
my $selected_path = $self->_getSelectedPath;
my $my_item = $self->getItem;
foreach my $item (@$selected_path) {
return 1 if $item == $my_item;
}
return undef;
}
*is_in_selected_path = \&isInSelectedPath;
=pod
=head2 getSelectedItem()
Returns the ItemInfo object corresponding to the selected menu
item.
=cut
sub getSelectedItem {
my ($self) = @_;
my $selected_path = $self->_getSelectedPath;
my $last_index = $#$selected_path;
return undef if $last_index < 0;
return $self->new($$selected_path[$last_index], $selected_path, $self->getKey);
}
*get_selected_item = \&getSelectedItem;
*getSelectedItemInfo = \&getSelectedItem;
*get_selected_item_info = \&getSelectedItem;
=pod
=head2 getSelectedLevel()
Returns the level in the hierarchy where the selected menu item
is located. Levels start at zero.
=cut
sub getSelectedLevel {
my ($self) = @_;
my $selected_path = $self->_getSelectedPath;
return $#$selected_path;
}
*get_selected_level = \&getSelectedLevel;
=pod
=head2 getMaxDisplayedLevel()
Returns the maximum level in the hierarchy to currently be
displayed.
=cut
sub getMaxDisplayedLevel {
my ($self) = @_;
my $selected_path = $self->_getSelectedPath;
my $max_level = $#$selected_path;
return $max_level if $max_level < 0;
if ($$selected_path[$max_level]->hasChildren) {
$max_level++;
}
return $max_level;
}
*get_max_displayed_level = \&getMaxDisplayedLevel;
sub getStandardCallbackParams {
my ($self) = @_;
my $params = $self->_getParam('std_callback_params');
unless (ref($params) eq 'HASH') {
$params = {};
}
return $params;
}
sub _checkOpenAllFields {
my ($self) = @_;
if (exists($$self{_is_open_all})) {
return $$self{_is_open_all};
}
my ($is_set, $val) = $self->_checkOpenField('open_all', '_is_open_all');
if ($is_set) {
return ($is_set, $val);
}
my $parent = $self;
while ($parent = $parent->getParent) {
my ($is_set, $val) = $parent->_checkOpenField('open_all', '_is_open_all');
if ($is_set) {
$$self{_is_open_all} = $val;
return ($is_set, $val);
}
}
$$self{_is_open_all} = undef;
return (undef, undef);
}
sub _checkOpenField {
my ($self, $field, $attr) = @_;
unless (defined($field)) {
$field = 'open';
$attr = '_is_open';
}
if (my $open = $self->getOtherField($field)) {
# simple case first
unless (ref($open)) {
$$self{$attr} = 1;
return (1, 1);
}
# now allow for a subroutine reference
if (ref($open) eq 'CODE') {
my $rv = &$open();
$$self{$attr} = $rv;
return (1, $rv);
} elsif (ref($open) eq 'ARRAY') {
my ($obj, $func, @args) = @$open;
my $rv;
if (defined($obj)) {
$rv = $obj->$func(@args);
} else {
$rv = &$func(@args);
}
$$self{$attr} = $rv;
return (1, $rv);
}
} # end 'open' field check
return (undef, undef);
}
=pod
=head2 isOpen()
Returns true if the current menu item is open, i.e., the current
item has child items and is also in the open path. Return false
otherwise.
=cut
sub isOpen {
my ($self) = @_;
if (exists($$self{_is_open})) {
return $$self{_is_open};
}
return 1 if $self->_hasSetOpenAll;
my ($is_set, $val) = $self->_checkOpenField;
return $val if $is_set;
($is_set, $val) = $self->_checkOpenAllFields;
return $val if $is_set;
my $this_item = $self->getItem;
unless ($this_item->hasChildren) {
$$self{_is_open} = undef;
return undef;
}
my $selected_path = $self->_getSelectedPath;
my $name = $this_item->getName;
foreach my $item (@$selected_path) {
if ($item->getName eq $name) {
# print $item->getName . " eq $name\n";
$$self{_is_open} = 1;
return 1;
}
}
$$self{_is_open} = undef;
return undef;
}
*is_open = \&isOpen;
=pod
=head2 isFirstDisplayed()
Returns true if the current menu item is the first one to be
displayed.
=cut
# added for v0_02
sub isFirstDisplayed {
my ($self) = @_;
my $item = $self->getPreviousItem;
if ($item) {
return undef;
} else {
return 1;
}
}
*is_first_displayed = \&isFirstDisplayed;
=pod
=head2 isLastDisplayed()
Returns true if the current menu item is the last to be
displayed.
=cut
# added for v0_02
sub isLastDisplayed {
my ($self) = @_;
my $item = $self->getNextItem;
if ($item) {
return undef;
} else {
return 1;
}
}
*is_last_displayed = \&isLastDisplayed;
=pod
=head2 isFirstSiblingDisplayed()
Returns true if the current menu item is the first of its
siblings to be displayed, false otherwise.
=cut
sub isFirstSiblingDisplayed {
my ($info_obj) = @_;
my $self = $info_obj;
my $my_level = $self->getLevel;
my $item = $self;
while (1) {
$item = $self->getPreviousItem;
return 1 unless $item;
my $level = $item->getLevel;
return undef if $level > $my_level;
return undef if $level == $my_level;
return 1 if $level < $my_level;
}
return undef;
}
*is_first_sibling_displayed = \&isFirstSiblingDisplayed;
=head2 isLastSiblingDisplayed()
Returns true if the current menu item is the last of its
siblings to be displayed, false otherwise.
=cut
sub isLastSiblingDisplayed {
my ($self) = @_;
my $my_level = $self->getLevel;
my $item = $self;
while (1) {
$item = $item->getNextItem;
return 1 unless $item;
my $level = $item->getLevel;
return 1 if $level < $my_level;
return undef if $level == $my_level;
}
return undef;
}
*is_last_sibling_displayed = \&isLastSiblingDisplayed;
=pod
=head2 getInfo()
Returns the value of the 'info' field for the current menu item
in the navigation configuration.
Instead of getting the 'info' hash and then accessing a field
within it, you may call a method to get that field directly.
This is implemented with AUTOLOAD, so if you do something like
my $text = $info_obj->getText;
my $image_src = $info_obj->getImageSrc;
or
my $text = $info_obj->getText;
my $image_src = $info_obj->get_image_src;
you will be given back the corresponding values in the 'info'
hash.
=cut
sub getInfo {
my ($self) = @_;
return $self->getItem()->getInfo;
}
*get_info = \&getInfo;
sub _getOtherFields {
my ($self) = @_;
return $self->getItem()->getOtherFields;
}
# get field from configuration that is at the same level as
# the name and children fields
sub getOtherField {
my ($self, $field) = @_;
my $fields = $self->_getOtherFields;
return $$fields{$field};
}
=pod
=head2 getName()
Returns the 'name' field for the current menu item in the
navigation configuration. This is used to determine which menu
item has been selected.
=cut
sub getName {
my ($self) = @_;
return $self->getItem()->getName;
}
*get_name = \&getName;
#####################
# getters and setters
=pod
=head2 getNextItem()
Returns the ItemInfo object corresponding to the next displayed
menu item.
=cut
sub getNextItem {
my ($self) = @_;
return $$self{_next_item};
}
*get_next_item = \&getNextItem;
sub setNextItem {
my ($self, $item) = @_;
$$self{_next_item} = $item;
}
=pod
=head2 getPreviousItem()
Returns the ItemInfo object corrsponding to the previously
displayed menu item.
=cut
sub getPreviousItem {
my ($self) = @_;
return $$self{_previous_item};
}
*get_previous_item = \&getPreviousItem;
sub setPreviousItem {
my ($self, $item) = @_;
$$self{_previous_item} = $item;
}
sub getKey {
my ($self) = @_;
return $$self{_key};
}
sub setKey {
my ($self, $key) = @_;
$$self{_key} = $key;
}
=pod
=head2 getLevel()
Returns the level in the menu hierarchy where the current menu
item is located. Levels start at zero.
=cut
sub getLevel {
my ($self) = @_;
return $$self{_level};
}
*get_level = \&getLevel;
sub setLevel {
my ($self, $level) = @_;
$$self{_level} = $level;
}
sub _getSelectedPath {
my ($self) = @_;
return $$self{_selected_path};
}
sub _setSelectedPath {
my ($self, $path) = @_;
$$self{_selected_path} = $path;
}
sub getItem {
my ($self) = @_;
return $$self{_item};
}
sub setItem {
my ($self, $item) = @_;
$$self{_item} = $item;
}
=pod
=head2 getParent()
Returns the info object for the current item's parent.
=cut
sub getParent {
my ($self) = @_;
return $$self{_parent};
}
sub setParent {
my ($self, $parent) = @_;
$$self{_parent} = $parent;
}
# added for v0_07
sub _getParams {
my ($self) = @_;
return $$self{_params} || {};
}
# added for v0_07
sub _setParams {
my ($self, $params) = @_;
$$self{_params} = $params;
}
# added for v0_08
sub _getParam {
my ($self, $param) = @_;
my $params = $self->_getParams;
return $$params{$param};
}
# added for v0_07
sub _getTopMenuObj {
my ($self) = @_;
my $params = $self->_getParams;
my $obj = $$params{top_menu_obj};
return $obj;
}
# added for v0_07
sub _hasSetOpenAll {
my ($self) = @_;
my $top_menu_obj = $self->_getTopMenuObj;
return undef unless $top_menu_obj;
return $top_menu_obj->hasParamSetOpenAll;
}
###########
# utilities
=pod
=head2 Utilities
=head2 my $encoded = $info->urlEncode($plain_text)
URL encodes the given string. This does full url-encoding, so a
space is %20, not a '+'.
=cut
sub urlEncode {
my ($self, $str) = @_;
$str =~ s|([^A-Za-z0-9_])|sprintf("%%%02x", ord($1))|eg;
return $str;
}
*url_encode = \&urlEncode;
=pod
=head2 my $query = $info->urlEncodeVars($var_hash)
Takes a hash containing key/value pairs and returns a
url-encoded query string appropriate for adding to the end of a
url. If a value is an array, it is assumed to be a multivalued
input field and is added to the query string as such.
If you want to encode the query stirng in the new style
recommended by the W3C (use a semicolon as a separator in place
of ampersand), pass a true value for the new_style_url parameter
when creating the HTML::Menu::Hierarchical object. This will
become the default in a later release.
=cut
sub urlEncodeVars {
my ($self, $hash) = @_;
my $string;
my $var;
my $vars = [ keys %$hash ];
my @pairs;
foreach $var (@$vars) {
my $value = $$hash{$var};
if (ref($value) eq 'ARRAY') {
my $name = $self->urlEncode($var);
foreach my $val (@$value) {
push(@pairs, $name . "=" . $self->urlEncode($val));
}
} else {
push(@pairs, $self->urlEncode($var) . "=" . $self->urlEncode($$hash{$var}));
}
}
return join($self->_getUrlSeparator, @pairs);
}
*url_encode_vars = \&urlEncodeVars;
=pod
=head2 my $plain_text = $info->urlDecode($url_enc_str)
Decodes the given url-encoded string.
=cut
sub urlDecode {
my ($self, $str) = @_;
$str =~ tr/+/ /;
$str =~ s|%([A-Fa-f0-9]{2})|chr(hex($1))|eg;
return $str;
}
*url_decode = \&urlDecode;
=pod
=head2 my $var_hash = $info->urlDecodeVars($url_enc_str)
Decodes the url-encoded query string and returns a hash contain
key/value pairs from the query string. If a field appears more
than once in the query string, it's value will be returned as a
reference to an array of values.
=cut
sub urlDecodeVars {
my ($self, $query_string) = @_;
my $pair;
my $vars = {};
foreach $pair (split /[;&]/, $query_string) {
my ($name, $field) = map { $self->urlDecode($_) } split(/=/, $pair, 2);
if (exists($$vars{$name})) {
my $val = $$vars{$name};
unless (ref($val) eq 'ARRAY') {
$val = [ $val ];
$$vars{$name} = $val;
}
push @$val, $field;
} else {
$$vars{$name} = $field;
}
}
return wantarray ? %$vars : $vars;
}
*url_decode_vars = \&urlDecodeVars;
sub _getUrlSeparator {
my ($self) = @_;
if ($self->_getParam('old_style_url')) {
return '&';
} elsif ($self->_getParam('new_style_url')) {
return ';';
} else {
return '&';
}
}
=pod
=head2 my $modified_url = $info->addArgsToUrl($url, $var_hash)
Takes the key/value pairs in $var_hash and tacks them onto the
end of $url as a query string.
=cut
sub addArgsToUrl {
my ($self, $url, $args) = @_;
if ($url =~ /\?/) {
$url .= $self->_getUrlSeparator unless $url =~ /\?$/;
} else {
$url .= '?';
}
my $arg_str;
if (ref($args) eq 'HASH') {
$arg_str = $self->urlEncodeVars($args);
} else {
$arg_str = $args;
}
$url .= $arg_str;
return $url;
}
*add_args_to_url = \&addArgsToUrl;
=pod
=head2 my $html = $info->escapeHtml($text)
Escapes the given text so that it is not interpreted as HTML.
=cut
sub escapeHtml {
my ($self, $text) = @_;
$text =~ s/\&/\&/g;
$text =~ s//\>/g;
$text =~ s/\"/\"/g;
$text =~ s/\$/\&dol;/g;
return $text;
}
*escape_html = \&escapeHtml;
=pod
=head2 my $text = $info->unescapeHtml($html)
Unescape the escaped text.
=cut
sub unescapeHtml {
my ($self, $text) = @_;
$text =~ s/\&/\&/g;
$text =~ s/\<//g;
$text =~ s/\"/\"/g;
$text =~ s/\&dol;/\$/g;
return $text;
}
*unescape_html = \&unescapeHtml;
sub AUTOLOAD {
my $self = shift;
my $method = $AUTOLOAD;
$method =~ s/^.*::([^:]+)$/$1/;
if ($method =~ /^get(.+)$/) {
my $str = $1;
if ($str =~ /_/) {
$str =~ s/^_//;
return $self->getInfo()->{$str};
} elsif ($str =~ /^[A-Z]/) {
$str = lcfirst($str);
$str =~ s/([A-Z])/_\L$1/g;
my $info = $self->getInfo;
return $info->{$str} if $info;
return undef;
} else {
return "invalid name";
}
}
return "undefined method $method";
}
}
1;
__END__
=pod
=head2 There are also underscore_separated versions of these methods.
E.g., unescapeHtml($html) becomes unescape_html($html)
=head1 TODO
hasChildrenDisplayed() - tell whether or not the current item's
children will be displayed
=head1 BUGS
Please send bug reports/feature requests to don@owensnet.com.
=head1 AUTHOR
Don Owens
=head1 COPYRIGHT
Copyright (c) 2003 Don Owens
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl
itself.
=head1 VERSION
$Id: ItemInfo.pm,v 1.30 2005/06/16 15:03:00 don Exp $
=cut
HTML-Menu-Hierarchical-0.13/lib/HTML/Menu/Hierarchical.pm 0000644 0000764 0000764 00000064033 10254315467 022220 0 ustar don don 0000000 0000000 # -*-perl-*-
# Creation date: 2003-01-05 20:35:53
# Authors: Don
# Change log:
# $Id: Hierarchical.pm,v 1.45 2005/06/16 15:31:03 don Exp $
#
# Copyright (c) 2003 Don Owens
#
# All rights reserved. This program is free software; you can
# redistribute it and/or modify it under the same terms as Perl
# itself.
=pod
=head1 NAME
HTML::Menu::Hierarchical - HTML Hierarchical Menu Generator
=head1 SYNOPSIS
my $menu_obj =
HTML::Menu::Hierarchical->new($conf, \&callback, $params);
my $html = $menu_obj->generateMenu($menu_item);
or
my $menu_obj =
HTML::Menu::Hierarchical->new($conf, [ $obj, $method ]);
my $html = $menu_obj->generateMenu($menu_item);
or
my $menu_obj =
HTML::Menu::Hierarchical->new($conf, $std_callback_name);
my $html = $menu_obj->generateMenu($menu_item);
In the first case, the callback is a function. In the second,
the callback is a method called on the given object. In the
third example, the callback is the name of a standard callback
defined by HTML::Menu::Hierarchical itself (see the section on
callback functions/methods).
The $conf parameter is a navigation configuration data structure
(described below).
The $params parameter is an optional hash reference containing
parameters pertaining to the menu as a whole. Recognized
parameters are:
=over 4
=item first_with_url
If this is set to a true value and you are using the 'url'
field in the info hash (see below) in the configuration to
specify the url for the menu item, then if a menu item is
chosen that does not have a url configured, the url for that
menu item will be changed to the url of the first child menu
item that has a url configured. This works by looking at the
items first child, then at that child's first child, and so
on. It does not look at the second child.
=item open_all
This has the same effect as the open_all parameter in the
menu configuration structure mentioned below, except that it
affects the entire menu hierarchy.
=item old_style_url
When using the utilities urlEncodeVars() and addArgsToUrl(),
this parameter controls which separator is used to separate
key/value pairs in the generated query string. Setting
old_style_url to a true value will cause an ampersand ('&')
to be used as the separator.
=item new_style_url
When using the utilities urlEncodeVars() and addArgsToUrl(),
this parameter controls which separator is used to separate
key/value pairs in the generated query string. Setting
new_style_url to a true value will cause a semicolon (';') to
be used as the separator, as recommended by the W3C. This
will become the default in a later release.
=back
=head1 DESCRIPTION
HTML::Menu::Hierarchical provides a way to easily generate a
hierarchical HTML menu without forcing a specific layout.
All output is provided by your own callbacks (subroutine
refs) and your own navigation configuration.
=head2 configuration data structure
A navigation configuration is a reference to an array whose
elements are hashrefs. Each hash contains configuration
information for one menu item and its children, if any.
Consider the following example:
my $conf = [
{ name => 'top_button_1',
info => { text => 'Top Level Button 1',
url => '/'
},
open => 1, # force this item's children to be displayed
children => [
{ name => 'button_1_level_2',
info => { text => "Child 1 of Button 1",
url => '/child1.cgi'
},
},
]
},
{ name => 'top_button_2',
info => { text => 'Top Level Button 2',
url => '/top2.cgi'
},
callback => [ $obj, 'my_callback' ]
},
];
In each hash, the 'name' parameter should correspond to the
$menu_item parameter passed to the generateMenu() method. This
is how the module computes which menu item is selected. This is
generally passed via a CGI parameter, which can be tacked onto
the end of the url in your callback function. Note that this
parameter must be unique among all the array entries.
Otherwise, the module will not be able to decide which menu item
is selected.
The value of the 'info' parameter is available to your callback
function via the getInfo() method called on the
HTML::Menu::Hierarchical::ItemInfo object passed to the callback
function. In the above example, the 'info' parameter contains
text to be displayed as the menu item, and a url the user is
sent to when clicking on the menu item.
The 'children' parameter is a reference to another array
containing configuration information for child menu items. This
is where the Hierarchical part comes in. There is no limit to
depth of the hierarchy (until you run out of RAM, anyway).
If a 'callback' parameter is specified that callback will be
used for that menu item instead of the global callback passed to
new().
An 'open' parameter can be specified to force an item's children
to be displayed. This can be a scalar value that indicates true
or false. Or it can be a subroutine reference that returns a
true or false value. It can also be an array, in which case the
first element is expected to be an object, the second element
the name of a method to call on that object, and the rest of the
elements will be passed as arguments to the method. If an
'open_all' parameter is passed, the current item and all items
under it in the hierarchy will be forced open.
=head2 callback functions/methods
Callback functions are passed a single parameter: an
HTML::Menu::Hierarchical::ItemInfo object. See the
documentation on this object for available methods. The
callback function should return the HTML necessary for the
corresponding menu item.
=cut
use strict;
use Carp;
{ package HTML::Menu::Hierarchical;
use vars qw($VERSION);
BEGIN {
$VERSION = '0.13'; # update below in POD as well
}
use HTML::Menu::Hierarchical::Item;
use HTML::Menu::Hierarchical::ItemInfo;
=pod
=head1 METHODS
=head2 new()
my $menu_obj = HTML::Menu::Hierarchical->new($conf, \&callback);
=cut
sub new {
my ($proto, $menu_config, $iterator_sub, $params) = @_;
my $self = bless { _open_list => {} }, ref($proto) || $proto;
$self->setConfig($self->_convertConfig($menu_config));
$self->setIterator($iterator_sub);
$self->_setParams($params);
return $self;
}
# for version v0_09
sub _getOpenList {
my ($self, $key) = @_;
my $list = $$self{_open_list}{$key};
return $list if $list;
$list = $self->generateOpenList($key);
$list = [] unless $list;
$$self{_open_list}{$key} = $list;
return $list;
}
=pod
=head2 generateMenu($menu_item)
my $html = $menu_obj->generateMenu($menu_item);
$menu_item is the 'name' parameter of the selected item,
typically passed as a CGI parameter.
=cut
sub generateMenu {
my ($self, $key) = @_;
my $str;
my $items = $self->generateOpenList($key);
foreach my $item (@$items) {
$str .= $self->_generateMenuSection($item);
}
$self->_cleanUpOpenlist($items);
return $str;
}
*generate_menu = \&generateMenu;
=pod
=head2 addChildConf($conf, $menu_item_name)
Adds another configuration tree into the current configuration
at the specified node (name of the menu item).
=cut
# added for v0_02
sub addChildConf {
my ($self, $conf, $menu_item) = @_;
return undef unless $conf;
my $selected_item = $self->getSelectedItem($menu_item);
return undef unless $selected_item;
my $converted_conf = $self->_convertConfig($conf);
$selected_item->setChildren($converted_conf);
return 1;
}
*add_child_conf = \&addChildConf;
=pod
=head2 addChildConfToChildren($conf, $menu_item_name)
Like addChildConf(), except add this conf to the list of
children of the parent with name $menu_item_name. If $conf is
an array, each element of the array will be added to the list of
children.
=cut
sub addChildConfToChildren {
my ($self, $conf, $menu_item) = @_;
return undef unless $conf;
my $selected_item = $self->getSelectedItem($menu_item);
return undef unless $selected_item;
my $converted_conf;
if (UNIVERSAL::isa($conf, 'ARRAY')) {
$converted_conf = $self->_convertConfig($conf);
} else {
$converted_conf = $self->_convertConfig([ $conf ]);
}
$selected_item->addChild($converted_conf);
return 1;
}
*add_child_conf_to_children = \&addChildConfToChildren;
# =pod
# =head2 getSelectedItem($menu_item)
# Returns the Item object corresponding to the selected menu
# item.
# =cut
sub getSelectedItem {
my ($self, $key) = @_;
my $path = $self->findSelectedPath($self->getConfig, $key);
return undef unless $path;
return pop(@$path);
}
# sub getSelectedItem {
# my ($self, $key) = @_;
# my $open_list = $self->_getOpenList($key);
# if (@$open_list) {
# return $$open_list[0]->getSelectedItem();
# }
# }
=pod
=head2 getSelectedItemInfo($menu_item)
Returns the ItemInfo object corresponding to the selected menu
item.
=cut
sub getSelectedItemInfo {
my ($self, $key) = @_;
my $path = $self->getSelectedPath($key);
if (UNIVERSAL::isa($path, 'ARRAY') and @$path) {
return $path->[$#$path];
}
}
*get_selected_item_info = \&getSelectedItemInfo;
=pod
=head2 getSelectedPath($menu_item)
Returns an array of InfoItem objects representing the path from
the top level menu item to the selected menu item.
=cut
# added for v0_09
sub getSelectedPath {
my ($self, $key) = @_;
my $open_list = $self->_getOpenList($key);
return [] unless @$open_list;
# take the path of Item objects and from that map out the
# list of ItemInfo objects.
my $item_path = $$open_list[0]->_getSelectedPath;
my %open_map = map { ($_->getName, $_) } @$open_list;
my @selected_path = map { $open_map{$_->getName} } @$item_path;
return \@selected_path;
}
*get_selected_path = \&getSelectedPath;
sub generateOpenList {
my ($self, $key) = @_;
my $params = $self->_getParams;
$self->_fixupConf;
if ($$params{first_with_url}) {
my $non_url_items = $self->_getNonUrlItems;
my $new_name = $$non_url_items{$key};
$key = $new_name unless $new_name eq '';
}
my $conf = $self->getConfig;
return '' unless $conf;
my $selected_path = $self->findSelectedPath($conf, $key);
my $list = [];
foreach my $item (@$conf) {
my $l = $self->_generateOpenList($item, $key, $selected_path, 0);
push @$list, @$l;
}
my $last_item;
foreach my $item (@$list) {
if ($last_item) {
$item->setPreviousItem($last_item);
$last_item->setNextItem($item);
}
$last_item = $item;
}
return $list;
}
# cleans up circular references in the open list so perl will
# deallocate the memory used
sub _cleanUpOpenlist {
my ($self, $list) = @_;
foreach my $item (@$list) {
$item->setPreviousItem(undef);
$item->setNextItem(undef);
}
}
sub _generateOpenList {
my ($self, $item, $key, $selected_path, $level, $parent) = @_;
my $new_level = $level + 1;
my $list = [];
my $hier_params = $self->_getParams;
my $params = { top_menu_obj => $self,
old_style_url => $$hier_params{old_style_url},
new_style_url => $$hier_params{new_style_url},
std_callback_params => $$hier_params{std_callback_params},
};
my $info_obj = HTML::Menu::Hierarchical::ItemInfo->new($item, $selected_path, $key,
$parent, $params);
$info_obj->setLevel($level);
push @$list, $info_obj;
if ($info_obj->isOpen and $info_obj->hasChildren) {
foreach my $child (@{$item->getChildren}) {
my $l = $self->_generateOpenList($child, $key, $selected_path, $new_level,
$info_obj);
push @$list, @$l;
}
}
return $list;
}
sub _generateMenuSection {
my ($self, $info_obj) = @_;
my $str;
my $iterator = $info_obj->getOtherField('callback');
$iterator = $self->getIterator unless $iterator;
if (ref($iterator) eq 'ARRAY') {
my ($obj, $meth) = @$iterator;
$str .= $obj->$meth($info_obj);
} elsif (not ref($iterator)) {
# string - use standard callback method
my $meth = "_stdCallback" . $iterator;
$str .= $self->$meth($info_obj);
} else {
$str .= $iterator->($info_obj);
}
return $str;
}
# added for v0_07
sub _addToItemsWithoutUrl {
my ($self, $name, $new_url) = @_;
my $non_url_items = $self->_getNonUrlItems;
$$non_url_items{$name} = $new_url;
}
# added for v0_07
sub _getNonUrlItems {
my ($self) = @_;
my $items = $$self{_non_url_items};
unless ($items) {
$items = {};
$$self{_non_url_items} = $items;
}
return $items;
}
# added for v0_07
sub _checkFirstUrl {
my ($self, $item) = @_;
my $info = $item->getInfo;
return undef unless $$info{url} eq '';
my ($url, $new_name) = $self->_findFirstUrlFromChild($item);
return undef if $url eq '';
my %new_info = %$info;
$new_info{url} = $url;
$item->setInfo(\%new_info);
$self->_addToItemsWithoutUrl($item->getName, $new_name);
return $url;
}
# added for v0_07
sub _findFirstUrlFromChild {
my ($self, $item) = @_;
my $children = $item->getChildren;
unless ($children and @$children) {
return wantarray ? ('', '') : '';
}
my $first_child = $$children[0];
my $info = $first_child->getInfo;
my $url = $$info{url};
unless ($url eq '') {
return ($url, $first_child->getName);
}
return $self->_findFirstUrlFromChild($first_child);
}
# added for v0_07
# Makes any adjustments necessary to the configuration
sub _fixupConf {
my ($self, $conf) = @_;
my $params = $self->_getParams;
return undef unless $$params{first_with_url};
$conf = $self->getConfig unless $conf;
return undef unless $conf;
foreach my $item (@$conf) {
$self->_checkFirstUrl($item) if $$params{first_with_url};
my $children = $item->getChildren;
if ($children and @$children) {
$self->_fixupConf($children);
}
}
}
sub findSelectedPath {
my ($self, $conf, $key) = @_;
return undef unless $conf;
my $params = $self->_getParams;
foreach my $item (@$conf) {
if ($item->getName eq $key) {
return [ $item ];
}
my $path = $self->findSelectedPath($item->getChildren, $key);
if ($path) {
unshift @$path, $item;
return $path;
}
}
return undef;
}
sub _convertConfig {
my ($self, $conf) = @_;
my $obj_array = [];
foreach my $item (@$conf) {
if (ref($item) eq 'HTML::Menu::Hierarchical::Item') {
push @$obj_array, $item;
next;
}
my $children;
if (my $new_conf = $$item{children}) {
$children = $self->_convertConfig($new_conf);
}
my $item = HTML::Menu::Hierarchical::Item->new(@$item{'name', 'info'}, $children,
$item);
push @$obj_array, $item;
}
return $obj_array;
}
#####################
# getters and setters
sub getConfig {
my ($self) = @_;
return $$self{_menu_config};
}
sub setConfig {
my ($self, $conf) = @_;
$$self{_menu_config} = $conf;
}
sub getIterator {
my ($self) = @_;
return $$self{_iterator};
}
sub setIterator {
my ($self, $iterator) = @_;
$$self{_iterator} = $iterator;
}
# added for v0_07
sub _getParams {
my ($self) = @_;
my $params = $$self{_params};
$params = {} unless $params;
return $params;
}
sub _setParams {
my ($self, $params) = @_;
$$self{_params} = $params;
}
# added for v0_07
sub hasParamSetOpenAll {
my ($self) = @_;
my $params = $self->_getParams;
if ($$params{open_all}) {
return 1;
}
return undef;
}
sub _stdCallbackUl1 {
my ($self, $info_obj) = @_;
my $html = '';
my $level = $info_obj->getLevel;
my $text = $info_obj->getText;
my $name = $info_obj->getName;
my $info = $info_obj->getInfo;
my $params = $info_obj->getStandardCallbackParams;
my $cgi_var_name = $$params{menu_item_param_name} || 'm_i';
my $url = $info_obj->addArgsToUrl($info_obj->getUrl, { $cgi_var_name => $name });
if ($level == 0 and $info_obj->isFirstDisplayed) {
my $style = qq{style="padding-left: 0em; margin-left: 1em"};
if (exists($$info{list_class})) {
$style = qq{class="$$info{list_class}"};
} elsif (exists($$params{list_class})) {
$style = qq{class="$$params{list_class}"};
}
$html .= qq{\n};
} elsif ($info_obj->isFirstSiblingDisplayed) { # new in version 0.12
my $style = qq{style="padding-left: 0em; margin-left: 1em"};
if (exists($$info{list_class})) {
$style = qq{class="$$info{list_class}"};
} elsif (exists($$params{list_class})) {
$style = qq{class="$$params{list_class}"};
}
$html .= " " x ($level + 1);
$html .= qq{\n};
}
$html .= " " x ($level == 0 ? $level + 1 : $level + 2);
$html .= qq{- \n};
my $link_style = qq{style="text-decoration: none};
$link_style .= qq{; font-family: arial, helvetica, sans-serif};
$link_style .= qq{; font-size: 12pt; font-weight: bold; color: #626262"};
if (exists($$info{link_class})) {
$link_style = qq{class="$$info{link_class}"};
} elsif (exists($$params{link_class})) {
$link_style = qq{class="$$params{link_class}"};
}
$html .= " " x ($level == 0 ? $level + 2 : $level + 3);
$html .= qq{$text\n};
unless ($info_obj->isOpen) {
$html .= " " x ($level == 0 ? $level + 1 : $level + 2);
$html .= qq{
\n};
}
if ($info_obj->isLastSiblingDisplayed and not $info_obj->hasChildren) {
$html .= " " x ($level + 1) unless $level == 0;
$html .= qq{
\n};
$html .= " " x ($level) . qq{\n};
}
if ($info_obj->isLastDisplayed) {
$html .= " " x ($level + 1) unless $level == 0;
$html .= qq{
\n};
}
return $html;
}
sub _stdCallbackCiscoExt {
my ($self, $info_obj) = @_;
my $info = $info_obj->getInfo;
my $level = $info_obj->getLevel;
my $selected_level = $info_obj->getSelectedLevel;
my $params = $info_obj->getStandardCallbackParams;
my $name = $info_obj->getName;
my $image_uri = '';
my $cgi_var_name = $$params{menu_item_param_name} || 'm_i';
my $url = $info_obj->addArgsToUrl($info_obj->getUrl, { $cgi_var_name => $name });
my $parent_bg_color = '#669999';
my $selected_bg_color = '#ffffff';
my $child_bg_color = '#cccccc';
my $peer_bg_color = '#999999';
my $architecture_bg_color = '#336666';
my $divider_color = '#003333';
my $text_class = 'hinavparent';
my $text_color = '#ffffff';
my $text_bg_color = $parent_bg_color;
my $child_indent = 9;
my $indent = 0;
if ($level == $selected_level) {
$text_class = 'hinavpeer';
$text_color = '#000000';
if ($info_obj->isSelected) {
$text_bg_color = $selected_bg_color;
} elsif ($level == 1) {
$text_color = '#ffffff';
$text_bg_color = $parent_bg_color;
} else {
$text_bg_color = $peer_bg_color;
}
} elsif ($level < $selected_level) {
$text_class = 'hinavparent';
$text_color = '#ffffff';
if ($selected_level - $level == 1) {
$text_bg_color = $parent_bg_color;
} else {
$text_bg_color = $architecture_bg_color;
}
} else {
# $level > $selected_level
$text_class = 'hinavchild';
$text_color = '#000000';
$text_bg_color = $child_bg_color;
}
if ($text_class eq 'hinavchild') {
$indent = $child_indent if $level > 1;
}
if ($info_obj->isSelected) {
$text_bg_color = $selected_bg_color;
$text_color = '#000000';
}
my $text = '';
if ($text_class =~ /parent/) {
$text = $info_obj->escapeHtml(uc($$info{text}));
} else {
$text = $info_obj->escapeHtml($$info{text});
}
my $plus = $image_uri . 'hinav_l0plus.gif';
if ($level) {
if ($text_class =~ /parent/) {
$plus = $image_uri . 'hinav_plusrev.gif';
} else {
$plus = $image_uri . 'hinav_plus.gif';
}
}
my $spacer = $image_uri . 's.gif';
my $html = '';
if ($level == 0) {
$html .= qq{\n};
$html .= qq{};
$html .= qq{ | };
$html .= qq{};
$html .= qq{$text | };
$html .= qq{};
$html .= qq{ | \n};
$html .= qq{\n};
$html .= qq{};
$html .= qq{ | };
$html .= qq{
\n};
return $html;
}
my $left_image = $image_uri . 's.gif';
my $link = qq{};
$link .= qq{$text};
$html .= qq{\n};
$html .= qq{};
$html .= qq{ | };
$html .= qq{$link | };
$html .= qq{};
if ($info_obj->hasChildren and not $info_obj->isOpen) {
$html .= qq{};
} else {
$html .= qq{ };
}
$html .= qq{ | \n
\n};
$html .= qq{\n};
$html .= qq{| };
$html .= qq{ | };
$html .= qq{
\n};
return $html;
}
# added for v0_09
sub DESTROY {
my ($self) = @_;
my $list_hash = $$self{_open_list};
if ($list_hash) {
while (my ($key, $list) = each %$list_hash) {
$self->_cleanUpOpenlist($list);
}
}
}
}
1;
__END__
=pod
=head2 There are also underscore_separated versions of these methods.
E.g., unescapeHtml($html) becomes unescape_html($html)
=head1 EXAMPLES
See the scripts in the examples subdirectory for example usages.
See the documentation for HTML::Menu::Hierarchical::ItemInfo for
methods available via the $info_obj parameter passed to the
menu_callback function below.
=over 4
sub menu_callback {
my ($info_obj) = @_;
my $info_hash = $info_obj->getInfo;
my $level = $info_obj->getLevel;
my $text = $$info_hash{text};
$text = ' ' if $text eq '';
my $item_arg = $info_obj->getName;
# Add a cgi parameter m_i to url so we know which menu
# item was chosen
my $url = $info_obj->addArgsToUrl($$info_hash{url},
{ m_i => $item_arg });
my $dpy_text = $info_obj->isSelected ? "<$text>" : $text;
my $spacer = ' ' x $level;
my $str = qq{\n};
$str .= qq{| };
$str .= $spacer . $dpy_text;
$str .= qq{ | };
$str .= qq{
\n};
return $str;
}
=back
=head1 BUGS
Please send bug reports/feature requests to don@owensnet.com.
There are currently no checks for loops in the configuration
data structure passed to the module.
=head1 AUTHOR
Don Owens
=head1 COPYRIGHT
Copyright (c) 2003 Don Owens
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl
itself.
=head1 VERSION
0.13
=cut
HTML-Menu-Hierarchical-0.13/INSTALL 0000644 0000764 0000764 00000000740 07642736606 016123 0 ustar don don 0000000 0000000 HTML::Menu::Hierarchical
Copyright (c) 2003 Don Owens
See the COPYRIGHT section in Hierarchical.pm for usage and
distribution rights.
HTML::Menu::Hierarchical is a Perl module for creating hierarchical
HTML menus of arbitrary structure.
INSTALLATION
perl Makefile.PL
make
make test
make install
DOCUMENTATION
There is documentation available in POD format for
HTML::Menu::Hierarchical and
HTML::Menu::Hierarchical::ItemInfo, e.g.
perldoc HTML::Menu::Hierarchical
HTML-Menu-Hierarchical-0.13/README 0000644 0000764 0000764 00000032707 10324035707 015743 0 ustar don don 0000000 0000000 NAME
HTML::Menu::Hierarchical - HTML Hierarchical Menu Generator
SYNOPSIS
my $menu_obj =
HTML::Menu::Hierarchical->new($conf, \&callback, $params);
my $html = $menu_obj->generateMenu($menu_item);
or
my $menu_obj =
HTML::Menu::Hierarchical->new($conf, [ $obj, $method ]);
my $html = $menu_obj->generateMenu($menu_item);
or
my $menu_obj =
HTML::Menu::Hierarchical->new($conf, $std_callback_name);
my $html = $menu_obj->generateMenu($menu_item);
In the first case, the callback is a function. In the second,
the callback is a method called on the given object. In the
third example, the callback is the name of a standard callback
defined by HTML::Menu::Hierarchical itself (see the section on
callback functions/methods).
The $conf parameter is a navigation configuration data structure
(described below).
The $params parameter is an optional hash reference containing
parameters pertaining to the menu as a whole. Recognized
parameters are:
first_with_url
If this is set to a true value and you are using the 'url'
field in the info hash (see below) in the configuration to
specify the url for the menu item, then if a menu item is
chosen that does not have a url configured, the url for that
menu item will be changed to the url of the first child menu
item that has a url configured. This works by looking at the
items first child, then at that child's first child, and so
on. It does not look at the second child.
open_all
This has the same effect as the open_all parameter in the
menu configuration structure mentioned below, except that it
affects the entire menu hierarchy.
old_style_url
When using the utilities urlEncodeVars() and addArgsToUrl(),
this parameter controls which separator is used to separate
key/value pairs in the generated query string. Setting
old_style_url to a true value will cause an ampersand ('&')
to be used as the separator.
new_style_url
When using the utilities urlEncodeVars() and addArgsToUrl(),
this parameter controls which separator is used to separate
key/value pairs in the generated query string. Setting
new_style_url to a true value will cause a semicolon (';') to
be used as the separator, as recommended by the W3C. This
will become the default in a later release.
DESCRIPTION
HTML::Menu::Hierarchical provides a way to easily generate a
hierarchical HTML menu without forcing a specific layout.
All output is provided by your own callbacks (subroutine
refs) and your own navigation configuration.
configuration data structure
A navigation configuration is a reference to an array whose
elements are hashrefs. Each hash contains configuration
information for one menu item and its children, if any.
Consider the following example:
my $conf = [
{ name => 'top_button_1',
info => { text => 'Top Level Button 1',
url => '/'
},
open => 1, # force this item's children to be displayed
children => [
{ name => 'button_1_level_2',
info => { text => "Child 1 of Button 1",
url => '/child1.cgi'
},
},
]
},
{ name => 'top_button_2',
info => { text => 'Top Level Button 2',
url => '/top2.cgi'
},
callback => [ $obj, 'my_callback' ]
},
];
In each hash, the 'name' parameter should correspond to the
$menu_item parameter passed to the generateMenu() method. This
is how the module computes which menu item is selected. This is
generally passed via a CGI parameter, which can be tacked onto
the end of the url in your callback function. Note that this
parameter must be unique among all the array entries.
Otherwise, the module will not be able to decide which menu item
is selected.
The value of the 'info' parameter is available to your callback
function via the getInfo() method called on the
HTML::Menu::Hierarchical::ItemInfo object passed to the callback
function. In the above example, the 'info' parameter contains
text to be displayed as the menu item, and a url the user is
sent to when clicking on the menu item.
The 'children' parameter is a reference to another array
containing configuration information for child menu items. This
is where the Hierarchical part comes in. There is no limit to
depth of the hierarchy (until you run out of RAM, anyway).
If a 'callback' parameter is specified that callback will be
used for that menu item instead of the global callback passed to
new().
An 'open' parameter can be specified to force an item's children
to be displayed. This can be a scalar value that indicates true
or false. Or it can be a subroutine reference that returns a
true or false value. It can also be an array, in which case the
first element is expected to be an object, the second element
the name of a method to call on that object, and the rest of the
elements will be passed as arguments to the method. If an
'open_all' parameter is passed, the current item and all items
under it in the hierarchy will be forced open.
callback functions/methods
Callback functions are passed a single parameter: an
HTML::Menu::Hierarchical::ItemInfo object. See the
documentation on this object for available methods. The
callback function should return the HTML necessary for the
corresponding menu item.
METHODS
new()
my $menu_obj = HTML::Menu::Hierarchical->new($conf, \&callback);
generateMenu($menu_item)
my $html = $menu_obj->generateMenu($menu_item);
$menu_item is the 'name' parameter of the selected item,
typically passed as a CGI parameter.
addChildConf($conf, $menu_item_name)
Adds another configuration tree into the current configuration
at the specified node (name of the menu item).
addChildConfToChildren($conf, $menu_item_name)
Like addChildConf(), except add this conf to the list of
children of the parent with name $menu_item_name. If $conf is
an array, each element of the array will be added to the list of
children.
getSelectedItemInfo($menu_item)
Returns the ItemInfo object corresponding to the selected menu
item.
getSelectedPath($menu_item)
Returns an array of InfoItem objects representing the path from
the top level menu item to the selected menu item.
There are also underscore_separated versions of these methods.
E.g., unescapeHtml($html) becomes unescape_html($html)
EXAMPLES
See the scripts in the examples subdirectory for example usages.
See the documentation for HTML::Menu::Hierarchical::ItemInfo for
methods available via the $info_obj parameter passed to the
menu_callback function below.
sub menu_callback { my ($info_obj) = @_; my $info_hash =
$info_obj->getInfo; my $level = $info_obj->getLevel;
my $text = $$info_hash{text};
$text = ' ' if $text eq '';
my $item_arg = $info_obj->getName;
# Add a cgi parameter m_i to url so we know which menu
# item was chosen
my $url = $info_obj->addArgsToUrl($$info_hash{url},
{ m_i => $item_arg });
my $dpy_text = $info_obj->isSelected ? "<$text>" : $text;
my $spacer = ' ' x $level;
my $str = qq{\n};
$str .= qq{| };
$str .= $spacer . $dpy_text;
$str .= qq{ | };
$str .= qq{
\n};
return $str;
}
BUGS
Please send bug reports/feature requests to don@owensnet.com.
There are currently no checks for loops in the configuration
data structure passed to the module.
AUTHOR
Don Owens
COPYRIGHT
Copyright (c) 2003 Don Owens
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl
itself.
VERSION
0.13
NAME
HTML::Menu::Hierarchical::ItemInfo - Used by HTML::Menu::Hierarchical.
Provides information about the menu item being processed.
SYNOPSIS
Created by HTML::Menu::Hierarchical objects.
DESCRIPTION
Information holder/gatherer representing one menu item.
METHODS
Getting back information
hasChildren()
Returns true if the current item has child items in the
configuration. False otherwise.
isSelected()
Returns true if the current item is the selected one.
isInSelectedPath()
Returns true if the current item is in the path from the root of
the hierarchy to the selected item.
getSelectedItem()
Returns the ItemInfo object corresponding to the selected menu
item.
getSelectedLevel()
Returns the level in the hierarchy where the selected menu item
is located. Levels start at zero.
getMaxDisplayedLevel()
Returns the maximum level in the hierarchy to currently be
displayed.
isOpen()
Returns true if the current menu item is open, i.e., the current
item has child items and is also in the open path. Return false
otherwise.
isFirstDisplayed()
Returns true if the current menu item is the first one to be
displayed.
isLastDisplayed()
Returns true if the current menu item is the last to be
displayed.
isFirstSiblingDisplayed()
Returns true if the current menu item is the first of its
siblings to be displayed, false otherwise.
isLastSiblingDisplayed()
Returns true if the current menu item is the last of its
siblings to be displayed, false otherwise.
getInfo()
Returns the value of the 'info' field for the current menu item
in the navigation configuration.
Instead of getting the 'info' hash and then accessing a field
within it, you may call a method to get that field directly.
This is implemented with AUTOLOAD, so if you do something like
my $text = $info_obj->getText;
my $image_src = $info_obj->getImageSrc;
or
my $text = $info_obj->getText;
my $image_src = $info_obj->get_image_src;
you will be given back the corresponding values in the 'info'
hash.
getName()
Returns the 'name' field for the current menu item in the
navigation configuration. This is used to determine which menu
item has been selected.
getNextItem()
Returns the ItemInfo object corresponding to the next displayed
menu item.
getPreviousItem()
Returns the ItemInfo object corrsponding to the previously
displayed menu item.
getLevel()
Returns the level in the menu hierarchy where the current menu
item is located. Levels start at zero.
getParent()
Returns the info object for the current item's parent.
Utilities
my $encoded = $info->urlEncode($plain_text)
URL encodes the given string. This does full url-encoding, so a
space is %20, not a '+'.
my $query = $info->urlEncodeVars($var_hash)
Takes a hash containing key/value pairs and returns a
url-encoded query string appropriate for adding to the end of a
url. If a value is an array, it is assumed to be a multivalued
input field and is added to the query string as such.
If you want to encode the query stirng in the new style
recommended by the W3C (use a semicolon as a separator in place
of ampersand), pass a true value for the new_style_url parameter
when creating the HTML::Menu::Hierarchical object. This will
become the default in a later release.
my $plain_text = $info->urlDecode($url_enc_str)
Decodes the given url-encoded string.
my $var_hash = $info->urlDecodeVars($url_enc_str)
Decodes the url-encoded query string and returns a hash contain
key/value pairs from the query string. If a field appears more
than once in the query string, it's value will be returned as a
reference to an array of values.
my $modified_url = $info->addArgsToUrl($url, $var_hash)
Takes the key/value pairs in $var_hash and tacks them onto the
end of $url as a query string.
my $html = $info->escapeHtml($text)
Escapes the given text so that it is not interpreted as HTML.
my $text = $info->unescapeHtml($html)
Unescape the escaped text.
There are also underscore_separated versions of these methods.
E.g., unescapeHtml($html) becomes unescape_html($html)
TODO
hasChildrenDisplayed() - tell whether or not the current item's
children will be displayed
BUGS
Please send bug reports/feature requests to don@owensnet.com.
AUTHOR
Don Owens
COPYRIGHT
Copyright (c) 2003 Don Owens
All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl
itself.
VERSION
$Id: README,v 1.21 2005/10/14 23:14:15 don Exp $
HTML-Menu-Hierarchical-0.13/Makefile.PL 0000755 0000764 0000764 00000002245 10324035707 017032 0 ustar don don 0000000 0000000 #!/usr/bin/env perl
# Creation date: 2003-02-25 22:25:01
# Authors: Don
# Change log:
# $Id: Makefile.PL,v 1.7 2005/10/14 23:14:15 don Exp $
use strict;
use Carp;
# main
{
local($SIG{__DIE__}) = sub { &Carp::cluck(); exit 0 };
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'HTML::Menu::Hierarchical',
DISTNAME => 'HTML-Menu-Hierarchical',
VERSION_FROM => 'lib/HTML/Menu/Hierarchical.pm',
ABSTRACT => 'HTML Hierarchical Menu Generator',
AUTHOR => 'Don Owens ',
PM => { 'lib/HTML/Menu/Hierarchical.pm' => '$(INST_LIBDIR)/Hierarchical.pm',
'lib/HTML/Menu/Hierarchical/Item.pm' => '$(INST_LIBDIR)/Hierarchical/Item.pm',
'lib/HTML/Menu/Hierarchical/ItemInfo.pm' => '$(INST_LIBDIR)/Hierarchical/ItemInfo.pm',
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz' },
DIR => [],
EXE_FILES => [],
);
}
exit 0;
###############################################################################
# Subroutines