/[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 472 - (hide annotations)
Sun Sep 26 16:44:23 2004 UTC (16 years, 7 months ago) by dpavlin
File size: 8194 byte(s)
create named anchor always on line as element (so that outlining won't
"miss" it), create classes in html based on tags.

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