Spreadsheet::Engine::Functions - Spreadsheet functions (SUM, MAX, etc)

  my $ok = calculate_function($fname, \@operand, \$errortext, \%typelookup, \%sheetdata);

  Spreadsheet::Engine->register(SUM => 'Spreadsheet::Engine::Function::SUM');

  my $ok = calculate_function($fname, \@operand, \$errortext, \%typelookup, \%sheetdata);

  $colnum = field_to_colnum(\@sheetdata, $col1num, $ncols, $row1num, $fieldname, $fieldtype)

package Spreadsheet::Engine::Functions;
## no critic

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 ],
);

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 /
);

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;
}

# 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;
}

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;

}

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;

}

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;

}

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;

}

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;

}

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__