/[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 471 - (show annotations)
Sun Sep 26 15:11:36 2004 UTC (19 years, 6 months ago) by dpavlin
File size: 8221 byte(s)
minor changes to have_children_at_level (but it's not really used),
fixed lookup (which obsoleted have_children_at_level :-)

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

  ViewVC Help
Powered by ViewVC 1.1.26