innreport.in

Alexander Bartolich alexander.bartolich at gmx.at
Tue Sep 9 21:56:34 UTC 2008


This a diff between subversion and my development version of innreport.

Function EscapeHTML sanitizes input from log files by replacing special
characters with (especially non-ASCII characters) with HTML-entities.

Split EvalExpr into parts:

PrepareEval takes a expression from innreport.conf (a string), substitutes
variable names and pseudo-functions, compiles the code to a anonymous
subroutine, and returns it together with references to enclosure variables.
EvalExpr and EvalHash call a subroutine compiled by PrepareEval.

All three functions provide diagnostic output (and throw an exception
on errors) if $DEBUG is true.

All expression evolution is now done through PrepareEval.

Functions ComputeTotal and ComputeTotalDouble now use a cache.
The performance gain is insignificant, but if $DEBUG is true then
modifications of the input parameter (a hash) can be detected.

New perl function Divide0 is available to innreport.conf as
"div0". It returns 0 if one of the divisors is 0.

At the moment expressions in innreport.conf throw lots of
division-by-zero exceptions, so it is not possible to run
innreport if $DEBUG is true.

Index: scripts/innreport.in
===================================================================
--- scripts/innreport.in	(revision 8020)
+++ scripts/innreport.in	(working copy)
@@ -91,6 +91,7 @@
  # to this file.

  use strict;
+use Carp qw(confess);

  ## Do you want to create a Web page. Pick DO or DONT.
  my $HTML = "DO";
@@ -99,7 +100,7 @@
  my $GRAPH = "DO";

  ## Directory for the Web pages (used only if the previous line is active)
-my $HTML_dir = "$INN::Config::pathhttp";
+my $HTML_dir = $INN::Config::pathhttp;

  ## Directory for the pictures (need HTML support) in the file space
  my $IMG_dir = "$HTML_dir/pics";
@@ -143,7 +144,7 @@
  ## THERE'S NOTHING TO CHANGE AFTER THIS LINE ##
  ###############################################

-my $version = "3.0.5";
+my $version = "3.1.0";
  my %output; # content of the configuration file.
  my $DEBUG = 0; # set to 1 to verify the structure/content of the conf file.
  my $start_time = time;
@@ -355,6 +356,13 @@
  eval $s;  # initialization
  die "Can't find/load $CLASS.pm : $@\n" if $@;

+my $collectFunc;
+{
+  my $s = '*{$' . $CLASS . '::{"collect"}}{"CODE"}';
+  $collectFunc = eval $s;
+  confess "eval($s) raises $@" if ($@ || !defined($s));
+}
+
  my $save_line = <>;
  $_ = $save_line;
  local $^W = 0 if $] < 5.004; # to avoid a warning for each '+=' first use.
@@ -380,7 +388,7 @@
    }

    # skip empty lines
-  next LINE if $_ eq '';
+  next LINE if length($_) == 0;

    my $res;
    my ($day, $hour, $prog, $left) =
@@ -440,11 +448,7 @@
    $prog_size{$prog} += $size;

    # The "heart" of the tool.
-  {
-    no strict;
-    next LINE if
-      &{$CLASS."::collect"} ($day, $hour, $prog, $res, $left, $CASE_SENSITIVE);
-  }
+  next LINE if &$collectFunc($day, $hour, $prog, $res, $left, $CASE_SENSITIVE);

    $unrecognize[$unrecognize_max] = $_
      unless $unrecognize_max > $MAX_UNRECOGNIZED
@@ -457,11 +461,14 @@
    &{$CLASS . "::adjust"} ($first_date, $last_date);
  }

-$| = 1;
+# man perlvar
+# $| ... If set to nonzero, forces a flush right away and after
+# every write or print on the currently selected output channel.
+$| = $DEBUG;

  die "no data. Abort.\n" unless $total_line;

