# Plugin for TWiki Enterprise Collaboration Platform, http://TWiki.org/ # # Copyright (C) 2001-2006 Peter Thoeny, peter@thoeny.org # # 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. For # more details read LICENSE in the root of this distribution. # # 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, published at # http://www.gnu.org/copyleft/gpl.html # # As per the GPL, removal of this notice is prohibited. # # ========================= # # This is part of TWiki's Spreadsheet Plugin. # # The code below is kept out of the main plugin module for # performance reasons, so it doesn't get compiled until it # is actually used. package TWiki::Plugins::SpreadSheetPlugin::Calc; use strict; use Time::Local; use Time::Local qw( timegm_nocheck timelocal_nocheck ); # Necessary for DOY # ========================= use vars qw( $web $topic $debug $dontSpaceRE $renderingWeb @tableMatrix $cPos $rPos $escToken %varStore @monArr @wdayArr %mon2num ); $escToken = "\0"; %varStore = (); $dontSpaceRE = ""; @monArr = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ); @wdayArr = ( "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday" ); { my $count = 0; %mon2num = map { $_ => $count++ } @monArr; } # ========================= sub init { ( $web, $topic, $debug ) = @_; # initialize variables, once per page view %varStore = (); $dontSpaceRE = ""; # Module initialized TWiki::Func::writeDebug( "- TWiki::Plugins::SpreadSheetPlugin::Calc::init( $web.$topic )" ) if $debug; return 1; } # ========================= sub CALC { ### my ( $text, $topic, $web ) = @_; # do not uncomment, use $_[0], $_[1]... instead TWiki::Func::writeDebug( "- SpreadSheetPlugin::Calc::CALC( $_[2].$_[1] )" ) if $debug; @tableMatrix = (); $cPos = -1; $rPos = -1; my $result = ""; my $insidePRE = 0; my $insideTABLE = 0; my $line = ""; my $before = ""; my $cell = ""; my @row = (); $_[0] =~ s/\r//go; $_[0] =~ s/\\\n//go; # Join lines ending in "\" foreach( split( /\n/, $_[0] ) ) { # change state: m|
|i && ( $insidePRE = 1 );
m||i && ( $insidePRE = 1 );
m| |i && ( $insidePRE = 0 );
m||i && ( $insidePRE = 0 );
if( ! ( $insidePRE ) ) {
if( /^\s*\|.*\|\s*$/ ) {
# inside | table |
if( ! $insideTABLE ) {
$insideTABLE = 1;
@tableMatrix = (); # reset table matrix
$cPos = -1;
$rPos = -1;
}
$line = $_;
$line =~ s/^(\s*\|)(.*)\|\s*$/$2/o;
$before = $1;
@row = split( /\|/o, $line, -1 );
push @tableMatrix, [ @row ];
$rPos++;
$line = "$before";
for( $cPos = 0; $cPos < @row; $cPos++ ) {
$cell = $row[$cPos];
$cell =~ s/%CALC\{(.*?)\}%/&doCalc($1)/geo;
$line .= "$cell|";
}
s/.*/$line/o;
} else {
# outside | table |
if( $insideTABLE ) {
$insideTABLE = 0;
}
s/%CALC\{(.*?)\}%/&doCalc($1)/geo;
}
}
$result .= "$_\n";
}
$_[0] = $result;
}
# =========================
sub doCalc
{
my( $theAttributes ) = @_;
my $text = &TWiki::Func::extractNameValuePair( $theAttributes );
# Add nesting level to parenthesis,
# e.g. "A(B())" gets "A-esc-1(B-esc-2(-esc-2)-esc-1)"
my $level = 0;
$text =~ s/([\(\)])/addNestingLevel($1, \$level)/geo;
$text = doFunc( "MAIN", $text );
if( ( $rPos >= 0 ) && ( $cPos >= 0 ) ) {
# update cell in table matrix
$tableMatrix[$rPos][$cPos] = $text;
}
return $text;
}
# =========================
sub addNestingLevel
{
my( $theParen, $theLevelRef ) = @_;
my $result = "";
if( $theParen eq "(" ) {
$$theLevelRef++;
$result = "$escToken$$theLevelRef$theParen";
} else {
$result = "$escToken$$theLevelRef$theParen";
$$theLevelRef--;
}
return $result;
}
# =========================
sub doFunc
{
my( $theFunc, $theAttr ) = @_;
$theAttr = "" unless( defined $theAttr );
TWiki::Func::writeDebug( "- SpreadSheetPlugin::Calc::doFunc: $theFunc( $theAttr ) start" ) if $debug;
unless( $theFunc =~ /^(IF|LISTIF|LISTMAP|NOEXEC)$/ ) {
# Handle functions recursively
$theAttr =~ s/\$([A-Z]+)$escToken([0-9]+)\((.*?)$escToken\2\)/&doFunc($1,$3)/geo;
# Clean up unbalanced mess
$theAttr =~ s/$escToken\-*[0-9]+([\(\)])/$1/go;
}
# else: delay the function handler to after parsing the parameters,
# in which case handling functions and cleaning up needs to be done later
my $result = "";
my $i = 0;
if( $theFunc eq "MAIN" ) {
$result = $theAttr;
} elsif( $theFunc eq "EXEC" ) {
# add nesting level escapes
my $level = 0;
$result = $theAttr;
$result =~ s/([\(\)])/addNestingLevel($1, \$level)/geo;
# execute functions in attribute recursively and clean up unbalanced parenthesis
$result =~ s/\$([A-Z]+)$escToken([0-9]+)\((.*?)$escToken\2\)/&doFunc($1,$3)/geo;
$result =~ s/$escToken\-*[0-9]+([\(\)])/$1/go;
} elsif( $theFunc eq "NOEXEC" ) {
$result = $theAttr;
} elsif( $theFunc eq "T" ) {
$result = "";
my @arr = getTableRange( "$theAttr..$theAttr" );
if( @arr ) {
$result = $arr[0];
}
} elsif( $theFunc eq "TRIM" ) {
$result = $theAttr || "";
$result =~ s/^\s*//o;
$result =~ s/\s*$//o;
$result =~ s/\s+/ /go;
} elsif( $theFunc eq "FORMAT" ) {
# Format FORMAT(TYPE, precision, value) returns formatted value -- JimStraus - 05 Jan 2003
my( $format, $res, $value ) = split( /,\s*/, $theAttr );
$format =~ s/^\s*(.*?)\s*$/$1/; #Strip leading and trailing spaces
$res =~ s/^\s*(.*?)\s*$/$1/;
$value =~ s/^\s*(.*?)\s*$/$1/;
if( $format eq "DOLLAR" ) {
my $neg = 1 if $value < 0;
$value = abs($value);
$result = sprintf("%0.${res}f", $value);
my $temp = reverse $result;
$temp =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
$result = "\$" . (scalar reverse $temp);
$result = "(".$result.")" if $neg;
} elsif( $format eq "COMMA" ) {
$result = sprintf("%0.${res}f", $value);
my $temp = reverse $result;
$temp =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
$result = scalar reverse $temp;
} elsif( $format eq "PERCENT" ) {
$result = sprintf("%0.${res}f%%", $value * 100);
} elsif( $format eq "NUMBER" ) {
$result = sprintf("%0.${res}f", $value);
} elsif( $format eq "K" ) {
$result = sprintf("%0.${res}f K", $value / 1024);
} elsif( $format eq "KB" ) {
$result = sprintf("%0.${res}f KB", $value / 1024);
} elsif ($format eq "MB") {
$result = sprintf("%0.${res}f MB", $value / (1024 * 1024));
} elsif( $format =~ /^KBMB/ ) {
$value /= 1024;
my @lbls = ( "MB", "GB", "TB", "PB", "EB", "ZB" );
my $lbl = "KB";
while( $value >= 1024 && @lbls ) {
$value /= 1024;
$lbl = shift @lbls;
}
$result = sprintf("%0.${res}f", $value) . " $lbl";
} else {
# FORMAT not recognized, just return value
$result = $value;
}
} elsif( $theFunc eq "EXACT" ) {
$result = 0;
my( $str1, $str2 ) = split( /,\s*/, $theAttr, 2 );
$str1 = "" unless( $str1 );
$str2 = "" unless( $str2 );
$str1 =~ s/^\s*(.*?)\s*$/$1/o; # cut leading and trailing spaces
$str2 =~ s/^\s*(.*?)\s*$/$1/o;
$result = 1 if( $str1 eq $str2 );
} elsif( $theFunc eq "RAND" ) {
my $max = _getNumber( $theAttr );
$max = 1 if( $max <= 0 );
$result = rand( $max );
} elsif( $theFunc eq "VALUE" ) {
$result = _getNumber( $theAttr );
} elsif( $theFunc =~ /^(EVAL|INT)$/ ) {
$result = safeEvalPerl( $theAttr );
unless( $result =~ /^ERROR/ ) {
$result = int( _getNumber( $result ) ) if( $theFunc eq "INT" );
}
} elsif( $theFunc eq "ROUND" ) {
# ROUND(num, digits)
my( $num, $digits ) = split( /,\s*/, $theAttr, 2 );
$result = safeEvalPerl( $num );
unless( $result =~ /^ERROR/ ) {
$result = _getNumber( $result );
if( ( $digits ) && ( $digits =~ s/^.*?(\-?[0-9]+).*$/$1/o ) && ( $digits ) ) {
my $factor = 10**$digits;
$result *= $factor;
( $result >= 0 ) ? ( $result += 0.5 ) : ( $result -= 0.5 );
$result = int( $result );
$result /= $factor;
} else {
( $result >= 0 ) ? ( $result += 0.5 ) : ( $result -= 0.5 );
$result = int( $result );
}
}
} elsif( $theFunc eq "MOD" ) {
$result = 0;
my( $num1, $num2 ) = split( /,\s*/, $theAttr, 2 );
$num1 = _getNumber( $num1 );
$num2 = _getNumber( $num2 );
if( $num1 && $num2 ) {
$result = $num1 % $num2;
}
} elsif( $theFunc eq "ODD" ) {
$result = _getNumber( $theAttr ) % 2;
} elsif( $theFunc eq "EVEN" ) {
$result = ( _getNumber( $theAttr ) + 1 ) % 2;
} elsif( $theFunc eq "AND" ) {
$result = 0;
my @arr = getListAsInteger( $theAttr );
foreach $i( @arr ) {
unless( $i ) {
$result = 0;
last;
}
$result = 1;
}
} elsif( $theFunc eq "OR" ) {
$result = 0;
my @arr = getListAsInteger( $theAttr );
foreach $i( @arr ) {
if( $i ) {
$result = 1;
last;
}
}
} elsif( $theFunc eq "NOT" ) {
$result = 1;
$result = 0 if( _getNumber( $theAttr ) );
} elsif( $theFunc eq "ABS" ) {
$result = abs( _getNumber( $theAttr ) );
} elsif( $theFunc eq "SIGN" ) {
$i = _getNumber( $theAttr );
$result = 0;
$result = 1 if( $i > 0 );
$result = -1 if( $i < 0 );
} elsif( $theFunc eq "IF" ) {
# IF(condition, value if true, value if false)
my( $condition, $str1, $str2 ) = _properSplit( $theAttr, 3 );
# with delay, handle functions in condition recursively and clean up unbalanced parenthesis
$condition =~ s/\$([A-Z]+)$escToken([0-9]+)\((.*?)$escToken\2\)/&doFunc($1,$3)/geo;
$condition =~ s/$escToken\-*[0-9]+([\(\)])/$1/go;
$condition =~ s/^\s*(.*?)\s*$/$1/o;
$result = safeEvalPerl( $condition );
unless( $result =~ /^ERROR/ ) {
if( $result ) {
$result = $str1;
} else {
$result = $str2;
}
$result = "" unless( defined( $result ) );
# with delay, handle functions in result recursively and clean up unbalanced parenthesis
$result =~ s/\$([A-Z]+)$escToken([0-9]+)\((.*?)$escToken\2\)/&doFunc($1,$3)/geo;
$result =~ s/$escToken\-*[0-9]+([\(\)])/$1/go;
} # else return error message
} elsif( $theFunc eq "UPPER" ) {
$result = uc( $theAttr );
} elsif( $theFunc eq "LOWER" ) {
$result = lc( $theAttr );
} elsif( $theFunc eq "PROPER" ) {
# FIXME: I18N
$result = lc( $theAttr );
$result =~ s/(^|[^a-z])([a-z])/$1 . uc($2)/geo;
} elsif( $theFunc eq "PROPERSPACE" ) {
$result = _properSpace( $theAttr );
} elsif( $theFunc eq "CHAR" ) {
if( $theAttr =~ /([0-9]+)/ ) {
$i = $1;
} else {
$i = 0;
}
$i = 255 if $i > 255;
$i = 0 if $i < 0;
$result = chr( $i );
} elsif( $theFunc eq "REPEAT" ) {
my( $str, $num ) = split( /,\s*/, $theAttr, 2 );
$str = "" unless( defined( $str ) );
$num = _getNumber( $num );
$result = "$str" x $num;
} elsif( $theFunc eq "CODE" ) {
$result = ord( $theAttr );
} elsif( $theFunc eq "LENGTH" ) {
$result = length( $theAttr );
} elsif( $theFunc eq "ROW" ) {
$i = $theAttr || 0;
$result = $rPos + $i + 1;
} elsif( $theFunc eq "COLUMN" ) {
$i = $theAttr || 0;
$result = $cPos + $i + 1;
} elsif( $theFunc eq "LEFT" ) {
$i = $rPos + 1;
$result = "R$i:C0..R$i:C$cPos";
} elsif( $theFunc eq "ABOVE" ) {
$i = $cPos + 1;
$result = "R0:C$i..R$rPos:C$i";
} elsif( $theFunc eq "RIGHT" ) {
$i = $rPos + 1;
$result = "R$i:C$cPos..R$i:C32000";
} elsif( $theFunc eq "DEF" ) {
# Format DEF(list) returns first defined cell
# Added by MF 26/3/2002, fixed by PeterThoeny
my @arr = getList( $theAttr );
foreach my $cell ( @arr ) {
if( $cell ) {
$cell =~ s/^\s*(.*?)\s*$/$1/o;
if( $cell ) {
$result = $cell;
last;
}
}
}
} elsif( $theFunc eq "MAX" ) {
my @arr = sort { $a <=> $b }
grep { /./ }
grep { defined $_ }
getListAsFloat( $theAttr );
$result = $arr[$#arr];
} elsif( $theFunc eq "MIN" ) {
my @arr = sort { $a <=> $b }
grep { /./ }
grep { defined $_ }
getListAsFloat( $theAttr );
$result = $arr[0];
} elsif( $theFunc eq "SUM" ) {
$result = 0;
my @arr = getListAsFloat( $theAttr );
foreach $i ( @arr ) {
$result += $i if defined $i;
}
} elsif( $theFunc eq "SUMPRODUCT" ) {
$result = 0;
my @arr;
my @lol = split( /,\s*/, $theAttr );
my $size = 32000;
for $i (0 .. $#lol ) {
@arr = getListAsFloat( $lol[$i] );
$lol[$i] = [ @arr ]; # store reference to array
$size = @arr if( @arr < $size ); # remember smallest array
}
if( ( $size > 0 ) && ( $size < 32000 ) ) {
my $y; my $prod; my $val;
$size--;
for $y (0 .. $size ) {
$prod = 1;
for $i (0 .. $#lol ) {
$val = $lol[$i][$y];
if( defined $val ) {
$prod *= $val;
} else {
$prod = 0; # don't count empty cells
}
}
$result += $prod;
}
}
} elsif( $theFunc =~ /^(SUMDAYS|DURATION)$/ ) {
# DURATION is undocumented, is for SvenDowideit
# contributed by SvenDowideit - 07 Mar 2003; modified by PTh
$result = 0;
my @arr = getListAsDays( $theAttr );
foreach $i ( @arr ) {
$result += $i if defined $i;
}
} elsif( $theFunc eq "WORKINGDAYS" ) {
my( $num1, $num2 ) = split( /,\s*/, $theAttr, 2 );
$result = _workingDays( _getNumber( $num1 ), _getNumber( $num2 ) );
} elsif( $theFunc =~ /^(MULT|PRODUCT)$/ ) { # MULT is deprecated, no not remove
$result = 0;
my @arr = getListAsFloat( $theAttr );
$result = 1;
foreach $i ( @arr ) {
$result *= $i if defined $i;
}
} elsif( $theFunc =~ /^(AVERAGE|MEAN)$/ ) {
$result = 0;
my $items = 0;
my @arr = getListAsFloat( $theAttr );
foreach $i ( @arr ) {
if( defined $i ) {
$result += $i;
$items++;
}
}
if( $items > 0 ) {
$result = $result / $items;
}
} elsif( $theFunc eq "MEDIAN" ) {
my @arr = sort { $a <=> $b } grep { defined $_ } getListAsFloat( $theAttr );
$i = @arr;
if( ( $i % 2 ) > 0 ) {
$result = $arr[$i/2];
} elsif( $i ) {
$i /= 2;
$result = ( $arr[$i] + $arr[$i-1] ) / 2;
}
} elsif( $theFunc eq "PERCENTILE" ) {
my( $percentile, $set ) = split( /,\s*/, $theAttr, 2 );
my @arr = sort { $a <=> $b } grep { defined $_ } getListAsFloat( $set );
$result = 0;
my $size = scalar( @arr );
if( $size > 0 ) {
$i = $percentile / 100 * ( $size + 1 );
my $iInt = int( $i );
if( $i <= 1 ) {
$result = $arr[0];
} elsif( $i >= $size ) {
$result = $arr[$size-1];
} elsif( $i == $iInt ) {
$result = $arr[$i-1];
} else {
# interpolate beween neighbors # Example: $i = 7.25
my $r1 = $iInt + 1 - $i; # 0.75 = 7 + 1 - 7.25
my $r2 = 1 - $r1; # 0.25 = 1 - 0.75
my $x1 = $arr[$iInt-1];
my $x2 = $arr[$iInt];
$result = ($r1 * $x1) + ($r2 * $x2);
}
}
} elsif( $theFunc eq "COUNTSTR" ) {
$result = 0; # count any string
$i = 0; # count string equal second attr
my $list = $theAttr;
my $str = "";
if( $theAttr =~ /^(.*),\s*(.*?)$/ ) { # greedy match for last comma
$list = $1;
$str = $2;
}
$str =~ s/\s*$//o;
my @arr = getList( $list );
foreach my $cell ( @arr ) {
if( defined $cell ) {
$cell =~ s/^\s*(.*?)\s*$/$1/o;
$result++ if( $cell );
$i++ if( $cell eq $str );
}
}
$result = $i if( $str );
} elsif( $theFunc eq "COUNTITEMS" ) {
$result = "";
my @arr = getList( $theAttr );
my %items = ();
my $key = "";
foreach $key ( @arr ) {
$key =~ s/^\s*(.*?)\s*$/$1/o if( $key );
if( $key ) {
if( exists( $items{ $key } ) ) {
$items{ $key }++;
} else {
$items{ $key } = 1;
}
}
}
foreach $key ( sort keys %items ) {
$result .= "$key: $items{ $key }