torrus/perllib/Torrus/Renderer/HTML.pm

   1 #  Copyright (C) 2002  Stanislav Sinyagin
   2 #
   3 #  This program is free software; you can redistribute it and/or modify
   4 #  it under the terms of the GNU General Public License as published by
   5 #  the Free Software Foundation; either version 2 of the License, or
   6 #  (at your option) any later version.
   7 #
   8 #  This program is distributed in the hope that it will be useful,
   9 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 #  GNU General Public License for more details.
  12 #
  13 #  You should have received a copy of the GNU General Public License
  14 #  along with this program; if not, write to the Free Software
  15 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
  16
  17 # $Id: HTML.pm,v 1.1 2010-12-27 00:03:44 ivan Exp $
  18 # Stanislav Sinyagin <ssinyagin@yahoo.com>
  19
  20 package Torrus::Renderer::HTML;
  21
  22 use strict;
  23
  24 use Torrus::ConfigTree;
  25 use Torrus::Search;
  26 use Torrus::Log;
  27
  28 use URI::Escape;
  29 use Template;
  30 use POSIX qw(abs log floor pow);
  31 use Date::Parse;
  32 use Date::Format;
  33
  34 Torrus::SiteConfig::loadStyling();
  35
  36 # All our methods are imported by Torrus::Renderer;
  37
  38 sub render_html
  39 {
  40     my $self = shift;
  41     my $config_tree = shift;
  42     my $token = shift;
  43     my $view = shift;
  44     my $outfile = shift;
  45
  46     my $tmplfile = $config_tree->getParam($view, 'html-template');
  47
  48     my $expires = $config_tree->getParam($view, 'expires');
  49
  50     # Create the Template Toolkit processor once, and reuse
  51     # it in subsequent render() calls
  52
  53     if( not defined( $self->{'tt'} ) )
  54     {
  55         $self->{'tt'} =
  56             new Template(INCLUDE_PATH => $Torrus::Global::templateDirs,
  57                          TRIM => 1);
  58     }
  59     my $ttvars =
  60     {
  61         'treeName'   => $config_tree->treeName(),
  62         'token'      => $token,
  63         'view'       => $view,
  64         'expires'    => $expires,
  65         'path'       => sub { return $config_tree->path($_[0]); },
  66         'pathToken'  => sub { return $config_tree->token($_[0]); },
  67         'nodeExists' => sub { return $config_tree->nodeExists($_[0]); },
  68         'children'   => sub { return $config_tree->getChildren($_[0]); },
  69         'isLeaf'     => sub { return $config_tree->isLeaf($_[0]); },
  70         'isAlias'    => sub { return $config_tree->isAlias($_[0]); },
  71         'sortTokens' => sub { return $self->sortTokens($config_tree,
  72                                                        $_[0]); },
  73         'nodeName'   => sub { return $self->nodeName($config_tree, $_[0]); },
  74         'parent'     => sub { return $config_tree->getParent($_[0]); },
  75         'nodeParam'  => sub { return $config_tree->getNodeParam(@_); },
  76         'param'      => sub { return $config_tree->getParam(@_); },
  77         'url'        => sub { return $self->makeURL($config_tree, 0, @_); },
  78         'persistentUrl' => sub { return $self->makeURL($config_tree, 1, @_); },
  79         'clearVar'   => sub { delete $self->{'options'}{'variables'}{$_[0]};
  80                               return undef;},
  81         'plainURL'   => $Torrus::Renderer::plainURL,
  82         'splitUrls'  => sub { return $self->makeSplitURLs($config_tree,
  83                                                           $_[0], $_[1]); },
  84         'topURL'     => ($Torrus::Renderer::rendererURL ne '' ?
  85                          $Torrus::Renderer::rendererURL : '/'),
  86         'rrprint'    => sub { return $self->rrPrint($config_tree,
  87                                                     $_[0], $_[1]); },
  88         'scale'      => sub { return $self->scale($_[0], $_[1]); },
  89         'tsetMembers' => sub { $config_tree->tsetMembers($_[0]); },
  90         'tsetList'   => sub { $config_tree->getTsets(); },
  91         'style'      => sub { return $self->style($_[0]); },
  92         'companyName'=> $Torrus::Renderer::companyName,
  93         'companyLogo'=> $Torrus::Renderer::companyLogo,
  94         'companyURL' => $Torrus::Renderer::companyURL,
  95         'siteInfo'   => $Torrus::Renderer::siteInfo,
  96         'treeInfo'   => sub { return $Torrus::Global::treeConfig{
  97             $config_tree->treeName()}{'info'}; },
  98         'version'    => $Torrus::Global::version,
  99         'xmlnorm'    => \&Torrus::Renderer::xmlnormalize,
 100         'userAuth'   => $Torrus::CGI::authorizeUsers,
 101         'uid'        => $self->{'options'}->{'uid'},
 102         'userAttr'   => sub { return $self->userAttribute( $_[0] ) },
 103         'mayDisplayAdmInfo' => sub {
 104             return $self->may_display_adminfo( $config_tree, $_[0] ) },
 105         'adminfo' => $self->{'adminfo'},
 106         'mayDisplayReports' => sub {
 107             return $self->may_display_reports($config_tree) },
 108         'reportsUrl' => sub {
 109             return $self->reportsUrl($config_tree); },
 110         'timestamp'  => sub { return time2str($Torrus::Renderer::timeFormat,
 111                                               time()); },
 112         'verifyDate'  => sub { return verifyDate($_[0]); },
 113         'markup'     => sub{ return $self->translateMarkup( @_ ); },
 114         'searchEnabled' => $Torrus::Renderer::searchEnabled,
 115         'searchResults' => sub { return $self->doSearch($config_tree, $_[0]); }
 116     };
 117
 118
 119     # Pass the options from Torrus::Renderer::render() to Template
 120     while( my( $opt, $val ) = each( %{$self->{'options'}} ) )
 121     {
 122         $ttvars->{$opt} = $val;
 123     }
 124
 125     my $result = $self->{'tt'}->process( $tmplfile, $ttvars, $outfile );
 126
 127     undef $ttvars;
 128
 129     if( not $result )
 130     {
 131         if( $config_tree->isTset( $token ) )
 132         {
 133             Error("Error while rendering tokenset $token: " .
 134                   $self->{'tt'}->error());
 135         }
 136         else
 137         {
 138             my $path = $config_tree->path($token);
 139             Error("Error while rendering $path: " .
 140                   $self->{'tt'}->error());
 141         }
 142         return undef;
 143     }
 144
 145     return ($expires+time(), 'text/html; charset=UTF-8');
 146 }
 147
 148
 149 sub nodeName
 150 {
 151     my $self = shift;
 152     my $config_tree = shift;
 153     my $token = shift;
 154
 155     my $n = $config_tree->getNodeParam($token, 'node-display-name', 1);
 156     if( defined( $n ) and length( $n ) > 0 )
 157     {
 158         return $n;
 159     }
 160
 161     return $config_tree->nodeName($config_tree->path($token));
 162 }
 163
 164
 165 sub sortTokens
 166 {
 167     my $self = shift;
 168     my $config_tree = shift;
 169     my $tokenlist = shift;
 170
 171     my @sorted = ();
 172     if( ref($tokenlist) and scalar(@{$tokenlist}) > 0 )
 173     {
 174         @sorted = sort
 175         {
 176             my $p_a = $config_tree->getNodeParam($a, 'precedence', 1);
 177             $p_a = 0 unless defined $p_a;
 178             my $p_b = $config_tree->getNodeParam($b, 'precedence', 1);
 179             $p_b = 0 unless defined $p_b;
 180             if( $p_a == $p_b )
 181             {
 182                 my $n_a = $config_tree->path($a);
 183                 my $n_b = $config_tree->path($b);
 184                 return $n_a cmp $n_b;
 185             }
 186             else
 187             {
 188                 return $p_b <=> $p_a;
 189             }
 190         } @{$tokenlist};
 191     }
 192     else
 193     {
 194         push(@sorted, $tokenlist);
 195     }
 196     return @sorted;
 197 }
 198
 199
 200 # compose an URL for a node.
 201 # $persistent defines if the link should be persistent
 202 # Persistent link is done with nodeid if available, or with path
 203
 204 sub makeURL
 205 {
 206     my $self = shift;
 207     my $config_tree = shift;
 208     my $persistent = shift;
 209     my $token = shift;
 210     my $view = shift;
 211     my @add_vars = @_;
 212
 213     my $ret = $Torrus::Renderer::rendererURL . '/' . $config_tree->treeName();
 214
 215     if( $persistent )
 216     {
 217         my $nodeid = $config_tree->getNodeParam($token, 'nodeid', 1);
 218         if( defined( $nodeid ) )
 219         {
 220             $ret .= '?nodeid=' .
 221                 uri_escape($nodeid, $Torrus::Renderer::uriEscapeExceptions);
 222         }
 223         else
 224         {
 225             $ret .= '?path=' .
 226                 uri_escape($config_tree->path($token),
 227                            $Torrus::Renderer::uriEscapeExceptions);
 228         }
 229     }
 230     else
 231     {
 232         $ret .= '?token=' . uri_escape($token);
 233     }
 234
 235     if( $view )
 236     {
 237         $ret .= '&amp;view=' . uri_escape($view);
 238     }
 239
 240     my %vars = ();
 241     # This could be array or a reference to array
 242     my $add_vars_size = scalar( @add_vars );
 243     if( $add_vars_size == 1 and ref( $add_vars[0] ) )
 244     {
 245         %vars = @{$add_vars[0]};
 246     }
 247     elsif( $add_vars_size > 0 and ($add_vars_size % 2 == 0) )
 248     {
 249         %vars = @add_vars;
 250     }
 251
 252     if( ref( $self->{'options'}->{'variables'} ) )
 253     {
 254         foreach my $name ( sort keys %{$self->{'options'}->{'variables'}} )
 255         {
 256             my $val = $self->{'options'}->{'variables'}->{$name};
 257             if( not defined( $vars{$name} ) )
 258             {
 259                 $vars{$name} = $val;
 260             }
 261         }
 262     }
 263
 264     foreach my $name ( sort keys %vars )
 265     {
 266         if( $vars{$name} ne '' )
 267         {
 268             $ret .= '&amp;' . $name . '=' .
 269                 uri_escape( $vars{$name},
 270                             $Torrus::Renderer::uriEscapeExceptions );
 271         }
 272     }
 273
 274     return $ret;
 275 }
 276
 277 sub makeSplitURLs
 278 {
 279     my $self = shift;
 280     my $config_tree = shift;
 281     my $token = shift;
 282     my $view = shift;
 283
 284     my $ret = '';
 285     while( defined( $token ) )
 286     {
 287         my $path = $config_tree->path($token);
 288
 289         my $str = '<SPAN CLASS="PathElement">';
 290         $str .=
 291             sprintf('<A HREF="%s">%s%s</A>',
 292                     $self->makeURL($config_tree, 0, $token, $view),
 293                     $config_tree->nodeName($path),
 294                     ( $config_tree->isSubtree($token) and
 295                       $path ne '/') ? '/':'' );
 296         $str .= "</SPAN>\n";
 297
 298         $ret = $str . $ret;
 299
 300         $token = $config_tree->getParent( $token );
 301     }
 302
 303     return $ret;
 304 }
 305
 306
 307 sub rrPrint
 308 {
 309     my $self = shift;
 310     my $config_tree = shift;
 311     my $token = shift;
 312     my $view = shift;
 313
 314     my @ret = ();
 315     my($fname, $mimetype) = $self->render( $config_tree, $token, $view );
 316
 317     if( $mimetype ne 'text/plain' )
 318     {
 319         Error("View $view does not produce text/plain for token $token");
 320     }
 321     else
 322     {
 323         if( not open(IN, $fname) )
 324         {
 325             Error("Cannot open $fname for reading: $!");
 326         }
 327         else
 328         {
 329             chomp(my $values = <IN>);
 330             @ret = split(':', $values);
 331             close IN;
 332         }
 333     }
 334     return @ret;
 335 }
 336
 337 # This subroutine is taken from Dave Plonka's Flowscan
 338
 339 sub scale
 340 {
 341     my $self = shift;
 342     # This is based somewhat on Tobi Oetiker's code in rrd_graph.c:
 343     my $fmt = shift;
 344     my $value = shift;
 345     my @symbols = ("a", # 10e-18 Ato
 346                    "f", # 10e-15 Femto
 347                    "p", # 10e-12 Pico
 348                    "n", # 10e-9  Nano
 349                    "u", # 10e-6  Micro
 350                    "m", # 10e-3  Milli
 351                    " ", # Base
 352                    "k", # 10e3   Kilo
 353                    "M", # 10e6   Mega
 354                    "G", # 10e9   Giga
 355                    "T", # 10e12  Terra
 356                    "P", # 10e15  Peta
 357                    "E"); # 10e18  Exa
 358
 359     my $symbcenter = 6;
 360     my $digits = (0 == $value)? 0 : floor(log(abs($value))/log(1000));
 361     return sprintf( $fmt . " %s", $value/pow(1000, $digits),
 362                     $symbols[ $symbcenter+$digits ] );
 363 }
 364
 365 sub style
 366 {
 367     my $self = shift;
 368     my $object = shift;
 369
 370     my $media;
 371     if( not defined( $media = $self->{'options'}->{'variables'}->{'MEDIA'} ) )
 372     {
 373         $media = 'default';
 374     }
 375     return  $Torrus::Renderer::styling{$media}{$object};
 376 }
 377
 378
 379
 380 sub userAttribute
 381 {
 382     my $self = shift;
 383     my $attr = shift;
 384
 385     if( $self->{'options'}->{'uid'} and $self->{'options'}->{'acl'} )
 386     {
 387         $self->{'options'}->{'acl'}->
 388             userAttribute( $self->{'options'}->{'uid'}, $attr );
 389     }
 390     else
 391     {
 392         return '';
 393     }
 394 }
 395
 396 sub hasPrivilege
 397 {
 398     my $self = shift;
 399     my $object = shift;
 400     my $privilege = shift;
 401
 402     if( $self->{'options'}->{'uid'} and $self->{'options'}->{'acl'} )
 403     {
 404         $self->{'options'}->{'acl'}->
 405             hasPrivilege( $self->{'options'}->{'uid'}, $object, $privilege );
 406     }
 407     else
 408     {
 409         return undef;
 410     }
 411 }
 412
 413
 414 sub translateMarkup
 415 {
 416     my $self = shift;
 417     my @strings = @_;
 418
 419     my $tt = new Template( TRIM => 1 );
 420
 421     my $ttvars =
 422     {
 423         'em'      =>  sub { return '<em>' . $_[0] . '</em>'; },
 424         'strong'  =>  sub { return '<strong>' . $_[0] . '</strong>'; }
 425     };
 426
 427     my $ret = '';
 428
 429     foreach my $str ( @strings )
 430     {
 431         my $output = '';
 432         my $result = $tt->process( \$str, $ttvars, \$output );
 433
 434         if( not $result )
 435         {
 436             Error('Error translating markup: ' . $tt->error());
 437         }
 438         else
 439         {
 440             $ret .= $output;
 441         }
 442     }
 443
 444     undef $tt;
 445
 446     return $ret;
 447 }
 448
 449
 450 sub verifyDate
 451 {
 452     my $input = shift;
 453
 454     my $time = str2time( $input );
 455     # rrdtool does not understand dates prior to 1980 (315529200)
 456     if( defined( $time ) and $time > 315529200 )
 457     {
 458         # Present the time in format understood by rrdtool
 459         return time2str('%H:%M %Y%m%d', $time);
 460     }
 461     else
 462     {
 463         return '';
 464     }
 465 }
 466
 467
 468 sub may_display_reports
 469 {
 470     my $self = shift;
 471     my $config_tree = shift;
 472
 473     if( $Torrus::Renderer::displayReports )
 474     {
 475         if( not $Torrus::CGI::authorizeUsers )
 476         {
 477             return 1;
 478         }
 479
 480         my $tree = $config_tree->treeName();
 481         if( $self->hasPrivilege( $tree, 'DisplayReports' ) and
 482             -r $Torrus::Global::reportsDir . '/' . $tree .
 483             '/html/index.html' )
 484         {
 485             return 1;
 486         }
 487     }
 488     return 0;
 489 }
 490
 491
 492 sub reportsUrl
 493 {
 494     my $self = shift;
 495     my $config_tree = shift;
 496
 497     return $Torrus::Renderer::rendererURL . '/' .
 498         $config_tree->treeName() . '?htmlreport=index.html';
 499 }
 500
 501
 502 sub doSearch
 503 {
 504     my $self = shift;
 505     my $config_tree = shift;
 506     my $string = shift;
 507
 508
 509     my $tree = $config_tree->treeName();
 510
 511     my $sr = new Torrus::Search;
 512     $sr->openTree( $tree );
 513     my $result = $sr->searchPrefix( $string, $tree );
 514     $sr->closeTree( $tree );
 515
 516     my $ret = [];
 517     push( @{$ret}, sort {$a->[0] cmp $b->[0]} @{$result} );
 518
 519     return $ret;
 520 }
 521
 522
 523 1;
 524
 525
 526 # Local Variables:
 527 # mode: perl
 528 # indent-tabs-mode: nil
 529 # perl-indent-level: 4
 530 # End: