/[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 530 by dpavlin, Tue Oct 19 17:43:52 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    
10  =head1 NAME  =head1 NAME
11    
# Line 23  of tree individually (so you can limit d Line 23  of tree individually (so you can limit d
23    
24   my @tree = ({   my @tree = ({
25          # level 0          # level 0
26          code_arr        => sub { @{$l->{$_[0]}} },          code_arr        => sub { @{$_[0]} },
27          filter_code     => sub { shift },          filter_code     => sub { shift },
28          lookup_v900     => sub {          lookup_v900     => sub {
29                                  my ($c,$p) = @_;                                  my ($c,$p) = @_;
# Line 32  of tree individually (so you can limit d Line 32  of tree individually (so you can limit d
32                          },                          },
33          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },
34          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },
35          have_children   => sub { defined($l->{$_[1]}) },          have_children   => sub { return $l->{$_[1]} },
         child_code      => sub { return $_[1] },  
36          },{          },{
37          # level 1          # level 1
38          code_arr        => sub { @{$l->{$_[0]}} },          code_arr        => sub { @{$_[0]} },
39          filter_code     => sub { shift },          filter_code     => sub { shift },
40          lookup_v900     => sub {          lookup_v900     => sub {
41                                  my ($c,$p) = @_;                                  my ($c,$p) = @_;
# Line 46  of tree individually (so you can limit d Line 45  of tree individually (so you can limit d
45          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },          lookup_term     => sub { shift @{$l->{"d:".$_[0]}} },
46          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },          lookup_mfn      => sub { shift @{$l->{"900_mfn:".$_[0]}} },
47          have_children   => sub { 0 },          have_children   => sub { 0 },
         child_code      => sub { 0 },  
48   )};   )};
49    
50    You can, however, create recursion with C<have_children_at_level> discussed
51    below, but you loose ability to limit tree depth or to specify different
52    style for each level.
53    
54  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:
55    
56  =over 5  =over 5
# Line 74  Returns code or C<false> if code has to Line 76  Returns code or C<false> if code has to
76    
77  Lookup value which will be called C<$v900> from now on.  Lookup value which will be called C<$v900> from now on.
78    
79   my $v900 = $t->{'lookup_v900'}->($code,$start_code);   my $v900 = $t->{'lookup_v900'}->($code);
80    
81  =item lookup_term  =item lookup_term
82    
# Line 90  Lookup mfn value, used to create hyperli Line 92  Lookup mfn value, used to create hyperli
92    
93  =item have_children  =item have_children
94    
95  Returns C<true> or C<false> depending if current node have children.  Returns children for next iteration of tree generation or undef.
96    
97     my $next_lvl = $t->{'have_children'}->($code,$v900);
98    
99   if ($t->{'have_children'}->($code,$v900,$start_code)) { ... }  =item have_children_at_level
100    
101  =item child_code  Returns children for next iteration and next level.
102    
103  Returns child code for next iteration of tree generation.   my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);
104    
105   my $child_code = $t->{'child_code'}->($code,$v900,$start_code);  It's safe to return undef just for next level data (C<$next_lvl> in example
106    above) to stop recursion.
107    
108  =back  =back
109    
# Line 109  Returns child code for next iteration of Line 114  Returns child code for next iteration of
114  Create new tree object  Create new tree object
115    
116   my $tree = new WebPAC::Tree(   my $tree = new WebPAC::Tree(
         dir => './out',  
         html => 'browse.html',  
         template => './output_template/tree.tt',  
         js => 'tree-ids.js',  
117          tree => \@tree,          tree => \@tree,
118          log => 'log4perl.conf',          log => 'log4perl.conf',
119   );   );
120    
 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.  
   
