package Javascript::Menu; use strict; use CGI; use Tree::Numbered; use constant DEFAULT_STYLES => {caption => 'caption', Mmenu => 'Mmenu', Smenu => 'Smenu'}; our $VERSION = '2.01.1'; our @ISA = qw(Tree::Numbered); # package stuff: my $cgi = CGI->new; # Just for HTML shortcuts. # A default action generator. See the args passed to it: my $default_action = sub { my $self = shift; my ($level, $unique) = @_; return ''; }; # constructs a new tree or node. # Arguments: By name: # value - the value to be stored in the node. # action - a perl sub that is responsible for generating Javascript # code to be executed on click. The sub will be called as # a method ($self->generator) so you have access to the # object data when you construct the action (optional). # URL - a url to navigate to on click (optional). # Returns: The tree object. sub new { my $parent = shift; my %args = @_; my $parent_serial; my $class; my %nargs = (Value => $args{value}); $nargs{URL} = $args{URL} if (exists $args{URL}); my $properties = $parent->SUPER::new(%nargs); my $action = $args{action}; if ($class = ref($parent)) { $properties->{_Parent} = $parent->{_Serial}; $action = $parent->getAction unless (defined $action); } else { $class = $parent; $properties->{_Parent} = 0; } $properties->addField('Action'); # Does nothing if exists. $properties->setAction((defined $action) ? $action : $default_action); return $properties; } # takes a Tree::Numbered and makes it a Javascript::Menu. # Arguments: By name: # tree - the tree to be converted to a menu. # action - an action generator, as described in . # parent - (not for the user) sets the _Parent property. # base_URL - a url that will be appended later by a relative one. # Returns: the tree, modified and re-blessed as a Javascript::Menu. sub convert { my $parent = shift; my $class = (ref($parent) or $parent); my %args = @_; my ($tree, $parent_num) = @args{'tree', 'parent'}; my $def_action = (exists $args{action}) ? $args{action} : $default_action; $parent_num ||= 0; # Won't change existing setting of 'Action' and 'URL' if it's there. $tree->addField('Action', $def_action); $tree->addField('URL', $args{base_URL}) if (exists $args{'base_URL'}); $tree->{_Parent} = $parent_num; for (@{ $tree->{Items} }) { my %inargs = (tree => $_, action => $def_action, parent => $tree->getNumber); $inargs{base_URL} = $args{base_URL} if (exists $args{'base_URL'}); $parent->convert(%inargs); } return bless $tree, $class; } # constructs a new Javascript::Menu from a table in a DB using # Tree::Numbered::DB. # Arguments: By name: # source_name - table name. # source - a DB handle to work with. # action - an action generator, as described in . # cols - ref to a hash with mappings (see Tree::Numbered::DB). # URL_col - shortcut to add the URL column to the cols. # Returns: the tree, modified and re-blessed as a Javascript::Menu. sub readDB { my $parent = shift; my $class = (ref($parent) or $parent); my %args = @_; my ($table, $dbh) = @args{'source_name', 'source'}; return undef unless ($table && $dbh); my $def_action = (exists $args{action}) ? $args{action} : $default_action; my $cols = $args{cols}; $cols->{URL_col} = $args{URL_col} if ($args{URL_col}); # Default creation of Value is no longer used because we request a field. $cols->{Value_col} ||= 'name'; require Tree::Numbered::DB; my @args = ($table, $dbh); push @args, $cols if $cols; #read -> revert -> convert: construct a DB tree, loose DBness, make Menu. my $tree = Tree::Numbered::DB->read(@args); $tree->revert; return $class->convert(tree => $tree, action => $def_action); } # returns the HTML and Javascript that show the menu. # Arguments: By name: # styles - alternative set of styles. Default will be used if this isn't # supplied or malformed. # caption - a starting caption. Optional. # no_ie - if true, no anchor tags will be added to captions. # Returns: In list context returns a list of HTML lines to print. In scalar # context returns a reference to same list. sub getHTML { my $self = shift; my %args = @_; my $caption = (exists $args{caption}) ? $args{caption} : $self->getValue; $caption = $self->getFullCap($args{no_ie}, $caption); my $styles = $args{styles}; $styles = DEFAULT_STYLES unless(ref $styles eq 'HASH' and $styles->{caption} and $styles->{Mmenu} and $styles->{Smenu}); my $unique = $self->getUniqueId; my $action = $self->getAction()->($self, -1, $unique); $action =~ s/([^;])\s*$/$1;/; my @html; # return value. push @html, $cgi->div({-class => $styles->{caption}, -id => "caption_$unique", -onMouseOver => "showMenu(1, 0, 'main_$unique', " . "this, 'main_$unique')", -onMouseOut => "outOfMenu()", -onClick => "${action}hideMenus(0)" }, $caption); $self->buildTable(1, 0, $unique, \@html, $args{no_ie}, %$styles); return @html if (wantarray); return \@html; } # Helper for (actually does the real work). # Recursively builds tables for each submenu and pushes the HTML into # @html which is used as a stack. # Arguments: $ismain - used to determine table style. # $level - the submenu's level (main is 0), # $unique - the menue's unique identifier. This is an argument so # changing the uniquifing rule, will only be in . # $id - The menu's HTML name, used for identification by JavaScript # functions. # $html - a reference to the stack. # $no_ie - no anchor tags will be added around the caption. # %styles - a hash of style names. # Returns: Nothing. Modifies buffer directly. sub buildTable { my $self = shift; my $serial = $self->{_Serial}; my ($ismain, $level, $unique, $html, $no_ie, %styles) = @_; my ($style, $name); if ($ismain) { $style = $styles{Mmenu}; $name = "main_$unique"; } else { $style = $styles{Smenu}; $name = "s_${serial}_$unique" } my $htmlstr = $cgi->start_table({-class => $style, -id => $name}); my $next_level = $level + 1; $self->savePlace; $self->reset; while (my $item = $self->nextNode) { # '~n' is a placeholder my $onMouse = "showMenu(0, ~1, 's_~2_$unique', this, 'main_$unique');"; my $onClick = $item->getAction()->($item, $level, $unique); if ($item->childCount) { # '~1' = _next_ menu's level. '~2' = branch serial. $onMouse =~ s/~2/$item->{_Serial}/; $onMouse =~ s/~1/$next_level/e; $item->buildTable(0, $next_level, $unique, $html, $no_ie, %styles); } else {$onMouse = "stopTimer();hideMenus($next_level);";} my $caption = $item->getFullCap($no_ie); $onClick =~ s/([^;])\s*$/$1;/; $htmlstr .= $cgi->Tr($cgi->td({-onMouseOver => $onMouse, -onClick => "${onClick}hideMenus(0)", -onMouseOut => 'outOfMenu()'}, $caption )); } $self->restorePlace; $htmlstr .= $cgi->end_table; push @$html, $htmlstr; } sub getFullCap { my ($item, $no_ie, $caption) = @_; my $value = $caption || $item->getValue; my $href = $item->getURL || '"javascript:void(0)"'; if ($no_ie && !$item->getURL) { return $value; } else { return "$value";} } # returns the html suffix id of the menu. # Arguments: None. # Returns: A unique suffix for HTML names which includes the lucky number and # the root node's serial number. sub getUniqueId { my $self = shift; return "$self->{_LuckyNumber}__$self->{_Serial}"; } # sets the action on an item. if no action is given, the default # do-nothing action is used. # Arguments: $action - an action, or nothing - implies default. # Returns: Nothing. sub setAction { my $self = shift; my $action = shift; $action ||= $default_action; $self->setField('Action', $action); } # are here to make sure nobody dies when they're called even if # the field doesn't exist. sub getURL { my $self = shift; return $self->getField('URL'); } sub setURL { my $self = shift; return $self->setField('URL', @_); } #************************************************************** # Class methods for generating required JavaScript and CSS. # returns the base style to be used with this module - some # definitions are esential, such as visibility. Note that using just the base # style will yield a transparent and ugly menu. # Arguments: None. # Returns: a hash containing for each required element (caption, Mmenu, # Smenu) another hash with property - value pairs. modify at will, # then print map {"$_: $hash->{$_};"} keys $hash; where $hash is the # properties hash for an element. sub baseCSS { my $self = shift; # Never used - class method. return {caption => {}, Mmenu => {position => 'absolute', top => '1', left => '1', 'z-index' => 10, visibility => 'hidden'}, Smenu => {position => 'absolute', top => '1', left => '1', 'z-index' => 10, visibility => 'hidden'} }; } # does the same thing as only with more properties. # Arguments: None. # Returns: See . sub reasonableCSS { my $self = shift; # Never used - class method. return {caption => {_border => 'solid 1px black', 'text-decoration' => 'none', background => 'blue', width => '10%', color => 'white', 'font-weight' => 'bold'}, Mmenu => {position => 'absolute', top => '1', left => '1', background => 'cyan', 'z-index' => 10, visibility => 'hidden', 'text-decoration' => 'none'}, Smenu => {position => 'absolute', top => '1', left => '1', background => 'cyan', 'z-index' => 10, visibility => 'hidden', 'text-decoration' => 'none'}, _Mmenu => {background => 'blue', 'z-index' => 10, color=>'white'}, _Smenu => {background => 'blue', 'z-index' => 10, color => 'white'} }; } # turns the datastructure provided by the previous two subs into # valid CSS. Hash keys are converted into classes, and hash keys preceded # with an underscore are converted into the "class td:hover" syntax. # Arguments: $raw_css - The datastructure described in . # $no_ie - no anchor style will be added to the hover style if true. # $no_autolink - prevents generation af a:link if true. # Returns: A string containing the CSS. sub buildCSS { my $self = shift; # Never used - class method. my ($raw_css, $no_ie, $no_autolink) = @_; my $css = ''; my $ie_bloat = ($no_ie) ? '' : ' a'; for my $class (keys %$raw_css) { my %props = %{ $raw_css->{$class} }; my $hover = ($class =~ s/^_//) ? 1 : 0; $css .= ".$class "; $css .= "td${ie_bloat}:hover" if ($hover); $css .= " {\n"; $css .= join "\n", map {my $under=$_; s/^_//; "\t$_: $props{$under};"} keys %props; $css .= "\n}\n\n"; # Generate link style for IE6 support... unless ($hover || $no_ie || $no_autolink) { my %hprops = %props; delete @hprops{'position', 'top', 'left', 'right', 'bottom', 'visibility', 'z-index'}; %hprops = map {$_=>$hprops{$_}} grep /^[^_]/, keys %hprops; $css .= ".$class a:link, .$class a:visited "; $css .= " {\n"; $css .= join "\n", map {"\t$_: $hprops{$_};"} keys %hprops; $css .= "\n}\n\n"; } } return $css; } # generates required Javascript code for use with this module. # Arguments: $rtl - if right-to-left menu. # Returns: Only the code. You can put this inside a