/[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

Diff of /trunk2/lib/WebPAC/Tree.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 443 by dpavlin, Tue Sep 14 20:57:58 2004 UTC revision 572 by dpavlin, Mon Nov 1 14:55:16 2004 UTC
# Line 5  use strict; Line 5  use strict;
5    
6  use Carp;  use Carp;
7  use Log::Log4perl qw(get_logger :levels);  use Log::Log4perl qw(get_logger :levels);
8  use locale;  use YAML;
9    use Template;
10    
11  =head1 NAME  =head1 NAME
12    
# Line 14  WebPAC::Tree - create tree from lookup d Line 15  WebPAC::Tree - create tree from lookup d
15  =head1 DESCRIPTION  =head1 DESCRIPTION
16    
17  This module will create tree from lookup data. It requires quite complicated  This module will create tree from lookup data. It requires quite complicated
18  data structure, but once you get hang of that, it's peace of case :-)  data structure, but once you get hang of that, it's peace of cake :-)
19    
20  Data structure for tree definition is non-recursive, and defines each level  Data structure for tree definition is non-recursive, and defines each level
21  of tree individually (so you can limit depth of tree) like this:  of tree individually (so you can limit depth of tree) like this:
# Line 23  of tree individually (so you can limit d Line 24  of tree individually (so you can limit d
24    
25   my @tree = ({   my @tree = ({
26          # level 0          # level 0
27          code_arr        => sub { @{$l->{$_[0]}} },          code_arr        => sub { @{$_[0]} },
28          filter_code     => sub { shift },          filter_code     => sub { shift },
29          lookup_v900     => sub {          lookup_v900     => sub {
30                                  my ($c,$p) = @_;                                  my ($c,$p) = @_;
# Line 32  of tree individually (so you can limit d Line 33  of tree individually (so you can limit d
33                          },                          },
34          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },
35          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },
36          have_children   => sub { defined($l->{$_[1]}) },          have_children   => sub { return $l->{$_[1]} },
37          child_code      => sub { return $_[1] },          iframe          => 1,
38          },{          },{
39          # level 1          # level 1
40          code_arr        => sub { @{$l->{$_[0]}} },          code_arr        => sub { @{$_[0]} },
41          filter_code     => sub { shift },          filter_code     => sub { shift },
42          lookup_v900     => sub {          lookup_v900     => sub {
43                                  my ($c,$p) = @_;                                  my ($c,$p) = @_;
# Line 46  of tree individually (so you can limit d Line 47  of tree individually (so you can limit d
47          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },
48          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },
49          have_children   => sub { 0 },          have_children   => sub { 0 },
50          child_code      => sub { 0 },          style           => 'display: none',
51   )};   )};
52    
53    You can, however, create recursion with C<have_children_at_level> discussed
54    below, but you loose ability to limit tree depth or to specify different
55    style for each level.
56    
57  Documentation for each element of tree is little sparse, but here it is:  Documentation for each element of tree is little sparse, but here it is:
58    
59  =over 5  =over 5
# Line 74  Returns code or C<false> if code has to Line 79  Returns code or C<false> if code has to
79    
80  Lookup value which will be called C<$v900> from now on.  Lookup value which will be called C<$v900> from now on.
81    
82   my $v900 = $t->{'lookup_v900'}->($code,$start_code);   my $v900 = $t->{'lookup_v900'}->($code);
83    
84  =item lookup_term  =item lookup_term
85    
# Line 90  Lookup mfn value, used to create hyperli Line 95  Lookup mfn value, used to create hyperli
95    
96  =item have_children  =item have_children
97    
98  Returns C<true> or C<false> depending if current node have children.  Returns children for next iteration of tree generation or undef.
99    
100     my $next_lvl = $t->{'have_children'}->($code,$v900);
101    
102    =item have_children_at_level
103    
104    Returns children for next iteration and next level.
105    
106     my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);
107    
108   if ($t->{'have_children'}->($code,$v900,$start_code)) { ... }  It's safe to return undef just for next level data (C<$next_lvl> in example
109    above) to stop recursion.
110    
111  =item child_code  =item iframe
112    
113  Returns child code for next iteration of tree generation.  This optional option will create all children nodes in separate file, and iframe in tree html,
114    so that generated tee html will have resonable size with large number of nodes.
115    
116   my $child_code = $t->{'child_code'}->($code,$v900,$start_code);  =item style
117    
118    Optional option to specify style of this node.
119    
120  =back  =back
121    
# Line 109  Returns child code for next iteration of Line 126  Returns child code for next iteration of
126  Create new tree object  Create new tree object
127    
128   my $tree = new WebPAC::Tree(   my $tree = new WebPAC::Tree(
         dir => './out',  
         html => 'browse.html',  
         template => './output_template/tree.tt',  
         js => 'tree-ids.js',  
129          tree => \@tree,          tree => \@tree,
130          log => 'log4perl.conf',          log => 'log4perl.conf',
131   );   );
132    
 C<dir> is output directory in which html files and JavaScript files will be  
 created (think of it as C<public_html>).  
   
 C<html> is name of output html file.  
   
 C<template> is name of template. It uses Template Toolkit syntax [% var %],  
 but doesn't really use TT.  
   
 C<js> is name of JavaScript file with shown and hidden ids.  
   
133  C<tree> is tree array with levels of tree described above.  C<tree> is tree array with levels of tree described above.
134    
135  C<log> is optional parametar which specify filename of L<Log::Log4Perl>  C<log> is optional parametar which specify filename of L<Log::Log4Perl>
# Line 144  sub new { Line 147  sub new {
147    
148          my $log = $self->_get_logger();          my $log = $self->_get_logger();
149    
150          foreach my $p (qw(dir html template js tree)) {          $log->logconfess("need tree") unless ($self->{'tree'});
                 $log->logconfess("need $p") unless ($self->{$p});  
         }  
151    
152          $self->{'show_ids'} = [];          $self->{'show_ids'} = [];
153          $self->{'hide_ids'} = [];          $self->{'hide_ids'} = [];
154    
155          my $html = $self->unroll(0,'');          $self->{'tree_html'} = $self->unroll(0,());
156    
157            if (! $self->{'tree_html'}) {
158                    $log->warn("no html generated by unroll...");
159                    return;
160            }
161    
162            return $self;
163    }
164    
165    =head2 output
166    
167    Create output files from tree object
168    
169     $tree->output(
170            dir => './out',
171            html => 'browse.html',
172            template_dir => './output_template/',
173            template_tree => 'tree.tt',
174            template_node => 'node.tt',
175            js => 'tree-ids.js',
176     );
177    
178    C<dir> is output directory in which html files and JavaScript files will be
179    created (think of it as C<public_html>).
180    
181    C<html> is name of output html file.
182    
183    C<template_dir> is directory with Template Toolkit templates.
184    
185          my $html_file = $self->{'dir'}.'/'.$self->{'html'};  C<template_tree> is name of template to produce tree.
186    
187          open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");  C<template_node> is (optional) name of template for node (if C<iframe>
188          my $tmpl;  options is used within tree definition).
189          while(<TEMPLATE>) {  
190                  $tmpl .= $_;  C<js> is name of JavaScript file with shown and hidden ids.
191    
192    =cut
193    
194    sub output {
195            my $self = shift;
196    
197            my $args = {@_};
198    
199            my $log = $self->_get_logger();
200    
201            foreach my $p (qw(dir html template_dir template_tree js)) {
202                    $log->logconfess("need $p") unless ($args->{$p});
203            }
204    
205            my $html = $self->{'tree_html'};
206            unless ($html) {
207                    $log->warn("no html, output aborted");
208                    return;
209            }
210    
211            my $html_file = $args->{'dir'}.'/'.$args->{'html'};
212    
213            $log->debug("templates are in ",$args->{'template_dir'});
214    
215            my $tt = Template->new(
216                    INCLUDE_PATH => $args->{'template_dir'},
217            );
218    
219            my $var = {
220                    js => $args->{'dir'}.'/'.$args->{'js'},
221                    tree => $html,
222            };
223    
224            $log->info("creating '$html_file' with tree from ",$args->{'template_tree'});
225    
226            $tt->process($args->{'template_tree'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
227    
228            my $js_file = $args->{'dir'}."/".$args->{'js'};
229            $log->info("creating '$js_file' with tree data");
230            $self->generate_js(
231                    file => $js_file,
232            );
233    
234            if (! $args->{'nodes'}) {
235                    $log->warn("skipping node creation");
236                    return $self;
237          }          }
         close(TEMPLATE);  
238    
239          $log->info("creating '$html_file' with tree");          foreach my $mfn (keys %{$self->{'node_html'}}) {
240    
241          my $js_arr_file = $self->{'js'};                  my $html_file = $args->{'dir'}."/".$args->{'nodes'}."/${mfn}.html";
         $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;  
         $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;  
242    
243          open(HTML, ">", $html_file) || $log->logdie("can't open '$html_file': $!");                  $log->debug("creating tree node $html_file");
         print HTML $tmpl;  
         close(HTML);  
244    
245          $self->generate_js();                  $var = {
246                            node => $self->{'node_html'}->{$mfn},
247                    };
248    
249                    $tt->process($args->{'template_node'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
250            }
251    
252          return $self;          return $self;
253  }  }
# Line 181  sub new { Line 256  sub new {
256    
257  Generate tree recursively.  Generate tree recursively.
258    
259   my $html = $tree->unroll($level,$start_code);   my $html = $tree->unroll($level,$data_arr);
260    
261  =cut  =cut
262    
263  sub unroll {  sub unroll {
264          my $self = shift;          my $self = shift;
265    
266          my ($level,$start_code) = @_;          my ($level,$data_arr) = @_;
267    
268          my $log = $self->_get_logger();          my $log = $self->_get_logger();
269    
270            if (! defined($level)) {
271                    $log->warn("level is undef, stoping recursion...");
272                    return;
273            }
274    
275            my $next_level = $level + 1;
276    
277          $log->logconfess("need level") unless (defined($level));          $log->logconfess("need level") unless (defined($level));
278          $log->logconfess("need start_code") unless (defined($start_code));          #$log->logconfess("need data_arr") unless (defined($data_arr));
279    
280          my $tree = $self->{'tree'};          my $tree = $self->{'tree'};
281    
# Line 202  sub unroll { Line 284  sub unroll {
284          # all levels passed?          # all levels passed?
285          return if (! defined($tree->[$level]));          return if (! defined($tree->[$level]));
286    
287          $log->debug("unroll level $level, start code $start_code");          $log->debug("unroll level $level");
288    
289          my $html;          my $html;
290    
291          foreach my $code ($tree->[$level]->{'code_arr'}->($start_code)) {          foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
292    
293                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {
294                                    
295                          $log->debug("# $level filter passed code $code");                          $log->debug("# $level filter passed code $code");
296    
297                          my $v900 = $tree->[$level]->{'lookup_v900'}->($code,$start_code) || $log->warn("can't lookup_v900($code,$start_code)");                          my $v900 = $tree->[$level]->{'lookup_v900'}->($code) || $log->warn("can't lookup_v900($code)") && return;
298                          $log->debug("# $level lookup_v900($code,$start_code) = $v900");                          $log->debug("# $level lookup_v900($code) = $v900");
299    
300                          my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)");                          my $term = $tree->[$level]->{'lookup_term'}->($code,$v900) || $log->warn("can't lookup_term($code,$v900)") && next;
301                          $log->debug("# $level lookup_term($code,$v900) = $term");                          $log->debug("# $level lookup_term($code,$v900) = $term");
302    
303                          my $mfn  = $tree->[$level]->{'lookup_mfn'}->($code,$v900)  || $log->warn("can't lookup_mfn($code,$v900)");                          my $mfn  = $tree->[$level]->{'lookup_mfn'}->($code,$v900)  || $log->warn("can't lookup_mfn($code,$v900)") && next;
304                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
305    
306                          $log->debug("$code -> $v900 : $term [$mfn]");                          $log->debug("$code -> $v900 : $term [$mfn]");
307    
308                          my ($link_start,$link_end) = ('','');                          my ($link_start,$link_end) = ('','');
309                    
310                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900,$start_code);                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
311                          if ($have_children) {  
312                                  ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>});                          if (! $have_children) {
313                          } else {                                  $log->debug("# $level doesn't have_children($code,$v900)");
314                                  $log->debug("# $level doesn't have_children($code,$v900,$start_code)");                                  ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
315                                    $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
316    
317                          }                          }
318    
319                            ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
320    
321                          my $mfn_link = "thes/$mfn.html";                          my $mfn_link = "thes/$mfn.html";
322                          if (-e "out/$mfn_link") {                          if (-e "out/$mfn_link") {
323                                    $term =~ s# *\* *# <img src="img/crovoc.png" border="0">#;
324                                  $html .= " " x $level .                                  $html .= " " x $level .
325                                          qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.                                          qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
326                                          qq{&nbsp;<a href="$mfn_link">&raquo;</a></li>\n};                                          qq{&nbsp;<a href="$mfn_link" onClick="javascript:return popup(this);"><img src="img/listic.png" border="0"></a></li>\n};
327                          } else {                          } else {
328                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
329                          }                          }
# Line 247  sub unroll { Line 334  sub unroll {
334                          my $style = $tree->[$level]->{'style'};                          my $style = $tree->[$level]->{'style'};
335    
336                          $html .= " " x $level .                          $html .= " " x $level .
337                                  qq{<a name="mfn$mfn"></a>\n <ul id="id$mfn"}.                                  qq{<ul id="id$mfn"}.
338                                  ($style ? ' style="'.$style.'"' : '').                                  ($style ? ' style="'.$style.'"' : '').
339                                  qq{>\n};                                  qq{>\n};
340    
# Line 262  sub unroll { Line 349  sub unroll {
349                                  push @{$self->{'show_ids'}}, "id$mfn";                                  push @{$self->{'show_ids'}}, "id$mfn";
350                          }                          }
351    
352                          $html .= $self->unroll($level+1, $tree->[$level]->{'child_code'}->($code,$v900,$start_code));                          if ($tree->[$level]->{'iframe'}) {
353                                                            # unroll to separate file
354                                    $self->{'node_html'}->{$mfn} = $self->unroll($next_level, $have_children);
355    
356                            } else {
357                                    # unroll at base HTML
358                                    $html .= $self->unroll($next_level, $have_children);
359                            }
360    
361                          $html .= " " x $level . qq{</ul>\n};                          $html .= " " x $level . qq{</ul>\n};
362    
363                  }                  }
# Line 276  sub unroll { Line 370  sub unroll {
370  Generate JavaScript arrays C<show> and C<hide> used to toggle display of  Generate JavaScript arrays C<show> and C<hide> used to toggle display of
371  elements.  elements.
372    
373   $tree->generate_js();   $tree->generate_js(
374            file = "./out/tree-ids.js",
375     );
376    
377  =cut  =cut
378    
379  sub generate_js {  sub generate_js {
380          my $self = shift;          my $self = shift;
381    
382            my $args = {@_};
383    
384          my $log = $self->_get_logger();          my $log = $self->_get_logger();
385    
386          my $js_file = $self->{'dir'}.'/'.$self->{'js'};          my $js_file = $args->{'file'};
387            $log->die("need file") unless ($args->{'file'});
388    
389          $log->info("creating '$js_file' with arrays of shown and hidden ids");          $log->info("creating '$js_file' with arrays of shown and hidden ids");
390    
Legend:
Removed from v.443  
changed lines
  Added in v.572
  ViewVC Help
Powered by ViewVC 1.1.26