diff options
Diffstat (limited to 'torrus/perllib/Torrus/RPN.pm')
| -rw-r--r-- | torrus/perllib/Torrus/RPN.pm | 213 |
1 files changed, 213 insertions, 0 deletions
diff --git a/torrus/perllib/Torrus/RPN.pm b/torrus/perllib/Torrus/RPN.pm new file mode 100644 index 000000000..20fe15a16 --- /dev/null +++ b/torrus/perllib/Torrus/RPN.pm @@ -0,0 +1,213 @@ +# +# Copyright (C) 1998 Jeff R. Allen and WebTV Networks, Inc. +# Copyright (C) 2002 Stanislav Sinyagin +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. + +# $Id: RPN.pm,v 1.1 2010-12-27 00:03:40 ivan Exp $ +# Stanislav Sinyagin <ssinyagin@yahoo.com> + +# a simple little RPN calculator -- implements the same operations +# that RRDTool does. + +# This file is based on Cricket's RPM.pm + +package Torrus::RPN; + +use strict; + +use Torrus::Log; +use Math::BigFloat; + +# Each RPN operator is defined by an array reference with the +# following elements: <number of args>, <subroutine>, <accepts undef> + +my $operators = { + '+' => [ 2, sub{ $_[0] + $_[1]; } ], + '-' => [ 2, sub{ $_[0] - $_[1]; } ], + '*' => [ 2, sub{ $_[0] * $_[1]; } ], + '/' => [ 2, sub{ $_[0] / $_[1]; } ], + '%' => [ 2, sub{ $_[0] % $_[1]; } ], + 'MOD' => [ 2, sub{ $_[0] % $_[1]; } ], + 'SIN' => [ 1, sub{ sin($_[0]->bsstr()); } ], + 'COS' => [ 1, sub{ cos($_[0]->bsstr()); } ], + 'LOG' => [ 1, sub{ log($_[0]); } ], + 'EXP' => [ 1, sub{ $_[0]->exponent() } ], + 'FLOOR' => [ 1, sub{ $_[0]->bfloor(); } ], + 'CEIL' => [ 1, sub{ $_[0]->bceil(); } ], + 'LT' => [ 2, sub{ ($_[0] < $_[1]) ? 1:0; } ], + 'LE' => [ 2, sub{ ($_[0] <= $_[1]) ? 1:0; } ], + 'GT' => [ 2, sub{ ($_[0] > $_[1]) ? 1:0; } ], + 'GE' => [ 2, sub{ ($_[0] >= $_[1]) ? 1:0; } ], + 'EQ' => [ 2, sub{ ($_[0] == $_[1]) ? 1:0; } ], + 'IF' => [ 3, sub{ defined($_[0]) ? ($_[0] ? $_[1] : $_[2]) : undef; }, 1], + 'MIN' => [ 2, sub{ ($_[0] < $_[1]) ? $_[0] : $_[1]; } ], + 'MAX' => [ 2, sub{ ($_[0] > $_[1]) ? $_[0] : $_[1]; } ], + 'UN' => [ 1, sub{ defined($_[0]) ? $_[0]->is_nan() : 1; }, 1 ], + 'UNKN' => [ 0, sub{ undef; } ], + # Operators not defined in RRDtool graph + 'NE' => [ 2, sub{ ($_[0] != $_[1]) ? 1:0; } ], + 'AND' => [ 2, sub{ ($_[0] and $_[1]) ? 1:0; } ], + 'OR' => [ 2, sub{ ($_[0] or $_[1]) ? 1:0; } ], + 'NOT' => [ 1, sub{ (not $_[0]) ? 1:0; } ], + 'ABS' => [ 1, sub{ abs($_[0]); } ], + 'NOW' => [ 0, sub{ time(); } ], + 'DUP' => [ 1, sub{ ($_[0], $_[0]);}, 1 ], + 'EXC' => [ 2, sub{ ($_[1], $_[0]); }, 1 ], + 'NUM' => [ 1, sub{ defined($_[0]) ? $_[0] : 0; }, 1 ], + 'INF' => [ 0, sub{ Math::BigFloat->binf(); } ], + 'NEGINF' => [ 0, sub{ Math::BigFloat->binf('-'); } ] + }; + + +sub new +{ + my $type = shift; + my $self = {}; + bless( $self, $type ); + $self->{'stack'} = []; + return $self; +} + + +sub operator +{ + my $self = shift; + my $op = shift; + + my $n_args = $operators->{$op}->[0]; + my $action = $operators->{$op}->[1]; + my $acceptsUndefined = $operators->{$op}->[2]; + my @args = (); + my $allDefined = 1; + for( my $i = 0; $i < $n_args; $i++ ) + { + my $arg = $self->popStack(); + if( defined( $arg ) or $acceptsUndefined ) + { + push( @args, $arg ); + } + else + { + $allDefined = 0; + } + } + $self->pushStack( $allDefined ? &{$action}(reverse @args) : undef ); +} + + +sub popStack +{ + my $self = shift; + + my $ret; + if( scalar( @{$self->{'stack'}} ) == 0 ) + { + Warn("Stack underflow"); + } + else + { + $ret = pop( @{$self->{'stack'}} ); + } + return $ret; +} + + +sub pushStack +{ + my $self = shift; + my @items = @_; + + push( @{$self->{'stack'}}, @items ); +} + + +sub translate +{ + my $self = shift; + my $string = shift; + my $callback = shift; + + # Debug("Translating RPN: $string"); + my $item; + my @new_items; + foreach $item ( split( /,/, $string ) ) + { + if( $item =~ /^\{([^\}]*)\}$/ ) + { + my $noderef = $1; + my $timeoffset; + if( $noderef =~ s/\(([^\)]+)\)// ) + { + $timeoffset = $1; + } + my $value = &{$callback}( $noderef, $timeoffset ); + $value = 'UNKN' unless defined( $value ); + # Debug("$item translated into $value"); + $item = $value; + } + elsif( $item eq 'MOD' ) + { + # In Torrus parameter value, percent sign is reserved for + # parameter expansion. Rrdtool understands % only. + $item = '%'; + } + push( @new_items, $item ); + } + + $string = join( ',', @new_items ); + # Debug("RPN translated: $string"); + return $string; +} + + +sub run +{ + my $self = shift; + my $string = shift; + my $callback = shift; + + # Debug("Input RPN: $string"); + + if( index( $string, '{' ) >= 0 ) + { + $string = $self->translate( $string, $callback ); + } + + my $item; + foreach $item ( split( /,/, $string ) ) + { + if( ref( $operators->{$item} ) ) + { + $self->operator($item); + } + else + { + $self->pushStack( Math::BigFloat->new($item) ); + } + } + + my $retval = $self->popStack(); + # Debug("RPN result: $retval"); + return $retval; +} + +1; + +# Local Variables: +# mode: perl +# indent-tabs-mode: nil +# perl-indent-level: 4 +# End: |