/[webpac]/trunk2/lib/WebPAC/Tree.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk2/lib/WebPAC/Tree.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 572 - (show annotations)
Mon Nov 1 14:55:16 2004 UTC (14 years, 9 months ago) by dpavlin
File size: 9934 byte(s)
convert WebPAC::Tree to use Template Toolkit,
started adding support for nodes in iframe

1 package WebPAC::Tree;
2
3 use warnings;
4 use strict;
5
6 use Carp;
7 use Log::Log4perl qw(get_logger :levels);
8 use YAML;
9 use Template;
10
11 =head1 NAME
12
13 WebPAC::Tree - create tree from lookup data
14
15 =head1 DESCRIPTION
16
17 This module will create tree from lookup data. It requires quite complicated
18 data structure, but once you get hang of that, it's peace of cake :-)
19
20 Data structure for tree definition is non-recursive, and defines each level
21 of tree individually (so you can limit depth of tree) like this:
22
23 my $l = $webpac->{'lookup'};
24
25 my @tree = ({
26 # level 0
27 code_arr => sub { @{$_[0]} },
28 filter_code => sub { shift },
29 lookup_v900 => sub {
30 my ($c,$p) = @_;
31 $p =~ s/^a:(..:....):.*$/$1/;
32 return "a:".$p.":".$c;
33 },
34 lookup_term => sub { shift @{$l->{"d:".$_[0]}} },
35 lookup_mfn => sub { shift @{$l->{"900_mfn:".$_[0]}} },
36 have_children => sub { return $l->{$_[1]} },
37 iframe => 1,
38 },{
39 # level 1
40 code_arr => sub { @{$_[0]} },
41 filter_code => sub { shift },
42 lookup_v900 => sub {
43 my ($c,$p) = @_;
44 $p =~ s/^a:(..:....):.*$/$1/;
45 return "a:".$p.":".$c;
46 },
47 lookup_term => sub { shift @{$l->{"d:".$_[0]}} },
48 lookup_mfn => sub { shift @{$l->{"900_mfn:".$_[0]}} },
49 have_children => sub { 0 },
50 style => 'display: none',
51 )};
52
53 You can, however, create recursion with C<have_children_at_level> discussed
54 below, but you loose ability to limit tree depth or to specify different
55 style for each level.
56
57 Documentation for each element of tree is little sparse, but here it is:
58
59 =over 5
60
61 =item code_arr
62
63 Called once for each level.
64
65 @mfns = $t->{'code_arr'}->($start_code);
66
67 Returns codes for this level.
68
69 =item filter_code
70
71 Optional function (which can be replaced by C<shift>) to filter which codes
72 are displayed.
73
74 $t->{'filter_code'}->($code);
75
76 Returns code or C<false> if code has to be skipped.
77
78 =item lookup_v900
79
80 Lookup value which will be called C<$v900> from now on.
81
82 my $v900 = $t->{'lookup_v900'}->($code);
83
84 =item lookup_term
85
86 Lookup term value, displayed as name of tree element.
87
88 my $term = $t->{'lookup_term'}->($code,$v900);
89
90 =item lookup_mfn
91
92 Lookup mfn value, used to create hyperlink from tree.
93
94 my $mfn = $t->{'lookup_mfn'}->($code,$v900);
95
96 =item have_children
97
98 Returns children for next iteration of tree generation or undef.
99
100 my $next_lvl = $t->{'have_children'}->($code,$v900);
101
102 =item have_children_at_level
103
104 Returns children for next iteration and next level.
105
106 my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);
107
108 It's safe to return undef just for next level data (C<$next_lvl> in example
109 above) to stop recursion.
110
111 =item iframe
112
113 This optional option will create all children nodes in separate file, and iframe in tree html,
114 so that generated tee html will have resonable size with large number of nodes.
115
116 =item style
117
118 Optional option to specify style of this node.
119
120 =back
121
122 =head1 METHODS
123
124 =head2 new
125
126 Create new tree object
127
128 my $tree = new WebPAC::Tree(
129 tree => \@tree,
130 log => 'log4perl.conf',
131 );
132
133 C<tree> is tree array with levels of tree described above.
134
135 C<log> is optional parametar which specify filename of L<Log::Log4Perl>
136 config file. Default is C<log.conf>.
137
138 =cut
139
140 sub new {
141 my $class = shift;
142 my $self = {@_};
143 bless($self, $class);
144
145 my $log_file = $self->{'log'} || "log.conf";
146 Log::Log4perl->init($log_file);
147
148 my $log = $self->_get_logger();
149
150 $log->logconfess("need tree") unless ($self->{'tree'});
151
152 $self->{'show_ids'} = [];
153 $self->{'hide_ids'} = [];
154
155 $self->{'tree_html'} = $self->unroll(0,());
156
157 if (! $self->{'tree_html'}) {
158 $log->warn("no html generated by unroll...");
159 return;
160 }
161
162 return $self;
163 }
164
165 =head2 output
166
167 Create output files from tree object
168
169 $tree->output(
170 dir => './out',
171 html => 'browse.html',
172 template_dir => './output_template/',
173 template_tree => 'tree.tt',
174 template_node => 'node.tt',
175 js => 'tree-ids.js',
176 );
177
178 C<dir> is output directory in which html files and JavaScript files will be
179 created (think of it as C<public_html>).
180
181 C<html> is name of output html file.
182
183 C<template_dir> is directory with Template Toolkit templates.
184
185 C<template_tree> is name of template to produce tree.
186
187 C<template_node> is (optional) name of template for node (if C<iframe>
188 options is used within tree definition).
189
190 C<js> is name of JavaScript file with shown and hidden ids.
191
192 =cut
193
194 sub output {
195 my $self = shift;
196
197 my $args = {@_};
198
199 my $log = $self->_get_logger();
200
201 foreach my $p (qw(dir html template_dir template_tree js)) {
202 $log->logconfess("need $p") unless ($args->{$p});
203 }
204
205 my $html = $self->{'tree_html'};
206 unless ($html) {
207 $log->warn("no html, output aborted");
208 return;
209 }
210
211 my $html_file = $args->{'dir'}.'/'.$args->{'html'};
212
213 $log->debug("templates are in ",$args->{'template_dir'});
214
215 my $tt = Template->new(
216 INCLUDE_PATH => $args->{'template_dir'},
217 );
218
219 my $var = {
220 js => $args->{'dir'}.'/'.$args->{'js'},
221 tree => $html,
222 };
223
224 $log->info("creating '$html_file' with tree from ",$args->{'template_tree'});
225
226 $tt->process($args->{'template_tree'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
227
228 my $js_file = $args->{'dir'}."/".$args->{'js'};
229 $log->info("creating '$js_file' with tree data");
230 $self->generate_js(
231 file => $js_file,
232 );
233
234 if (! $args->{'nodes'}) {
235 $log->warn("skipping node creation");
236 return $self;
237 }
238
239 foreach my $mfn (keys %{$self->{'node_html'}}) {
240
241 my $html_file = $args->{'dir'}."/".$args->{'nodes'}."/${mfn}.html";
242
243 $log->debug("creating tree node $html_file");
244
245 $var = {
246 node => $self->{'node_html'}->{$mfn},
247 };
248
249 $tt->process($args->{'template_node'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
250 }
251
252 return $self;
253 }
254
255 =head2 unroll
256
257 Generate tree recursively.
258
259 my $html = $tree->unroll($level,$data_arr);
260
261 =cut
262
263 sub unroll {
264 my $self = shift;
265
266 my ($level,$data_arr) = @_;
267
268 my $log = $self->_get_logger();
269
270 if (! defined($level)) {
271 $log->warn("level is undef, stoping recursion...");
272 return;
273 }
274
275 my $next_level = $level + 1;
276
277 $log->logconfess("need level") unless (defined($level));
278 #$log->logconfess("need data_arr") unless (defined($data_arr));
279
280 my $tree = $self->{'tree'};
281
282 $log->logconfess("tree is not defined") unless (defined($tree));
283
284 # all levels passed?
285 return if (! defined($tree->[$level]));
286
287 $log->debug("unroll level $level");
288
289 my $html;
290
291 foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
292
293 if ($code = $tree->[$level]->{'filter_code'}->($code)) {
294
295 $log->debug("# $level filter passed code $code");
296
297 my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
298 $log->debug("# $level lookup_v900($code) = $v900");
299
300 my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && next;
301 $log->debug("# $level lookup_term($code,$v900) = $term");
302
303 my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) || $log->warn("can't lookup_mfn($code,$v900)") && next;
304 $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
305
306 $log->debug("$code -> $v900 : $term [$mfn]");
307
308 my ($link_start,$link_end) = ('','');
309
310 my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
311
312 if (! $have_children) {
313 $log->debug("# $level doesn't have_children($code,$v900)");
314 ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
315 $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
316
317 }
318
319 ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
320
321 my $mfn_link = "thes/$mfn.html";
322 if (-e "out/$mfn_link") {
323 $term =~ s# *\* *# <img src="img/crovoc.png" border="0">#;
324 $html .= " " x $level .
325 qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
326 qq{&nbsp;<a href="$mfn_link" onClick="javascript:return popup(this);"><img src="img/listic.png" border="0"></a></li>\n};
327 } else {
328 $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
329 }
330
331 unless ($have_children) {
332 next;
333 }
334 my $style = $tree->[$level]->{'style'};
335
336 $html .= " " x $level .
337 qq{<ul id="id$mfn"}.
338 ($style ? ' style="'.$style.'"' : '').
339 qq{>\n};
340
341 if ($style) {
342 if ($style =~ m/display\s*:\s*none/i) {
343 push @{$self->{'hide_ids'}}, "id$mfn";
344 } else {
345 push @{$self->{'show_ids'}}, "id$mfn";
346 }
347 } else {
348 # default: show
349 push @{$self->{'show_ids'}}, "id$mfn";
350 }
351
352 if ($tree->[$level]->{'iframe'}) {
353 # unroll to separate file
354 $self->{'node_html'}->{$mfn} = $self->unroll($next_level, $have_children);
355
356 } else {
357 # unroll at base HTML
358 $html .= $self->unroll($next_level, $have_children);
359 }
360
361 $html .= " " x $level . qq{</ul>\n};
362
363 }
364 }
365 return $html;
366 }
367
368 =head2 generate_js
369
370 Generate JavaScript arrays C<show> and C<hide> used to toggle display of
371 elements.
372
373 $tree->generate_js(
374 file = "./out/tree-ids.js",
375 );
376
377 =cut
378
379 sub generate_js {
380 my $self = shift;
381
382 my $args = {@_};
383
384 my $log = $self->_get_logger();
385
386 my $js_file = $args->{'file'};
387 $log->die("need file") unless ($args->{'file'});
388
389 $log->info("creating '$js_file' with arrays of shown and hidden ids");
390
391 open(JS, ">", $js_file) || $log->logdie("can't open '$js_file': $!");
392 print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";
393 print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";
394 close(JS);
395
396 $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
397
398 }
399
400 #
401
402 =head1 INTERNAL METHODS
403
404 You shouldn't call this methods directly.
405
406 =head2 _get_logger
407
408 Get C<Log::Log4perl> object with a twist: domains are defined for each
409 method
410
411 my $log = $webpac->_get_logger();
412
413 =cut
414
415 sub _get_logger {
416 my $self = shift;
417
418 my $name = (caller(1))[3] || caller;
419 return get_logger($name);
420 }
421
422 1;

  ViewVC Help
Powered by ViewVC 1.1.26