/[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 455 - (show annotations)
Mon Sep 20 19:13:27 2004 UTC (19 years, 6 months ago) by dpavlin
File size: 8206 byte(s)
break out from recursion loop

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

  ViewVC Help
Powered by ViewVC 1.1.26