/[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 443 - (show annotations)
Tue Sep 14 20:57:58 2004 UTC (16 years, 1 month ago) by dpavlin
File size: 7635 byte(s)
add span for outline

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

  ViewVC Help
Powered by ViewVC 1.1.26