/[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 584 - (show annotations)
Sat Nov 6 18:36:54 2004 UTC (19 years, 4 months ago) by dpavlin
File size: 11936 byte(s)
never show scrollbars (fix scrollbars in Firefox)

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 detail_url => sub {
132 my $mfn = shift;
133 my $path = "thes/${mfn}.html";
134 return $path if (-e "./out/$path");
135 },
136 nodes_dir => 'nodes',
137 );
138
139 C<tree> is tree array with levels of tree described above.
140
141 C<log> is optional parametar which specify filename of L<Log::Log4Perl>
142 config file. Default is C<log.conf>.
143
144 C<detail_url> code ref to check if detail html exists (and return URL if
145 it does).
146
147 C<nodes_dir> is relative path from output directory where tree nodes for
148 iframes will be created.
149
150 =cut
151
152 sub new {
153 my $class = shift;
154 my $self = {@_};
155 bless($self, $class);
156
157 my $log_file = $self->{'log'} || "log.conf";
158 Log::Log4perl->init($log_file);
159
160 my $log = $self->_get_logger();
161
162 $log->logconfess("need tree") unless ($self->{'tree'});
163
164 $self->{'show_ids'} = [];
165 $self->{'hide_ids'} = [];
166
167 # figure out relative URL to other content from nodes_dir
168 my $iframe_base = $self->{'nodes_dir'};
169 if ($iframe_base) {
170 $iframe_base = s#[^/]*##g;
171 $iframe_base = '../' x ( length($iframe_base) );
172 $self->{'iframe_base'} = $iframe_base;
173 $log->debug("nodes dir is '",$self->{'nodes_dir'},"' so iframe_base is '",$self->{'iframe_base'},"'");
174 }
175
176 $self->{'tree_html'} = $self->unroll(0,());
177
178 if (! $self->{'tree_html'}) {
179 $log->warn("no html generated by unroll...");
180 return;
181 }
182
183 return $self;
184 }
185
186 =head2 output
187
188 Create output files from tree object
189
190 $tree->output(
191 dir => './out',
192 html => 'browse.html',
193 template_dir => './output_template/',
194 template_tree => 'tree.tt',
195 template_node => 'node.tt',
196 js => 'tree-ids.js',
197 );
198
199 C<dir> is output directory in which html files and JavaScript files will be
200 created (think of it as C<public_html>).
201
202 C<html> is name of output html file.
203
204 C<template_dir> is directory with Template Toolkit templates.
205
206 C<template_tree> is name of template to produce tree.
207
208 C<template_node> is (optional) name of template for node (if C<iframe>
209 options is used within tree definition).
210
211 C<js> is name of JavaScript file with shown and hidden ids.
212
213 =cut
214
215 sub output {
216 my $self = shift;
217
218 my $args = {@_};
219
220 my $log = $self->_get_logger();
221
222 foreach my $p (qw(dir html template_dir template_tree js)) {
223 $log->logconfess("need $p") unless ($args->{$p});
224 }
225
226 my $html = $self->{'tree_html'};
227 unless ($html) {
228 $log->warn("no html, output aborted");
229 return;
230 }
231
232 my $html_file = $args->{'dir'}.'/'.$args->{'html'};
233
234 $log->debug("templates are in ",$args->{'template_dir'});
235
236 my $tt = Template->new(
237 INCLUDE_PATH => $args->{'template_dir'},
238 );
239
240 my $var = {
241 js => $args->{'dir'}.'/'.$args->{'js'},
242 tree => $html,
243 };
244
245 $log->info("creating '$html_file' with tree from ",$args->{'template_tree'});
246
247 $tt->process($args->{'template_tree'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
248
249 my $js_file = $args->{'dir'}."/".$args->{'js'};
250 $log->info("creating '$js_file' with tree data");
251 $self->generate_js(
252 file => $js_file,
253 );
254
255 if (! $self->{'nodes_dir'}) {
256 $log->warn("skipping node creation");
257 return $self;
258 }
259
260 foreach my $mfn (keys %{$self->{'node_html'}}) {
261
262 my $html_file = $args->{'dir'}."/".$self->{'nodes_dir'}."/${mfn}.html";
263
264 $log->debug("creating tree node $html_file");
265
266 $var = {
267 node => $self->{'node_html'}->{$mfn},
268 };
269
270 $tt->process($args->{'template_node'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
271 }
272
273 return $self;
274 }
275
276 =head2 unroll
277
278 Generate tree recursively.
279
280 my $html = $tree->unroll($level,$data_arr);
281
282 =cut
283
284 sub unroll {
285 my $self = shift;
286
287 my ($level,$data_arr, $base_path) = @_;
288
289 $base_path ||= '';
290
291 my $log = $self->_get_logger();
292
293 if (! defined($level)) {
294 $log->warn("level is undef, stoping recursion...");
295 return;
296 }
297
298 my $next_level = $level + 1;
299
300 $log->logconfess("need level") unless (defined($level));
301 #$log->logconfess("need data_arr") unless (defined($data_arr));
302
303 my $tree = $self->{'tree'};
304
305 $log->logconfess("tree is not defined") unless (defined($tree));
306
307 # all levels passed?
308 return if (! defined($tree->[$level]));
309
310 $log->debug("unroll level $level base path ",($base_path || "none"));
311
312 my $html;
313
314 foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
315
316 if ($code = $tree->[$level]->{'filter_code'}->($code)) {
317
318 $log->debug("# $level filter passed code $code");
319
320 my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
321 $log->debug("# $level lookup_v900($code) = $v900");
322
323 my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && next;
324 $log->debug("# $level lookup_term($code,$v900) = $term");
325
326 my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) || $log->warn("can't lookup_mfn($code,$v900)") && next;
327 $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
328
329 $log->debug("$code -> $v900 : $term [$mfn]");
330
331 my ($link_start,$link_end,$level_el) = ('','','ul');
332
333 my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
334
335 if (! $have_children) {
336 $log->debug("# $level doesn't have_children($code,$v900)");
337 ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
338 $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
339
340 }
341
342 my $iframe = $tree->[$level]->{'iframe'};
343
344 if ($have_children) {
345 ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>});
346 if ($iframe) {
347 my $url = $self->{'nodes_dir'} || $log->logdie("no nodes_dir?");
348 $url .= "/${mfn}.html";
349 $link_start = qq{<a href="#mfn$mfn" onClick="iframe_load('i$mfn','$url'); return toggle_display('id$mfn');">};
350 $level_el = 'div';
351 }
352 }
353
354 my $mfn_link;
355 $mfn_link = $self->{'detail_url'}->($mfn) if ($self->{'detail_url'});
356
357 if ($mfn_link) {
358 $term =~ s/ *#C# */ <img src="${base_path}img\/crovoc.png" border="0">/;
359 $html .= " " x $level .
360 qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
361 qq{&nbsp;<a href="${base_path}${mfn_link}" onClick="javascript:return popup(this);"><img src="${base_path}img/listic.png" border="0"></a></li>\n};
362 $log->debug("linked details to $mfn_link");
363 } else {
364 $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
365 }
366
367 # save mfn for iframe
368 push @{$self->{'mfn_arr'}}, $mfn;
369
370 unless ($have_children) {
371 next;
372 }
373 my $style = $tree->[$level]->{'style'};
374
375 $html .= " " x $level .
376 qq{<$level_el id="id$mfn"}.
377 ($style ? ' style="'.$style.';"' : '').
378 qq{>\n};
379
380 if ($style) {
381 if ($style =~ m/display\s*:\s*none/i) {
382 push @{$self->{'hide_ids'}}, "id$mfn";
383 } else {
384 push @{$self->{'show_ids'}}, "id$mfn";
385 }
386 } else {
387 # default: show
388 push @{$self->{'show_ids'}}, "id$mfn";
389 }
390
391
392 if ($iframe) {
393
394 # reset list of current mfns
395 $self->{'mfn_arr'} = ();
396
397 # unroll to separate file
398 $self->{'node_html'}->{$mfn} = $self->unroll($next_level, $have_children, $self->{'iframe_base'});
399 $html .= " " x $level . qq{<span id="w$mfn" style="display: none;">Uèitavanje podataka...</span>\n};
400
401 $html .= " " x $level .
402 qq{<iframe id="i$mfn" name="i$mfn" width="100%" height="0" marginwidth="0" marginheight="0" style="margin: 0;" frameborder="0" border="0" onLoad="iframe_resize(this.name);" scrolling="no"></iframe>\n};
403 @{$self->{'iframe_mfn'}->{$mfn}} = @{$self->{'mfn_arr'}};
404
405 } else {
406 # unroll at base HTML
407 $html .= $self->unroll($next_level, $have_children, $base_path);
408 }
409
410 $html .= " " x $level . qq{</$level_el>\n};
411
412 }
413 }
414 return $html;
415 }
416
417 =head2 generate_js
418
419 Generate JavaScript arrays C<show> and C<hide> used to toggle display of
420 elements.
421
422 $tree->generate_js(
423 file = "./out/tree-ids.js",
424 );
425
426 =cut
427
428 sub generate_js {
429 my $self = shift;
430
431 my $args = {@_};
432
433 my $log = $self->_get_logger();
434
435 my $js_file = $args->{'file'};
436 $log->die("need file") unless ($args->{'file'});
437
438 $log->info("creating '$js_file' with arrays of shown and hidden ids");
439
440 open(JS, ">", $js_file) || $log->logdie("can't open '$js_file': $!");
441 print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";
442 print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";
443
444 my @mfn_iframe;
445
446 foreach my $if (keys %{$self->{'iframe_mfn'}}) {
447 push @mfn_iframe, join(",", map { "$_:$if" } @{$self->{'iframe_mfn'}->{$if}});
448 }
449
450 print JS "var mfn_iframe = {\n",join(",\n",@mfn_iframe),"\n};\n";
451
452 close(JS);
453
454 $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
455
456 }
457
458 #
459
460 =head1 INTERNAL METHODS
461
462 You shouldn't call this methods directly.
463
464 =head2 _get_logger
465
466 Get C<Log::Log4perl> object with a twist: domains are defined for each
467 method
468
469 my $log = $webpac->_get_logger();
470
471 =cut
472
473 sub _get_logger {
474 my $self = shift;
475
476 my $name = (caller(1))[3] || caller;
477 return get_logger($name);
478 }
479
480 1;

  ViewVC Help
Powered by ViewVC 1.1.26