/[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 442 by dpavlin, Tue Sep 14 17:10:04 2004 UTC revision 573 by dpavlin, Mon Nov 1 15:29:17 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            detail_url => sub {
132                    my $mfn = shift;
133                    my $path = "./out/thes/${mfn}.html";
134                    return $path if (-e $path);
135            },
136   );   );
137    
 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.  
   
138  C<tree> is tree array with levels of tree described above.  C<tree> is tree array with levels of tree described above.
139    
140  C<log> is optional parametar which specify filename of L<Log::Log4Perl>  C<log> is optional parametar which specify filename of L<Log::Log4Perl>
141  config file. Default is C<log.conf>.  config file. Default is C<log.conf>.
142    
143    C<detail_url> code ref to check if detail html exists (and return URL if
144    it does).
145    
146  =cut  =cut
147    
148  sub new {  sub new {
# Line 144  sub new { Line 155  sub new {
155    
156          my $log = $self->_get_logger();          my $log = $self->_get_logger();
157    
158          foreach my $p (qw(dir html template js tree)) {          $log->logconfess("need tree") unless ($self->{'tree'});
                 $log->logconfess("need $p") unless ($self->{$p});  
         }  
159    
160          $self->{'show_ids'} = [];          $self->{'show_ids'} = [];
161          $self->{'hide_ids'} = [];          $self->{'hide_ids'} = [];
162    
163          my $html = $self->unroll(0,'');          $self->{'tree_html'} = $self->unroll(0,());
164    
165            if (! $self->{'tree_html'}) {
166                    $log->warn("no html generated by unroll...");
167                    return;
168            }
169    
170            return $self;
171    }
172    
173    =head2 output
174    
175    Create output files from tree object
176    
177     $tree->output(
178            dir => './out',
179            html => 'browse.html',
180            template_dir => './output_template/',
181            template_tree => 'tree.tt',
182            template_node => 'node.tt',
183            js => 'tree-ids.js',
184     );
185    
186    C<dir> is output directory in which html files and JavaScript files will be
187    created (think of it as C<public_html>).
188    
189    C<html> is name of output html file.
190    
191    C<template_dir> is directory with Template Toolkit templates.
192    
193    C<template_tree> is name of template to produce tree.
194    
195          my $html_file = $self->{'dir'}.'/'.$self->{'html'};  C<template_node> is (optional) name of template for node (if C<iframe>
196    options is used within tree definition).
197    
198          open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");  C<js> is name of JavaScript file with shown and hidden ids.
199          my $tmpl;  
200          while(<TEMPLATE>) {  =cut
201                  $tmpl .= $_;  
202    sub output {
203            my $self = shift;
204    
205            my $args = {@_};
206    
207            my $log = $self->_get_logger();
208    
209            foreach my $p (qw(dir html template_dir template_tree js)) {
210                    $log->logconfess("need $p") unless ($args->{$p});
211          }          }
         close(TEMPLATE);  
212    
213          $log->info("creating '$html_file' with tree");          my $html = $self->{'tree_html'};
214            unless ($html) {
215                    $log->warn("no html, output aborted");
216                    return;
217            }
218    
219            my $html_file = $args->{'dir'}.'/'.$args->{'html'};
220    
221            $log->debug("templates are in ",$args->{'template_dir'});
222    
223            my $tt = Template->new(
224                    INCLUDE_PATH => $args->{'template_dir'},
225            );
226    
227            my $var = {
228                    js => $args->{'dir'}.'/'.$args->{'js'},
229                    tree => $html,
230            };
231    
232            $log->info("creating '$html_file' with tree from ",$args->{'template_tree'});
233    
234            $tt->process($args->{'template_tree'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
235    
236            my $js_file = $args->{'dir'}."/".$args->{'js'};
237            $log->info("creating '$js_file' with tree data");
238            $self->generate_js(
239                    file => $js_file,
240            );
241    
242            if (! $args->{'nodes'}) {
243                    $log->warn("skipping node creation");
244                    return $self;
245            }
246    
247          my $js_arr_file = $self->{'js'};          foreach my $mfn (keys %{$self->{'node_html'}}) {
         $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;  
         $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;  
248    
249          open(HTML, ">", $html_file) || $log->logdie("can't open '$html_file': $!");                  my $html_file = $args->{'dir'}."/".$args->{'nodes'}."/${mfn}.html";
         print HTML $tmpl;  
         close(HTML);  
250    
251          $self->generate_js();                  $log->debug("creating tree node $html_file");
252    
253                    $var = {
254                            node => $self->{'node_html'}->{$mfn},
255                    };
256    
257                    $tt->process($args->{'template_node'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
258            }
259    
260          return $self;          return $self;
261  }  }
# Line 181  sub new { Line 264  sub new {
264    
265  Generate tree recursively.  Generate tree recursively.
266    
267   my $html = $tree->unroll($level,$start_code);   my $html = $tree->unroll($level,$data_arr);
268    
269  =cut  =cut
270    
271  sub unroll {  sub unroll {
272          my $self = shift;          my $self = shift;
273    
274          my ($level,$start_code) = @_;          my ($level,$data_arr, $base_path) = @_;
275    
276            $base_path ||= '';
277    
278          my $log = $self->_get_logger();          my $log = $self->_get_logger();
279    
280            if (! defined($level)) {
281                    $log->warn("level is undef, stoping recursion...");
282                    return;
283            }
284    
285            my $next_level = $level + 1;
286    
287          $log->logconfess("need level") unless (defined($level));          $log->logconfess("need level") unless (defined($level));
288          $log->logconfess("need start_code") unless (defined($start_code));          #$log->logconfess("need data_arr") unless (defined($data_arr));
289    
290          my $tree = $self->{'tree'};          my $tree = $self->{'tree'};
291    
# Line 202  sub unroll { Line 294  sub unroll {
294          # all levels passed?          # all levels passed?
295          return if (! defined($tree->[$level]));          return if (! defined($tree->[$level]));
296    
297          $log->debug("unroll level $level, start code $start_code");          $log->debug("unroll level $level");
298    
299          my $html;          my $html;
300    
301          foreach my $code ($tree->[$level]->{'code_arr'}->($start_code)) {          foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
302    
303                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {
304                                    
305                          $log->debug("# $level filter passed code $code");                          $log->debug("# $level filter passed code $code");
306    
307                          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;
308                          $log->debug("# $level lookup_v900($code,$start_code) = $v900");                          $log->debug("# $level lookup_v900($code) = $v900");
309    
310                          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;
311                          $log->debug("# $level lookup_term($code,$v900) = $term");                          $log->debug("# $level lookup_term($code,$v900) = $term");
312    
313                          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;
314                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
315    
316                          $log->debug("$code -> $v900 : $term [$mfn]");                          $log->debug("$code -> $v900 : $term [$mfn]");
317    
318                          my ($link_start,$link_end) = ('','');                          my ($link_start,$link_end) = ('','');
319                    
320                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900,$start_code);                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
321                          if ($have_children) {  
322                                  ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>});                          if (! $have_children) {
323                          } else {                                  $log->debug("# $level doesn't have_children($code,$v900)");
324                                  $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'});
325                                    $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
326    
327                          }                          }
328    
329                          my $mfn_link = "thes/$mfn.html";                          ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
330                          if (-e "out/$mfn_link") {  
331                            my $mfn_link;
332                            $mfn_link = $self->{'detail_url'}->($mfn) if ($self->{'detail_url'});
333    
334                            if ($mfn_link) {
335                                    $term =~ s, *#C# *, <img src="${base_path}img/crovoc.png" border="0">,;
336                                  $html .= " " x $level .                                  $html .= " " x $level .
337                                          qq{<li>${link_start}${term}${link_end}}.                                          qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
338                                          qq{&nbsp;<a href="$mfn_link">&raquo;</a></li>\n};                                          qq{&nbsp;<a href="${base_path}${mfn_link}" onClick="javascript:return popup(this);"><img src="${base_path}img/listic.png" border="0"></a></li>\n};
339                                    $log->debug("linked details to $mfn_link");
340                          } else {                          } else {
341                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
342                          }                          }
# Line 247  sub unroll { Line 347  sub unroll {
347                          my $style = $tree->[$level]->{'style'};                          my $style = $tree->[$level]->{'style'};
348    
349                          $html .= " " x $level .                          $html .= " " x $level .
350                                  qq{<a name="mfn$mfn"></a>\n <ul id="id$mfn"}.                                  qq{<ul id="id$mfn"}.
351                                  ($style ? ' style="'.$style.'"' : '').                                  ($style ? ' style="'.$style.'"' : '').
352                                  qq{>\n};                                  qq{>\n};
353    
# Line 262  sub unroll { Line 362  sub unroll {
362                                  push @{$self->{'show_ids'}}, "id$mfn";                                  push @{$self->{'show_ids'}}, "id$mfn";
363                          }                          }
364    
365                          $html .= $self->unroll($level+1, $tree->[$level]->{'child_code'}->($code,$v900,$start_code));                          if ($tree->[$level]->{'iframe'}) {
366                                                            # unroll to separate file
367                                    $self->{'node_html'}->{$mfn} = $self->unroll($next_level, $have_children, '../');
368    
369                            } else {
370                                    # unroll at base HTML
371                                    $html .= $self->unroll($next_level, $have_children, $base_path);
372                            }
373    
374                          $html .= " " x $level . qq{</ul>\n};                          $html .= " " x $level . qq{</ul>\n};
375    
376                  }                  }
# Line 276  sub unroll { Line 383  sub unroll {
383  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
384  elements.  elements.
385    
386   $tree->generate_js();   $tree->generate_js(
387            file = "./out/tree-ids.js",
388     );
389    
390  =cut  =cut
391    
392  sub generate_js {  sub generate_js {
393          my $self = shift;          my $self = shift;
394    
395            my $args = {@_};
396    
397          my $log = $self->_get_logger();          my $log = $self->_get_logger();
398    
399          my $js_file = $self->{'dir'}.'/'.$self->{'js'};          my $js_file = $args->{'file'};
400            $log->die("need file") unless ($args->{'file'});
401    
402          $log->info("creating '$js_file' with arrays of shown and hidden ids");          $log->info("creating '$js_file' with arrays of shown and hidden ids");
403    
Legend:
Removed from v.442  
changed lines
  Added in v.573
  ViewVC Help
Powered by ViewVC 1.1.26