-my $sec_glob = &ConvDate ("$last_date") - &ConvDate ("$first_date");
+my $sec_glob = &ConvDate($last_date) - &ConvDate($first_date);
  unless ($sec_glob) {
    print "WARNING: bad date (\"$last_date\" or \"$first_date\")\n" .
          "         Please, contact the author of innreport.\n";
@@ -567,7 +574,11 @@
  # Compare 2 dates (+hour)
  sub DateCompare {
    # ex: "May 12 06"   for May 12, 6:00am
+
+  # $[ ... The index of the first element in an array, and of the first
+  #        character in a substring. Default is 0.
    local $[ = 0;
+
    # The 2 dates are near. The range is less than a few days that's why we
    # can cheat to determine the order. It is only important if one date
    # is in January and the other in December.
@@ -589,41 +600,25 @@


  # Convert: seconds to hh:mm:ss
-sub second2time {
-  my $temp;
-  my $t = shift;
-  # Hours
-  $temp = sprintf "%02d", $t / 3600;
-  my $chaine = "$temp:";
-  $t %= 3600;
-  # Min
-  $temp = sprintf "%02d", $t / 60;
-  $chaine .= "$temp:";
-  $t %= 60;
-  # Sec
-  $chaine .= sprintf "%02d", $t;
-  return $chaine;
+sub second2time($) {
+  my $sec = shift;
+  my $hour = $sec / 3600;
+  $sec %= 3600;
+  my $min = $sec / 60;
+  $sec %= 60;
+  return sprintf '%02d:%02d:%02d', $hour, $min, $sec;
  }

  # Convert: milliseconds to hh:mm:ss:mm
-sub ms2time {
-  my $temp;
-  my $t = shift;
-  # Hours
-  $temp = sprintf "%02d", $t / 3600000;
-  my $chaine = "$temp:";
-  $t %= 3600000;
-  # Min
-  $temp = sprintf "%02d", $t / 60000;
-  $chaine .= "$temp:";
-  $t %= 60000;
-  # Sec
-  $temp = sprintf "%02d", $t / 1000;
-  $chaine .= "$temp.";
-  $t %= 1000;
-  # Millisec
-  $chaine .= sprintf "%03d", $t;
-  return $chaine;
+sub ms2time($) {
+  my $ms = shift;
+  my $hour = $ms / 3600000;
+  $ms %= 3600000;
+  my $min = $ms / 60000;
+  $ms %= 60000;
+  my $sec = $ms / 1000;
+  $ms %= 1000;
+  return sprintf '%02d:%02d:%02d.%03d', $hour, $min, $sec, $ms;
  }

  # Rotate the archive files..
@@ -697,28 +692,53 @@
    $lb <=> $la;
  }

-sub ComputeTotal {
-  my $h = shift;
+my %ComputeTotalCache;
+sub ComputeTotal($) {
+  my $h = shift || confess;
+
+  my $cached = $ComputeTotalCache{$h};
+  if (defined($cached) && !$DEBUG) { return $cached; }
+
    my $total = 0;
-  my $key;
-  foreach $key (keys (%$h)) {
-    $total += $$h{$key};
+  while(my ($key, $value) = each %$h) {
+    confess $key unless(defined($value));
+    $total += $value;
    }
-  $total;
+  if (defined($cached) && $cached != $total)
+    { confess "ComputeTotal mismatch $cached != $total"; }
+  return $ComputeTotalCache{$h} = $total;
  }

-sub ComputeTotalDouble {
-  my $h = shift;
+my %ComputeTotalDouble;
+sub ComputeTotalDouble($) {
+  my $h = shift || confess;
+
+  my $cached = $ComputeTotalCache{$h};
+  if (defined($cached) && !$DEBUG) { return $cached; }
+
    my $total = 0;
-  my ($key1, $key2);
-  foreach $key1 (keys (%$h)) {
-    foreach $key2 (keys (%{$$h{$key1}})) {
-      $total += ${$$h{$key1}}{$key2};
+  while(my ($key1, $value1) = each %$h) {
+    confess $key1 unless(defined($value1));
+    while(my ($key2, $value2) = each %$value1) {
+      confess $key2 unless(defined($value2));
+      $total += $value2;
      }
    }
-  $total;
+  if (defined($cached) && $cached != $total)
+    { confess "ComputeTotalDouble mismatch $cached != $total"; }
+  return $ComputeTotalDouble{$h} = $total;
  }

+sub EscapeHTML($) {
+  my $v = shift;
+  confess unless(defined($v));
+  $v =~ s/&/\&amp;/g;
+  $v =~ s/</\&lt;/g;
+  $v =~ s/>/\&gt;/g;
+  $v =~ s/([\x{7F}-\x{FFFF}])/sprintf('&#%d;', ord($1))/eg;
+  return $v;
+}
+
  sub GetHTMLHeader($) {
    my $title = shift;

@@ -737,7 +757,6 @@
    my $style_sheet = '';
    my $css_url = $output{'default'}{'html_css_url'};
    if (defined($css_url)) {
-printf STDERR "css_url [%s]\n", $css_url;
      $css_url = &GetValue($css_url);
      $style_sheet = <<EOF;
  <link rel="stylesheet" type="text/css" media="all" href="$css_url"/>
@@ -903,7 +922,7 @@
  }

  # make an index for archive pages
-sub Make_Index {
+sub Make_Index($$$$) {
    my ($rep, $index, $filename, $data) = @_;
    my %output = %$data;

@@ -1078,7 +1097,7 @@
    my $xmax = shift;               # width
    my $n = shift;                  # Number of hash code tables

-  no strict;
+  use strict;
    my ($i, $k, $t);
    my @val;
    for $i (0 .. $n - 1) {
@@ -1310,11 +1329,11 @@
    $ymax;
  }

-sub Histo {
+sub Histo($$$$$$$$) {
    my ($filename, $title, $xmax, $factor,
        $labelx, $labely, $val1, $labels1) = @_;

-  no strict;
+  use strict;
    my $max = 0;
    my $ymax = 300;
    my $nb = 0;
@@ -1933,10 +1952,7 @@
      print HTML "<ul>\n";
      foreach $k (@{$$h{'_order_'}}) {
        next if $k =~ m/^(default|index)$/;
-      my ($data) = $$h{$k}{'data'} =~ m/^\"\s*(.*?)\s*\"$/o;
-      $data =~ s/^\%/\%$CLASS\:\:/ unless $data eq '%prog_type';
-      my %data;
-      { local $^W = 0; no strict; %data = eval $data }
+      my $r_data = EvalHash( $h->{$k}{'data'} );
        my ($string) = $$h{$k}{'title'} =~ m/^\"\s*(.*?)\s*\"$/o;
        $string =~ s/\s*:$//o;
        my $want = 1;
@@ -1944,7 +1960,9 @@
        ($want) = $$h{$k}{'skip'} =~ m/^\"?\s*(.*?)\s*\"?$/o
  	if defined $$h{$k}{'skip'};
        $want = $want eq 'true' ? 0 : 1;
-      print HTML "<li><a href=\"#$k\">$string</a></li>\n" if %data && $want;
+      if (%$r_data && $want) {
+	printf HTML "<li><a href=\"#%s\">%s</a></li>\n", $k, $string;
+      }
      }
      print HTML "</ul>\n";
    }
@@ -1971,10 +1989,7 @@
        chomp $unrecognize[$l];     # sometimes, the last line need a CR
        print "$unrecognize[$l]\n"; # so, we always add one
        if ($HTML && $WANT_HTML_UNKNOWN) {
-	$unrecognize[$l] =~ s/&/\&amp;/g;
-	$unrecognize[$l] =~ s/</\&lt;/g;
-	$unrecognize[$l] =~ s/>/\&gt;/g;
-	print HTML $unrecognize[$l], "<br/>\n";
+        print HTML EscapeHTML($unrecognize[$l]), "<br/>\n";
        }
      }
      print "\n";
@@ -2032,26 +2047,17 @@
    my $TOP_TEXT = defined $output{$report}{'top_text'} ?
                     $output{$report}{'top_text'} : $TOP;

-  my (%h, %d, $h);
+  my (%h, $r_data, @keys, $h);
    {
      my $t = $output{$report}{'data'} ||
        die "Error in section $report. Need a 'data' field.\n";
-    $t =~ s/^\"\s*(.*?)\s*\"$/$1/o;
-    $t =~ s/^\%/\%$CLASS\:\:/ unless $t eq '%prog_type';
-    %d = eval $t;
-    return unless %d; # nothing to report. exit.
-    return unless keys (%d); # nothing to report. exit.
+    $r_data = EvalHash($t);
+    @keys = keys (%$r_data);
+    return unless @keys; # nothing to report. exit.
    }
    {
-    my $t = defined $output{$report}{'sort'} ? $output{$report}{'sort'} :
-      "\$a cmp \$b";
-    $t =~ s/\n/ /smog;
-    $t =~ s/^\"\s*(.*?)\s*\"$/$1/o;
-    $t =~ s/([\$\%\@])/$1${CLASS}\:\:/go;
-    $t =~ s/([\$\%\@])${CLASS}\:\:(prog_(?:size|type)|key|num)/$1$2/go;
-    $t =~ s/\{\$${CLASS}\:\:(a|b)\}/\{\$$1\}/go;
-    $t =~ s/\$${CLASS}\:\:(a|b)/\$$1/go;
-    $h = $t;
+    my $t = $output{$report}{'sort'};
+    ( $h ) = defined($t) ? PrepareEval($t) : sub { $a cmp $b };
    }

    if ($HTML) {
@@ -2116,15 +2122,15 @@
    my $done;
    if ($DOUBLE) {
      my $num_d = 0;
-    foreach $key1 (sort keys (%d)) {
+    foreach $key1 (sort @keys) {
        $done = 0;
        $num = 0;
        $num_d++;
        $s = '';
        $html = '';
        my @res;
-      foreach $key2 (sort {$d{$key1}{$b} <=> $d{$key1}{$a}}
-		     keys (%{$d{$key1}})) {
+      foreach $key2 (sort {$r_data->{$key1}{$b} <=> $r_data->{$key1}{$a}}
+		     keys (%{$r_data->{$key1}})) {
  	my $first = 0;
  	$num++;
  	foreach $i (@{$output{$report}{'column'}}) {
@@ -2165,7 +2171,7 @@

  		# Hardcoded colspan=3 works for "Miscellaneous innd statistics:".
  		$html .= "<td class=\"ir-primaryKey\" align=\"left\" colspan=\"3\">";
-		$html .= sprintf($v1, $r);
+		$html .= sprintf($v1, EscapeHTML($r));
  		$html .= "</td></tr>\n<tr><td></td>";
  	      }
  	    }
@@ -2176,10 +2182,10 @@
  	      $s .= sprintf $v1 . " ", $r;
  	    }
  	    if ($HTML && $whtml) {
-	      $html .= $numbering ? "<td></td>" : '' if $first == 1;
+	      $html .= $numbering ? '<td></td>' : '' if $first == 1;
  	      $v1 =~ s/\%-?(?:\d+(?:\.\d+)?)?s/\%s/g;
  	      my $temp = $first > 1 ? "right" : "left";
-	      $html .= sprintf "<td align=\"$temp\">$v1</td>", $r;
+	      $html .= sprintf "<td align=\"%s\">$v1</td>", $temp, EscapeHTML($r);
  	    }
  	  }
  	  $done = 1 if $p;
@@ -2212,11 +2218,11 @@
  	    (defined ($$i{'format'}) ? $$i{'format'} : "%s");
  	  $v1 =~ s/^\"\s*(.*?)\s*\"$/$1/o;
  	  my $r = $first == 1 ? $num : $res[$first];
-	  $s .= sprintf $v1 . " ", $r;
+	  $s .= sprintf $v1 . ' ', $r;
  	  if ($HTML) {
  	    my $temp = $first > 1 ? 'align="right"' : 'class="ir-totalColumn"';
  	    $v1 =~ s/\%-?(?:\d+(?:\.\d+)?)?s/\%s/g;
-	    $html .= sprintf "<td $temp>$v1</td>", $r;
+	    $html .= sprintf "<td %s>$v1</td>", $temp, EscapeHTML($r);
  	  }
  	  $first++;
  	}
@@ -2257,7 +2263,7 @@
  	$temp .= ' colspan="2"' if $numbering && !$first;
  	$v1 =~ s/\%-?(?:\d+(?:\.\d+)?)?s/\%s/g;
  	$html .= $first == 1 ? "<td></td>" :
-	         sprintf "<td $temp>$v1</td>", $r;
+	         sprintf "<td %s>$v1</td>", $temp, EscapeHTML($r);
        }
        $first++;
      }
@@ -2272,10 +2278,9 @@
      }
    }
    else {
-    # foreach $key (sort { local $^W = 0; no strict; eval $h } (keys (%d)))
-    foreach $key ((eval "sort {local \$^W = 0; no strict; $h} (keys (%d))")) {
+    foreach $key (sort $h @keys) {
        next unless defined $key;
-      next unless defined $d{$key}; # to avoid problems after some undef()
+      next unless defined $r_data->{$key}; # to avoid problems after some undef()
        $num++;
        next unless $num <= $TOP_HTML || $TOP_HTML == -1 ||
  	          $num <= $TOP_TEXT || $TOP_TEXT == -1;
@@ -2300,10 +2305,14 @@
  	$s .= sprintf $v1 . " ", $r
  	  if $wtext && (($num <= $TOP_TEXT) || ($TOP_TEXT == -1));
  	if ($HTML && $whtml && ($num <= $TOP_HTML || $TOP_HTML == -1)) {
+
+          # substitute full fledged "%s" specifiers (alignment, width
+          # and precision) with a plain "%s"
  	  $v1 =~ s/\%-?(?:\d+(?:\.\d+)?)?s/\%s/g;
+
  	  $html .= "<th align=\"center\">$num</th>" if $numbering && !$first;
  	  my $temp = $first ? "right" : "left";
-	  $html .= sprintf "<td align=\"$temp\">$v1</td>", $r;
+	  $html .= sprintf "<td align=\"$temp\">$v1</td>", EscapeHTML($r);
  	}
  	$first++;
        }
@@ -2343,7 +2352,7 @@
  	$v1 =~ s/\%-?(?:\d+(?:\.\d+)?)?s/\%s/g;
  	my $temp = $first ? 'align="right"' : 'class="ir-totalColumn"';
  	$temp .= ' colspan="2"' if $numbering && !$first;
-	$html .= sprintf "<td $temp>$v1</td>", $r;
+	$html .= sprintf "<td $temp>$v1</td>", EscapeHTML($r);
        }
        $first++;
      }
@@ -2366,11 +2375,7 @@
  	  my $j;
  	  foreach $j (@{${${$output{$report}{'graph'}}[$i]}{'data'}}) {
  	    $num++;
-	    my ($h) = $$j{'value'} =~ m/^\"\s*(.*?)\s*\"$/o;
-	    my %hh;
-	    $h =~ s/^\%/\%$CLASS\:\:/ unless $h eq '%prog_type';
-	    { local $^W = 0; no strict; %hh = eval $h }
-	    push @values, \%hh;
+	    push @values, EvalHash( $j->{'value'} );
  	    my ($t) = $$j{'name'} =~ m/^\"\s*(.*?)\s*\"$/o;
  	    push @labels, $t;
  	    $t = $$j{'color'} ||
@@ -2395,7 +2400,6 @@
  	  print HTML "src=\"$IMG_pth$report$s.$GD_FORMAT\"/></div>\n";
  	}
          elsif ($type eq 'histo') {
-	  my (%values, %labels);
  	  my $factor =
  	    ${${${${$output{$report}{'graph'}}[$i]}{'data'}}[1]}{'factor'}
               || die "Error in section $report section 'graph'. " .
@@ -2418,24 +2422,25 @@
  	       "No 'value' specified for " .
  	       ${${${${$output{$report}{'graph'}}[$i]}{'data'}}[0]}{'name'} .
  	       ".\n";
-	  $t =~ s/^\"\s*(.*?)\s*\"$/$1/o;
-	  $t =~ s/^\%/\%$CLASS\:\:/ unless $t eq '%prog_type';
-	  { local $^W = 0; no strict; %labels = eval $t }
+          my $r_labels = EvalHash( $t );

  	  $t = ${${${${$output{$report}{'graph'}}[$i]}{'data'}}[1]}{'value'} ||
  	     die "Error in section $report section 'graph'. " .
  	       "No 'value' specified for " .
  	       ${${${${$output{$report}{'graph'}}[$i]}{'data'}}[1]}{'name'} .
  	       ".\n";
-	  $t =~ s/^\"\s*(.*?)\s*\"$/$1/o;
-	  $t =~ s/^\%/\%$CLASS\:\:/ unless $t eq '%prog_type';
-	  { local $^W = 0; no strict; %values = eval $t }
+	  my $r_values = EvalHash( $t );
  	  my $s = ($i ? $i : '') . $suffix;
  	  {
  	    my $r;
  	    close HTML;
+	    #
+	    # 6th argument of function Histo is a reference to a hash,
+	    # but it is modified, so pass it a copy
+	    #
+	    my %values = %$r_values;
  	    $r = &Histo ("$IMG_dir/$report$s.$GD_FORMAT", $title, $xmax,
-			 $factor, $labelx, $labely, \%values, \%labels);
+			 $factor, $labelx, $labely, \%values, $r_labels);
  	    open (HTML, ">> $HTML_output") ||
  	      die "Error: cant open $HTML_output\n";
  	    if ($r) {
@@ -2454,47 +2459,127 @@
  	    "Invalid 'type' value.\n"
  	}
  	$i++;
-	print HTML "<p/>\n";
        }
      }
    }
    close HTML if $HTML;
  }

-sub EvalExpr {
-  my $v = shift;
-  my ($key, $num, $key1) = @_;
+sub PrepareEval($;$) {
+  my $string = shift;
+  my $double = shift;
+
+  # reduce white space (including line feeds) to single space
+  $string =~ s/\s+/ /smog;
+
+  # remove surrounding double quotes, if any
+  $string =~ s/^\"\s*(.*?)\s*\"$/$1/o;
+
+  # convert "%innd_his" to "%innreport_inn::innd_his"
+  $string =~ s/([\$\%\@])([^{\s\d])/$1${CLASS}\:\:$2/og;
+
+  # However, a few variables are defined through the enclosure.
+  # $a and $b are provided by function sort.
+  # So convert "%innreport_inn::prog_type" back to "%prog_type"
+  $string =~ s/([\$\%\@])${CLASS}\:\:(
+    a|
+    b|
+    key\d*|
+    num|
+    prog_size|
+    prog_type|
+    sec_glob
+  )\b/$1$2/xog;
+
+  # If expression consists of a single hash then just return a
+  # reference to it.
+
+  if ($string !~ s/^\%/\\%/) {
+
+    # otherwise convert pseudo-functions to real Perl code
+
+    my %Func = (
+      'bytes'   => '&NiceByte(',
+      'div0'    => '&Divide0(',
+      'time_ms' => '&ms2time(',
+      'time'    => '&second2time(',
+      'total%'  => (
+	$double ? '&ComputeTotalDouble(\\%' : '&ComputeTotal(\\%'
+      )
+    );
+
+    my $i = 0;
+    do {
+      if ($DEBUG) { printf STDERR "PrepareEval %d [%s]\n", $i++, $string; }
+    } while(
+      $string =~ s/ (^|[^&\w]) ([a-z][a-z_0-9]+) \s* \( \s* (%)?
+		  /$1 . $Func{$2 . ($3||'')}
+		  /xoge
+    );
+  }
+
+  if ($DEBUG) { printf STDERR "PrepareEval - [%s]\n", $string; }
+
+  # These variables are provided to the function inside the closure.
+  # PrepareEval returns references to these variables.
+  my $sub;
+  my $num;
+  my $key;
+  my $key1;
    my $key2;

-  $v =~ s/\n/ /smog;
-  $v =~ s/^\"(.*?)\"$/$1/o;
-  if ($key1) {
-    $key2 = $key;
-    $v =~ s/([^a-zA-Z_\-]?)total\s*\(\s*%/$1&ComputeTotalDouble\(\\%/og;
-  }
-  else {
-    $v =~ s/([^a-zA-Z_\-]?)total\s*\(\s*%/$1&ComputeTotal\(\\%/og;
-    # $v =~ s/([^a-zA-Z_\-]?)total\s*\(\s*%([^\)]*)\)/$1&ComputeTotal\("$2"\)/og;
-  }
-  $v =~ s/([^a-zA-Z_\-]?)bytes\s*\(\s*/$1&NiceByte\(/og;
-  $v =~ s/([^a-zA-Z_\-]?)time\s*\(\s*/$1&second2time\(/og;
-  $v =~ s/([^a-zA-Z_\-]?)time_ms\s*\(\s*/$1&ms2time\(/og;
-  # $v =~ s/([\$\%\@])/$1${CLASS}\:\:/og;
-  $v =~ s/([\$\%\@])([^{\s\d])/$1${CLASS}\:\:$2/og;
-  $v =~ s/([\$\%\@])${CLASS}\:\:(prog_(?:size|type)|key|sec_glob|num)/$1$2/og;
+  # man perlvar
+  # $^W ... The current value of the warning switch, initially
+  #         true if -w was used.
+  { local $^W = $DEBUG; $sub = eval "sub { $string; }"; }
+  if ($@) { confess "PrepareEval($string) raises $@"; }
+
+  return ( $sub, \$num, \$key, \$key1, \$key2 );
+}
+
+sub EvalHash($) {
+  my $v = shift;
+  my ( $sub ) = PrepareEval($v);
+
+  my $result;
+  eval { local $^W = $DEBUG; $result = &$sub(); };
+  if ($@ && $DEBUG) { confess "EvalHash($v) raises $@"; }
+  if (ref($result) ne 'HASH')
+    { confess "EvalHash($v) does not return reference to hash."; }
+  return $result;
+}
+
+sub EvalExpr {
+  my ( $v, $key, $num, $key1 ) = @_;
+  my ( $sub, $r_num, $r_key, $r_key1, $r_key2 ) = PrepareEval($v, $key1);
+
+  $$r_num = $num;
+  $$r_key = $key;
+  $$r_key1 = $key1;
+  $$r_key2 = $key1 ? $key : undef;
+
    my $r;
-  # eval { local $^W = 0; no strict; ($r) = eval $v; };
-  eval " local \$^W = 0; no strict; (\$r) = $v; ";
-  $r = 0 unless defined $r;
-  $r;
+  eval { local $^W = $DEBUG; ($r) = &$sub(); };
+  if ($@ && $DEBUG) { confess "EvalExpr($v) raises $@"; }
+  return ($r || 0);
  }

-sub NiceByte {
-  my $size = shift;
-  my $t;
+sub Divide0(@)
+{
+  my $dividend = shift;
+  return 0 unless $dividend;

-  $size = 0 unless defined $size;
-  $t = $size / 1024 / 1024 / 1024 > 1 ?
+  for my $divisor(@_)
+  {
+    return 0 unless $divisor;
+    $dividend /= $divisor;
+  }
+  return $dividend;
+}
+
+sub NiceByte(;$) {
+  my $size = shift() || 0;
+  my $t = $size / 1024 / 1024 / 1024 > 1 ?
      sprintf "%.1f GB", $size / 1024 / 1024 / 1024 :
        ($size / 1024 / 1024 > 1 ? sprintf "%.1f MB", $size / 1024 / 1024 :
  	sprintf "%.1f KB", $size / 1024);



More information about the inn-patches mailing list