package Spreadsheet::Engine::Functions; ## no critic =head1 NAME Spreadsheet::Engine::Functions - Spreadsheet functions (SUM, MAX, etc) =head1 SYNOPSIS my $ok = calculate_function($fname, \@operand, \$errortext, \%typelookup, \%sheetdata); =head1 DESCRIPTION This provides all the spreadsheet functions (SUM, MAX, IRR, ISNULL, etc). =cut use strict; use Spreadsheet::Engine::Sheet; # bah! use Time::Local; # For timegm in NOW and TODAY use Encode; use base 'Exporter'; our @EXPORT = qw(calculate_function); our @EXPORT_OK = qw(cr_to_coord); #0 = no arguments #>0 = exactly that many arguments #<0 = that many arguments (abs value) or more our %function_list = ( COLUMNS => [ \&columns_rows_function, 1 ], COUNTIF => [ \&countif_sumif_functions, 2 ], DAVERAGE => [ \&dseries_functions, 3 ], DCOUNT => [ \&dseries_functions, 3 ], DCOUNTA => [ \&dseries_functions, 3 ], DGET => [ \&dseries_functions, 3 ], DMAX => [ \&dseries_functions, 3 ], DMIN => [ \&dseries_functions, 3 ], DPRODUCT => [ \&dseries_functions, 3 ], DSTDEV => [ \&dseries_functions, 3 ], DSTDEVP => [ \&dseries_functions, 3 ], DSUM => [ \&dseries_functions, 3 ], DVAR => [ \&dseries_functions, 3 ], DVARP => [ \&dseries_functions, 3 ], INDEX => [ \&index_function, -1 ], ROWS => [ \&columns_rows_function, 1 ], SUMIF => [ \&countif_sumif_functions, -2 ], HTML => [ \&html_function, -1 ], PLAINTEXT => [ \&text_function, -1 ], ); =head1 EXTENDING =head2 register Spreadsheet::Engine->register(SUM => 'Spreadsheet::Engine::Function::SUM'); If you wish to make a new function available you should register it here. A series of base classes are provided that do all the argument checking etc., allowing you to concentrate on the calculations. Have a look at how the existing functions are implemented for details (it should hopefully be mostly self-explanatory!) information on how many arguments should be passed: =cut my $_reg = {}; sub register { my ($class, %to_reg) = @_; while (my ($name, $where) = each %to_reg) { eval "use $where"; die $@ if $@; $_reg->{$name} = $where; } } __PACKAGE__->register( map +($_ => "Spreadsheet::Engine::Function::$_"), qw/ ABS ACOS AND ASIN ATAN ATAN2 AVERAGE CHOOSE COS COUNT COUNTA COUNTBLANK DATE DAY DDB DEGREES ERRCELL EVEN EXACT EXP FACT FALSE FIND FV HLOOKUP HOUR IF INT IRR ISBLANK ISERR ISERROR ISLOGICAL ISNA ISNONTEXT ISNUMBER ISTEXT LEFT LEN LN LOG LOG10 LOWER MATCH MAX MID MIN MINUTE MOD MONTH N NA NOT NOW NPER NPV ODD OR PI PMT POWER PRODUCT PROPER PV RADIANS RATE REPLACE REPT RIGHT ROUND SECOND SIN SLN SQRT STDEV STDEVP SUBSTITUTE SUM SYD T TAN TIME TODAY TRIM TRUE TRUNC UPPER VALUE VAR VARP VLOOKUP WEEKDAY YEAR / ); =head1 EXPORTS =head2 calculate_function my $ok = calculate_function($fname, \@operand, \$errortext, \%typelookup, \%sheetdata); =cut sub calculate_function { my ($fname, $operand, $errortext, $typelookup, $sheetdata) = @_; # has the function been registered? (new style) if (my $fclass = $_reg->{$fname}) { my $fn = $fclass->new( fname => $fname, operand => $operand, errortext => $errortext, typelookup => $typelookup, sheetdata => $sheetdata, ); $fn->execute; return 1; } # Otherwise is it in our function_list (old style) my ($function_sub, $want_args) = @{ $function_list{$fname} }[ 0, 1 ]; if ($function_sub) { copy_function_args($operand, \my @foperand); my $have_args = scalar @foperand; if ( ($want_args < 0 and $have_args < -$want_args) or ($want_args >= 0 and $have_args != $want_args)) { function_args_error($fname, $operand, $errortext); return 0; } $function_sub->( $fname, $operand, \@foperand, $errortext, $typelookup, $sheetdata ); } else { my $ttext = $fname; if (@$operand && $operand->[ @$operand - 1 ]->{type} eq "start") { # no arguments - name or zero arg function pop @$operand; push @$operand, { type => "name", value => $ttext }; } else { $$errortext = "Unknown function $ttext. "; } } return 1; } =head1 FUNCTION providers =head2 dseries_functions =over =item DAVERAGE(databaserange, fieldname, criteriarange) =item DCOUNT(databaserange, fieldname, criteriarange) =item DCOUNTA(databaserange, fieldname, criteriarange) =item DGET(databaserange, fieldname, criteriarange) =item DMAX(databaserange, fieldname, criteriarange) =item DMIN(databaserange, fieldname, criteriarange) =item DPRODUCT(databaserange, fieldname, criteriarange) =item DSTDEV(databaserange, fieldname, criteriarange) =item DSTDEVP(databaserange, fieldname, criteriarange) =item DSUM(databaserange, fieldname, criteriarange) =item DVAR(databaserange, fieldname, criteriarange) =item DVARP(databaserange, fieldname, criteriarange) =back =cut # Calculate all of these and then return the desired one (overhead is in accessing not calculating) # If this routine is changed, check the series_functions, too. sub dseries_functions { my ($fname, $operand, $foperand, $errortext, $typelookup, $sheetdata) = @_; my ($value1, $tostype, $cr); my $sum = 0; my $resulttypesum = ""; my $count = 0; my $counta = 0; my $countblank = 0; my $product = 1; my $maxval; my $minval; my ($mk, $sk, $mk1, $sk1); # For variance, etc.: M sub k, k-1, and S sub k-1 # as per Knuth "The Art of Computer Programming" Vol. 2 3rd edition, page 232 my ($dbrange, $dbrangetype) = top_of_stack_value_and_type($sheetdata, $foperand, $errortext); my $fieldtype; my $fieldname = operand_value_and_type($sheetdata, $foperand, $errortext, \$fieldtype); my ($criteriarange, $criteriarangetype) = top_of_stack_value_and_type($sheetdata, $foperand, $errortext); if ($dbrangetype ne "range" || $criteriarangetype ne "range") { function_args_error($fname, $operand, $errortext); return 0; } my ($dbsheetdata, $dbcol1num, $ndbcols, $dbrow1num, $ndbrows) = decode_range_parts($sheetdata, $dbrange, $dbrangetype); my ( $criteriasheetdata, $criteriacol1num, $ncriteriacols, $criteriarow1num, $ncriteriarows ) = decode_range_parts($sheetdata, $criteriarange, $criteriarangetype); my $fieldasnum = field_to_colnum($dbsheetdata, $dbcol1num, $ndbcols, $dbrow1num, $fieldname, $fieldtype); $fieldasnum = int($fieldasnum); if ($fieldasnum <= 0) { push @$operand, { type => "e#VALUE!", value => 0 }; return; } my $targetcol = $dbcol1num + $fieldasnum - 1; my (@criteriafieldnums, $criteriafieldname, $criteriafieldtype, $criterianum); for (my $i = 0 ; $i < $ncriteriacols ; $i++) { # get criteria field colnums my $criteriacr = cr_to_coord($criteriacol1num + $i, $criteriarow1num); $criteriafieldname = $criteriasheetdata->{datavalues}->{$criteriacr}; $criteriafieldtype = $criteriasheetdata->{valuetypes}->{$criteriacr}; $criterianum = field_to_colnum($dbsheetdata, $dbcol1num, $ndbcols, $dbrow1num, $criteriafieldname, $criteriafieldtype); $criterianum = int($criterianum); if ($criterianum <= 0) { push @$operand, { type => "e#VALUE!", value => 0 }; return; } push @criteriafieldnums, $dbcol1num + $criterianum - 1; } my ($testok, $criteria, $testcol, $testcr); for (my $i = 1 ; $i < $ndbrows ; $i++) { # go through each row of the database $testok = 0; CRITERIAROW: for (my $j = 1 ; $j < $ncriteriarows ; $j++) { # go through each criteria row for (my $k = 0 ; $k < $ncriteriacols ; $k++) { # look at each column my $criteriacr = cr_to_coord($criteriacol1num + $k, $criteriarow1num + $j) ; # where criteria is $criteria = $criteriasheetdata->{datavalues}->{$criteriacr}; next unless $criteria; # blank items are OK $testcol = $criteriasheetdata->{datavalues} ->{ cr_to_coord($criteriacol1num + $k, $criteriarow1num) }; $testcol = $criteriafieldnums[$k]; $testcr = cr_to_coord($testcol, $dbrow1num + $i); # cell to check next CRITERIAROW unless test_criteria($criteriasheetdata->{datavalues}->{$testcr}, ($criteriasheetdata->{valuetypes}->{$testcr} || "b"), $criteria); } $testok = 1; last CRITERIAROW; } next unless $testok; $cr = cr_to_coord($targetcol, $dbrow1num + $i) ; # get cell of this row to do the function on $value1 = $dbsheetdata->{datavalues}->{$cr}; $tostype = $dbsheetdata->{valuetypes}->{$cr}; $tostype ||= "b"; if ($tostype eq "b") { # blank $value1 = 0; } $count += 1 if substr($tostype, 0, 1) eq "n"; $counta += 1 if substr($tostype, 0, 1) ne "b"; $countblank += 1 if substr($tostype, 0, 1) eq "b"; if (substr($tostype, 0, 1) eq "n") { $sum += $value1; $product *= $value1; $maxval = (defined $maxval) ? ($value1 > $maxval ? $value1 : $maxval) : $value1; $minval = (defined $minval) ? ($value1 < $minval ? $value1 : $minval) : $value1; if ($count eq 1) { # initialize with with first values for variance used in STDEV, VAR, etc. $mk1 = $value1; $sk1 = 0; } else { # Accumulate S sub 1 through n as per Knuth noted above $mk = $mk1 + ($value1 - $mk1) / $count; $sk = $sk1 + ($value1 - $mk1) * ($value1 - $mk); $sk1 = $sk; $mk1 = $mk; } $resulttypesum = lookup_result_type($tostype, $resulttypesum || $tostype, $typelookup->{plus}); } elsif (substr($tostype, 0, 1) eq "e" && substr($resulttypesum, 0, 1) ne "e") { $resulttypesum = $tostype; } } $resulttypesum ||= "n"; if ($fname eq "DSUM") { push @$operand, { type => $resulttypesum, value => $sum }; } elsif ($fname eq "DPRODUCT") { # may handle cases with text differently than some other spreadsheets push @$operand, { type => $resulttypesum, value => $product }; } elsif ($fname eq "DMIN") { push @$operand, { type => $resulttypesum, value => ($minval || 0) }; } elsif ($fname eq "DMAX") { push @$operand, { type => $resulttypesum, value => ($maxval || 0) }; } elsif ($fname eq "DCOUNT") { push @$operand, { type => "n", value => $count }; } elsif ($fname eq "DCOUNTA") { push @$operand, { type => "n", value => $counta }; } elsif ($fname eq "DAVERAGE") { if ($count > 0) { push @$operand, { type => $resulttypesum, value => ($sum / $count) }; } else { push @$operand, { type => "e#DIV/0!", value => 0 }; } } elsif ($fname eq "DSTDEV") { if ($count > 1) { push @$operand, { type => $resulttypesum, value => (sqrt($sk / ($count - 1))) }; } else { push @$operand, { type => "e#DIV/0!", value => 0 }; } } elsif ($fname eq "DSTDEVP") { if ($count > 1) { push @$operand, { type => $resulttypesum, value => (sqrt($sk / $count)) }; } else { push @$operand, { type => "e#DIV/0!", value => 0 }; } } elsif ($fname eq "DVAR") { if ($count > 1) { push @$operand, { type => $resulttypesum, value => ($sk / ($count - 1)) }; } else { push @$operand, { type => "e#DIV/0!", value => 0 }; } } elsif ($fname eq "DVARP") { if ($count > 1) { push @$operand, { type => $resulttypesum, value => ($sk / $count) }; } else { push @$operand, { type => "e#DIV/0!", value => 0 }; } } elsif ($fname eq "DGET") { if ($count == 1) { push @$operand, { type => $resulttypesum, value => $sum }; } elsif ($count == 0) { push @$operand, { type => "e#VALUE!", value => 0 }; } else { push @$operand, { type => "e#NUM!", value => 0 }; } } return; } =head2 index_function =over =item INDEX(range, rownum, colnum) =back =cut sub index_function { my ($fname, $operand, $foperand, $errortext, $typelookup, $sheetdata) = @_; my ($range, $rangetype) = top_of_stack_value_and_type($sheetdata, $foperand, $errortext) ; # get range if ($rangetype ne "range") { function_args_error($fname, $operand, $errortext); return 0; } my ($indexsheetdata, $col1num, $ncols, $row1num, $nrows) = decode_range_parts($sheetdata, $range, $rangetype); my $rowindex = 0; my $colindex = 0; my $tostype; if (scalar @$foperand) { # look for row number $rowindex = operand_as_number($sheetdata, $foperand, $errortext, \$tostype); if (substr($tostype, 0, 1) ne "n" || $rowindex < 0) { push @$operand, { type => "e#VALUE!", value => 0 }; return; } if (scalar @$foperand) { # look for col number $colindex = operand_as_number($sheetdata, $foperand, $errortext, \$tostype); if (substr($tostype, 0, 1) ne "n" || $colindex < 0) { push @$operand, { type => "e#VALUE!", value => 0 }; return; } if (scalar @$foperand) { function_args_error($fname, $operand, $errortext); return 0; } } else { # col number missing if ($nrows == 1) { # if only one row, then rowindex is really colindex $colindex = $rowindex; $rowindex = 0; } } } if ($rowindex > $nrows || $colindex > $ncols) { push @$operand, { type => "e#REF!", value => 0 }; return; } my ($result, $resulttype); if ($rowindex == 0) { if ($colindex == 0) { if ($nrows == 1 && $ncols == 1) { $result = cr_to_coord($col1num, $row1num); $resulttype = "coord"; } else { $result = cr_to_coord($col1num, $row1num) . "|" . cr_to_coord($col1num + $ncols - 1, $row1num + $nrows - 1) . "|"; $resulttype = "range"; } } else { if ($nrows == 1) { $result = cr_to_coord($col1num + $colindex - 1, $row1num); $resulttype = "coord"; } else { $result = cr_to_coord($col1num + $colindex - 1, $row1num) . "|" . cr_to_coord($col1num + $colindex - 1, $row1num + $nrows - 1) . "|"; $resulttype = "range"; } } } else { if ($colindex == 0) { if ($ncols == 1) { $result = cr_to_coord($col1num, $row1num + $rowindex - 1); $resulttype = "coord"; } else { $result = cr_to_coord($col1num, $row1num + $rowindex - 1) . "|" . cr_to_coord($col1num + $ncols - 1, $row1num + $rowindex - 1) . "|"; $resulttype = "range"; } } else { $result = cr_to_coord($col1num + $colindex - 1, $row1num + $rowindex - 1); $resulttype = "coord"; } } push @$operand, { type => $resulttype, value => $result }; return; } =head2 countif_sumif_functions =over =item COUNTIF(c1:c2,"criteria") =item SUMIF(c1:c2,"criteria") =back =cut sub countif_sumif_functions { my ($fname, $operand, $foperand, $errortext, $typelookup, $sheetdata) = @_; my ($tostype, $tostype2, $sumrangevalue, $sumrangetype); my ($rangevalue, $rangetype) = top_of_stack_value_and_type($sheetdata, $foperand, $errortext) ; # get range or coord my ($criteriavalue, $criteriatype) = operand_as_text($sheetdata, $foperand, $errortext, \$tostype) ; # get criteria if ($fname eq "SUMIF") { if ((scalar @$foperand) == 1) { # three arg form of SUMIF ($sumrangevalue, $sumrangetype) = top_of_stack_value_and_type($sheetdata, $foperand, $errortext); } elsif ((scalar @$foperand) == 0) { # two arg form $sumrangevalue = $rangevalue; $sumrangetype = $rangetype; } else { function_args_error($fname, $operand, $errortext); return 0; } } else { $sumrangevalue = $rangevalue; $sumrangetype = $rangetype; } my $ct = substr($criteriatype || '', 0, 1) || ''; if ($ct eq "n") { $criteriavalue = "$criteriavalue"; } elsif ($ct eq "e") { # error undef $criteriavalue; } elsif ($ct eq "b") { # blank here is undefined undef $criteriavalue; } if ($rangetype ne "coord" && $rangetype ne "range") { function_args_error($fname, $operand, $errortext); return 0; } if ( $fname eq "SUMIF" && $sumrangetype ne "coord" && $sumrangetype ne "range") { function_args_error($fname, $operand, $errortext); return 0; } push @$foperand, { type => $rangetype, value => $rangevalue }; my @f2operand; # to allow for 3 arg form push @f2operand, { type => $sumrangetype, value => $sumrangevalue }; my $sum = 0; my $resulttypesum = ""; my $count = 0; while (@$foperand) { my $value1 = operand_value_and_type($sheetdata, $foperand, $errortext, \$tostype); my $value2 = operand_value_and_type($sheetdata, \@f2operand, $errortext, \$tostype2); next unless test_criteria($value1, $tostype, $criteriavalue); $count += 1; if (substr($tostype2, 0, 1) eq "n") { $sum += $value2; $resulttypesum = lookup_result_type($tostype2, $resulttypesum || $tostype2, $typelookup->{plus}); } elsif (substr($tostype2, 0, 1) eq "e" && substr($resulttypesum, 0, 1) ne "e") { $resulttypesum = $tostype2; } } $resulttypesum ||= "n"; if ($fname eq "SUMIF") { push @$operand, { type => $resulttypesum, value => $sum }; } elsif ($fname eq "COUNTIF") { push @$operand, { type => "n", value => $count }; } return; } =head2 columns_rows_function =over =item COLUMNS(c1:c2) =item ROWS(c1:c2) =back =cut sub columns_rows_function { my ($fname, $operand, $foperand, $errortext, $typelookup, $sheetdata) = @_; my ($value1, $tostype, $resultvalue, $resulttype); ($value1, $tostype) = top_of_stack_value_and_type($sheetdata, $foperand, $errortext); if ($tostype eq "coord") { $resultvalue = 1; $resulttype = "n"; } elsif ($tostype eq "range") { my ($v1, $v2, $sequence) = split (/\|/, $value1); my ($sheet1, $sheet2); ($v1, $sheet1) = split (/!/, $v1); ($v2, $sheet2) = split (/!/, $v2); my ($c1, $r1) = coord_to_cr($v1); my ($c2, $r2) = coord_to_cr($v2); ($c2, $c1) = ($c1, $c2) if ($c1 > $c2); ($r2, $r1) = ($r1, $r2) if ($r1 > $r2); if ($fname eq "COLUMNS") { $resultvalue = $c2 - $c1 + 1; } elsif ($fname eq "ROWS") { $resultvalue = $r2 - $r1 + 1; } $resulttype = "n"; } else { $resultvalue = 0; $resulttype = "e#VALUE!"; } push @$operand, { type => $resulttype, value => $resultvalue }; return; } =head2 text_function =over =item PLAINTEXT =back =cut sub text_function { my ($fname, $operand, $foperand, $errortext, $typelookup, $sheetdata) = @_; my ($value1, $tostype, $resulttype); my $textstr = ""; $resulttype = ""; while (@$foperand) { $value1 = operand_as_text($sheetdata, $foperand, $errortext, \$tostype); if (substr($tostype, 0, 1) eq "t") { $textstr .= $value1; $resulttype = lookup_result_type($tostype, $resulttype || $tostype, $typelookup->{concat}); } elsif (substr($tostype, 0, 1) eq "e" && substr($resulttype, 0, 1) ne "e") { $resulttype = $tostype; } } $resulttype = substr($resulttype, 0, 1) eq "t" ? "t" : $resulttype; push @$operand, { type => $resulttype, value => $textstr }; return; } =head2 html_function =over =item HTML =back =cut sub html_function { my ($fname, $operand, $foperand, $errortext, $typelookup, $sheetdata) = @_; my ($value1, $tostype, $resulttype); my $textstr = ""; $resulttype = ""; while (@$foperand) { $value1 = operand_as_text($sheetdata, $foperand, $errortext, \$tostype); if (substr($tostype, 0, 1) eq "t") { $textstr .= $value1; $resulttype = lookup_result_type($tostype, $resulttype || $tostype, $typelookup->{concat}); } elsif (substr($tostype, 0, 1) eq "e" && substr($resulttype, 0, 1) ne "e") { $resulttype = $tostype; } } $resulttype = substr($resulttype, 0, 1) eq "t" ? "th" : $resulttype; push @$operand, { type => $resulttype, value => $textstr }; return; } =head1 HELPERS =head2 field_to_colnum $colnum = field_to_colnum(\@sheetdata, $col1num, $ncols, $row1num, $fieldname, $fieldtype) If fieldname is a number, uses it, otherwise looks up string in cells in row to find field number If not found, returns 0. =cut sub field_to_colnum { my ($sheetdata, $col1num, $ncols, $row1num, $fieldname, $fieldtype) = @_; if (substr($fieldtype, 0, 1) eq "n") { # number - return it if legal if ($fieldname <= 0 || $fieldname > $ncols) { return 0; } return int($fieldname); } if (substr($fieldtype, 0, 1) ne "t") { # must be text otherwise return 0; } $fieldname = decode('utf8', $fieldname); # change UTF-8 bytes to chars $fieldname = lc $fieldname; my ($cr, $value); for (my $i = 0 ; $i < $ncols ; $i++) { # look through column headers for a match $cr = cr_to_coord($col1num + $i, $row1num); $value = $sheetdata->{datavalues}->{$cr}; $value = decode('utf8', $value); $value = lc $value; #ignore case next if $value ne $fieldname; # no match return $i + 1; # match } return 0; # looked at all and no match } 1; __END__ =head1 HISTORY This is a Modified Version of SocialCalc::Functions from SocialCalc 1.1.0 =head1 COPYRIGHT Portions (c) Copyright 2005, 2006, 2007 Software Garden, Inc. All Rights Reserved. Portions (c) Copyright 2007 Socialtext, Inc. All Rights Reserved. Portions (c) Copyright 2007, 2008 Tony Bowden =head1 LICENCE The contents of this file are subject to the Artistic License 2.0; you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.perlfoundation.org/artistic_license_2_0