/[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 470 - (hide annotations)
Fri Sep 24 20:31:11 2004 UTC (16 years, 7 months ago) by dpavlin
File size: 8160 byte(s)
open detail data in new window (popup)

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     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 dpavlin 460 my $html = $tree->unroll($level,$data_arr);
190 dpavlin 441
191     =cut
192    
193     sub unroll {
194     my $self = shift;
195    
196 dpavlin 460 my ($level,$data_arr) = @_;
197 dpavlin 441
198 dpavlin 455 my $log = $self->_get_logger();
199    
200     if (! defined($level)) {
201     $log->warn("level is undef, stoping recursion...");
202     return;
203     }
204    
205 dpavlin 454 my $next_level = $level + 1;
206    
207 dpavlin 441 $log->logconfess("need level") unless (defined($level));
208 dpavlin 460 #$log->logconfess("need data_arr") unless (defined($data_arr));
209 dpavlin 441
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 dpavlin 460 $log->debug("unroll level $level");
218 dpavlin 441
219     my $html;
220    
221 dpavlin 460 foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
222 dpavlin 441
223     if ($code = $tree->[$level]->{'filter_code'}->($code)) {
224    
225     $log->debug("# $level filter passed code $code");
226    
227 dpavlin 460 my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
228     $log->debug("# $level lookup_v900($code) = $v900");
229 dpavlin 441
230 dpavlin 460 my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && return;
231 dpavlin 441 $log->debug("# $level lookup_term($code,$v900) = $term");
232    
233 dpavlin 460 my $mfn = $tree->[$level]->{'lookup_mfn'}->($code,$v900) || $log->warn("can't lookup_mfn($code,$v900)") && return;
234 dpavlin 441 $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
235    
236     $log->debug("$code -> $v900 : $term [$mfn]");
237    
238 dpavlin 469 my ($link_start,$link_end) = ('<a name="mfn'.$mfn.'"></a>','');
239 dpavlin 441
240 dpavlin 460 my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
241 dpavlin 454
242     if (! $have_children) {
243 dpavlin 460 $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 dpavlin 454
247 dpavlin 441 }
248    
249 dpavlin 454 ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
250    
251 dpavlin 441 my $mfn_link = "thes/$mfn.html";
252     if (-e "out/$mfn_link") {
253     $html .= " " x $level .
254 dpavlin 443 qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
255 dpavlin 470 qq{&nbsp;<a href="$mfn_link" onClick="javascript:return popup(this);">&raquo;</a></li>\n};
256 dpavlin 441 } 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 dpavlin 454 $html .= $self->unroll($next_level, $have_children);
282 dpavlin 441
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 dpavlin 442 $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
314 dpavlin 441
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