/[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 472 by dpavlin, Sun Sep 26 16:44:23 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 151  sub new { Line 156  sub new {
156          $self->{'show_ids'} = [];          $self->{'show_ids'} = [];
157          $self->{'hide_ids'} = [];          $self->{'hide_ids'} = [];
158    
159          my $html = $self->unroll(0,'');          my $html = $self->unroll(0,());
160    
161            $log->logdie("no html generated by unroll...") unless ($html);
162    
163          my $html_file = $self->{'dir'}.'/'.$self->{'html'};          my $html_file = $self->{'dir'}.'/'.$self->{'html'};
164    
# Line 181  sub new { Line 188  sub new {
188    
189  Generate tree recursively.  Generate tree recursively.
190    
191   my $html = $tree->unroll($level,$start_code);   my $html = $tree->unroll($level,$data_arr);
192    
193  =cut  =cut
194    
195  sub unroll {  sub unroll {
196          my $self = shift;          my $self = shift;
197    
198          my ($level,$start_code) = @_;          my ($level,$data_arr) = @_;
199    
200          my $log = $self->_get_logger();          my $log = $self->_get_logger();
201    
202            if (! defined($level)) {
203                    $log->warn("level is undef, stoping recursion...");
204                    return;
205            }
206    
207            my $next_level = $level + 1;
208    
209          $log->logconfess("need level") unless (defined($level));          $log->logconfess("need level") unless (defined($level));
210          $log->logconfess("need start_code") unless (defined($start_code));          #$log->logconfess("need data_arr") unless (defined($data_arr));
211    
212          my $tree = $self->{'tree'};          my $tree = $self->{'tree'};
213    
# Line 202  sub unroll { Line 216  sub unroll {
216          # all levels passed?          # all levels passed?
217          return if (! defined($tree->[$level]));          return if (! defined($tree->[$level]));
218    
219          $log->debug("unroll level $level, start code $start_code");          $log->debug("unroll level $level");
220    
221          my $html;          my $html;
222    
223          foreach my $code ($tree->[$level]->{'code_arr'}->($start_code)) {          foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
224    
225                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {
226                                    
227                          $log->debug("# $level filter passed code $code");                          $log->debug("# $level filter passed code $code");
228    
229                          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;
230                          $log->debug("# $level lookup_v900($code,$start_code) = $v900");                          $log->debug("# $level lookup_v900($code) = $v900");
231    
232                          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;
233                          $log->debug("# $level lookup_term($code,$v900) = $term");                          $log->debug("# $level lookup_term($code,$v900) = $term");
234    
235                          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;
236                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
237    
238                          $log->debug("$code -> $v900 : $term [$mfn]");                          $log->debug("$code -> $v900 : $term [$mfn]");
239    
240                          my ($link_start,$link_end) = ('','');                          my ($link_start,$link_end) = ('','');
241                    
242                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900,$start_code);                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
243                          if ($have_children) {  
244                                  ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>});                          if (! $have_children) {
245                          } else {                                  $log->debug("# $level doesn't have_children($code,$v900)");
246                                  $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'});
247                                    $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
248    
249                          }                          }
250    
251                            ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>}) if ($have_children);
252    
253                          my $mfn_link = "thes/$mfn.html";                          my $mfn_link = "thes/$mfn.html";
254                          if (-e "out/$mfn_link") {                          if (-e "out/$mfn_link") {
255                                  $html .= " " x $level .                                  $html .= " " x $level .
256                                          qq{<li>${link_start}${term}${link_end}}.                                          qq{<li><a name="mfn${mfn}"></a>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
257                                          qq{&nbsp;<a href="$mfn_link">&raquo;</a></li>\n};                                          qq{&nbsp;<a href="$mfn_link" onClick="javascript:return popup(this);">&raquo;</a></li>\n};
258                          } else {                          } else {
259                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
260                          }                          }
# Line 247  sub unroll { Line 265  sub unroll {
265                          my $style = $tree->[$level]->{'style'};                          my $style = $tree->[$level]->{'style'};
266    
267                          $html .= " " x $level .                          $html .= " " x $level .
268                                  qq{<a name="mfn$mfn"></a>\n <ul id="id$mfn"}.                                  qq{<ul id="id$mfn"}.
269                                  ($style ? ' style="'.$style.'"' : '').                                  ($style ? ' style="'.$style.'"' : '').
270                                  qq{>\n};                                  qq{>\n};
271    
# Line 262  sub unroll { Line 280  sub unroll {
280                                  push @{$self->{'show_ids'}}, "id$mfn";                                  push @{$self->{'show_ids'}}, "id$mfn";
281                          }                          }
282    
283                          $html .= $self->unroll($level+1, $tree->[$level]->{'child_code'}->($code,$v900,$start_code));                          $html .= $self->unroll($next_level, $have_children);
284                                                    
285                          $html .= " " x $level . qq{</ul>\n};                          $html .= " " x $level . qq{</ul>\n};
286    

Legend:
Removed from v.442  
changed lines
  Added in v.472

  ViewVC Help
Powered by ViewVC 1.1.26