/[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 454 - (hide annotations)
Wed Sep 15 22:36:23 2004 UTC (15 years, 6 months ago) by dpavlin
File size: 8112 byte(s)
new simplier implementation of WebPAC::Tree with support for recursion
(still buggy)

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

  ViewVC Help
Powered by ViewVC 1.1.26