1# See bottom of file for license and copyright information
2#
3# This is part of Foswiki's Spreadsheet Plugin.
4#
5# The code below is kept out of the main plugin module for
6# performance reasons, so it doesn't get compiled until it
7# is actually used.
8
9package Foswiki::Plugins::SpreadSheetPlugin::Calc;
10
11use strict;
12use warnings;
13use HTML::Entities;
14use Time::Local;
15use Time::Local qw( timegm_nocheck timelocal_nocheck );    # Necessary for DOY
16
17# =========================
18my $web;
19my $topic;
20my $debug;
21my @tableMatrix;
22my $cPos;
23my $rPos;
24my $escToken = "\0";
25my $escComma =
26  "\1";    # Single char escapes so that size functions work as expected
27my $escOpenP    = "\2";
28my $escCloseP   = "\3";
29my $escNewLn    = "\4";
30my %varStore    = ();
31my $dontSpaceRE = "";
32
33# SMELL: I18N
34my @monArr = (
35    "Jan", "Feb", "Mar", "Apr", "May", "Jun",
36    "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"
37);
38my @wdayArr = (
39    "Sunday",   "Monday", "Tuesday", "Wednesday",
40    "Thursday", "Friday", "Saturday"
41);
42my %mon2num;
43{
44    my $count = 0;
45    %mon2num = map { $_ => $count++ } @monArr;
46}
47my $recurseFunc = \&_recurseFunc;
48
49my $allowHTML;
50
51# =========================
52sub init {
53    ( $web, $topic, $debug ) = @_;
54
55    # initialize variables, once per page view
56    %varStore    = ();
57    $dontSpaceRE = "";
58
59    $allowHTML =
60      Foswiki::Func::getPreferencesFlag("SPREADSHEETPLUGIN_ALLOWHTML");
61
62    # Module initialized
63    Foswiki::Func::writeDebug(
64        "- Foswiki::Plugins::SpreadSheetPlugin::Calc::init( $web.$topic )")
65      if $debug;
66    return 1;
67}
68
69# =========================
70sub CALC {
71### my ( $text, $topic, $web ) = @_;   # do not uncomment, use $_[0], $_[1]... instead
72
73    Foswiki::Func::writeDebug("- SpreadSheetPlugin::Calc::CALC( $_[2].$_[1] )")
74      if $debug;
75
76    @tableMatrix = ();
77    $cPos        = -1;
78    $rPos        = -1;
79    $web         = $_[2];
80
81    my @result      = ();
82    my $insidePRE   = 0;
83    my $insideTABLE = 0;
84    my $line        = "";
85    my $before      = "";
86    my $cell        = "";
87    my @row         = ();
88
89    $_[0] =~ s/\r//g;
90    $_[0] =~ s/\\\n//g;    # Join lines ending in "\"
91    foreach ( split( /\n/, $_[0] ) ) {
92
93        # change state:
94        m|<pre>|i       && ( $insidePRE = 1 );
95        m|<verbatim>|i  && ( $insidePRE = 1 );
96        m|</pre>|i      && ( $insidePRE = 0 );
97        m|</verbatim>|i && ( $insidePRE = 0 );
98
99        if ( !($insidePRE) ) {
100
101            if (/^\s*\|.*\|\s*$/) {
102
103                # inside | table |
104                if ( !$insideTABLE ) {
105                    $insideTABLE = 1;
106                    @tableMatrix = ();    # reset table matrix
107                    $cPos        = -1;
108                    $rPos        = -1;
109                }
110                $line = $_;
111                $line =~ s/^(\s*\|)(.*)\|\s*$/$2/;
112                $before = $1;
113                @row = split( /\|/, $line, -1 );
114                $row[0] = '' unless @row;    # See Item5163
115                push( @tableMatrix, [@row] );
116                $rPos++;
117                $line = "$before";
118
119                for ( $cPos = 0 ; $cPos < @row ; $cPos++ ) {
120                    $cell = $row[$cPos];
121                    $cell =~ s/%CALC\{(.*?)\}%/_doCalc($1)/ge;
122                    $line .= "$cell|";
123                }
124                s/.*/$line/;
125
126            }
127            else {
128
129                # outside | table |
130                if ($insideTABLE) {
131                    $insideTABLE = 0;
132                }
133                s/%CALC\{(.*?)\}%/_doCalc($1)/ge;
134            }
135        }
136        push( @result, $_ );
137    }
138    $_[0] = join( "\n", @result );
139    return $_[0];
140}
141
142# =========================
143sub _doCalc {
144    my ($theAttributes) = @_;
145
146    my $text = &Foswiki::Func::extractNameValuePair($theAttributes);
147
148    # Escape commas, parenthesis and newlines in tripple quoted strings
149    $text =~ s/'''(.*?)'''/_escapeString($1)/ges;
150
151    # For better performance, use a function reference when calling the recurse
152    # functions, instead of an "if" statement within the &$recurseFunc function
153    if ( $text =~ /\n/ ) {
154
155# recursively evaluate functions, and remove white space around functions and parameters
156        $recurseFunc = \&_recurseFuncCutWhitespace;
157    }
158    else {
159
160# recursively evaluate functions without removing white space (compatible with old spec)
161        $recurseFunc = \&_recurseFunc;
162    }
163
164    # Add nesting level to parenthesis,
165    # e.g. "A(B())" gets "A-esc-1(B-esc-2(-esc-2)-esc-1)"
166    my $level = 0;
167    $text =~ s/([\(\)])/_addNestingLevel($1, \$level)/ge;
168    $text = _doFunc( "MAIN", $text );
169
170    if ( defined($rPos) && defined($cPos) && $rPos >= 0 && $cPos >= 0 ) {
171
172        # update cell in table matrix
173        $tableMatrix[$rPos][$cPos] = $text;
174    }
175
176    # Restore escaped strings
177    $text =~ s/$escComma/,/g;
178    $text =~ s/$escOpenP/\(/g;
179    $text =~ s/$escCloseP/\)/g;
180    $text =~ s/$escNewLn/\n/g;
181
182    unless ($allowHTML) {
183
184        # encode < > to prevent html insertion
185        # SMELL: what about '"%
186        $text =~ s/([<>])/HTML::Entities::encode_entities($1)/ge;
187    }
188    return $text;
189}
190
191# =========================
192sub _escapeString {
193    my ($text) = @_;
194    $text =~ s/,/$escComma/g;
195    $text =~ s/\(/$escOpenP/g;
196    $text =~ s/\)/$escCloseP/g;
197    $text =~ s/\n/$escNewLn/g;
198    return $text;
199}
200
201# =========================
202sub _addNestingLevel {
203    my ( $theParen, $theLevelRef ) = @_;
204
205    my $result = "";
206    if ( $theParen eq "(" ) {
207        $$theLevelRef++;
208        $result = "$escToken$$theLevelRef$theParen";
209    }
210    else {
211        $result = "$escToken$$theLevelRef$theParen";
212        $$theLevelRef--;
213    }
214    return $result;
215}
216
217# =========================
218sub _recurseFunc {
219
220    # Handle functions recursively
221    no warnings 'uninitialized';
222    $_[0] =~
223s/\$([A-Z]+[A-Z0-9]*)$escToken([0-9]+)\((.*?)$escToken\2\)/_doFunc($1,$3)/geos;
224    use warnings 'uninitialized';
225
226    # Clean up unbalanced mess
227    $_[0] =~ s/$escToken\-*[0-9]+([\(\)])/$1/go;
228}
229
230# =========================
231sub _recurseFuncCutWhitespace {
232
233    # Handle functions recursively
234    $_[0] =~
235s/\s*\$([A-Z]+[A-Z0-9]*)$escToken([0-9]+)\(\s*(.*?)\s*$escToken\2\)\s*/_doFunc($1,$3)/geos;
236
237    # Clean up unbalanced mess
238    $_[0] =~ s/$escToken\-*[0-9]+([\(\)])/$1/go;
239}
240
241#<<<  do not let perltidy touch this
242    # Commented functions new in TWiki
243my $Function = {
244    ABOVE            => sub { my  $i = $cPos + 1; return "R1:C$i..R$rPos:C$i" },
245    ABS              => sub { abs( _getNumber($_[0]) ) },
246    # ADDLIST
247    AND              => \&_AND,
248    AVERAGE          => \&_AVERAGE,
249    BIN2DEC          => \&_BIN2DEC,
250    BITXOR           => \&_BITXOR,
251    CEILING          => \&_CEILING,
252    CHAR             => \&_CHAR,
253    CODE             => sub { ord($_[0]) },
254    COLUMN           => sub { $cPos + ( $_[0] || 0 ) + 1 },
255    COUNTITEMS       => \&_COUNTITEMS,
256    COUNTSTR         => \&_COUNTSTR,
257    DEC2BIN          => \&_DEC2BIN,
258    DEC2HEX          => \&_DEC2HEX,
259    DEC2OCT          => \&_DEC2OCT,
260    DEF              => \&_DEF,
261    EMPTY            => sub { ( length($_[0]) ) ? 0 : 1 },
262    EVAL             => sub { _safeEvalPerl($_[0]) },
263    EVEN             => sub { ( _getNumber($_[0]) + 1 ) % 2 },
264    EXACT            => \&_EXACT,
265    EXEC             => \&_EXEC,
266    EXISTS           => sub { ( Foswiki::Func::topicExists( $web, $_[0] ) ) ? 1 : 0 },
267    EXP              => sub { exp( _getNumber($_[0]) ) },
268    FILTER           => \&_FILTER,
269    FIND             => \&_FIND,
270    FLOOR            => \&_FLOOR,
271    FORMAT           => \&_FORMAT,
272    FORMATGMTIME     => \&_FORMATGMTIME,
273    FORMATTIME       => \&_FORMATTIME,
274    FORMATTIMEDIFF   => \&_FORMATTIMEDIFF,
275    GET              => \&_GET,
276    # GETHASH
277    # GETLIST  - Get a saved list
278    # HASH2LIST - Convert hash to list
279    # HASHCOPY - Copy a hash
280    # HASHEACH - Evaluate & update each element
281    # HASHEXISTS - Test if hash exists
282    # HASHREVERSE - Swap keys and values
283    HEX2DEC          => \&_HEX2DEC,
284    HEXDECODE        => \&_HEXDECODE,
285    HEXENCODE        => sub { uc( unpack( "H*", $_[0] ) ) },
286    IF               => \&_IF,
287    INSERTSTRING     => \&_INSERTSTRING,
288    INT              => sub {
289                        my $rslt = _safeEvalPerl($_[0]);
290                        return ( $rslt =~ /^ERROR/ ) ? $rslt : int( _getNumber($rslt) );
291                       },
292    ISDIGIT          => sub { ($_[0] =~ m/^[[:digit:]]+$/ ) ? 1 : 0 },
293    ISLOWER          => sub { ($_[0] =~ m/^[[:lower:]]+$/ ) ? 1 : 0 },
294    ISUPPER          => sub { ($_[0] =~ m/^[[:upper:]]+$/ ) ? 1 : 0 },
295    ISWIKIWORD       => sub { (Foswiki::isValidWikiWord( $_[0] ) ) ? 1 : 0 },
296    LEFT             => sub { my $i = $rPos + 1; return "R$i:C1..R$i:C$cPos" },
297    LEFTSTRING       => \&_LEFTSTRING,
298    LENGTH           => sub { length( $_[0] ) },
299    LIST             => sub { _listToDelimitedString(_getList($_[0])) },
300    # LIST2HASH
301    LISTEACH         => \&_LISTMAP,
302    LISTIF           => \&_LISTIF,
303    LISTITEM         => \&_LISTITEM,
304    LISTJOIN         => \&_LISTJOIN,
305    LISTMAP          => \&_LISTMAP,
306    LISTNONEMPTY     => sub { _listToDelimitedString( grep { /./ } _getList($_[0]) ) },
307    LISTRAND         => \&_LISTRAND,
308    LISTREVERSE      => sub { _listToDelimitedString(reverse _getList($_[0])) },
309    LISTSHUFFLE      => \&_LISTSHUFFLE,
310    LISTSIZE         => sub { scalar( _getList($_[0])) },
311    LISTSORT         => \&_LISTSORT,
312    LISTTRUNCATE     => \&_LISTTRUNCATE,
313    LISTUNIQUE       => \&_LISTUNIQUE,
314    LN               => sub { log( _getNumber($_[0]) ) },
315    LOG              => \&_LOG,
316    LOWER            => sub { lc( $_[0] ) },
317    MAIN             => sub { $_[0] },
318    MAX              => \&_MAX,
319    MEDIAN           => \&_MEDIAN,
320    MIN              => \&_MIN,
321    MOD              => \&_MOD,
322    NOEXEC           => sub { $_[0] },
323    NOP              => \&_NOP,
324    NOT              => sub { ( _getNumber( $_[0] )) ? 0 : 1 },
325    OCT2DEC          => \&_OCT2DEC,
326    ODD              => sub { _getNumber( $_[0] ) % 2 },
327    OR               => \&_OR,
328    PERCENTILE       => \&_PERCENTILE,
329    PI               => sub { 3.1415926535897932384 },
330    PRODUCT          => \&_PRODUCT,
331    PROPER           => sub {
332        $_[0] =~ s/(\w+)/\u\L$1/g;
333        return $_[0];
334    },
335    PROPERSPACE      => sub { _properSpace($_[0]) },
336    RAND             => sub {
337                        my $max = _getNumber($_[0]);
338                        $max = 1 if ( $max <= 0 );
339                        rand($max);
340                       },
341    RANDSTRING       => \&_RANDSTRING,
342    REPEAT           => \&_REPEAT,
343    REPLACE          => \&_REPLACE,
344    RIGHT            => sub {
345                            my $i = $rPos + 1;
346                            my $c = $cPos + 2;
347                            return "R$i:C$c..R$i:C32000";
348                            },
349    RIGHTSTRING      => \&_RIGHTSTRING,
350    ROUND            => \&_ROUND,
351    ROW              => sub { $rPos + ( $_[0] || 0 ) + 1 },
352    SEARCH           => \&_SEARCH,
353    SET              => \&_SET,
354    # SETHASH - Set a hash for later use
355    SETIFEMPTY       => \&_SETIFEMPTY,
356    # SETLIST - Save a list for later use
357    SETM             => \&_SETM,
358    # SETMHASH - Modify a hash
359    SIGN             => sub {
360                         my $i = _getNumber($_[0]);
361                         return ( $i > 0 ) ? 1
362                             :  ( $i < 0 ) ? -1
363                             :  0;
364                        },
365    SPLIT            => \&_SPLIT,
366    SQRT             => sub { sqrt( _getNumber( $_[0] ) ) },
367    # STDEV  - Std. Deviation
368    # STDEVP - Std. Deviation population
369    SUBSTITUTE       => \&_SUBSTITUTE,
370    SUBSTRING        => \&_SUBSTRING,
371    SUM              => \&_SUM,
372    SUMDAYS          => \&_SUMDAYS,,
373    SUMPRODUCT       => \&_SUMPRODUCT,
374    T                => \&_T,
375    TIME             => \&_TIME,
376    TIMEADD          => \&_TIMEADD,
377    TIMEDIFF         => \&_TIMEDIFF,
378    TODAY            => sub { _date2serial( _serial2date( time(), '$year/$month/$day GMT', 1 ) ) },
379    TRANSLATE        => \&_TRANSLATE,
380    TRIM             => sub {
381                         $_[0] =~ s/^\s*//;
382                         $_[0] =~ s/\s*$//;
383                         $_[0] =~ s/\s+/ /g;
384                         return $_[0];
385                       },
386    UPPER            => sub { uc( $_[0] ) },
387    VALUE            => sub { _getNumber( $_[0] ) },
388    # VAR  - Variance sample
389    # VARP - Variance population
390    WHILE            => \&_WHILE,
391    WORKINGDAYS      => sub {
392                        my ($stime, $etime) = split( /,\s*/, $_[0], 2);
393                        _workingDays( _getNumber($stime), _getNumber($etime));
394                       },
395    XOR              => \&_XOR,
396};
397#>>>
398$Function->{MIDSTRING} = $Function->{SUBSTRING};    # MIDSTRING Undocumented
399$Function->{DURATION} = $Function->{SUMDAYS};  # DURATION undocumented, for Sven
400$Function->{MULT}     = $Function->{PRODUCT};  # MULT deprecated
401$Function->{MEAN}     = $Function->{AVERAGE};  # # Both documented & supported
402
403sub _doFunc {
404    my ( $theFunc, $theAttr ) = @_;
405
406    $theAttr = "" unless ( defined $theAttr );
407    Foswiki::Func::writeDebug(
408        "- SpreadSheetPlugin::Calc::_doFunc: $theFunc( $theAttr ) start")
409      if $debug;
410
411    unless ( $theFunc =~ /^(IF|LISTEACH|LISTIF|LISTMAP|NOEXEC|WHILE)$/ ) {
412        &$recurseFunc($theAttr);
413    }
414
415    # else: delay the function handler to after parsing the parameters,
416    # in which case handling functions and cleaning up needs to be done later
417
418    my $result = "";
419    my $i      = 0;
420
421    # Execute functions defined in the above $Function hash
422    if ( defined $Function->{$theFunc} ) {
423        my $f = $Function->{$theFunc};
424        $result = &$f($theAttr);
425    }
426
427    Foswiki::Func::writeDebug(
428"- SpreadSheetPlugin::Calc::_doFunc: $theFunc( $theAttr ) returns: $result"
429    ) if $debug;
430    return $result;
431}
432
433#########################
434# Spreadsheet Cells
435#########################
436
437# ======================
438sub _T {
439    my @arr = _getTableRange("$_[0]..$_[0]");
440    return (@arr) ? $arr[0] : '';
441}
442
443# ======================
444sub _DEF {
445
446    # Format DEF(list) returns first defined cell
447    # Added by MF 26/3/2002, fixed by PeterThoeny
448    my $result = '';
449    my @arr    = _getList( $_[0] );
450    foreach my $cell (@arr) {
451        if ($cell) {
452            $cell =~ s/^\s*(.*?)\s*$/$1/;
453            if ($cell) {
454                $result = $cell;
455                last;
456            }
457        }
458    }
459    return $result;
460}
461
462#########################
463#  Conditional and Looping
464#########################
465
466# ======================
467sub _EXEC {
468
469    # add nesting level escapes
470    my $level = 0;
471    $_[0] =~ s/([\(\)])/_addNestingLevel($1, \$level)/ge;
472
473# execute functions in attribute recursively and clean up unbalanced parenthesis
474    &$recurseFunc( $_[0] );
475    return $_[0];
476}
477
478# =======================
479sub _IF {
480
481    # IF(condition, value if true, value if false)
482    my ( $condition, $str1, $str2 ) = _properSplit( $_[0], 3 );
483
484# with delay, handle functions in condition recursively and clean up unbalanced parenthesis
485    &$recurseFunc($condition);
486    $condition =~ s/^\s*(.*?)\s*$/$1/;
487    my $result = _safeEvalPerl($condition);
488    unless ( $result =~ /^ERROR/ ) {
489        if ($result) {
490            $result = $str1;
491        }
492        else {
493            $result = $str2;
494        }
495        $result = "" unless ( defined($result) );
496
497# with delay, handle functions in result recursively and clean up unbalanced parenthesis
498        &$recurseFunc($result);
499
500    }    # else return error message
501    return $result;
502}
503
504# =========================
505sub _NOP {
506
507    # pass everything through, this will allow plugins to defy plugin order
508    # for example the %SEARCH{}% variable
509    $_[0] =~ s/\$per(cnt)?/%/g;
510    $_[0] =~ s/\$quot/"/g;
511    return $_[0];
512}
513
514# ===========================
515sub _WHILE {
516
517    # WHILE(condition, do something)
518    my ( $condition, $str ) = _properSplit( $_[0], 2 );
519    return '' unless defined $condition;
520    my $result;
521    my $i = 0;
522    while (1) {
523        if ( $i++ >= 32767 ) {
524            $result .= 'ERROR: Infinite loop (32767 cycles)';
525            last;    # prevent infinite loop
526        }
527
528# with delay, handle functions in condition recursively and clean up unbalanced parenthesis
529        my $cond = $condition;
530        $cond =~ s/\$counter/$i/g;
531        &$recurseFunc($cond);
532        $cond =~ s/^\s*(.*?)\s*$/$1/;
533        my $res = _safeEvalPerl($cond);
534        if ( $res =~ /^ERROR/ ) {
535            $result .= $res;
536            last;    # exit loop and return error
537        }
538        last unless ($res);    # proper loop exit
539        $res = $str;
540        $res = "" unless ( defined($res) );
541
542# with delay, handle functions in result recursively and clean up unbalanced parenthesis
543        $res =~ s/\$counter/$i/g;
544        &$recurseFunc($res);
545        $result .= $res;
546    }
547    return $result;
548}
549
550#######################
551# Numeric Functions
552#######################
553
554# =========================
555sub _AVERAGE {
556    my $result = 0;
557    my $items  = 0;
558    my @arr    = _getListAsFloat( $_[0] );
559    foreach my $i (@arr) {
560        if ( defined $i ) {
561            $result += $i;
562            $items++;
563        }
564    }
565    if ( $items > 0 ) {
566        $result = $result / $items;
567    }
568    return $result;
569}
570
571# =========================
572sub _CEILING {
573    my $i      = _getNumber( $_[0] );
574    my $result = int($i);
575    if ( $i > 0 && $i != $result ) {
576        $result += 1;
577    }
578    return $result;
579}
580
581# =========================
582sub _BIN2DEC {
583
584    $_[0] =~ s/[^0-1]//g;    # only binary digits
585    $_[0] ||= 0;
586    return oct( '0b' . $_[0] );
587}
588
589# =========================
590sub _DEC2BIN {
591
592    my ( $num, $size ) = _getListAsInteger( $_[0] );
593    $num ||= 0;
594    my $format = '%';
595    $format .= '0' . $size if ($size);
596    $format .= 'b';
597    return sprintf( $format, $num );
598}
599
600# =========================
601sub _HEX2DEC {
602
603    $_[0] =~ s/[^0-9A-Fa-f]//g;    # only hex numbers
604    $_[0] ||= 0;
605    return hex( $_[0] );
606}
607
608# =========================
609sub _DEC2HEX {
610
611    my ( $num, $size ) = _getListAsInteger( $_[0] );
612    $num ||= 0;
613    my $format = '%';
614    $format .= '0' . $size if ($size);
615    $format .= 'X';
616    return sprintf( $format, $num );
617}
618
619# =========================
620sub _OCT2DEC {
621
622    $_[0] =~ s/[^0-7]//g;    # only octal digits
623    $_[0] ||= 0;
624    return oct( $_[0] );
625}
626
627# =========================
628sub _DEC2OCT {
629
630    my ( $num, $size ) = _getListAsInteger( $_[0] );
631    $num ||= 0;
632    my $format = '%';
633    $format .= '0' . $size if ($size);
634    $format .= 'o';
635    return sprintf( $format, $num );
636}
637
638# =========================
639sub _FLOOR {
640    my $i      = _getNumber( $_[0] );
641    my $result = int($i);
642    if ( $i < 0 && $i != $result ) {
643        $result -= 1;
644    }
645    return $result;
646}
647
648# =====================
649sub _FORMAT {
650
651# Format FORMAT(TYPE, precision, value) returns formatted value -- JimStraus - 05 Jan 2003
652    my ( $format, $res, $value ) = split( /,\s*/, $_[0] );
653    $format =~ s/^\s*(.*?)\s*$/$1/;    #Strip leading and trailing spaces
654    $res    =~ s/^\s*(.*?)\s*$/$1/;
655    $value  =~ s/^\s*(.*?)\s*$/$1/;
656    $res    =~ m/^(.*)$/;              # SMELL why do we need to untaint
657    $res = $1;
658    my $result = '';
659    if ( $format eq "DOLLAR" ) {
660        my $neg = 0;
661        $neg    = 1 if $value < 0;
662        $value  = abs($value);
663        $result = sprintf( "%0.${res}f", $value );
664        my $temp = reverse $result;
665        $temp =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
666        $result = "\$" . ( scalar( reverse($temp) ) );
667        $result = "(" . $result . ")" if $neg;
668    }
669
670    # TWIKI: Added CURRENCY format
671    elsif ( $format eq "COMMA" ) {
672        $result = sprintf( "%0.${res}f", $value );
673        my $temp = reverse $result;
674        $temp =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
675        $result = scalar( reverse($temp) );
676    }
677    elsif ( $format eq "PERCENT" ) {
678        $result = sprintf( "%0.${res}f%%", $value * 100 );
679    }
680    elsif ( $format eq "NUMBER" ) {
681        $result = sprintf( "%0.${res}f", $value );
682    }
683    elsif ( $format eq "K" ) {
684        $result = sprintf( "%0.${res}f K", $value / 1024 );
685    }
686    elsif ( $format eq "KB" ) {
687        $result = sprintf( "%0.${res}f KB", $value / 1024 );
688    }
689    elsif ( $format eq "MB" ) {
690        $result = sprintf( "%0.${res}f MB", $value / ( 1024 * 1024 ) );
691    }
692    elsif ( $format =~ /^KBMB/ ) {
693        $value /= 1024;
694        my @lbls = ( "MB", "GB", "TB", "PB", "EB", "ZB" );
695        my $lbl = "KB";
696        while ( $value >= 1024 && @lbls ) {
697            $value /= 1024;
698            $lbl = shift @lbls;
699        }
700        $result = sprintf( "%0.${res}f", $value ) . " $lbl";
701    }
702    else {
703
704        # FORMAT not recognized, just return value
705        $result = $value;
706    }
707    return $result;
708}
709
710# =========================
711sub _HEXDECODE {
712    my $theAttr = shift;
713    $theAttr =~ s/[^0-9A-Fa-f]//g;                     # only hex numbers
714    $theAttr =~ s/.$// if ( length($theAttr) % 2 );    # must be set of two
715    return pack( "H*", $theAttr );
716}
717
718# =======================
719sub _LOG {
720
721    my ( $num, $base ) = split( /,\s*/, $_[0], 2 );
722    $num  = _getNumber($num);
723    $base = _getNumber($base);
724    $base = 10 if ( $base <= 0 );
725    return log($num) / log($base);
726
727}
728
729# =========================
730sub _MAX {
731    my @arr = sort { $a <=> $b }
732      grep { /./ }
733      grep { defined $_ } _getListAsFloat( $_[0] );
734    return $arr[-1];
735}
736
737# =========================
738sub _MEDIAN {
739    my @arr =
740      sort { $a <=> $b } grep { defined $_ } _getListAsFloat( $_[0] );
741    my $i      = @arr;
742    my $result = '';
743    if ( ( $i % 2 ) > 0 ) {
744        $result = $arr[ $i / 2 ];
745    }
746    elsif ($i) {
747        $i /= 2;
748        $result = ( $arr[$i] + $arr[ $i - 1 ] ) / 2;
749    }
750    return $result;
751}
752
753# =========================
754sub _MIN {
755    my @arr = sort { $a <=> $b }
756      grep { /./ }
757      grep { defined $_ } _getListAsFloat( $_[0] );
758    return $arr[0];
759}
760
761# =======================
762sub _MOD {
763
764    my $result = 0;
765    my ( $num1, $num2 ) = split( /,\s*/, $_[0], 2 );
766    $num1 = _getNumber($num1);
767    $num2 = _getNumber($num2);
768    if ( $num1 && $num2 ) {
769        $result = $num1 % $num2;
770    }
771    return $result;
772}
773
774# =========================
775sub _PERCENTILE {
776    my ( $percentile, $set ) = split( /,\s*/, $_[0], 2 );
777    my $i;
778    my @arr = sort { $a <=> $b } grep { defined $_ } _getListAsFloat($set);
779    my $result = 0;
780
781    my $size = scalar(@arr);
782    if ( $size > 0 ) {
783        $i = $percentile / 100 * ( $size + 1 );
784        my $iInt = int($i);
785        if ( $i <= 1 ) {
786            $result = $arr[0];
787        }
788        elsif ( $i >= $size ) {
789            $result = $arr[ $size - 1 ];
790        }
791        elsif ( $i == $iInt ) {
792            $result = $arr[ $i - 1 ];
793        }
794        else {
795
796            # interpolate beween neighbors # Example: $i = 7.25
797            my $r1 = $iInt + 1 - $i;      # 0.75 = 7 + 1 - 7.25
798            my $r2 = 1 - $r1;             # 0.25 = 1 - 0.75
799            my $x1 = $arr[ $iInt - 1 ];
800            my $x2 = $arr[$iInt];
801            $result = ( $r1 * $x1 ) + ( $r2 * $x2 );
802        }
803    }
804    return $result;
805}
806
807# =========================
808sub _PRODUCT {
809    my $result = 0;
810    my @arr    = _getListAsFloat( $_[0] );
811
812    # no arguments,  return 0.
813    return 0 unless scalar @arr;
814    $result = 1;
815    foreach my $i (@arr) {
816        $result *= $i if defined $i;
817    }
818    return $result;
819}
820
821# =========================
822sub _ROUND {
823
824    # ROUND(num, digits)
825    my ( $num, $digits ) = split( /,\s*/, $_[0], 2 );
826    my $result = _safeEvalPerl($num);
827    unless ( $result =~ /^ERROR/ ) {
828        $result = _getNumber($result);
829        if (   ($digits)
830            && ( $digits =~ s/^.*?(\-?[0-9]+).*$/$1/ )
831            && ($digits) )
832        {
833            my $factor = 10**$digits;
834            $result *= $factor;
835            ( $result >= 0 ) ? ( $result += 0.5 ) : ( $result -= 0.5 );
836            $result = int($result);
837            $result /= $factor;
838        }
839        else {
840            ( $result >= 0 ) ? ( $result += 0.5 ) : ( $result -= 0.5 );
841            $result = int($result);
842        }
843    }
844    return $result;
845}
846
847# =========================
848sub _SUM {
849    my $result = 0;
850    my @arr    = _getListAsFloat( $_[0] );
851    foreach my $i (@arr) {
852        $result += $i if defined $i;
853    }
854    return $result;
855}
856
857# =========================
858sub _SUMPRODUCT {
859    my $result = 0;
860    my @arr;
861    my @lol = split( /,\s*/, $_[0] );
862    my $size = 32000;
863    for my $i ( 0 .. $#lol ) {
864        @arr     = _getListAsFloat( $lol[$i] );
865        $lol[$i] = [@arr];                        # store reference to array
866        $size    = @arr if ( @arr < $size );      # remember smallest array
867    }
868    if ( ( $size > 0 ) && ( $size < 32000 ) ) {
869        my $y;
870        my $prod;
871        my $val;
872        $size--;
873        for my $y ( 0 .. $size ) {
874            $prod = 1;
875            for my $i ( 0 .. $#lol ) {
876                $val = $lol[$i][$y];
877                if ( defined $val ) {
878                    $prod *= $val;
879                }
880                else {
881                    $prod = 0;    # don't count empty cells
882                }
883            }
884            $result += $prod;
885        }
886    }
887    return $result;
888}
889
890#######################
891#   GET / SET Functions
892#######################
893
894# =========================
895sub _GET {
896    my $name = $_[0];
897    $name =~ s/[^a-zA-Z0-9\_]//g;
898    my $result = $varStore{$name} if ($name);
899    $result = "" unless ( defined($result) );
900    return $result;
901}
902
903# =========================
904sub _SET {
905    my ( $name, $value ) = split( /,\s*/, $_[0], 2 );
906    return '' unless defined $name;
907    $name =~ s/[^a-zA-Z0-9\_]//g;
908    if ( $name && defined($value) ) {
909        $value =~ s/\s*$//;
910        $varStore{$name} = $value;
911    }
912    return '';
913}
914
915# =========================
916sub _SETIFEMPTY {
917    my ( $name, $value ) = split( /,\s*/, $_[0], 2 );
918    return '' unless defined $name;
919    $name =~ s/[^a-zA-Z0-9\_]//g;
920    if ( $name && defined($value) && !$varStore{$name} ) {
921        $value =~ s/\s*$//;
922        $varStore{$name} = $value;
923    }
924    return '';
925}
926
927# =========================
928sub _SETM {
929    my ( $name, $value ) = split( /,\s*/, $_[0], 2 );
930    return '' unless defined $name;
931    $name =~ s/[^a-zA-Z0-9\_]//g;
932    if ($name) {
933        my $old = $varStore{$name};
934        $old   = "" unless ( defined($old) );
935        $value = "" unless ( defined($value) );
936        $value = _safeEvalPerl("$old $value");
937        $varStore{$name} = $value;
938    }
939    return '';
940}
941
942#######################
943#   LIST Functions
944#######################
945
946# =====================
947sub _COUNTITEMS {
948    my $result = '';
949    my @arr    = _getList( $_[0] );
950    my %items  = ();
951    foreach my $key (@arr) {
952        $key =~ s/^\s*(.*?)\s*$/$1/ if ($key);
953        if ($key) {
954            if ( exists( $items{$key} ) ) {
955                $items{$key}++;
956            }
957            else {
958                $items{$key} = 1;
959            }
960        }
961    }
962    foreach my $key ( sort keys %items ) {
963        $result .= "$key: $items{ $key }%BR% ";
964    }
965    $result =~ s|%BR% $||;
966    return $result;
967}
968
969# =========================
970# LISTIF(cmd, item 1, item 2, ...)
971#
972sub _LISTIF {
973    my ( $cmd, $str ) = _properSplit( $_[0], 2 );
974    $cmd = "" unless ( defined($cmd) );
975    $cmd =~ s/^\s*(.*?)\s*$/$1/;
976    $str = "" unless ( defined($str) );
977
978# with delay, handle functions in result $str and clean up unbalanced parenthesis
979    &$recurseFunc($str);
980
981    my $item = qw{};
982    my $eval = qw{};
983    my $i    = 0;
984    my @arr =
985      grep { !/^FOSWIKI_GREP_REMOVE$/ }
986      map {
987        $item = $_;
988        $_    = $cmd;
989        $i++;
990        s/\$index/$i/g;
991        s/\$item/$item/g;
992        &$recurseFunc($_);
993        $eval = _safeEvalPerl($_);
994        if ( $eval =~ /^ERROR/ ) {
995            $_ = $eval;
996        }
997        elsif ($eval) {
998            $_ = $item;
999        }
1000        else {
1001            $_ = "FOSWIKI_GREP_REMOVE";
1002        }
1003      } _getList($str);
1004    return _listToDelimitedString(@arr);
1005}
1006
1007# =========================
1008sub _LISTITEM {
1009    my ( $index, $str ) = _properSplit( $_[0], 2 );
1010    my $result = '';
1011    $index = _getNumber($index);
1012    $str = "" unless ( defined($str) );
1013    my @arr  = _getList($str);
1014    my $size = scalar(@arr);
1015    if ( $index && $size ) {
1016        $index-- if ( $index > 0 );    # documented index starts at 1
1017        $index = $size + $index
1018          if ( $index < 0 );           # start from back if negative
1019        $result = $arr[$index] if ( ( $index >= 0 ) && ( $index < $size ) );
1020    }
1021    return $result;
1022}
1023
1024# =========================
1025sub _LISTJOIN {
1026    my ( $sep, $str ) = _properSplit( $_[0], 2 );
1027    $str = "" unless ( defined($str) );
1028
1029# SMELL: repairing standard delimiter ", " in the constructed string to our custom separator
1030    my $result = _listToDelimitedString( _getList($str) );
1031    if ( length $sep ) {
1032        $sep =~ s/\$comma/,/g;
1033        $sep =~ s/\$sp/ /g;
1034        $sep =~ s/\$(nop|empty)//g
1035          ;  # make sure $nop appears before $n otherwise you end up with "\nop"
1036        $sep    =~ s/\$n/\n/g;
1037        $result =~ s/, /$sep/g;
1038    }
1039    return $result;
1040}
1041
1042# =========================
1043sub _LISTMAP {
1044
1045    # LISTMAP(action, item 1, item 2, ...)
1046    my ( $action, $str ) = _properSplit( $_[0], 2 );
1047    $action = "" unless ( defined($action) );
1048    $str    = "" unless ( defined($str) );
1049
1050# with delay, handle functions in $str recursively and clean up unbalanced parenthesis
1051    &$recurseFunc($str);
1052
1053    my $item = qw{};
1054    my $i    = 0;
1055    my @arr  = map {
1056        $item = $_;
1057        $_    = $action;
1058        $i++;
1059        s/\$index/$i/g;
1060        $_ .= $item unless (s/\$item/$item/g);
1061        &$recurseFunc($_);
1062        $_
1063    } _getList($str);
1064    return _listToDelimitedString(@arr);
1065}
1066
1067# =========================
1068sub _LISTRAND {
1069    my @arr    = _getList( $_[0] );
1070    my $size   = scalar(@arr);
1071    my $result = '';
1072    if ( $size > 0 ) {
1073        my $i = int( rand($size) );
1074        $result = $arr[$i];
1075    }
1076    return $result;
1077}
1078
1079# =========================
1080sub _LISTSHUFFLE {
1081    my @arr  = _getList( $_[0] );
1082    my $size = scalar(@arr);
1083    if ( $size > 1 ) {
1084        for ( my $i = $size ; $i-- ; ) {
1085            my $j = int( rand( $i + 1 ) );
1086            next if ( $i == $j );
1087            @arr[ $i, $j ] = @arr[ $j, $i ];
1088        }
1089    }
1090    return _listToDelimitedString(@arr);
1091}
1092
1093# =========================
1094sub _LISTSORT {
1095    my $isNumeric = 1;
1096    my @arr       = map {
1097        $isNumeric = 0 unless ( $_ =~ /^[\+\-]?[0-9\.]+$/ );
1098        $_
1099    } _getList( $_[0] );
1100    if ($isNumeric) {
1101        @arr = sort { $a <=> $b } @arr;
1102    }
1103    else {
1104        @arr = sort @arr;
1105    }
1106    return _listToDelimitedString(@arr);
1107}
1108
1109# =========================
1110sub _LISTTRUNCATE {
1111    my ( $index, $str ) = _properSplit( $_[0], 2 );
1112    $index = int( _getNumber($index) );
1113    $str = "" unless ( defined($str) );
1114    my @arr    = _getList($str);
1115    my $size   = scalar(@arr);
1116    my $result = '';
1117    if ( $index > 0 ) {
1118        $index  = $size if ( $index > $size );
1119        $#arr   = $index - 1;
1120        $result = _listToDelimitedString(@arr);
1121    }
1122    elsif ( $index < 0 ) {
1123        $index = -$size if ( $index < -$size );
1124        splice( @arr, 0, $size + $index );
1125        $result = _listToDelimitedString(@arr);
1126    }
1127    return $result;
1128}
1129
1130# =========================
1131sub _LISTUNIQUE {
1132    my %seen = ();
1133    my @arr = grep { !$seen{$_}++ } _getList( $_[0] );
1134    return _listToDelimitedString(@arr);
1135}
1136
1137###########################
1138#  Logical functions
1139###########################
1140
1141# =========================
1142sub _AND {
1143    my $result = 0;
1144    my @arr    = _getListAsInteger( $_[0] );
1145    foreach my $i (@arr) {
1146        unless ($i) {
1147            $result = 0;
1148            last;
1149        }
1150        $result = 1;
1151    }
1152    return $result;
1153}
1154
1155# =========================
1156sub _OR {
1157    my $result = 0;
1158    my @arr    = _getListAsInteger( $_[0] );
1159    foreach my $i (@arr) {
1160        if ($i) {
1161            $result = 1;
1162            last;
1163        }
1164    }
1165    return $result;
1166}
1167
1168# =========================
1169sub _XOR {
1170    my @arr    = _getListAsInteger( $_[0] );
1171    my $result = shift(@arr);
1172    if ( scalar(@arr) > 0 ) {
1173        foreach my $i (@arr) {
1174            next unless defined $i;
1175            $result = ( $result xor $i );
1176        }
1177    }
1178    else {
1179        $result = 0;
1180    }
1181    $result = $result ? 1 : 0;
1182    return $result;
1183}
1184
1185# =========================
1186sub _BITXOR {
1187    my @arr    = _getList( $_[0] );
1188    my $result = '';
1189
1190# SMELL: This usage is bogus.   It takes the ones-complement of the string, and does NOT do a bit-wise XOR
1191# which would require two operators.   An XOR with itself would clear the field not flip all the bits.
1192# This should probably be called a BITNOT.
1193#if ( scalar(@arr) == 1 ) {
1194#    use bytes;
1195#    my $ff = chr(255) x length( $_[0] );
1196#    $result = $_[0] ^ $ff;
1197#    no bytes;
1198#}
1199
1200    # This is a standard bit-wise xor of a list of integers.
1201    #else {
1202    @arr = _getListAsInteger( $_[0] );
1203
1204    return '' unless scalar @arr;
1205    my $ent = shift(@arr);
1206    $result = ( defined $ent ) ? int($ent) : 0;
1207    if ( scalar(@arr) > 0 ) {
1208        foreach my $i (@arr) {
1209            next unless defined $i;
1210            $result = ( $result ^ int($i) );
1211        }
1212    }
1213    else {
1214        $result = 0;
1215    }
1216
1217    #}
1218    return $result;
1219}
1220
1221# =========================
1222sub _RANDSTRING {
1223    my ($theAttr) = @_;
1224    my ( $chars, $format ) = split( /,\s*/, $theAttr, 2 );
1225    $chars = '' unless defined($chars);
1226    $chars =~ s/(.)\.\.(.)/_expandRange($1, $2)/ge;
1227    my @pool = split( //, $chars );
1228    @pool = ( 'a' .. 'z', 'A' .. 'Z', '0' .. '9', '_' )
1229      unless ( scalar(@pool) );
1230    my $num = 0;
1231    $format = '' unless defined($format);
1232
1233    if ( $format =~ m/^([0-9]*)$/ ) {
1234        $num    = _getNumber($format);
1235        $num    = 8 if ( $num < 1 );
1236        $num    = 1024 if ( $num > 1024 );
1237        $format = 'x' x $num;
1238    }
1239    else {
1240        $num = length($format);
1241    }
1242    my $result;
1243    foreach my $ch ( split( //, $format ) ) {
1244        if ( $ch eq 'x' ) {
1245            $result .= $pool[ rand @pool ];
1246        }
1247        else {
1248            $result .= $ch;
1249        }
1250    }
1251    return $result;
1252}
1253
1254# =========================
1255sub _expandRange {
1256    my ( $lowCh, $highCh ) = @_;
1257    my $text =
1258      "$1$2";    # in case out of range, return just low char and high char
1259    if ( ord $highCh > ord $lowCh ) {
1260        $text = join( '', ( $lowCh .. $highCh ) );
1261    }
1262    return $text;
1263}
1264
1265##########################
1266# DATE / TIME Functions
1267# #######################
1268
1269# =========================
1270sub _FORMATGMTIME {
1271
1272    # Call FORMATTIME with flag to suggest use GMT
1273    _FORMATTIME( $_[0], '1' );
1274}
1275
1276# =========================
1277sub _FORMATTIME {
1278
1279    #elsif ( $theFunc =~ /^(FORMATTIME|FORMATGMTIME)$/ ) {
1280
1281    my ( $time, $str ) = split( /,\s*/, $_[0], 2 );
1282    if ( $time =~ /(-?[0-9]+)/ ) {
1283        $time = $1;
1284    }
1285    else {
1286        $time = time();
1287    }
1288    my $isGmt = $_[1] || 0;
1289    $isGmt = 1
1290      if ( ( $str =~ m/ gmt/i ) );
1291    return _serial2date( $time, $str, $isGmt );
1292}
1293
1294# =========================
1295sub _FORMATTIMEDIFF {
1296    my ( $scale, $prec, $time ) = split( /,\s*/, $_[0], 3 );
1297    $scale = "" unless ($scale);
1298    $prec  = int( _getNumber($prec) - 1 );
1299    $prec  = 0 if ( $prec < 0 );
1300    $time  = _getNumber($time);
1301    $time *= -1 if ( $time < 0 );
1302    my @unit = ( 0, 0, 0, 0, 0, 0 );    # sec, min, hours, days, month, years
1303    my @factor =
1304      ( 1, 60, 60, 24, 30.4166, 12 );    # sec, min, hours, days, month, years
1305    my @singular = ( 'second',  'minute',  'hour',  'day',  'month', 'year' );
1306    my @plural   = ( 'seconds', 'minutes', 'hours', 'days', 'month', 'years' );
1307    my $min      = 0;
1308    my $max      = $prec;
1309
1310    if ( $scale =~ /^min/i ) {
1311        $min = 1;
1312        $unit[1] = $time;
1313    }
1314    elsif ( $scale =~ /^hou/i ) {
1315        $min = 2;
1316        $unit[2] = $time;
1317    }
1318    elsif ( $scale =~ /^day/i ) {
1319        $min = 3;
1320        $unit[3] = $time;
1321    }
1322    elsif ( $scale =~ /^mon/i ) {
1323        $min = 4;
1324        $unit[4] = $time;
1325    }
1326    elsif ( $scale =~ /^yea/i ) {
1327        $min = 5;
1328        $unit[5] = $time;
1329    }
1330    else {
1331        $unit[0] = $time;
1332    }
1333    my @arr  = ();
1334    my $i    = 0;
1335    my $val1 = 0;
1336    my $val2 = 0;
1337    for ( $i = $min ; $i < 5 ; $i++ ) {
1338        $val1 = $unit[$i];
1339        $val2 = $unit[ $i + 1 ] = int( $val1 / $factor[ $i + 1 ] );
1340        $val1 = $unit[$i] = $val1 - int( $val2 * $factor[ $i + 1 ] );
1341
1342        push( @arr, "$val1 $singular[$i]" ) if ( $val1 == 1 );
1343        push( @arr, "$val1 $plural[$i]" )   if ( $val1 > 1 );
1344    }
1345    push( @arr, "$val2 $singular[$i]" ) if ( $val2 == 1 );
1346    push( @arr, "$val2 $plural[$i]" )   if ( $val2 > 1 );
1347    push( @arr, "0 $plural[$min]" ) unless (@arr);
1348    my @reverse = reverse(@arr);
1349    $#reverse = $prec if ( @reverse > $prec );
1350    my $result = join( ', ', @reverse );
1351    $result =~ s/(.+)\, /$1 and /;
1352    return $result;
1353}
1354
1355# =========================
1356sub _SUMDAYS {
1357
1358    # Also implements DURATION
1359    # DURATION is undocumented, is for SvenDowideit
1360    # contributed by SvenDowideit - 07 Mar 2003; modified by PTh
1361    my $result = 0;
1362    my @arr    = _getListAsDays( $_[0] );
1363    foreach my $i (@arr) {
1364        $result += $i if defined $i;
1365    }
1366    return $result;
1367}
1368
1369# =========================
1370sub _TIME {
1371    my $result = $_[0];
1372    $result =~ s/^\s+//;
1373    $result =~ s/\s+$//;
1374    if ($result) {
1375        $result = _date2serial($result);
1376    }
1377    else {
1378        $result = time();
1379    }
1380    return $result;
1381}
1382
1383# =========================
1384sub _TIMEADD {
1385
1386    my ( $time, $value, $scale ) = split( /,\s*/, $_[0], 3 );
1387    $time  = 0  unless ($time);
1388    $value = 0  unless ($value);
1389    $scale = "" unless ($scale);
1390    $time  =~ s/.*?(-?[0-9]+).*/$1/   || 0;
1391    $value =~ s/.*?(-?[0-9\.]+).*/$1/ || 0;
1392    $value *= 60            if ( $scale =~ /^min/i );
1393    $value *= 3600          if ( $scale =~ /^hou/i );
1394    $value *= 3600 * 24     if ( $scale =~ /^day/i );
1395    $value *= 3600 * 24 * 7 if ( $scale =~ /^week/i );
1396    $value *= 3600 * 24 * 30.42
1397      if ( $scale =~ /^mon/i );    # FIXME: exact calc
1398    $value *= 3600 * 24 * 365 if ( $scale =~ /^year/i );    # FIXME: exact calc
1399    return int( $time + $value );
1400
1401}
1402
1403# =========================
1404sub _TIMEDIFF {
1405
1406    my ( $time1, $time2, $scale ) = split( /,\s*/, $_[0], 3 );
1407    $scale ||= '';
1408    $time1 = 0 unless ($time1);
1409    $time2 = 0 unless ($time2);
1410    $time1 =~ s/[^-0-9]*?(-?[0-9]+).*/$1/ || 0;
1411    $time2 =~ s/[^-0-9]*?(-?[0-9]+).*/$1/ || 0;
1412    my $result = $time2 - $time1;
1413    $result /= 60            if ( $scale =~ /^min/i );
1414    $result /= 3600          if ( $scale =~ /^hou/i );
1415    $result /= 3600 * 24     if ( $scale =~ /^day/i );
1416    $result /= 3600 * 24 * 7 if ( $scale =~ /^week/i );
1417    $result /= 3600 * 24 * 30.42
1418      if ( $scale =~ /^mon/i );    # FIXME: exact calc
1419    $result /= 3600 * 24 * 365
1420      if ( $scale =~ /^year/i );    # FIXME: exact calc
1421    return $result;
1422}
1423
1424###########################
1425# String Functions
1426###########################
1427
1428# =========================
1429sub _CHAR {
1430    my $i = 0;
1431    if ( $_[0] =~ /([0-9]+)/ ) {
1432        $i = $1;
1433    }
1434    $i = 255 if $i > 255;
1435    $i = 0   if $i < 0;
1436    return chr($i);
1437}
1438
1439# =========================
1440sub _COUNTSTR {
1441    my $result = 0;       # count any string
1442    my $i      = 0;       # count string equal second attr
1443    my $list   = $_[0];
1444    my $str    = "";
1445    if ( $_[0] =~ /^(.*),\s*(.*?)$/ ) {    # greedy match for last comma
1446        $list = $1;
1447        $str  = $2;
1448    }
1449    $str =~ s/\s*$//;
1450    my @arr = _getList($list);
1451    foreach my $cell (@arr) {
1452        if ( defined $cell ) {
1453            $cell =~ s/^\s*(.*?)\s*$/$1/;
1454            $result++ if ($cell);
1455            $i++ if ( $cell eq $str );
1456        }
1457    }
1458    $result = $i if ($str);
1459    return $result;
1460}
1461
1462# ========================
1463sub _EXACT {
1464    my ( $str1, $str2 ) = split( /,\s*/, $_[0], 2 );
1465    $str1 = "" unless ($str1);
1466    $str2 = "" unless ($str2);
1467    $str1 =~ s/^\s*(.*?)\s*$/$1/;    # cut leading and trailing spaces
1468    $str2 =~ s/^\s*(.*?)\s*$/$1/;
1469    return ( $str1 eq $str2 ) ? 1 : 0;
1470}
1471
1472# =========================
1473sub _FILTER {
1474    my $result = '';
1475    my ( $filter, $string ) = split( /,\s*/, $_[0], 2 );
1476    if ( defined $string ) {
1477        $filter =~ s/\$comma/,/g;
1478        $filter =~ s/\$sp/ /g;
1479        eval '$string =~ s/$filter//go';
1480        $result = $string;
1481    }
1482    return $result;
1483}
1484
1485# ========================
1486sub _FIND {
1487    return _SEARCH( $_[0], 'FIND' );
1488}
1489
1490# ========================
1491sub _SEARCH {
1492    my ( $searchString, $string, $pos ) = split( /,\s*/, $_[0], 3 );
1493    $string       = '' unless ( defined $string );
1494    $searchString = '' unless ( defined $searchString );
1495    my $result = 0;
1496    $pos--;
1497    $pos = 0 if ( $pos < 0 );
1498    $searchString = quotemeta($searchString) if ( $_[1] );
1499    pos($string) = $pos if ($pos);
1500
1501    # using zero width lookahead '(?=...)' to keep pos at the beginning of match
1502    if ( $searchString ne '' && eval '$string =~ m/(?=$searchString)/g' ) {
1503        $result = pos($string) + 1;
1504    }
1505    return $result;
1506}
1507
1508# ========================
1509sub _REPLACE {
1510    my ( $string, $start, $num, $replace ) = split( /,\s*/, $_[0], 4 );
1511    $string = "" unless ( defined $string );
1512    my $result = $string;
1513    $start ||= 0;
1514    $start-- unless ( $start < 1 );
1515    $num     = 0  unless ($num);
1516    $replace = "" unless ( defined $replace );
1517    $replace =~ s/\$comma/,/g;
1518    $replace =~ s/\$sp/ /g;
1519    eval 'substr( $string, $start, $num, $replace )';
1520    $result = $string;
1521    return $result;
1522}
1523
1524# ========================
1525sub _SUBSTITUTE {
1526    my ( $string, $from, $to, $inst, $options ) = split( /,\s*/, $_[0] );
1527    $string = "" unless ( defined $string );
1528    my $result = $string;
1529    $from = "" unless ( defined $from );
1530    $from =~ s/\$comma/,/g;
1531    $from =~ s/\$sp/ /g;
1532    $from = quotemeta($from) unless ( $options && $options =~ /r/i );
1533    $to = "" unless ( defined $to );
1534    $to =~ s/\$comma/,/g;
1535    $to =~ s/\$sp/ /g;
1536
1537    # Note that the number 0 is valid string. An empty string as well as 0
1538    # are valid return values
1539    if ( $string ne "" && $from ne "" ) {
1540        if ($inst) {
1541
1542            # replace Nth instance
1543            my $count = 0;
1544            if (
1545                eval
1546'$string =~ s/($from)/if( ++$count == $inst ) { $to; } else { $1; }/gex;'
1547              )
1548            {
1549                $result = $string;
1550            }
1551        }
1552        else {
1553
1554            # global replace
1555            if ( eval '$string =~ s/$from/$to/g' ) {
1556                $result = $string;
1557            }
1558        }
1559    }
1560    return $result;
1561
1562}
1563
1564# ========================
1565sub _LEFTSTRING {
1566    my ( $string, $num ) = split( /,\s*/, $_[0], 2 );
1567    my $result = '';
1568    $string = "" unless ( defined $string );
1569    $num = 1 if ( !defined $num );
1570    eval '$result = substr( $string, 0, $num )';
1571    return $result;
1572}
1573
1574# ========================
1575sub _RIGHTSTRING {
1576    my ( $string, $num ) = split( /,\s*/, $_[0], 2 );
1577    my $result = '';
1578    $string = "" unless ( defined $string );
1579    $num = 1 if ( !defined $num );
1580    $num = 0 if ( $num < 0 );
1581    my $start = length($string) - $num;
1582    $start = 0 if $start < 0;
1583    eval '$result = substr( $string, $start, $num )';
1584    return $result;
1585}
1586
1587# ========================
1588sub _INSERTSTRING {
1589    my ( $string, $start, $new ) = split( /,\s*/, $_[0], 3 );
1590    $string = "" unless ( defined $string );
1591    $start = _getNumber($start);
1592    eval 'substr( $string, $start, 0, $new )';
1593    return $string;
1594
1595}
1596
1597# ========================
1598sub _TRANSLATE {
1599    my $result = $_[0];
1600
1601# greedy match for comma separated parameters (in case first parameter has embedded commas)
1602    if ( $_[0] =~ /^(.*)\,\s*(.+)\,\s*(.+)$/ ) {
1603        my $string = $1;
1604        my $from   = $2;
1605        my $to     = $3;
1606        $from =~ s/\$comma/,/g;
1607        $from =~ s/\$sp/ /g;
1608        $from = quotemeta($from);
1609        $to =~ s/\$comma/,/g;
1610        $to =~ s/\$sp/ /g;
1611        $to = quotemeta($to);
1612        $from =~ s/([a-zA-Z0-9])\\\-([a-zA-Z0-9])/$1\-$2/g
1613          ;    # fix quotemeta (allow only ranges)
1614        $to =~ s/([a-zA-Z0-9])\\\-([a-zA-Z0-9])/$1\-$2/g;
1615        $result = $string;
1616
1617        if ( $string && eval "\$string =~ tr/$from/$to/" ) {
1618            $result = $string;
1619        }
1620    }
1621    return $result;
1622}
1623
1624# =========================
1625sub _REPEAT {
1626    my ( $str, $num ) = split( /,\s*/, $_[0], 2 );
1627    $str = "" unless ( defined($str) );
1628    $num = _getNumber($num);
1629    return "$str" x $num;
1630}
1631
1632# ========================
1633sub _SPLIT {
1634    my ( $sep, $str ) = _properSplit( $_[0], 2 );
1635
1636    # Not documented - if called without 2 parameters,  assume space delimiter
1637    if ( !defined $str || $str eq '' ) {
1638        $str = $_[0];
1639        $sep = '$sp$sp*';
1640    }
1641
1642    $str =~ s/^\s+//;
1643    $str =~ s/\s+$//;
1644
1645    $sep = '$sp$sp*' if ( $sep eq '' );
1646    $sep =~ s/\$sp/\\s/g;
1647
1648   #SMELL:  Optimizing this next regex breaks reuse for some reason, perl 5.12.3
1649    $sep =~ s/\$(nop|empty)//g;
1650    $sep =~ s/\$comma/,/g;
1651
1652    return _listToDelimitedString( split( /$sep/, $str ) );
1653}
1654
1655# =========================
1656sub _SUBSTRING {
1657    my $result = '';
1658
1659# greedy match for comma separated parameters (in case first parameter has embedded commas)
1660    if ( $_[0] =~ /^(.*)\,\s*(.+)\,\s*(.+)$/ ) {
1661        my ( $string, $start, $num ) = ( $1, $2, $3 );
1662        if ( $start && $num ) {
1663            $start-- unless ( $start < 1 );
1664            eval '$result = substr( $string, $start, $num )';
1665        }
1666    }
1667    return $result;
1668}
1669
1670######################
1671#  Utility Functions
1672#####################
1673
1674# =========================
1675sub _listToDelimitedString {
1676    my @arr = map { s/^\s*//; s/\s*$//; $_ } @_;
1677    my $text = join( ", ", @arr );
1678    return $text;
1679}
1680
1681# =========================
1682sub _properSplit {
1683    my ( $theAttr, $theLevel ) = @_;
1684
1685    # escape commas inside functions
1686    $theAttr =~
1687      s/(\$[A-Z]+$escToken([0-9]+)\(.*?$escToken\2\))/_escapeCommas($1)/geo;
1688
1689    # split at commas and restore commas inside functions
1690    my @arr =
1691      map { s/<$escToken>/\,/go; $_ } split( /,\s*/, $theAttr, $theLevel );
1692    return @arr;
1693}
1694
1695# =========================
1696sub _escapeCommas {
1697    my ($theText) = @_;
1698    $theText =~ s/\,/<$escToken>/g;
1699    return $theText;
1700}
1701
1702# =========================
1703sub _getNumber {
1704    my ($theText) = @_;
1705    return 0 unless ($theText);
1706    $theText =~ s/([0-9])\,(?=[0-9]{3})/$1/g;    # "1,234,567" ==> "1234567"
1707    if ( $theText =~ /[0-9]e/i ) {               # "1.5e-3"    ==> "0.0015"
1708        $theText = sprintf "%.20f", $theText;
1709        $theText =~ s/0+$//;
1710    }
1711    unless ( $theText =~ s/^.*?(\-?[0-9\.]+).*$/$1/ )
1712    {                                            # "xy-1.23zz" ==> "-1.23"
1713        $theText = 0;
1714    }
1715    $theText =~ s/^(\-?)0+([0-9])/$1$2/;         # "-0009.12"  ==> "-9.12"
1716    $theText =~ s/^(\-?)\./${1}0\./;             # "-.25"      ==> "-0.25"
1717    $theText =~ s/^\-0$/0/;                      # "-0"        ==> "0"
1718    $theText =~ s/\.$//;                         # "123."      ==> "123"
1719    return $theText;
1720}
1721
1722# =========================
1723sub _safeEvalPerl {
1724    my ($theText) = @_;
1725    $theText = '' unless defined $theText;
1726
1727    # Allow only simple math with operators - + * / % ( )
1728    $theText =~ s/\%\s*[^\-\+\*\/0-9\.\(\)]+//g; # defuse %hash but keep modulus
1729      # keep only numbers and operators (shh... don't tell anyone, we support comparison operators)
1730    $theText =~ s/[^\!\<\=\>\-\+\*\/\%0-9e\.\(\)]*//g;
1731    $theText =~ s/(^|[^\.])\b0+(?=[0-9])/$1/g
1732      ;    # remove leading 0s to defuse interpretation of numbers as octals
1733    $theText =~
1734      s/(^|[^0-9])e/$1/g;   # remove "e"-s unless in expression such as "123e-4"
1735    $theText =~ /(.*)/;
1736    $theText = $1;          # untainted variable
1737    return "" unless ($theText);
1738    local $SIG{__DIE__} =
1739      sub { Foswiki::Func::writeDebug( $_[0] ); warn $_[0] };
1740    my $result = eval $theText;
1741
1742    if ($@) {
1743        $result = $@;
1744        $result =~ s/[\n\r]//g;
1745        $result =~
1746          s/\[[^\]]+.*view.*?\:\s?//;  # Cut "[Mon Mar 15 23:31:39 2004] view: "
1747        $result =~ s/\s?at \(eval.*?\)\sline\s?[0-9]*\.?\s?//g
1748          ;                            # Cut "at (eval 51) line 2."
1749        $result = "ERROR: $result";
1750
1751    }
1752    else {
1753        $result = 0 unless ($result);    # logical false is "0"
1754    }
1755    return $result;
1756}
1757
1758# =========================
1759sub _getListAsInteger {
1760    my ($theAttr) = @_;
1761
1762    my $val  = 0;
1763    my @list = _getList($theAttr);
1764    ( my $baz = "foo" ) =~ s/foo//;      # reset search vars. defensive coding
1765    for my $i ( 0 .. $#list ) {
1766        $val = $list[$i];
1767
1768        # search first integer pattern, skip over HTML tags
1769        if ( $val =~ /^\s*(?:<[^>]*>)*([\-\+]*[0-9]+).*/ ) {
1770            $list[$i] = $1;              # untainted variable, possibly undef
1771        }
1772        else {
1773            $list[$i] = undef;
1774        }
1775    }
1776    return @list;
1777}
1778
1779# =========================
1780sub _getListAsFloat {
1781    my ($theAttr) = @_;
1782
1783    my $val  = 0;
1784    my @list = _getList($theAttr);
1785    ( my $baz = "foo" ) =~ s/foo//;    # reset search vars. defensive coding
1786    for my $i ( 0 .. $#list ) {
1787        $val = $list[$i];
1788        $val = "" unless defined $val;
1789
1790        # search first float pattern, skip over HTML tags
1791        if ( $val =~ /^\s*(?:<[^>]*>)*\$?([\-\+]*[0-9\.]+).*/ ) {
1792            $list[$i] = $1;            # untainted variable, possibly undef
1793        }
1794        else {
1795            $list[$i] = undef;
1796        }
1797    }
1798    return @list;
1799}
1800
1801# =========================
1802sub _getListAsDays {
1803    my ($theAttr) = @_;
1804
1805    # contributed by by SvenDowideit - 07 Mar 2003; modified by PTh
1806    my $val = 0;
1807    my @arr = _getList($theAttr);
1808    ( my $baz = "foo" ) =~ s/foo//;    # reset search vars. defensive coding
1809    for my $i ( 0 .. $#arr ) {
1810        $val = $arr[$i] || "";
1811
1812        # search first float pattern
1813        if ( $val =~ /^\s*([\-\+]*[0-9\.]+)\s*d/i ) {
1814            $arr[$i] = $1;             # untainted variable, possibly undef
1815        }
1816        elsif ( $val =~ /^\s*([\-\+]*[0-9\.]+)\s*w/i ) {
1817            $arr[$i] = 5 * $1;         # untainted variable, possibly undef
1818        }
1819        elsif ( $val =~ /^\s*([\-\+]*[0-9\.]+)\s*h/i ) {
1820            $arr[$i] = $1 / 8;         # untainted variable, possibly undef
1821        }
1822        elsif ( $val =~ /^\s*([\-\+]*[0-9\.]+)/ ) {
1823            $arr[$i] = $1;             # untainted variable, possibly undef
1824        }
1825        else {
1826            $arr[$i] = undef;
1827        }
1828    }
1829    return @arr;
1830}
1831
1832# =========================
1833sub _getList {
1834    my ($theAttr) = @_;
1835
1836    my @list = ();
1837    return @list unless $theAttr;
1838    $theAttr =~ s/^\s*//;    # Drop leading / trailing spaces
1839    $theAttr =~ s/\s*$//;
1840    foreach ( split( /\s*,\s*/, $theAttr ) ) {
1841        if (m/\s*R([0-9]+)\:C([0-9]+)\s*\.\.+\s*R([0-9]+)\:C([0-9]+)/) {
1842            foreach ( _getTableRange($_) ) {
1843
1844                # table range - appears to contain a list
1845                if ( $_ =~ m/,/ ) {
1846                    push( @list, ( split( /\s*,\s*/, $_ ) ) );
1847                }
1848                else {
1849                    push( @list, $_ );
1850                }
1851            }
1852        }
1853        else {
1854
1855            # list item
1856            push( @list, $_ );
1857        }
1858    }
1859    return @list;
1860}
1861
1862# =========================
1863sub _getTableRange {
1864    my ($theAttr) = @_;
1865
1866    my @arr = ();
1867    if ( $rPos < 0 ) {
1868        return @arr;
1869    }
1870
1871    Foswiki::Func::writeDebug(
1872        "- SpreadSheetPlugin::Calc::_getTableRange( $theAttr )")
1873      if $debug;
1874    unless (
1875        $theAttr =~ /\s*R([0-9]+)\:C([0-9]+)\s*\.\.+\s*R([0-9]+)\:C([0-9]+)/ )
1876    {
1877        return @arr;
1878    }
1879    my $r1 = $1 - 1;
1880    my $c1 = $2 - 1;
1881    my $r2 = $3 - 1;
1882    my $c2 = $4 - 1;
1883    my $r  = 0;
1884    my $c  = 0;
1885    if ( $c1 < 0 ) { $c1 = 0; }
1886    if ( $c2 < 0 ) { $c2 = 0; }
1887    if ( $c2 < $c1 ) { $c = $c1; $c1 = $c2; $c2 = $c; }
1888    if ( $r1 > $rPos ) { $r1 = $rPos; }
1889    if ( $r1 < 0 )     { $r1 = 0; }
1890    if ( $r2 > $rPos ) { $r2 = $rPos; }
1891    if ( $r2 < 0 )     { $r2 = 0; }
1892    if ( $r2 < $r1 ) { $r = $r1; $r1 = $r2; $r2 = $r; }
1893
1894    my $pRow = ();
1895    for my $r ( $r1 .. $r2 ) {
1896        $pRow = $tableMatrix[$r];
1897        for my $c ( $c1 .. $c2 ) {
1898            if ( $c < @$pRow ) {
1899
1900                # Strip trailing spaces from each cell.
1901                # The are for left/right justification and should
1902                # not be considered part of the table data.
1903                my ($rd) = $$pRow[$c] =~ m/^\s*(.*?)\s*$/;
1904                push( @arr, $rd );
1905            }
1906        }
1907    }
1908    Foswiki::Func::writeDebug(
1909        "- SpreadSheetPlugin::Calc::_getTableRange() returns @arr")
1910      if $debug;
1911    return @arr;
1912}
1913
1914# =========================
1915sub _date2serial {
1916    my ($theText) = @_;
1917
1918    my $sec  = 0;
1919    my $min  = 0;
1920    my $hour = 0;
1921    my $day  = 1;
1922    my $mon  = 0;
1923    my $year = 0;
1924
1925    # Handle DOY (Day of Year)
1926    if ( $theText =~
1927m|([Dd][Oo][Yy])\s*([0-9]{4})[\.]([0-9]{1,3})[\.]([0-9]{1,2})[\.]([0-9]{1,2})[\.]([0-9]{1,2})|
1928      )
1929    {
1930
1931        # "DOY2003.122.23.15.59", "DOY2003.2.9.3.5.9" i.e. year.ddd.hh.mm.ss
1932        $year = $2;
1933        $day  = $3;
1934        $hour = $4;
1935        $min  = $5;
1936        $sec  = $6;    # Note: $day is in fact doy
1937    }
1938    elsif ( $theText =~
1939m|([Dd][Oo][Yy])\s*([0-9]{4})[\.]([0-9]{1,3})[\.]([0-9]{1,2})[\.]([0-9]{1,2})|
1940      )
1941    {
1942
1943        # "DOY2003.122.23.15", "DOY2003.2.9.3" i.e. year.ddd.hh.mm
1944        $year = $2;
1945        $day  = $3;
1946        $hour = $4;
1947        $min  = $5;
1948    }
1949    elsif ( $theText =~
1950        m|([Dd][Oo][Yy])\s*([0-9]{4})[\.]([0-9]{1,3})[\.]([0-9]{1,2})| )
1951    {
1952
1953        # "DOY2003.122.23", "DOY2003.2.9" i.e. year.ddd.hh
1954        $year = $2;
1955        $day  = $3;
1956        $hour = $4;
1957    }
1958    elsif ( $theText =~ m|([Dd][Oo][Yy])\s*([0-9]{4})[\.]([0-9]{1,3})| ) {
1959
1960        # "DOY2003.122", "DOY2003.2" i.e. year.ddd
1961        $year = $2;
1962        $day  = $3;
1963    }
1964    elsif ( $theText =~
1965m|([0-9]{1,2})[-\s/]+([A-Z][a-z][a-z])[-\s/]+([0-9]{4})[-\s/]+([0-9]{1,2}):([0-9]{1,2}):([0-9]{1,2})|
1966      )
1967    {
1968
1969# "31 Dec 2003 - 23:59:59", "31-Dec-2003 - 23:59:59", "31 Dec 2003 - 23:59:59 - any suffix"
1970        $day  = $1;
1971        $mon  = $mon2num{$2} || 0;
1972        $year = $3;
1973        $hour = $4;
1974        $min  = $5;
1975        $sec  = $6;
1976    }
1977    elsif ( $theText =~
1978m|([0-9]{1,2})[-\s/]+([A-Z][a-z][a-z])[-\s/]+([0-9]{4})[-\s/]+([0-9]{1,2}):([0-9]{1,2})|
1979      )
1980    {
1981
1982# "31 Dec 2003 - 23:59", "31-Dec-2003 - 23:59", "31 Dec 2003 - 23:59 - any suffix"
1983        $day  = $1;
1984        $mon  = $mon2num{$2} || 0;
1985        $year = $3;
1986        $hour = $4;
1987        $min  = $5;
1988    }
1989    elsif (
1990        $theText =~ m|([0-9]{1,2})[-\s/]+([A-Z][a-z][a-z])[-\s/]+([0-9]{2,4})| )
1991    {
1992
1993        # "31 Dec 2003", "31 Dec 03", "31-Dec-2003", "31/Dec/2003"
1994        $day  = $1;
1995        $mon  = $mon2num{$2} || 0;
1996        $year = $3;
1997        $year += 2000 if ( $year < 80 );
1998        $year += 1900 if ( $year < 100 and $year >= 80 );
1999    }
2000    elsif ( $theText =~
2001m|([0-9]{4})[-/\.]([0-9]{1,2})[-/\.]([0-9]{1,2})[-/\.\,\s]+([0-9]{1,2})[-\:/\.]([0-9]{1,2})[-\:/\.]([0-9]{1,2})|
2002      )
2003    {
2004
2005        # "2003/12/31 23:59:59", "2003-12-31-23-59-59", "2003.12.31.23.59.59"
2006        $year = $1;
2007        $mon  = $2 - 1;
2008        $day  = $3;
2009        $hour = $4;
2010        $min  = $5;
2011        $sec  = $6;
2012    }
2013    elsif ( $theText =~
2014m|([0-9]{4})[-/\.]([0-9]{1,2})[-/\.]([0-9]{1,2})[-/\.\,\s]+([0-9]{1,2})[-\:/\.]([0-9]{1,2})|
2015      )
2016    {
2017
2018        # "2003/12/31 23:59", "2003-12-31-23-59", "2003.12.31.23.59"
2019        $year = $1;
2020        $mon  = $2 - 1;
2021        $day  = $3;
2022        $hour = $4;
2023        $min  = $5;
2024    }
2025    elsif ( $theText =~ m|([0-9]{4})[-/]([0-9]{1,2})[-/]([0-9]{1,2})| ) {
2026
2027        # "2003/12/31", "2003-12-31"
2028        $year = $1;
2029        $mon  = $2 - 1;
2030        $day  = $3;
2031    }
2032    elsif ( $theText =~ m|([0-9]{1,2})[-/]([0-9]{1,2})[-/]([0-9]{2,4})| ) {
2033
2034# "12/31/2003", "12/31/03", "12-31-2003"
2035# (shh, don't tell anyone that we support ambiguous American dates, my boss asked me to)
2036        $year = $3;
2037        $mon  = $1 - 1;
2038        $day  = $2;
2039        $year += 2000 if ( $year < 80 );
2040        $year += 1900 if ( $year < 100 and $year >= 80 );
2041    }
2042    else {
2043
2044        # unsupported format
2045        return 0;
2046    }
2047    if (   ( $sec > 60 )
2048        || ( $min > 59 )
2049        || ( $hour > 23 )
2050        || ( $day < 1 )
2051        || ( $day > 365 )
2052        || ( $mon > 11 ) )
2053    {
2054
2055        # unsupported, out of range
2056        return 0;
2057    }
2058
2059    # Flag to force the TIME function to convert entered dates to GMT.
2060    # This will normally cause trouble for users on a server installed
2061    # the east of Greenwich because dates entered without a time get
2062    # converted to the day before and this is usually not what the user
2063    # intended. Especially the function WORKINGDAYS suffer from this.
2064    # and it also causes surprises with respect to daylight saving time
2065
2066    my $timeislocal =
2067      Foswiki::Func::getPreferencesFlag("SPREADSHEETPLUGIN_TIMEISLOCAL") || 0;
2068    $timeislocal = Foswiki::Func::isTrue($timeislocal);
2069
2070    $timeislocal = 0 if ( $theText =~ /GMT/i );    #If explicitly GMT, ignore
2071
2072# To handle DOY, use timegm_nocheck or timelocal_nocheck that won't check input data range.
2073# This is necessary because with DOY, $day must be able to be greater than 31 and timegm
2074# and timelocal won't allow it. Keep using timegm or timelocal for non-DOY stuff.
2075
2076    if ( ( $theText =~ /local/i ) || ($timeislocal) ) {
2077        if ( $theText =~ /DOY/i ) {
2078            return timelocal_nocheck( $sec, $min, $hour, $day, $mon, $year );
2079        }
2080        else {
2081            return timelocal( $sec, $min, $hour, $day, $mon, $year );
2082        }
2083    }
2084    else {
2085        if ( $theText =~ /DOY/i ) {
2086            return timegm_nocheck( $sec, $min, $hour, $day, $mon, $year );
2087        }
2088        else {
2089            return timegm( $sec, $min, $hour, $day, $mon, $year );
2090        }
2091    }
2092}
2093
2094# =========================
2095sub _serial2date {
2096    my ( $theTime, $theStr, $isGmt ) = @_;
2097
2098    my ( $sec, $min, $hour, $day, $mon, $year, $wday, $yday ) =
2099      ( $isGmt ? gmtime($theTime) : localtime($theTime) );
2100
2101    $theStr =~
2102s/\$isoweek\(([^\)]*)\)/_isoWeek( $1, $day, $mon, $year, $wday, $theTime )/gei;
2103    $theStr =~
2104      s/\$isoweek/_isoWeek( '$week', $day, $mon, $year, $wday, $theTime )/gei;
2105    $theStr =~ s/\$sec[o]?[n]?[d]?[s]?/sprintf("%.2u",$sec)/gei;
2106    $theStr =~ s/\$min[u]?[t]?[e]?[s]?/sprintf("%.2u",$min)/gei;
2107    $theStr =~ s/\$hou[r]?[s]?/sprintf("%.2u",$hour)/gei;
2108    $theStr =~ s/\$day/sprintf("%.2u",$day)/gei;
2109    $theStr =~ s/\$mon(?!t)/$monArr[$mon]/gi;
2110    $theStr =~ s/\$mo[n]?[t]?[h]?/sprintf("%.2u",$mon+1)/gei;
2111    $theStr =~ s/\$yearday/$yday+1/gei;
2112    $theStr =~ s/\$yea[r]?/sprintf("%.4u",$year+1900)/gei;
2113    $theStr =~ s/\$ye/sprintf("%.2u",$year%100)/gei;
2114    $theStr =~ s/\$wday/substr($wdayArr[$wday],0,3)/gei;
2115    $theStr =~ s/\$wd/$wday+1/gei;
2116    $theStr =~ s/\$weekday/$wdayArr[$wday]/gi;
2117
2118    return $theStr;
2119}
2120
2121# =========================
2122sub _isoWeek {
2123    my ( $format, $day, $mon, $year, $wday, $serial ) = @_;
2124
2125    # Contributed by PeterPayne - 22 Oct 2007
2126    # Enhanced by PeterThoeny 2010-08-27
2127    # Calculate the ISO8601 week number from the serial.
2128
2129    my $isoyear = $year + 1900;
2130    my $yearserial = _year2isoweek1serial( $year + 1900, 1 );
2131    if ( $mon >= 11 ) {    # check if date is in next year's first week
2132        my $yearnextserial = _year2isoweek1serial( $year + 1900 + 1, 1 );
2133        if ( $serial >= $yearnextserial ) {
2134            $yearserial = $yearnextserial;
2135            $isoyear += 1;
2136        }
2137    }
2138    elsif ( $serial < $yearserial ) {
2139        $yearserial = _year2isoweek1serial( $year + 1900 - 1, 1 );
2140        $isoyear -= 1;
2141    }
2142
2143    # calculate GMT of just past midnight today
2144    my $today_gmt = timegm( 0, 0, 0, $day, $mon, $year );
2145    my $isoweek = int( ( $today_gmt - $yearserial ) / ( 7 * 24 * 3600 ) ) + 1;
2146    my $isowk = sprintf( "%.2u", $isoweek );
2147    my $isoday = $wday;
2148    $isoday = 7 unless ($isoday);
2149
2150    $format =~ s/\$iso/$isoyear-W$isoweek/g;
2151    $format =~ s/\$year/$isoyear/g;
2152    $format =~ s/\$week/$isoweek/g;
2153    $format =~ s/\$wk/$isowk/g;
2154    $format =~ s/\$day/$isoday/g;
2155
2156    return $format;
2157}
2158
2159# =========================
2160sub _year2isoweek1serial {
2161    my ( $year, $isGmt ) = @_;
2162
2163    # Contributed by PeterPayne - 22 Oct 2007
2164    # Calculate the serial of the beginning of week 1 for specified year.
2165    # Year is 4 digit year (e.g. "2000")
2166
2167    $year -= 1900;
2168
2169    # get Jan 4
2170    my @param = ( 0, 0, 0, 4, 0, $year );
2171    my $jan4epoch = ( $isGmt ? timegm(@param) : timelocal(@param) );
2172
2173    # what day does Jan 4 fall on?
2174    my $jan4day =
2175      ( $isGmt ? ( gmtime($jan4epoch) )[6] : ( localtime($jan4epoch) )[6] );
2176
2177    $jan4day += 7 if ( $jan4day < 1 );
2178
2179    return ( $jan4epoch - ( 24 * 3600 * ( $jan4day - 1 ) ) );
2180}
2181
2182# =========================
2183sub _properSpace {
2184    my ($theStr) = @_;
2185
2186    # FIXME: I18N
2187
2188    unless ($dontSpaceRE) {
2189        $dontSpaceRE =
2190             &Foswiki::Func::getPreferencesValue("DONTSPACE")
2191          || &Foswiki::Func::getPreferencesValue("SPREADSHEETPLUGIN_DONTSPACE")
2192          || "CodeWarrior, MacDonald, McIntosh, RedHat, SuSE";
2193        $dontSpaceRE =~ s/[^a-zA-Z0-9\,\s]//g;
2194        $dontSpaceRE =
2195          "(" . join( "|", split( /[\,\s]+/, $dontSpaceRE ) ) . ")";
2196
2197        # Example: "(RedHat|McIntosh)"
2198    }
2199    $theStr =~ s/$dontSpaceRE/_spaceWikiWord( $1, "<DONT_SPACE>" )/geo
2200      ;    # e.g. "Mc<DONT_SPACE>Intosh"
2201    $theStr =~
2202      s/(^|[\s\(]|\]\[)([a-zA-Z0-9]+)/$1 . _spaceWikiWord( $2, " " )/ge;
2203    $theStr =~ s/<DONT_SPACE>//g;    # remove "<DONT_SPACE>" marker
2204
2205    return $theStr;
2206}
2207
2208# =========================
2209sub _spaceWikiWord {
2210    my ( $theStr, $theSpacer ) = @_;
2211
2212    $theStr =~ s/([a-z])([A-Z0-9])/$1$theSpacer$2/g;
2213    $theStr =~ s/([0-9])([a-zA-Z])/$1$theSpacer$2/g;
2214
2215    return $theStr;
2216}
2217
2218# =========================
2219sub _workingDays {
2220    my ( $start, $end ) = @_;
2221
2222# Rewritten by PeterThoeny - 2009-05-03 (previous implementation was buggy)
2223# Calculate working days between two times. Times are standard system times (secs since 1970).
2224# Working days are Monday through Friday (sorry, Israel!)
2225# A day has 60 * 60 * 24 sec
2226# Adding 3601 sec to account for daylight saving change in March in Northern Hemisphere
2227    my $days                = int( ( abs( $end - $start ) + 3601 ) / 86400 );
2228    my $weeks               = int( $days / 7 );
2229    my $fullWeekWorkingDays = 5 * $weeks;
2230    my $extra               = $days % 7;
2231    if ( $extra > 0 ) {
2232        $start = $end if ( $start > $end );
2233        my @tm   = gmtime($start);
2234        my $wday = $tm[6];           # 0 is Sun, 6 is Sat
2235        if ( $wday == 0 ) {
2236            $extra--;
2237        }
2238        else {
2239            my $sum = $wday + $extra;
2240            $extra-- if ( $sum > 6 );
2241            $extra-- if ( $sum > 7 );
2242        }
2243    }
2244    return $fullWeekWorkingDays + $extra;
2245}
2246
22471;
2248
2249__END__
2250Foswiki - The Free and Open Source Wiki, http://foswiki.org/
2251
2252Copyright (C) 2008-2015 Foswiki Contributors. Foswiki Contributors
2253are listed in the AUTHORS file in the root of this distribution.
2254NOTE: Please extend that file, not this notice.
2255
2256Additional copyrights apply to some or all of the code in this
2257file as follows:
2258
2259&copy; 2001-2015 Peter Thoeny, [[http://twiki.org/][TWiki.org]]
2260&copy; 2008-2015 TWiki:TWiki.TWikiContributor
2261&copy; 2015 Wave Systems Corp.
2262
2263This program is free software; you can redistribute it and/or
2264modify it under the terms of the GNU General Public License
2265as published by the Free Software Foundation; either version 2
2266of the License, or (at your option) any later version. For
2267more details read LICENSE in the root of this distribution.
2268
2269This program is distributed in the hope that it will be useful,
2270but WITHOUT ANY WARRANTY; without even the implied warranty of
2271MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
2272
2273As per the GPL, removal of this notice is prohibited.
2274