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© 2001-2015 Peter Thoeny, [[http://twiki.org/][TWiki.org]] 2260© 2008-2015 TWiki:TWiki.TWikiContributor 2261© 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