/[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 455 - (hide annotations)
Mon Sep 20 19:13:27 2004 UTC (19 years, 6 months ago) by dpavlin
File size: 8206 byte(s)
break out from recursion loop

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

  ViewVC Help
Powered by ViewVC 1.1.26