/[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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 584 - (hide annotations)
Sat Nov 6 18:36:54 2004 UTC (15 years, 5 months ago) by dpavlin
File size: 11936 byte(s)
never show scrollbars (fix scrollbars in Firefox)

1 dpavlin 441 package WebPAC::Tree;
2    
3     use warnings;
4     use strict;
5    
6     use Carp;
7     use Log::Log4perl qw(get_logger :levels);
8 dpavlin 460 use YAML;
9 dpavlin 572 use Template;
10 dpavlin 441
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 dpavlin 572 data structure, but once you get hang of that, it's peace of cake :-)
19 dpavlin 441
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 dpavlin 454 code_arr => sub { @{$_[0]} },
28 dpavlin 441 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 dpavlin 454 have_children => sub { return $l->{$_[1]} },
37 dpavlin 572 iframe => 1,
38 dpavlin 441 },{
39     # level 1
40 dpavlin 454 code_arr => sub { @{$_[0]} },
41 dpavlin 441 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 dpavlin 572 style => 'display: none',
51 dpavlin 441 )};
52    
53 dpavlin 454 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 dpavlin 441 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 dpavlin 460 my $v900 = $t->{'lookup_v900'}->($code);
83 dpavlin 441
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 dpavlin 454 Returns children for next iteration of tree generation or undef.
99 dpavlin 441
100 dpavlin 460 my $next_lvl = $t->{'have_children'}->($code,$v900);
101 dpavlin 441
102 dpavlin 454 =item have_children_at_level
103 dpavlin 441
104 dpavlin 454 Returns children for next iteration and next level.
105 dpavlin 441
106 dpavlin 460 my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);
107 dpavlin 441
108 dpavlin 454 It's safe to return undef just for next level data (C<$next_lvl> in example
109     above) to stop recursion.
110    
111 dpavlin 572 =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 dpavlin 441 =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 dpavlin 573 detail_url => sub {
132     my $mfn = shift;
133 dpavlin 574 my $path = "thes/${mfn}.html";
134     return $path if (-e "./out/$path");
135 dpavlin 573 },
136 dpavlin 575 nodes_dir => 'nodes',
137 dpavlin 441 );
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 dpavlin 573 C<detail_url> code ref to check if detail html exists (and return URL if
145     it does).
146    
147 dpavlin 575 C<nodes_dir> is relative path from output directory where tree nodes for
148     iframes will be created.
149 dpavlin 574
150 dpavlin 441 =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 dpavlin 530 $log->logconfess("need tree") unless ($self->{'tree'});
163 dpavlin 441
164     $self->{'show_ids'} = [];
165     $self->{'hide_ids'} = [];
166    
167 dpavlin 575 # 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 dpavlin 530 $self->{'tree_html'} = $self->unroll(0,());
177 dpavlin 441
178 dpavlin 530 if (! $self->{'tree_html'}) {
179 dpavlin 492 $log->warn("no html generated by unroll...");
180     return;
181     }
182 dpavlin 471
183 dpavlin 530 return $self;
184     }
185 dpavlin 441
186 dpavlin 530 =head2 output
187    
188     Create output files from tree object
189    
190     $tree->output(
191     dir => './out',
192     html => 'browse.html',
193 dpavlin 572 template_dir => './output_template/',
194     template_tree => 'tree.tt',
195     template_node => 'node.tt',
196 dpavlin 530 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 dpavlin 572 C<template_dir> is directory with Template Toolkit templates.
205 dpavlin 530
206 dpavlin 572 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 dpavlin 530 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 dpavlin 572 foreach my $p (qw(dir html template_dir template_tree js)) {
223 dpavlin 530 $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 dpavlin 572 $log->debug("templates are in ",$args->{'template_dir'});
235 dpavlin 441
236 dpavlin 572 my $tt = Template->new(
237     INCLUDE_PATH => $args->{'template_dir'},
238     );
239 dpavlin 441
240 dpavlin 572 my $var = {
241     js => $args->{'dir'}.'/'.$args->{'js'},
242     tree => $html,
243     };
244 dpavlin 441
245 dpavlin 572 $log->info("creating '$html_file' with tree from ",$args->{'template_tree'});
246 dpavlin 441
247 dpavlin 572 $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 dpavlin 530 $self->generate_js(
252 dpavlin 572 file => $js_file,
253 dpavlin 530 );
254 dpavlin 441
255 dpavlin 575 if (! $self->{'nodes_dir'}) {
256 dpavlin 572 $log->warn("skipping node creation");
257     return $self;
258     }
259    
260     foreach my $mfn (keys %{$self->{'node_html'}}) {
261    
262 dpavlin 575 my $html_file = $args->{'dir'}."/".$self->{'nodes_dir'}."/${mfn}.html";
263 dpavlin 572
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 dpavlin 441 return $self;
274     }
275    
276     =head2 unroll
277    
278     Generate tree recursively.
279    
280 dpavlin 460 my $html = $tree->unroll($level,$data_arr);
281 dpavlin 441
282     =cut
283    
284     sub unroll {
285     my $self = shift;
286    
287 dpavlin 573 my ($level,$data_arr, $base_path) = @_;
288 dpavlin 441
289 dpavlin 573 $base_path ||= '';
290    
291 dpavlin 455 my $log = $self->_get_logger();
292    
293     if (! defined($level)) {
294     $log->warn("level is undef, stoping recursion...");
295     return;
296     }
297    
298 dpavlin 454 my $next_level = $level + 1;
299    
300 dpavlin 441 $log->logconfess("need level") unless (defined($level));
301 dpavlin 460 #$log->logconfess("need data_arr") unless (defined($data_arr));
302 dpavlin 441
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 dpavlin 575 $log->debug("unroll level $level base path ",($base_path || "none"));
311 dpavlin 441
312     my $html;
313    
314 dpavlin 460 foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
315 dpavlin 441
316     if ($code = $tree->[$level]->{'filter_code'}->($code)) {
317    
318     $log->debug("# $level filter passed code $code");
319    
320 dpavlin 460 my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
321     $log->debug("# $level lookup_v900($code) = $v900");
322 dpavlin 441
323 dpavlin 471 my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && next;
324 dpavlin 441 $log->debug("# $level lookup_term($code,$v900) = $term");
325    
326 dpavlin 471 my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) || $log->warn("can't lookup_mfn($code,$v900)") && next;
327 dpavlin 441 $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
328    
329     $log->debug("$code -> $v900 : $term [$mfn]");
330    
331 dpavlin 576 my ($link_start,$link_end,$level_el) = ('','','ul');
332 dpavlin 441
333 dpavlin 460 my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
334 dpavlin 454
335     if (! $have_children) {
336 dpavlin 460 $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 dpavlin 454
340 dpavlin 441 }
341    
342 dpavlin 575 my $iframe = $tree->[$level]->{'iframe'};
343 dpavlin 454
344 dpavlin 575 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 dpavlin 576 $level_el = 'div';
351 dpavlin 575 }
352     }
353    
354 dpavlin 573 my $mfn_link;
355     $mfn_link = $self->{'detail_url'}->($mfn) if ($self->{'detail_url'});
356    
357     if ($mfn_link) {
358 dpavlin 574 $term =~ s/ *#C# */ <img src="${base_path}img\/crovoc.png" border="0">/;
359 dpavlin 441 $html .= " " x $level .
360 dpavlin 499 qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
361 dpavlin 573 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 dpavlin 441 } else {
364     $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
365     }
366    
367 dpavlin 574 # save mfn for iframe
368     push @{$self->{'mfn_arr'}}, $mfn;
369    
370 dpavlin 441 unless ($have_children) {
371     next;
372     }
373     my $style = $tree->[$level]->{'style'};
374    
375     $html .= " " x $level .
376 dpavlin 576 qq{<$level_el id="id$mfn"}.
377     ($style ? ' style="'.$style.';"' : '').
378 dpavlin 441 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 dpavlin 574
392 dpavlin 575 if ($iframe) {
393 dpavlin 574
394     # reset list of current mfns
395     $self->{'mfn_arr'} = ();
396    
397 dpavlin 572 # unroll to separate file
398 dpavlin 574 $self->{'node_html'}->{$mfn} = $self->unroll($next_level, $have_children, $self->{'iframe_base'});
399 dpavlin 580 $html .= " " x $level . qq{<span id="w$mfn" style="display: none;">Uèitavanje podataka...</span>\n};
400    
401 dpavlin 574 $html .= " " x $level .
402 dpavlin 584 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 dpavlin 574 @{$self->{'iframe_mfn'}->{$mfn}} = @{$self->{'mfn_arr'}};
404 dpavlin 572
405     } else {
406     # unroll at base HTML
407 dpavlin 573 $html .= $self->unroll($next_level, $have_children, $base_path);
408 dpavlin 572 }
409    
410 dpavlin 576 $html .= " " x $level . qq{</$level_el>\n};
411 dpavlin 441
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 dpavlin 530 $tree->generate_js(
423     file = "./out/tree-ids.js",
424     );
425 dpavlin 441
426     =cut
427    
428     sub generate_js {
429     my $self = shift;
430    
431 dpavlin 530 my $args = {@_};
432    
433 dpavlin 441 my $log = $self->_get_logger();
434    
435 dpavlin 530 my $js_file = $args->{'file'};
436     $log->die("need file") unless ($args->{'file'});
437 dpavlin 441
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 dpavlin 574
444 dpavlin 581 my @mfn_iframe;
445    
446 dpavlin 574 foreach my $if (keys %{$self->{'iframe_mfn'}}) {
447 dpavlin 581 push @mfn_iframe, join(",", map { "$_:$if" } @{$self->{'iframe_mfn'}->{$if}});
448 dpavlin 574 }
449 dpavlin 581
450     print JS "var mfn_iframe = {\n",join(",\n",@mfn_iframe),"\n};\n";
451 dpavlin 574
452 dpavlin 441 close(JS);
453    
454 dpavlin 442 $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
455 dpavlin 441
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