/[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 454 - (show annotations)
Wed Sep 15 22:36:23 2004 UTC (16 years, 2 months ago) by dpavlin
File size: 8112 byte(s)
new simplier implementation of WebPAC::Tree with support for recursion
(still buggy)

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

  ViewVC Help
Powered by ViewVC 1.1.26