torrus/perllib/Torrus/RPN.pm

   1 #
   2 #    Copyright (C) 1998 Jeff R. Allen and WebTV Networks, Inc.
   3 #    Copyright (C) 2002  Stanislav Sinyagin
   4 #
   5 #    This program is free software; you can redistribute it and/or modify
   6 #    it under the terms of the GNU General Public License as published by
   7 #    the Free Software Foundation; either version 2 of the License, or
   8 #    (at your option) any later version.
   9 #
  10 #    This program is distributed in the hope that it will be useful,
  11 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 #    GNU General Public License for more details.
  14 #
  15 #    You should have received a copy of the GNU General Public License
  16 #    along with this program; if not, write to the Free Software
  17 #    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
  18
  19 # $Id: RPN.pm,v 1.1 2010-12-27 00:03:40 ivan Exp $
  20 # Stanislav Sinyagin <ssinyagin@yahoo.com>
  21
  22 # a simple little RPN calculator -- implements the same operations
  23 # that RRDTool does.
  24
  25 # This file is based on Cricket's RPM.pm
  26
  27 package Torrus::RPN;
  28
  29 use strict;
  30
  31 use Torrus::Log;
  32 use Math::BigFloat;
  33
  34 # Each RPN operator is defined by an array reference with the
  35 # following  elements: <number of args>, <subroutine>, <accepts undef>
  36
  37 my $operators = {
  38     '+' => [ 2, sub{ $_[0] + $_[1]; } ],
  39     '-' => [ 2, sub{ $_[0] - $_[1]; } ],
  40     '*' => [ 2, sub{ $_[0] * $_[1]; } ],
  41     '/' => [ 2, sub{ $_[0] / $_[1]; } ],
  42     '%' => [ 2, sub{ $_[0] % $_[1]; } ],
  43     'MOD' => [ 2, sub{ $_[0] % $_[1]; } ],
  44     'SIN' => [ 1, sub{ sin($_[0]->bsstr()); } ],
  45     'COS' => [ 1, sub{ cos($_[0]->bsstr()); } ],
  46     'LOG' => [ 1, sub{ log($_[0]); } ],
  47     'EXP' => [ 1, sub{ $_[0]->exponent() } ],
  48     'FLOOR' => [ 1, sub{ $_[0]->bfloor(); } ],
  49     'CEIL' => [ 1, sub{ $_[0]->bceil(); } ],
  50     'LT' => [ 2, sub{ ($_[0] <  $_[1]) ? 1:0; } ],
  51     'LE' => [ 2, sub{ ($_[0] <= $_[1]) ? 1:0; } ],
  52     'GT' => [ 2, sub{ ($_[0] >  $_[1]) ? 1:0; } ],
  53     'GE' => [ 2, sub{ ($_[0] >= $_[1]) ? 1:0; } ],
  54     'EQ' => [ 2, sub{ ($_[0] == $_[1]) ? 1:0; } ],
  55     'IF' => [ 3, sub{ defined($_[0]) ? ($_[0] ? $_[1] : $_[2]) : undef; }, 1],
  56     'MIN' => [ 2, sub{ ($_[0] <  $_[1]) ? $_[0] : $_[1]; } ],
  57     'MAX' => [ 2, sub{ ($_[0] >  $_[1]) ? $_[0] : $_[1]; } ],
  58     'UN'   => [ 1, sub{ defined($_[0]) ? $_[0]->is_nan() : 1; }, 1 ],
  59     'UNKN' => [ 0, sub{ undef; } ],
  60     # Operators not defined in RRDtool graph
  61     'NE'  => [ 2, sub{ ($_[0] != $_[1]) ? 1:0; } ],
  62     'AND' => [ 2, sub{ ($_[0] and $_[1]) ? 1:0; } ],
  63     'OR'  => [ 2, sub{ ($_[0] or $_[1]) ? 1:0; } ],
  64     'NOT' => [ 1, sub{ (not $_[0]) ? 1:0; } ],
  65     'ABS' => [ 1, sub{ abs($_[0]); } ],
  66     'NOW' => [ 0, sub{ time(); } ],
  67     'DUP' => [ 1, sub{ ($_[0], $_[0]);}, 1 ],
  68     'EXC' => [ 2, sub{ ($_[1], $_[0]); }, 1 ],
  69     'NUM' => [ 1, sub{ defined($_[0]) ? $_[0] : 0; }, 1 ],
  70     'INF' => [ 0, sub{ Math::BigFloat->binf(); } ],
  71     'NEGINF' => [ 0, sub{ Math::BigFloat->binf('-'); } ]
  72     };
  73
  74
  75 sub new
  76 {
  77     my $type = shift;
  78     my $self = {};
  79     bless( $self, $type );
  80     $self->{'stack'} = [];
  81     return $self;
  82 }
  83
  84
  85 sub operator
  86 {
  87     my $self = shift;
  88     my $op = shift;
  89
  90     my $n_args           = $operators->{$op}->[0];
  91     my $action           = $operators->{$op}->[1];
  92     my $acceptsUndefined = $operators->{$op}->[2];
  93     my @args = ();
  94     my $allDefined = 1;
  95     for( my $i = 0; $i < $n_args; $i++ )
  96     {
  97         my $arg = $self->popStack();
  98         if( defined( $arg ) or $acceptsUndefined )
  99         {
 100             push( @args, $arg );
 101         }
 102         else
 103         {
 104             $allDefined = 0;
 105         }
 106     }
 107     $self->pushStack( $allDefined ? &{$action}(reverse @args) : undef );
 108 }
 109
 110
 111 sub popStack
 112 {
 113     my $self = shift;
 114
 115     my $ret;
 116     if( scalar( @{$self->{'stack'}} ) == 0 )
 117     {
 118         Warn("Stack underflow");
 119     }
 120     else
 121     {
 122         $ret = pop( @{$self->{'stack'}} );
 123     }
 124     return $ret;
 125 }
 126
 127
 128 sub pushStack
 129 {
 130     my $self = shift;
 131     my @items = @_;
 132
 133     push( @{$self->{'stack'}}, @items );
 134 }
 135
 136
 137 sub translate
 138 {
 139     my $self = shift;
 140     my $string = shift;
 141     my $callback = shift;
 142
 143     # Debug("Translating RPN: $string");
 144     my $item;
 145     my @new_items;
 146     foreach $item ( split( /,/, $string ) )
 147     {
 148         if( $item =~ /^\{([^\}]*)\}$/ )
 149         {
 150             my $noderef = $1;
 151             my $timeoffset;
 152             if( $noderef =~ s/\(([^\)]+)\)// )
 153             {
 154                $timeoffset = $1;
 155             }
 156             my $value = &{$callback}( $noderef, $timeoffset );
 157             $value = 'UNKN' unless defined( $value );
 158             # Debug("$item translated into $value");
 159             $item = $value;
 160         }
 161         elsif( $item eq 'MOD' )
 162         {
 163             # In Torrus parameter value, percent sign is reserved for
 164             # parameter expansion. Rrdtool understands % only.
 165             $item = '%';
 166         }
 167         push( @new_items, $item );
 168     }
 169
 170     $string = join( ',', @new_items );
 171     # Debug("RPN translated: $string");
 172     return $string;
 173 }
 174
 175
 176 sub run
 177 {
 178     my $self = shift;
 179     my $string = shift;
 180     my $callback = shift;
 181
 182     # Debug("Input RPN: $string");
 183
 184     if( index( $string, '{' ) >= 0 )
 185     {
 186         $string = $self->translate( $string, $callback );
 187     }
 188
 189     my $item;
 190     foreach $item ( split( /,/, $string ) )
 191     {
 192         if( ref( $operators->{$item} ) )
 193         {
 194             $self->operator($item);
 195         }
 196         else
 197         {
 198             $self->pushStack( Math::BigFloat->new($item) );
 199         }
 200     }
 201
 202     my $retval = $self->popStack();
 203     # Debug("RPN result: $retval");
 204     return $retval;
 205 }
 206
 207 1;
 208
 209 # Local Variables:
 210 # mode: perl
 211 # indent-tabs-mode: nil
 212 # perl-indent-level: 4
 213 # End: