/[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 530 - (show annotations)
Tue Oct 19 17:43:52 2004 UTC (15 years, 4 months ago) by dpavlin
File size: 8777 byte(s)
major restructuring of tree output: new function WebPAC::Tree::output which
produce output (so you can apply same output to more than one template)

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

  ViewVC Help
Powered by ViewVC 1.1.26