/[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 441 - (hide annotations)
Tue Sep 14 17:07:59 2004 UTC (19 years, 6 months ago) by dpavlin
File size: 7597 byte(s)
refactore tree generation into WebPAC::Tree

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     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}${term}${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 ",@{$self->{'show_ids'}}," shown and ",@{$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