/[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

Annotation of /trunk2/lib/WebPAC/Tree.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 492 - (hide annotations)
Sat Oct 9 21:48:30 2004 UTC (17 years 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 dpavlin 441 package WebPAC::Tree;
2    
3     use warnings;
4     use strict;
5    
6     use Carp;
7     use Log::Log4perl qw(get_logger :levels);
8 dpavlin 460 use YAML;
9 dpavlin 441
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 dpavlin 454 code_arr => sub { @{$_[0]} },
27 dpavlin 441 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 dpavlin 454 have_children => sub { return $l->{$_[1]} },
36 dpavlin 441 },{
37     # level 1
38 dpavlin 454 code_arr => sub { @{$_[0]} },
39 dpavlin 441 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 dpavlin 454 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 dpavlin 441 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 dpavlin 460 my $v900 = $t->{'lookup_v900'}->($code);
80 dpavlin 441
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 dpavlin 454 Returns children for next iteration of tree generation or undef.
96 dpavlin 441
97 dpavlin 460 my $next_lvl = $t->{'have_children'}->($code,$v900);
98 dpavlin 441
99 dpavlin 454 =item have_children_at_level
100 dpavlin 441
101 dpavlin 454 Returns children for next iteration and next level.
102 dpavlin 441
103 dpavlin 460 my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);
104 dpavlin 441
105 dpavlin 454 It's safe to return undef just for next level data (C<$next_lvl> in example
106     above) to stop recursion.
107    
108 dpavlin 441 =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 dpavlin 460 my $html = $self->unroll(0,());
160 dpavlin 441
161 dpavlin 492 if (! $html) {
162     $log->warn("no html generated by unroll...");
163     return;
164     }
165 dpavlin 471
166 dpavlin 441 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 dpavlin 460 my $html = $tree->unroll($level,$data_arr);
195 dpavlin 441
196     =cut
197    
198     sub unroll {
199     my $self = shift;
200    
201 dpavlin 460 my ($level,$data_arr) = @_;
202 dpavlin 441
203 dpavlin 455 my $log = $self->_get_logger();
204    
205     if (! defined($level)) {
206     $log->warn("level is undef, stoping recursion...");
207     return;
208     }
209    
210 dpavlin 454 my $next_level = $level + 1;
211    
212 dpavlin 441 $log->logconfess("need level") unless (defined($level));
213 dpavlin 460 #$log->logconfess("need data_arr") unless (defined($data_arr));
214 dpavlin 441
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 dpavlin 460 $log->debug("unroll level $level");
223 dpavlin 441
224     my $html;
225    
226 dpavlin 460 foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
227 dpavlin 441
228     if ($code = $tree->[$level]->{'filter_code'}->($code)) {
229    
230     $log->debug("# $level filter passed code $code");
231    
232 dpavlin 460 my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
233     $log->debug("# $level lookup_v900($code) = $v900");
234 dpavlin 441
235 dpavlin 471 my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && next;
236 dpavlin 441 $log->debug("# $level lookup_term($code,$v900) = $term");
237    
238 dpavlin 471 my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) || $log->warn("can't lookup_mfn($code,$v900)") && next;
239 dpavlin 441 $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
240    
241     $log->debug("$code -> $v900 : $term [$mfn]");
242    
243 dpavlin 472 my ($link_start,$link_end) = ('','');
244 dpavlin 441
245 dpavlin 460 my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
246 dpavlin 454
247     if (! $have_children) {
248 dpavlin 460 $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 dpavlin 454
252 dpavlin 441 }
253    
254 dpavlin 454 ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
255    
256 dpavlin 441 my $mfn_link = "thes/$mfn.html";
257     if (-e "out/$mfn_link") {
258     $html .= " " x $level .
259 dpavlin 472 qq{<li><a name="mfn${mfn}"></a>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
260 dpavlin 470 qq{&nbsp;<a href="$mfn_link" onClick="javascript:return popup(this);">&raquo;</a></li>\n};
261 dpavlin 441 } 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 dpavlin 472 qq{<ul id="id$mfn"}.
272 dpavlin 441 ($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 dpavlin 454 $html .= $self->unroll($next_level, $have_children);
287 dpavlin 441
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 dpavlin 442 $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
319 dpavlin 441
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