/[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 455 by dpavlin, Mon Sep 20 19:13:27 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 YAML;
9    
10  =head1 NAME  =head1 NAME
11    
# Line 75  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 93  Lookup mfn value, used to create hyperli Line 94  Lookup mfn value, used to create hyperli
94    
95  Returns children for next iteration of tree generation or undef.  Returns children for next iteration of tree generation or undef.
96    
97   my $next_lvl = $t->{'have_children'}->($code,$v900,$start_code);   my $next_lvl = $t->{'have_children'}->($code,$v900);
98    
99  =item have_children_at_level  =item have_children_at_level
100    
101  Returns children for next iteration and next level.  Returns children for next iteration and next level.
102    
103   my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900,$start_code);   my ($level,$next_lvl) = $t->{'have_children_at_level'}->($code,$v900);
104    
105  It's safe to return undef just for next level data (C<$next_lvl> in example  It's safe to return undef just for next level data (C<$next_lvl> in example
106  above) to stop recursion.  above) to stop recursion.
# Line 113  above) to stop recursion. Line 114  above) to stop recursion.
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 148  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          my $html_file = $self->{'dir'}.'/'.$self->{'html'};  =head2 output
154    
155          open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");  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 $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, $args->{'template'}) || $log->logdie("can't open '",$args->{'template'},": $!");
196          my $tmpl;          my $tmpl;
197          while(<TEMPLATE>) {          while(<TEMPLATE>) {
198                  $tmpl .= $_;                  $tmpl .= $_;
# Line 168  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 176  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 185  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    
# Line 204  sub unroll { Line 239  sub unroll {
239          my $next_level = $level + 1;          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 213  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    
276                          if (! $have_children) {                          if (! $have_children) {
277                                  $log->debug("# $level doesn't have_children($code,$v900,$start_code)");                                  $log->debug("# $level doesn't have_children($code,$v900)");
278                                  ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900,$start_code) if ($tree->[$level]->{'have_children_at_level'});                                  ($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,$start_code) on level $next_level") if ($have_children);                                  $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
280    
281                          }                          }
282    
# Line 249  sub unroll { Line 284  sub unroll {
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}<span id="o$mfn">${term}</span>${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 262  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 291  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.455  
changed lines
  Added in v.530
  ViewVC Help
Powered by ViewVC 1.1.26