/[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 441 by dpavlin, Tue Sep 14 17:07:59 2004 UTC revision 583 by dpavlin, Tue Nov 2 17:17:51 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    It's safe to return undef just for next level data (C<$next_lvl> in example
109    above) to stop recursion.
110    
111   if ($t->{'have_children'}->($code,$v900,$start_code)) { ... }  =item iframe
112    
113  =item child_code  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  Returns child code for next iteration of tree generation.  =item style
117    
118   my $child_code = $t->{'child_code'}->($code,$v900,$start_code);  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 = "thes/${mfn}.html";
134                    return $path if (-e "./out/$path");
135            },
136            nodes_dir => 'nodes',
137   );   );
138    
 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.  
   
139  C<tree> is tree array with levels of tree described above.  C<tree> is tree array with levels of tree described above.
140    
141  C<log> is optional parametar which specify filename of L<Log::Log4Perl>  C<log> is optional parametar which specify filename of L<Log::Log4Perl>
142  config file. Default is C<log.conf>.  config file. Default is C<log.conf>.
143    
144    C<detail_url> code ref to check if detail html exists (and return URL if
145    it does).
146    
147    C<nodes_dir> is relative path from output directory where tree nodes for
148    iframes will be created.
149    
150  =cut  =cut
151    
152  sub new {  sub new {
# Line 144  sub new { Line 159  sub new {
159    
160          my $log = $self->_get_logger();          my $log = $self->_get_logger();
161    
162          foreach my $p (qw(dir html template js tree)) {          $log->logconfess("need tree") unless ($self->{'tree'});
                 $log->logconfess("need $p") unless ($self->{$p});  
         }  
163    
164          $self->{'show_ids'} = [];          $self->{'show_ids'} = [];
165          $self->{'hide_ids'} = [];          $self->{'hide_ids'} = [];
166    
167          my $html = $self->unroll(0,'');          # figure out relative URL to other content from nodes_dir
168            my $iframe_base = $self->{'nodes_dir'};
169            if ($iframe_base) {
170                    $iframe_base = s#[^/]*##g;
171                    $iframe_base = '../' x ( length($iframe_base) );
172                    $self->{'iframe_base'} = $iframe_base;
173                    $log->debug("nodes dir is '",$self->{'nodes_dir'},"' so iframe_base is '",$self->{'iframe_base'},"'");
174            }
175    
176            $self->{'tree_html'} = $self->unroll(0,());
177    
178            if (! $self->{'tree_html'}) {
179                    $log->warn("no html generated by unroll...");
180                    return;
181            }
182    
183            return $self;
184    }
185    
186    =head2 output
187    
188    Create output files from tree object
189    
190     $tree->output(
191            dir => './out',
192            html => 'browse.html',
193            template_dir => './output_template/',
194            template_tree => 'tree.tt',
195            template_node => 'node.tt',
196            js => 'tree-ids.js',
197     );
198    
199    C<dir> is output directory in which html files and JavaScript files will be
200    created (think of it as C<public_html>).
201    
202    C<html> is name of output html file.
203    
204    C<template_dir> is directory with Template Toolkit templates.
205    
206    C<template_tree> is name of template to produce tree.
207    
208    C<template_node> is (optional) name of template for node (if C<iframe>
209    options is used within tree definition).
210    
211    C<js> is name of JavaScript file with shown and hidden ids.
212    
213    =cut
214    
215    sub output {
216            my $self = shift;
217    
218            my $args = {@_};
219    
220          my $html_file = $self->{'dir'}.'/'.$self->{'html'};          my $log = $self->_get_logger();
221    
222            foreach my $p (qw(dir html template_dir template_tree js)) {
223                    $log->logconfess("need $p") unless ($args->{$p});
224            }
225    
226          open(TEMPLATE, $self->{'template'}) || $log->logdie("can't open '",$self->{'template'},": $!");          my $html = $self->{'tree_html'};
227          my $tmpl;          unless ($html) {
228          while(<TEMPLATE>) {                  $log->warn("no html, output aborted");
229                  $tmpl .= $_;                  return;
230          }          }
         close(TEMPLATE);  
231    
232          $log->info("creating '$html_file' with tree");          my $html_file = $args->{'dir'}.'/'.$args->{'html'};
233    
234          my $js_arr_file = $self->{'js'};          $log->debug("templates are in ",$args->{'template_dir'});
         $tmpl =~ s/\[%\s+js\s+%\]/$js_arr_file/gi;  
         $tmpl =~ s/\[%\s+tree\s+%\]/$html/gi;  
235    
236          open(HTML, ">", $html_file) || $log->logdie("can't open '$html_file': $!");          my $tt = Template->new(
237          print HTML $tmpl;                  INCLUDE_PATH => $args->{'template_dir'},
238          close(HTML);          );
239    
240            my $var = {
241                    js => $args->{'dir'}.'/'.$args->{'js'},
242                    tree => $html,
243            };
244    
245            $log->info("creating '$html_file' with tree from ",$args->{'template_tree'});
246    
247            $tt->process($args->{'template_tree'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
248    
249            my $js_file = $args->{'dir'}."/".$args->{'js'};
250            $log->info("creating '$js_file' with tree data");
251            $self->generate_js(
252                    file => $js_file,
253            );
254    
255            if (! $self->{'nodes_dir'}) {
256                    $log->warn("skipping node creation");
257                    return $self;
258            }
259    
260          $self->generate_js();          foreach my $mfn (keys %{$self->{'node_html'}}) {
261    
262                    my $html_file = $args->{'dir'}."/".$self->{'nodes_dir'}."/${mfn}.html";
263    
264                    $log->debug("creating tree node $html_file");
265    
266                    $var = {
267                            node => $self->{'node_html'}->{$mfn},
268                    };
269    
270                    $tt->process($args->{'template_node'}, $var, $html_file) || $log->logdie("template error: ",$tt->error());
271            }
272    
273          return $self;          return $self;
274  }  }
# Line 181  sub new { Line 277  sub new {
277    
278  Generate tree recursively.  Generate tree recursively.
279    
280   my $html = $tree->unroll($level,$start_code);   my $html = $tree->unroll($level,$data_arr);
281    
282  =cut  =cut
283    
284  sub unroll {  sub unroll {
285          my $self = shift;          my $self = shift;
286    
287          my ($level,$start_code) = @_;          my ($level,$data_arr, $base_path) = @_;
288    
289            $base_path ||= '';
290    
291          my $log = $self->_get_logger();          my $log = $self->_get_logger();
292    
293            if (! defined($level)) {
294                    $log->warn("level is undef, stoping recursion...");
295                    return;
296            }
297    
298            my $next_level = $level + 1;
299    
300          $log->logconfess("need level") unless (defined($level));          $log->logconfess("need level") unless (defined($level));
301          $log->logconfess("need start_code") unless (defined($start_code));          #$log->logconfess("need data_arr") unless (defined($data_arr));
302    
303          my $tree = $self->{'tree'};          my $tree = $self->{'tree'};
304    
# Line 202  sub unroll { Line 307  sub unroll {
307          # all levels passed?          # all levels passed?
308          return if (! defined($tree->[$level]));          return if (! defined($tree->[$level]));
309    
310          $log->debug("unroll level $level, start code $start_code");          $log->debug("unroll level $level base path ",($base_path || "none"));
311    
312          my $html;          my $html;
313    
314          foreach my $code ($tree->[$level]->{'code_arr'}->($start_code)) {          foreach my $code ($tree->[$level]->{'code_arr'}->($data_arr)) {
315    
316                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {                  if ($code = $tree->[$level]->{'filter_code'}->($code)) {
317                                    
318                          $log->debug("# $level filter passed code $code");                          $log->debug("# $level filter passed code $code");
319    
320                          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;
321                          $log->debug("# $level lookup_v900($code,$start_code) = $v900");                          $log->debug("# $level lookup_v900($code) = $v900");
322    
323                          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;
324                          $log->debug("# $level lookup_term($code,$v900) = $term");                          $log->debug("# $level lookup_term($code,$v900) = $term");
325    
326                          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;
327                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");                          $log->debug("# $level lookup_mfn($code,$v900) = $mfn");
328    
329                          $log->debug("$code -> $v900 : $term [$mfn]");                          $log->debug("$code -> $v900 : $term [$mfn]");
330    
331                          my ($link_start,$link_end) = ('','');                          my ($link_start,$link_end,$level_el) = ('','','ul');
332                    
333                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900,$start_code);                          my $have_children = $tree->[$level]->{'have_children'}->($code,$v900);
334    
335                            if (! $have_children) {
336                                    $log->debug("# $level doesn't have_children($code,$v900)");
337                                    ($next_level,$have_children) = $tree->[$level]->{'have_children_at_level'}->($code,$v900) if ($tree->[$level]->{'have_children_at_level'});
338                                    $log->debug("# $level have_children($code,$v900) on level $next_level") if ($have_children);
339    
340                            }
341    
342                            my $iframe = $tree->[$level]->{'iframe'};
343    
344                          if ($have_children) {                          if ($have_children) {
345                                  ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>});                                  ($link_start,$link_end) = (qq{<a href="#mfn$mfn" onClick="return toggle_display('id$mfn');">},qq{</a>});
346                          } else {                                  if ($iframe) {
347                                  $log->debug("# $level doesn't have_children($code,$v900,$start_code)");                                          my $url = $self->{'nodes_dir'} || $log->logdie("no nodes_dir?");
348                                            $url .= "/${mfn}.html";
349                                            $link_start = qq{<a href="#mfn$mfn" onClick="iframe_load('i$mfn','$url'); return toggle_display('id$mfn');">};
350                                            $level_el = 'div';
351                                    }
352                          }                          }
353    
354                          my $mfn_link = "thes/$mfn.html";                          my $mfn_link;
355                          if (-e "out/$mfn_link") {                          $mfn_link = $self->{'detail_url'}->($mfn) if ($self->{'detail_url'});
356    
357                            if ($mfn_link) {
358                                    $term =~ s/ *#C# */ <img src="${base_path}img\/crovoc.png" border="0">/;
359                                  $html .= " " x $level .                                  $html .= " " x $level .
360                                          qq{<li>${link_start}${term}${link_end}}.                                          qq{<li>${link_start}<span id="o$mfn">${term}</span>${link_end}}.
361                                          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};
362                                    $log->debug("linked details to $mfn_link");
363                          } else {                          } else {
364                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");                                  $log->warn("file 'out/$mfn_link' doesn't exist, skipping");
365                          }                          }
366    
367                            # save mfn for iframe
368                            push @{$self->{'mfn_arr'}}, $mfn;
369    
370                          unless ($have_children) {                          unless ($have_children) {
371                                  next;                                  next;
372                          }                          }
373                          my $style = $tree->[$level]->{'style'};                          my $style = $tree->[$level]->{'style'};
374    
375                          $html .= " " x $level .                          $html .= " " x $level .
376                                  qq{<a name="mfn$mfn"></a>\n <ul id="id$mfn"}.                                  qq{<$level_el id="id$mfn"}.
377                                  ($style ? ' style="'.$style.'"' : '').                                  ($style ? ' style="'.$style.';"' : '').
378                                  qq{>\n};                                  qq{>\n};
379    
380                          if ($style) {                          if ($style) {
# Line 262  sub unroll { Line 388  sub unroll {
388                                  push @{$self->{'show_ids'}}, "id$mfn";                                  push @{$self->{'show_ids'}}, "id$mfn";
389                          }                          }
390    
391                          $html .= $self->unroll($level+1, $tree->[$level]->{'child_code'}->($code,$v900,$start_code));  
392                                                    if ($iframe) {
393                          $html .= " " x $level . qq{</ul>\n};  
394                                    # reset list of current mfns
395                                    $self->{'mfn_arr'} = ();
396    
397                                    # unroll to separate file
398                                    $self->{'node_html'}->{$mfn} = $self->unroll($next_level, $have_children, $self->{'iframe_base'});
399                                    $html .= " " x $level . qq{<span id="w$mfn" style="display: none;">Učitavanje podataka...</span>\n};
400    
401                                    $html .= " " x $level .
402                                    qq{<iframe id="i$mfn" name="i$mfn" width="100%" height="0" marginwidth="0" marginheight="0" style="margin: 0;" frameborder="0" border="0" onLoad="iframe_resize(this.name);"></iframe>\n};
403                                    @{$self->{'iframe_mfn'}->{$mfn}} = @{$self->{'mfn_arr'}};
404    
405                            } else {
406                                    # unroll at base HTML
407                                    $html .= $self->unroll($next_level, $have_children, $base_path);
408                            }
409    
410                            $html .= " " x $level . qq{</$level_el>\n};
411    
412                  }                  }
413          }          }
# Line 276  sub unroll { Line 419  sub unroll {
419  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
420  elements.  elements.
421    
422   $tree->generate_js();   $tree->generate_js(
423            file = "./out/tree-ids.js",
424     );
425    
426  =cut  =cut
427    
428  sub generate_js {  sub generate_js {
429          my $self = shift;          my $self = shift;
430    
431            my $args = {@_};
432    
433          my $log = $self->_get_logger();          my $log = $self->_get_logger();
434    
435          my $js_file = $self->{'dir'}.'/'.$self->{'js'};          my $js_file = $args->{'file'};
436            $log->die("need file") unless ($args->{'file'});
437    
438          $log->info("creating '$js_file' with arrays of shown and hidden ids");          $log->info("creating '$js_file' with arrays of shown and hidden ids");
439    
440          open(JS, ">", $js_file) || $log->logdie("can't open '$js_file': $!");          open(JS, ">", $js_file) || $log->logdie("can't open '$js_file': $!");
441          print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";          print JS "var show = ['",join("','",@{$self->{'show_ids'}}),"'];\n";
442          print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";          print JS "var hide = ['",join("','",@{$self->{'hide_ids'}}),"'];\n";
443    
444            my @mfn_iframe;
445    
446            foreach my $if (keys %{$self->{'iframe_mfn'}}) {
447                    push @mfn_iframe, join(",", map { "$_:$if" } @{$self->{'iframe_mfn'}->{$if}});
448            }
449            
450            print JS "var mfn_iframe = {\n",join(",\n",@mfn_iframe),"\n};\n";
451    
452          close(JS);          close(JS);
453    
454          $log->debug("stored ",@{$self->{'show_ids'}}," shown and ",@{$self->{'hide_ids'}}," hidden elements");          $log->debug("stored ",scalar @{$self->{'show_ids'}}," shown and ",scalar @{$self->{'hide_ids'}}," hidden elements");
455    
456  }  }
457    
Legend:
Removed from v.441  
changed lines
  Added in v.583
  ViewVC Help
Powered by ViewVC 1.1.26