File Coverage

blib/lib/Javascript/Menu.pm
Criterion Covered Total %
statement 95 156 60.9
branch 15 44 34.0
condition 12 41 29.2
subroutine 12 18 66.6
pod 12 14 85.7
total 146 273 53.4


line stmt bran cond sub pod time code
1             package Javascript::Menu;
2              
3 1     1   4532 use strict;
  1         2  
  1         29  
4              
5 1     1   1896 use CGI;
  1         15785  
  1         9  
6 1     1   72 use Tree::Numbered;
  1         3  
  1         36  
7              
8 1         2519 use constant DEFAULT_STYLES => {caption => 'caption',
9             Mmenu => 'Mmenu',
10 1     1   5 Smenu => 'Smenu'};
  1         3  
11              
12             our $VERSION = '2.02';
13             our @ISA = qw(Tree::Numbered);
14              
15             # package stuff:
16             my $cgi = CGI->new; # Just for HTML shortcuts.
17              
18             # A default action generator. See the args passed to it:
19             my $default_action = sub {
20             my $self = shift;
21             my ($level, $unique) = @_;
22              
23             return '';
24             };
25              
26             # constructs a new tree or node.
27             # Arguments: By name:
28             # value - the value to be stored in the node.
29             # action - a perl sub that is responsible for generating Javascript
30             # code to be executed on click. The sub will be called as
31             # a method ($self->generator) so you have access to the
32             # object data when you construct the action (optional).
33             # URL - a url to navigate to on click (optional).
34             # Returns: The tree object.
35              
36             sub new {
37 1     1 1 2 my $parent = shift;
38 1         4 my %args = @_;
39              
40 1         3 my $parent_serial;
41             my $class;
42            
43 1         3 my %nargs = (Value => $args{value});
44 1 50       7 $nargs{URL} = $args{URL} if (exists $args{URL});
45 1         12 my $properties = $parent->SUPER::new(%nargs);
46              
47 1         3 my $action = $args{action};
48 1 50       4 if ($class = ref($parent)) {
49 1         3 $properties->{_Parent} = $parent->{_Serial};
50 1 50       19 $action = $parent->getAction unless (defined $action);
51             } else {
52 0         0 $class = $parent;
53 0         0 $properties->{_Parent} = 0;
54             }
55              
56 1         5 $properties->addField('Action'); # Does nothing if exists.
57 1 50       9 $properties->setAction((defined $action) ? $action : $default_action);
58 1         5 return $properties;
59             }
60              
61             # takes a Tree::Numbered and makes it a Javascript::Menu.
62             # Arguments: By name:
63             # tree - the tree to be converted to a menu.
64             # action - an action generator, as described in .
65             # parent - (not for the user) sets the _Parent property.
66             # base_URL - a url that will be appended later by a relative one.
67             # Returns: the tree, modified and re-blessed as a Javascript::Menu.
68              
69             sub convert {
70 4     4 1 35 my $parent = shift;
71 4   33     32 my $class = (ref($parent) or $parent);
72              
73 4         14 my %args = @_;
74 4         10 my ($tree, $parent_num) = @args{'tree', 'parent'};
75 4 50       12 my $def_action = (exists $args{action}) ? $args{action} : $default_action;
76 4   100     12 $parent_num ||= 0;
77              
78             # Won't change existing setting of 'Action' and 'URL' if it's there.
79 4         16 $tree->addField('Action', $def_action);
80 4 50       12 $tree->addField('URL', $args{base_URL}) if (exists $args{'base_URL'});
81 4         7 $tree->{_Parent} = $parent_num;
82              
83 4         7 for (@{ $tree->{Items} }) {
  4         10  
84 3         13 my %inargs = (tree => $_, action => $def_action,
85             parent => $tree->getNumber);
86 3 50       9 $inargs{base_URL} = $args{base_URL} if (exists $args{'base_URL'});
87 3         16 $parent->convert(%inargs);
88             }
89 4         20 return bless $tree, $class;
90             }
91              
92             # constructs a new Javascript::Menu from a table in a DB using
93             # Tree::Numbered::DB.
94             # Arguments: By name:
95             # source_name - table name.
96             # source - a DB handle to work with.
97             # action - an action generator, as described in .
98             # cols - ref to a hash with mappings (see Tree::Numbered::DB).
99             # URL_col - shortcut to add the URL column to the cols.
100             # Returns: the tree, modified and re-blessed as a Javascript::Menu.
101              
102             sub readDB {
103 0     0 1 0 my $parent = shift;
104 0   0     0 my $class = (ref($parent) or $parent);
105 0         0 my %args = @_;
106              
107 0         0 my ($table, $dbh) = @args{'source_name', 'source'};
108 0 0 0     0 return undef unless ($table && $dbh);
109              
110 0 0       0 my $def_action = (exists $args{action}) ? $args{action} : $default_action;
111 0         0 my $cols = $args{cols};
112 0 0       0 $cols->{URL_col} = $args{URL_col} if ($args{URL_col});
113             # Default creation of Value is no longer used because we request a field.
114 0   0     0 $cols->{Value_col} ||= 'name';
115              
116 0         0 require Tree::Numbered::DB;
117 0         0 my @args = ($table, $dbh);
118 0 0       0 push @args, $cols if $cols;
119             #read -> revert -> convert: construct a DB tree, loose DBness, make Menu.
120 0         0 my $tree = Tree::Numbered::DB->read(@args);
121 0         0 $tree->revert;
122 0         0 return $class->convert(tree => $tree, action => $def_action);
123             }
124              
125              
126             # returns the HTML and Javascript that show the menu.
127             # Arguments: By name:
128             # styles - alternative set of styles. Default will be used if this isn't
129             # supplied or malformed.
130             # caption - a starting caption. Optional.
131             # no_ie - if true, no anchor tags will be added to captions.
132             # Returns: In list context returns a list of HTML lines to print. In scalar
133             # context returns a reference to same list.
134              
135             sub getHTML {
136 2     2 1 942 my $self = shift;
137 2         5 my %args = @_;
138              
139 2 50       19 my $caption = (exists $args{caption}) ? $args{caption} : $self->getValue;
140 2         10 $caption = $self->getFullCap($args{no_ie}, $caption);
141              
142 2         4 my $styles = $args{styles};
143 2 0 33     10 $styles = DEFAULT_STYLES unless(ref $styles eq 'HASH'
      33        
      0        
144             and $styles->{caption}
145             and $styles->{Mmenu}
146             and $styles->{Smenu});
147 2         5 my $unique = $self->getUniqueId;
148 2         11 my $action = $self->getAction()->($self, -1, $unique);
149 2         35 $action =~ s/([^;])\s*$/$1;/;
150 2         2 my @html; # return value.
151              
152 2         62 push @html, $cgi->div({-class => $styles->{caption},
153             -id => "caption_$unique",
154             -onMouseOver => "showMenu(1, 0, 'main_$unique', " .
155             "this, 'main_$unique')",
156             -onMouseOut => "outOfMenu()",
157             -onClick => "${action}hideMenus(0)"
158             }, $caption);
159 2         1288 $self->buildTable(1, 0, $unique, \@html, $args{no_ie}, %$styles);
160              
161 2 50       67 return @html if (wantarray);
162 0         0 return \@html;
163             }
164              
165             # Helper for (actually does the real work).
166             # Recursively builds tables for each submenu and pushes the HTML into
167             # @html which is used as a stack.
168             # Arguments: $ismain - used to determine table style.
169             # $level - the submenu's level (main is 0),
170             # $unique - the menue's unique identifier. This is an argument so
171             # changing the uniquifing rule, will only be in .
172             # $id - The menu's HTML name, used for identification by JavaScript
173             # functions.
174             # $html - a reference to the stack.
175             # $no_ie - no anchor tags will be added around the caption.
176             # %styles - a hash of style names.
177             # Returns: Nothing. Modifies buffer directly.
178              
179             sub buildTable {
180 4     4 0 5 my $self = shift;
181 4         9 my $serial = $self->{_Serial};
182 4         17 my ($ismain, $level, $unique, $html, $no_ie, %styles) = @_;
183            
184 4         5 my ($style, $name);
185 4 100       9 if ($ismain) {
186 2         4 $style = $styles{Mmenu};
187 2         4 $name = "main_$unique";
188             } else {
189 2         3 $style = $styles{Smenu};
190 2         15 $name = "s_${serial}_$unique"
191             }
192              
193 4         91 my $htmlstr = $cgi->start_table({-class => $style, -id => $name});
194 4         631 my $next_level = $level + 1;
195            
196 4         53 $self->savePlace;
197 4         19 $self->reset;
198              
199 4         14 while (my $item = $self->nextNode) {
200             # '~n' is a placeholder
201 8         21 my $onMouse = "showMenu(0, ~1, 's_~2_$unique', this, 'main_$unique');";
202 8         36 my $onClick = $item->getAction()->($item, $level, $unique);
203              
204 8 100       59 if ($item->childCount) {
  6         12  
205             # '~1' = _next_ menu's level. '~2' = branch serial.
206 2         13 $onMouse =~ s/~2/$item->{_Serial}/;
207 2         9 $onMouse =~ s/~1/$next_level/e;
  2         6  
208              
209 2         15 $item->buildTable(0, $next_level, $unique, $html, $no_ie, %styles);
210             } else {$onMouse = "stopTimer();hideMenus($next_level);";}
211              
212 8         24 my $caption = $item->getFullCap($no_ie);
213 8         90 $onClick =~ s/([^;])\s*$/$1;/;
214 8         201 $htmlstr .= $cgi->Tr($cgi->td({-onMouseOver => $onMouse,
215             -onClick => "${onClick}hideMenus(0)",
216             -onMouseOut => 'outOfMenu()'},
217             $caption ));
218             }
219 4         18 $self->restorePlace;
220 4         68 $htmlstr .= $cgi->end_table;
221 4         387 push @$html, $htmlstr;
222             }
223              
224             sub getFullCap {
225 10     10 0 14 my ($item, $no_ie, $caption) = @_;
226 10   100     52 my $value = $caption || $item->getValue;
227 10   50     24 my $href = $item->getURL || '"javascript:void(0)"';
228 10 100 66     35 if ($no_ie && !$item->getURL) { return $value; }
  5         11  
229 5         17 else { return "$value";}
230             }
231              
232             # returns the html suffix id of the menu.
233             # Arguments: None.
234             # Returns: A unique suffix for HTML names which includes the lucky number and
235             # the root node's serial number.
236              
237             sub getUniqueId {
238 4     4 1 5 my $self = shift;
239 4         19 return "$self->{_LuckyNumber}__$self->{_Serial}";
240             }
241              
242             # sets the action on an item. if no action is given, the default
243             # do-nothing action is used.
244             # Arguments: $action - an action, or nothing - implies default.
245             # Returns: Nothing.
246              
247             sub setAction {
248 1     1 1 2 my $self = shift;
249 1         2 my $action = shift;
250            
251 1   33     5 $action ||= $default_action;
252 1         5 $self->setField('Action', $action);
253             }
254              
255             # are here to make sure nobody dies when they're called even if
256             # the field doesn't exist.
257              
258             sub getURL {
259 15     15 1 17 my $self = shift;
260 15         35 return $self->getField('URL');
261             }
262              
263             sub setURL {
264 0     0 1   my $self = shift;
265 0           return $self->setField('URL', @_);
266             }
267              
268             #**************************************************************
269             # Class methods for generating required JavaScript and CSS.
270              
271             # returns the base style to be used with this module - some
272             # definitions are esential, such as visibility. Note that using just the base
273             # style will yield a transparent and ugly menu.
274             # Arguments: None.
275             # Returns: a hash containing for each required element (caption, Mmenu,
276             # Smenu) another hash with property - value pairs. modify at will,
277             # then print map {"$_: $hash->{$_};"} keys $hash; where $hash is the
278             # properties hash for an element.
279              
280             sub baseCSS {
281 0     0 1   my $self = shift; # Never used - class method.
282 0           return {caption => {},
283             Mmenu => {position => 'absolute', top => '1', left => '1',
284             'z-index' => 10, visibility => 'hidden'},
285             Smenu => {position => 'absolute', top => '1', left => '1',
286             'z-index' => 10, visibility => 'hidden'}
287             };
288             }
289              
290             # does the same thing as only with more properties.
291             # Arguments: None.
292             # Returns: See .
293              
294             sub reasonableCSS {
295 0     0 1   my $self = shift; # Never used - class method.
296 0           return {caption => {_border => 'solid 1px black',
297             'text-decoration' => 'none',
298             background => 'blue', width => '10%',
299             color => 'white', 'font-weight' => 'bold'},
300             Mmenu => {position => 'absolute', top => '1', left => '1',
301             background => 'cyan', 'z-index' => 10,
302             visibility => 'hidden', 'text-decoration' => 'none'},
303             Smenu => {position => 'absolute', top => '1', left => '1',
304             background => 'cyan', 'z-index' => 10,
305             visibility => 'hidden', 'text-decoration' => 'none'},
306             _Mmenu => {background => 'blue', 'z-index' => 10,
307             color=>'white'},
308             _Smenu => {background => 'blue', 'z-index' => 10,
309             color => 'white'}
310              
311             };
312             }
313              
314             # turns the datastructure provided by the previous two subs into
315             # valid CSS. Hash keys are converted into classes, and hash keys preceded
316             # with an underscore are converted into the "class td:hover" syntax.
317             # Arguments: $raw_css - The datastructure described in .
318             # $no_ie - no anchor style will be added to the hover style if true.
319             # $no_autolink - prevents generation af a:link if true.
320             # Returns: A string containing the CSS.
321              
322             sub buildCSS {
323 0     0 1   my $self = shift; # Never used - class method.
324 0           my ($raw_css, $no_ie, $no_autolink) = @_;
325 0           my $css = '';
326 0 0         my $ie_bloat = ($no_ie) ? '' : ' a';
327            
328 0           for my $class (keys %$raw_css) {
329 0           my %props = %{ $raw_css->{$class} };
  0            
330 0 0         my $hover = ($class =~ s/^_//) ? 1 : 0;
331              
332 0           $css .= ".$class ";
333 0 0         $css .= "td${ie_bloat}:hover" if ($hover);
334 0           $css .= " {\n";
335 0           $css .= join "\n",
336 0           map {my $under=$_; s/^_//; "\t$_: $props{$under};"}
  0            
  0            
337             keys %props;
338 0           $css .= "\n}\n\n";
339              
340             # Generate link style for IE6 support...
341 0 0 0       unless ($hover || $no_ie || $no_autolink) {
      0        
342 0           my %hprops = %props;
343 0           delete @hprops{'position', 'top', 'left', 'right', 'bottom',
344             'visibility', 'z-index'};
345 0           %hprops = map {$_=>$hprops{$_}} grep /^[^_]/, keys %hprops;
  0            
346 0           $css .= ".$class a:link, .$class a:visited ";
347 0           $css .= " {\n";
348 0           $css .= join "\n", map {"\t$_: $hprops{$_};"} keys %hprops;
  0            
349 0           $css .= "\n}\n\n";
350             }
351             }
352 0           return $css;
353             }
354              
355             # generates required Javascript code for use with this module.
356             # Arguments: $rtl - if right-to-left menu.
357             # $menu_delay - option to manually set microseconds of delay
358             # before a menu closes. Default is 500ms.
359             # Returns: Only the code. You can put this inside a