/[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 492 - (show annotations)
Sat Oct 9 21:48:30 2004 UTC (16 years, 7 months ago) by dpavlin
File size: 8207 byte(s)
warn and not die if there is no html generated for tree (while debugging for
example)

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 dir => './out',
118 html => 'browse.html',
119 template => './output_template/tree.tt',
120 js => 'tree-ids.js',
121 tree => \@tree,
122 log => 'log4perl.conf',
123 );
124
125 C<dir> is output directory in which html files and JavaScript files will be
126 created (think of it as C<public_html>).
127
128 C<html> is name of output html file.
129
130 C<template> is name of template. It uses Template Toolkit syntax [% var %],
131 but doesn't really use TT.
132
133 C<js> is name of JavaScript file with shown and hidden ids.
134
135 C<tree> is tree array with levels of tree described above.
136
137 C<log> is optional parametar which specify filename of L<Log::Log4Perl>
138 config file. Default is C<log.conf>.
139
140 =cut
141
142 sub new {
143 my $class = shift;
144 my $self = {@_};
145 bless($self, $class);
146
147 my $log_file = $self->{'log'} || "log.conf";
148 Log::Log4perl->init($log_file);
149
150 my $log = $self->_get_logger();
151
152 foreach my $p (qw(dir html template js tree)) {
153 $log->logconfess("need $p") unless ($self->{$p});
154 }
155
156 $self->{'show_ids'} = [];
157 $self->{'hide_ids'} = [];
158
159 my $html = $self->unroll(0,());
160
161 if (! $html) {
162 $log->warn("no html generated by unroll...");
163 return;
164 }
165
166 my $html_file = $self->{'dir'}.'/'.$self->{'html'};
167
168 open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");
169 my $tmpl;
170 while(<TEMPLATE>) {
171 $tmpl .= $_;
172 }
173 close(TEMPLATE);
174
175 $log->info("creating '$html_file' with tree");
176
177 my $js_arr_file = $self->{'js'};
178 $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;
179 $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;
180
181 open(HTML, ">", $html_file) || $log->logdie("can't open '$html_file': $!");
182 print HTML $tmpl;
183 close(HTML);
184
185 $self->generate_js();
186
187 return $self;
188 }
189
190 =head2 unroll
191
192 Generate tree recursively.
193
194 my $html = $tree->unroll($level,$data_arr);
195
196 =cut
197
198 sub unroll {
199 my $self = shift;
200
201 my ($level,$data_arr) = @_;
202
203 my $log = $self->_get_logger();
204
205 if (! defined($level)) {
206 $log->warn("level is undef, stoping recursion...");
207 return;
208 }
209
210 my $next_level = $level + 1;
211
212 $log->logconfess("need level") unless (defined($level));
213 #$log->logconfess("need data_arr") unless (defined($data_arr));
214
215 my $tree = $self->{'tree'};
216
217 $log->logconfess("tree is not defined") unless (defined($tree));
218
219 # all levels passed?
220 return if (! defined($tree->[$level]));
221
222 $log->debug("unroll level $level");
223
224 my $html;
225
226 foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
227
228 if ($code = $tree->[$level]->{'filter_code'}->($code)) {
229
230 $log->debug("# $level filter passed code $code");
231
232 my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
233 $log->debug("# $level lookup_v900($code) = $v900");
234
235 my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && next;
236 $log->debug("# $level lookup_term($code,$v900) = $term");
237
238 my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) || $log->warn("can't lookup_mfn($code,$v900)") && next;
239 $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
240
241 $log->debug("$code -> $v900 : $term [$mfn]");
242
243 my ($link_start,$link_end) = ('','');
244
245 my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
246
247 if (! $have_children) {
248 $log->debug("# $level doesn't have_children($code,$v900)");
249 ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
250 $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
251
252 }
253
254 ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
255
256 my $mfn_link = "thes/$mfn.html";
257 if (-e "out/$mfn_link") {
258 $html .= " " x $level .
259 qq{<li><a name="mfn${mfn}"></a>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
260 qq{&nbsp;<a href="$mfn_link" onClick="javascript:return popup(this);">&raquo;</a></li>\n};
261 } else {
262 $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
263 }
264
265 unless ($have_children) {
266 next;
267 }
268 my $style = $tree->[$level]->{'style'};
269
270 $html .= " " x $level .
271 qq{<ul id="id$mfn"}.
272 ($style ? ' style="'.$style.'"' : '').
273 qq{>\n};
274
275 if ($style) {
276 if ($style =~ m/display\s*:\s*none/i) {
277 push @{$self->{'hide_ids'}}, "id$mfn";
278 } else {
279 push @{$self->{'show_ids'}}, "id$mfn";
280 }
281 } else {
282 # default: show
283 push @{$self->{'show_ids'}}, "id$mfn";
284 }
285
286 $html .= $self->unroll($next_level, $have_children);
287
288 $html .= " " x $level . qq{</ul>\n};
289
290 }
291 }
292 return $html;
293 }
294
295 =head2 generate_js
296
297 Generate JavaScript arrays C<show> and C<hide> used to toggle display of
298 elements.
299
300 $tree->generate_js();
301
302 =cut
303
304 sub generate_js {
305 my $self = shift;
306
307 my $log = $self->_get_logger();
308
309 my $js_file = $self->{'dir'}.'/'.$self->{'js'};
310
311 $log->info("creating '$js_file' with arrays of shown and hidden ids");
312
313 open(JS, ">", $js_file) || $log->logdie("can't open '$js_file': $!");
314 print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";
315 print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";
316 close(JS);
317
318 $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
319
320 }
321
322 #
323
324 =head1 INTERNAL METHODS
325
326 You shouldn't call this methods directly.
327
328 =head2 _get_logger
329
330 Get C<Log::Log4perl> object with a twist: domains are defined for each
331 method
332
333 my $log = $webpac->_get_logger();
334
335 =cut
336
337 sub _get_logger {
338 my $self = shift;
339
340 my $name = (caller(1))[3] || caller;
341 return get_logger($name);
342 }
343
344 1;

  ViewVC Help
Powered by ViewVC 1.1.26