# # TWiki WikiClone ($wikiversion has version info) # # Copyright (C) 2001-2004 Peter Thoeny, Peter@Thoeny.com # # 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, published at # http://www.gnu.org/copyleft/gpl.html # # ========================= # # This is the spreadsheet TWiki plugin. # # Each plugin is a package that contains the subs: # # initPlugin ( $topic, $web, $user ) # commonTagsHandler ( $text, $topic, $web ) # startRenderingHandler( $text, $web ) # outsidePREHandler ( $text ) # insidePREHandler ( $text ) # endRenderingHandler ( $text ) # # initPlugin is required, all other are optional. # For increased performance, DISABLE handlers you don't need. # ========================= package TWiki::Plugins::SpreadSheetPlugin; use Time::Local; # ========================= use vars qw( $web $topic $user $installWeb $VERSION $debug $skipInclude $dontSpaceRE $renderingWeb @tableMatrix $cPos $rPos $tableRows $tableLine $escToken %varStore @monArr @wdayArr %mon2num ); $VERSION = '1.013'; # 17 Jul 2004 $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 initPlugin { ( $topic, $web, $user, $installWeb ) = @_; # check for Plugins.pm versions if( $TWiki::Plugins::VERSION < 1 ) { &TWiki::Func::writeWarning( "Version mismatch between SpreadSheetPlugin and Plugins.pm" ); return 0; } $renderingWeb = $web; # Get plugin debug flag $debug = &TWiki::Func::getPreferencesFlag( "SPREADSHEETPLUGIN_DEBUG" ); # Flag to skip calc if in include $skipInclude = &TWiki::Func::getPreferencesFlag( "SPREADSHEETPLUGIN_SKIPINCLUDE" ); # initialize variables %varStore = (); $dontSpaceRE = ""; # Plugin correctly initialized &TWiki::Func::writeDebug( "- TWiki::Plugins::SpreadSheetPlugin::initPlugin( $web.$topic ) is OK" ) if $debug; return 1; } # ========================= sub commonTagsHandler { ### my ( $text, $topic, $web ) = @_; # do not uncomment, use $_[0], $_[1]... instead &TWiki::Func::writeDebug( "- SpreadSheetPlugin::commonTagsHandler( $_[2].$_[1] )" ) if $debug; if( ( $_[3] ) && ( $skipInclude ) ) { # bail out, handler called from an %INCLUDE{}% return; } unless( $_[0] =~ /%CALC\{.*?\}%/ ) { # nothing to do return; } @tableMatrix = (); @tableLine = (); # added by BenWebb for delayed table calculation $cPos = -1; $rPos = -1; $tableRows = -1; #this allows getTableRange to access then entire table - BenWebb 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
@tableLine = (); # reset table lines
$tableRows = -1;
}
$line = $_;
$line =~ s/^(\s*\|)(.*)\|\s*$/$2/o;
$before = $1;
@row = split( /\|/o, $line, -1 );
push @tableMatrix, [ @row ];
$tableRows++;
push(@tableLine, $before);
s/.*//o; # blank the line - we rebuild the table once it's completely read
} else {
# outside | table |
if( $insideTABLE ) {
$insideTABLE = 0;
# rebuild the table and add it back in
doTable();
$result .= join("\n", @tableLine) . "\n";
}
s/%CALC\{(.*?)\}%/&doCalc($1)/geo;
}
}
$result .= "$_\n";
}
if ($insideTABLE){
# this has to be here in case we ended with a table
doTable();
$result .= join("\n", @tableLine) . "\n";
}
$_[0] = $result;
}
# =========================
# added by BenWebb to facilitate calculation of the table after
# the entire thing has been read. The beginning of each line
# is cached in @tableLine (there is a potential bug here in that
# we don't currently catch the end of the line) and the rest
# of the line is subsequently built from @tableMatrix
# See also getTableRange for other changes that were added to make
# this work
sub doTable
{
my $redocount = 3; # this is protection from infinite loops.
my $redo = 1;
my $tableLineEnd = ();
while ($redo && $redocount > 0){
$redo = 0;
$redocount--;
@tableLineEnd = ();
for ($rPos = 0; $rPos <= $#tableMatrix; $rPos++){
for ($cPos = 0; $cPos <= $#{ $tableMatrix[$rPos] } ; $cPos++){
$cell = $tableMatrix[$rPos][$cPos];
my $cellcopy = $cell;
$cell =~ s/%CALC\{(.*?)\}%/&doCalc($1)/geo;
if ($cell =~ /CALC/ || $cell =~ /ERROR/){
$redo = 1;
$tableMatrix[$rPos][$cPos] = $cellcopy;
# that looks redundant but doCalc clobbers the tableMatrix cell when it runs
} else {
$tableLineEnd[$rPos] .= "$cell|";
}
}
}
}
for ($rPos = 0; $rPos <= $#tableMatrix; $rPos++){
$tableLine[$rPos] .= $tableLineEnd[$rPos];
}
}
# =========================
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)"
$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 ) = @_;
&TWiki::Func::writeDebug( "- SpreadSheetPlugin::doFunc: $theFunc( $theAttr ) start" ) if $debug;
unless( $theFunc =~ /^(IF|LISTIF|LISTMAP)$/ ) {
# 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 "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);
} 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 "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" ) {
$theAttr =~ /([0-9]+)/;
$i = $1 || 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 "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 }