121  C<tree> is tree array with levels of tree described above.  C<tree> is tree array with levels of tree described above.
122    
123  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 135  sub new {
135    
136          my $log = $self->_get_logger();          my $log = $self->_get_logger();
137    
138          foreach my $p (qw(dir html template js tree)) {          $log->logconfess("need tree") unless ($self->{'tree'});
                 $log->logconfess("need $p") unless ($self->{$p});  
         }  
139    
140          $self->{'show_ids'} = [];          $self->{'show_ids'} = [];
141          $self->{'hide_ids'} = [];          $self->{'hide_ids'} = [];
142    
143          my $html = $self->unroll(0,'');          $self->{'tree_html'} = $self->unroll(0,());
144    
145            if (! $self->{'tree_html'}) {
146                    $log->warn("no html generated by unroll...");
147                    return;
148            }
149    
150            return $self;
151    }
152    
153    =head2 output
154    
155    Create output files from tree object
156    
157     $tree->output(
158            dir => './out',
159            html => 'browse.html',
160            template => './output_template/tree.tt',
161            js => 'tree-ids.js',
162     );
163    
164    C<dir> is output directory in which html files and JavaScript files will be
165    created (think of it as C<public_html>).
166    
167    C<html> is name of output html file.
168    
169    C<template> is name of template. It uses Template Toolkit syntax [% var %],
170    but doesn't really use TT.
171    
172    C<js> is name of JavaScript file with shown and hidden ids.
173    
174    =cut
175    
176    sub output {
177            my $self = shift;
178    
179            my $args = {@_};
180    
181          my $html_file = $self->{'dir'}.'/'.$self->{'html'};          my $log = $self->_get_logger();
182    
183            foreach my $p (qw(dir html template js)) {
184                    $log->logconfess("need $p") unless ($args->{$p});
185            }
186    
187            my $html = $self->{'tree_html'};
188            unless ($html) {
189                    $log->warn("no html, output aborted");
190                    return;
191            }
192    
193            my $html_file = $args->{'dir'}.'/'.$args->{'html'};
194    
195          open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");          open(TEMPLATE, $args->{'template'}) || $log->logdie("can't open '",$args->{'template'},": $!");
196          my $tmpl;          my $tmpl;
197          while(<TEMPLATE>) {          while(<TEMPLATE>) {
198                  $tmpl .= $_;                  $tmpl .= $_;
# Line 164  sub new { Line 201  sub new {
201    
202          $log->info("creating '$html_file' with tree");          $log->info("creating '$html_file' with tree");
203    
204          my $js_arr_file = $self->{'js'};          my $js_arr_file = $args->{'js'};
205          $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;          $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;
206          $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;          $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;
207    
# Line 172  sub new { Line 209  sub new {
209          print HTML $tmpl;          print HTML $tmpl;
210          close(HTML);          close(HTML);
211    
212          $self->generate_js();          $self->generate_js(
213                    file => $args->{'dir'}."/".$args->{'js'},
214            );
215    
216          return $self;          return $self;
217  }  }
# Line 181  sub new { Line 220  sub new {
220    
221  Generate tree recursively.  Generate tree recursively.
222    
223   my $html = $tree->unroll($level,$start_code);   my $html = $tree->unroll($level,$data_arr);
224    
225  =cut  =cut
226    
227  sub unroll {  sub unroll {
228          my $self = shift;          my $self = shift;
229    
230          my ($level,$start_code) = @_;          my ($level,$data_arr) = @_;
231    
232          my $log = $self->_get_logger();          my $log = $self->_get_logger();
233    
234            if (! defined($level)) {
235                    $log->warn("level is undef, stoping recursion...");
236                    return;
237            }
238    
239            my $next_level = $level + 1;
240    
241          $log->logconfess("need level") unless (defined($level));          $log->logconfess("need level") unless (defined($level));
242          $log->logconfess("need start_code") unless (defined($start_code));          #$log->logconfess("need data_arr") unless (defined($data_arr));
243    
244          my $tree = $self->{'tree'};          my $tree = $self->{'tree'};
245    
# Line 202  sub unroll { Line 248  sub unroll {
248          # all levels passed?          # all levels passed?
249          return if (! defined($tree->[$level]));          return if (! defined($tree->[$level]));
250    
251          $log->debug("unroll level $level, start code $start_code");          $log->debug("unroll level $level");
252    
253          my $html;          my $html;
254    
255          foreach my $code ($tree->[$level]->{'code_arr'}->($start_code)) {          foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
256    
257                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {
258                                    
259                          $log->debug("# $level filter passed code $code");                          $log->debug("# $level filter passed code $code");
260    
261                          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;
262                          $log->debug("# $level lookup_v900($code,$start_code) = $v900");                          $log->debug("# $level lookup_v900($code) = $v900");
263    
264                          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;
265                          $log->debug("# $level lookup_term($code,$v900) = $term");                          $log->debug("# $level lookup_term($code,$v900) = $term");
266    
267                          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;
268                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
269    
270                          $log->debug("$code -> $v900 : $term [$mfn]");                          $log->debug("$code -> $v900 : $term [$mfn]");
271    
272                          my ($link_start,$link_end) = ('','');                          my ($link_start,$link_end) = ('','');
273                    
274                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900,$start_code);                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
275                          if ($have_children) {  
276                                  ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>});                          if (! $have_children) {
277                          } else {                                  $log->debug("# $level doesn't have_children($code,$v900)");
278                                  $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'});
279                                    $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
280    
281                          }                          }
282    
283                            ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
284    
285                          my $mfn_link = "thes/$mfn.html";                          my $mfn_link = "thes/$mfn.html";
286                          if (-e "out/$mfn_link") {                          if (-e "out/$mfn_link") {
287                                    $term =~ s# *\* *# <img src="img/crovoc.png" border="0">#;
288                                  $html .= " " x $level .                                  $html .= " " x $level .
289                                          qq{<li>${link_start}${term}${link_end}}.                                          qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
290                                          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};
291                          } else {                          } else {
292                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
293                          }                          }
# Line 247  sub unroll { Line 298  sub unroll {
298                          my $style = $tree->[$level]->{'style'};                          my $style = $tree->[$level]->{'style'};
299    
300                          $html .= " " x $level .                          $html .= " " x $level .
301                                  qq{<a name="mfn$mfn"></a>\n <ul id="id$mfn"}.                                  qq{<ul id="id$mfn"}.
302                                  ($style ? ' style="'.$style.'"' : '').                                  ($style ? ' style="'.$style.'"' : '').
303                                  qq{>\n};                                  qq{>\n};
304    
# Line 262  sub unroll { Line 313  sub unroll {
313                                  push @{$self->{'show_ids'}}, "id$mfn";                                  push @{$self->{'show_ids'}}, "id$mfn";
314                          }                          }
315    
316                          $html .= $self->unroll($level+1, $tree->[$level]->{'child_code'}->($code,$v900,$start_code));                          $html .= $self->unroll($next_level, $have_children);
317                                                    
318                          $html .= " " x $level . qq{</ul>\n};                          $html .= " " x $level . qq{</ul>\n};
319    
# Line 276  sub unroll { Line 327  sub unroll {
327  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
328  elements.  elements.
329    
330   $tree->generate_js();   $tree->generate_js(
331            file = "./out/tree-ids.js",
332     );
333    
334  =cut  =cut
335    
336  sub generate_js {  sub generate_js {
337          my $self = shift;          my $self = shift;
338    
339            my $args = {@_};
340    
341          my $log = $self->_get_logger();          my $log = $self->_get_logger();
342    
343          my $js_file = $self->{'dir'}.'/'.$self->{'js'};          my $js_file = $args->{'file'};
344            $log->die("need file") unless ($args->{'file'});
345    
346          $log->info("creating '$js_file' with arrays of shown and hidden ids");          $log->info("creating '$js_file' with arrays of shown and hidden ids");
347    
Legend:
Removed from v.442  
changed lines
  Added in v.530
  ViewVC Help
Powered by ViewVC 1.1.26