/[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 460 - (show annotations)
Tue Sep 21 20:43:43 2004 UTC (15 years, 5 months ago) by dpavlin
File size: 8093 byte(s)
fixed tree generation (have_children_at_level still doesn't work)

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 my $html_file = $self->{'dir'}.'/'.$self->{'html'};
162
163 open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");
164 my $tmpl;
165 while(<TEMPLATE>) {
166 $tmpl .= $_;
167 }
168 close(TEMPLATE);
169
170 $log->info("creating '$html_file' with tree");
171
172 my $js_arr_file = $self->{'js'};
173 $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;
174 $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;
175
176 open(HTML, ">", $html_file) || $log->logdie("can't open '$html_file': $!");
177 print HTML $tmpl;
178 close(HTML);
179
180 $self->generate_js();
181
182 return $self;
183 }
184
185 =head2 unroll
186
187 Generate tree recursively.
188
189 my $html = $tree->unroll($level,$data_arr);
190
191 =cut
192
193 sub unroll {
194 my $self = shift;
195
196 my ($level,$data_arr) = @_;
197
198 my $log = $self->_get_logger();
199
200 if (! defined($level)) {
201 $log->warn("level is undef, stoping recursion...");
202 return;
203 }
204
205 my $next_level = $level + 1;
206
207 $log->logconfess("need level") unless (defined($level));
208 #$log->logconfess("need data_arr") unless (defined($data_arr));
209
210 my $tree = $self->{'tree'};
211
212 $log->logconfess("tree is not defined") unless (defined($tree));
213
214 # all levels passed?
215 return if (! defined($tree->[$level]));
216
217 $log->debug("unroll level $level");
218
219 my $html;
220
221 foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
222
223 if ($code = $tree->[$level]->{'filter_code'}->($code)) {
224
225 $log->debug("# $level filter passed code $code");
226
227 my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
228 $log->debug("# $level lookup_v900($code) = $v900");
229
230 my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && return;
231 $log->debug("# $level lookup_term($code,$v900) = $term");
232
233 my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) || $log->warn("can't lookup_mfn($code,$v900)") && return;
234 $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
235
236 $log->debug("$code -> $v900 : $term [$mfn]");
237
238 my ($link_start,$link_end) = ('','');
239
240 my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
241
242 if (! $have_children) {
243 $log->debug("# $level doesn't have_children($code,$v900)");
244 ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
245 $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
246
247 }
248
249 ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
250
251 my $mfn_link = "thes/$mfn.html";
252 if (-e "out/$mfn_link") {
253 $html .= " " x $level .
254 qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
255 qq{&nbsp;<a href="$mfn_link">&raquo;</a></li>\n};
256 } else {
257 $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
258 }
259
260 unless ($have_children) {
261 next;
262 }
263 my $style = $tree->[$level]->{'style'};
264
265 $html .= " " x $level .
266 qq{<a name="mfn$mfn"></a>\n <ul id="id$mfn"}.
267 ($style ? ' style="'.$style.'"' : '').
268 qq{>\n};
269
270 if ($style) {
271 if ($style =~ m/display\s*:\s*none/i) {
272 push @{$self->{'hide_ids'}}, "id$mfn";
273 } else {
274 push @{$self->{'show_ids'}}, "id$mfn";
275 }
276 } else {
277 # default: show
278 push @{$self->{'show_ids'}}, "id$mfn";
279 }
280
281 $html .= $self->unroll($next_level, $have_children);
282
283 $html .= " " x $level . qq{</ul>\n};
284
285 }
286 }
287 return $html;
288 }
289
290 =head2 generate_js
291
292 Generate JavaScript arrays C<show> and C<hide> used to toggle display of
293 elements.
294
295 $tree->generate_js();
296
297 =cut
298
299 sub generate_js {
300 my $self = shift;
301
302 my $log = $self->_get_logger();
303
304 my $js_file = $self->{'dir'}.'/'.$self->{'js'};
305
306 $log->info("creating '$js_file' with arrays of shown and hidden ids");
307
308 open(JS, ">", $js_file) || $log->logdie("can't open '$js_file': $!");
309 print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";
310 print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";
311 close(JS);
312
313 $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
314
315 }
316
317 #
318
319 =head1 INTERNAL METHODS
320
321 You shouldn't call this methods directly.
322
323 =head2 _get_logger
324
325 Get C<Log::Log4perl> object with a twist: domains are defined for each
326 method
327
328 my $log = $webpac->_get_logger();
329
330 =cut
331
332 sub _get_logger {
333 my $self = shift;
334
335 my $name = (caller(1))[3] || caller;
336 return get_logger($name);
337 }
338
339 1;

  ViewVC Help
Powered by ViewVC 1.1.26