1# Vend::Util - Interchange utility functions 2# 3# Copyright (C) 2002-2010 Interchange Development Group 4# Copyright (C) 1996-2002 Red Hat, Inc. 5# 6# This program was originally based on Vend 0.2 and 0.3 7# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com> 8# 9# This program is free software; you can redistribute it and/or modify 10# it under the terms of the GNU General Public License as published by 11# the Free Software Foundation; either version 2 of the License, or 12# (at your option) any later version. 13# 14# This program is distributed in the hope that it will be useful, 15# but WITHOUT ANY WARRANTY; without even the implied warranty of 16# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17# GNU General Public License for more details. 18# 19# You should have received a copy of the GNU General Public 20# License along with this program; if not, write to the Free 21# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, 22# MA 02110-1301 USA. 23 24package Vend::Util; 25require Exporter; 26 27@ISA = qw(Exporter); 28 29@EXPORT = qw( 30 catfile 31 check_security 32 copyref 33 currency 34 dbref 35 dump_structure 36 errmsg 37 escape_chars 38 evalr 39 dotted_hash 40 file_modification_time 41 file_name_is_absolute 42 find_special_page 43 format_log_msg 44 generate_key 45 get_option_hash 46 hash_string 47 header_data_scrub 48 hexify 49 is_hash 50 is_no 51 is_yes 52 l 53 lockfile 54 logData 55 logDebug 56 logError 57 logGlobal 58 logOnce 59 logtime 60 random_string 61 readfile 62 readin 63 round_to_frac_digits 64 secure_vendUrl 65 send_mail 66 setup_escape_chars 67 set_lock_type 68 show_times 69 string_to_ref 70 tag_nitems 71 timecard_stamp 72 timecard_read 73 backtrace 74 uneval 75 uneval_it 76 uneval_fast 77 unhexify 78 unlockfile 79 vendUrl 80); 81 82use strict; 83no warnings qw(uninitialized numeric); 84use Config; 85use Fcntl; 86use Errno; 87use Text::ParseWords; 88require HTML::Entities; 89use Safe; 90use Vend::File; 91use subs qw(logError logGlobal); 92use vars qw($VERSION @EXPORT @EXPORT_OK); 93$VERSION = substr(q$Revision: 2.118 $, 10); 94 95my $Eval_routine; 96my $Eval_routine_file; 97my $Pretty_uneval; 98my $Fast_uneval; 99my $Fast_uneval_file; 100 101### END CONFIGURABLE MODULES 102 103## ESCAPE_CHARS 104 105$ESCAPE_CHARS::ok_in_filename = 106 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' . 107 'abcdefghijklmnopqrstuvwxyz' . 108 '0123456789' . 109 '-:_.$/' 110 ; 111 112$ESCAPE_CHARS::ok_in_url = 113 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' . 114 'abcdefghijklmnopqrstuvwxyz' . 115 '0123456789' . 116 '-_./~=' 117 ; 118 119## This is a character class for HTML::Entities 120$ESCAPE_CHARS::std = qq{^\n\t\X !\#\$%\'-;=?-Z\\\]-~}; 121 122## Some standard error templates 123 124## This is an alias for a commonly-used function 125*dbref = \&Vend::Data::database_exists_ref; 126 127my $need_escape; 128 129sub setup_escape_chars { 130 my($ok, $i, $a, $t); 131 132 ## HTML::Entities caches this, let's get it cached right away so 133 ## each child doesn't have to re-eval 134 my $junk = ">>>123<<<"; 135 HTML::Entities::encode($junk, $ESCAPE_CHARS::std); 136 137 foreach $i (0..255) { 138 $a = chr($i); 139 if (index($ESCAPE_CHARS::ok_in_filename,$a) == -1) { 140 $t = '%' . sprintf( "%02X", $i ); 141 } 142 else { 143 $t = $a; 144 } 145 $ESCAPE_CHARS::translate[$i] = $t; 146 if (index($ESCAPE_CHARS::ok_in_url,$a) == -1) { 147 $t = '%' . sprintf( "%02X", $i ); 148 } 149 else { 150 $t = $a; 151 } 152 $ESCAPE_CHARS::translate_url[$i] = $t; 153 } 154 155 my $string = "[^$ESCAPE_CHARS::ok_in_url]"; 156 $need_escape = qr{$string}; 157} 158 159# Replace any characters that might not be safe in a filename (especially 160# shell metacharacters) with the %HH notation. 161 162sub escape_chars { 163 my($in) = @_; 164 my($c, $r); 165 166 $r = ''; 167 foreach $c (split(m{}, $in)) { 168 $r .= $ESCAPE_CHARS::translate[ord($c)]; 169 } 170 171 # safe now 172 return $r; 173} 174 175# Replace any characters that might not be safe in an URL 176# with the %HH notation. 177 178sub escape_chars_url { 179 my($in) = @_; 180 return $in unless $in =~ $need_escape; 181 my($c, $r); 182 183 $r = ''; 184 foreach $c (split(m{}, $in)) { 185 $r .= $ESCAPE_CHARS::translate_url[ord($c)]; 186 } 187 188 # safe now 189 return $r; 190} 191 192# Returns its arguments as a string of tab-separated fields. Tabs in the 193# argument values are converted to spaces. 194 195sub tabbed { 196 return join("\t", map { $_ = '' unless defined $_; 197 s/\t/ /g; 198 $_; 199 } @_); 200} 201 202# Finds common-log-style offset 203# Unproven, authoratative code welcome 204my $Offset; 205FINDOFFSET: { 206 my $now = time; 207 my ($gm,$gh,$gd,$gy) = (gmtime($now))[1,2,5,7]; 208 my ($lm,$lh,$ld,$ly) = (localtime($now))[1,2,5,7]; 209 if($gy != $ly) { 210 $gy < $ly ? $lh += 24 : $gh += 24; 211 } 212 elsif($gd != $ld) { 213 $gd < $ld ? $lh += 24 : $gh += 24; 214 } 215 $gh *= 100; 216 $lh *= 100; 217 $gh += $gm; 218 $lh += $lm; 219 $Offset = sprintf("%05d", $lh - $gh); 220 $Offset =~ s/0(\d\d\d\d)/+$1/; 221} 222 223# Returns time in HTTP common log format 224sub logtime { 225 return POSIX::strftime("[%d/%B/%Y:%H:%M:%S $Offset]", localtime()); 226} 227 228sub format_log_msg { 229 my($msg) = @_; 230 my(@params); 231 232 # IP, Session, REMOTE_USER (if any) and time 233 push @params, ($CGI::remote_host || $CGI::remote_addr || '-'); 234 push @params, ($Vend::SessionName || '-'); 235 push @params, ($CGI::user || '-'); 236 push @params, logtime(); 237 238 # Catalog name 239 my $string = ! defined $Vend::Cfg ? '-' : ($Vend::Cat || '-'); 240 push @params, $string; 241 242 # Path info and script 243 $string = $CGI::script_name || '-'; 244 $string .= $CGI::path_info || ''; 245 push @params, $string; 246 247 # Message, quote newlined area 248 $msg =~ s/\n/\n> /g; 249 push @params, $msg; 250 return join " ", @params; 251} 252 253sub round_to_frac_digits { 254 my ($num, $digits) = @_; 255 if (defined $digits) { 256 # use what we were given 257 } 258 elsif ( $Vend::Cfg->{Locale} ) { 259 $digits = $Vend::Cfg->{Locale}{frac_digits}; 260 $digits = 2 if ! defined $digits; 261 } 262 else { 263 $digits = 2; 264 } 265 my @frac; 266 $num =~ /^(-?)(\d*)(?:\.(\d+))?$/ 267 or return $num; 268 my $sign = $1 || ''; 269 my $int = $2; 270 @frac = split(m{}, ($3 || 0)); 271 local($^W) = 0; 272 my $frac = join "", @frac[0 .. $digits - 1]; 273 if($frac[$digits] > 4) { 274 $frac++; 275 } 276 if(length($frac) > $digits) { 277 $int++; 278 $frac = 0 x $digits; 279 } 280 $frac .= '0' while length($frac) < $digits; 281 return "$sign$int.$frac"; 282} 283 284use vars qw/%MIME_type/; 285%MIME_type = (qw| 286 jpg image/jpeg 287 gif image/gif 288 jpeg image/jpeg 289 png image/png 290 xpm image/xpm 291 htm text/html 292 html text/html 293 txt text/plain 294 asc text/plain 295 csv text/plain 296 xls application/vnd.ms-excel 297 default application/octet-stream 298 | 299 ); 300# Return a mime type based on either catalog configuration or some defaults 301sub mime_type { 302 my ($val) = @_; 303 $val =~ s:.*\.::s; 304 305 ! length($val) and return $Vend::Cfg->{MimeType}{default} || 'text/plain'; 306 307 $val = lc $val; 308 309 return $Vend::Cfg->{MimeType}{$val} 310 || $MIME_type{$val} 311 || $Vend::Cfg->{MimeType}{default} 312 || $MIME_type{default}; 313} 314 315# Return AMOUNT formatted as currency. 316sub commify { 317 local($_) = shift; 318 my $sep = shift || ','; 319 1 while s/^(-?\d+)(\d{3})/$1$sep$2/; 320 return $_; 321} 322 323my %safe_locale = ( 324 C => 1, 325 en_US => 1, 326 en_UK => 1, 327 en_GB => 1, 328 ); 329 330sub safe_sprintf { 331 # need to supply $fmt as a scalar to prevent prototype problems 332 my $fmt = shift; 333 334 # query the locale 335 my $save = POSIX::setlocale (&POSIX::LC_NUMERIC); 336 337 # This should be faster than doing set every time....but when 338 # is locale C anymore? Should we set this by default? 339 return sprintf($fmt, @_) if $safe_locale{$save}; 340 341 # Need to set. 342 POSIX::setlocale (&POSIX::LC_NUMERIC, 'C'); 343 my $val = sprintf($fmt, @_); 344 POSIX::setlocale (&POSIX::LC_NUMERIC, $save); 345 return $val; 346} 347 348sub picture_format { 349 my($amount, $pic, $sep, $point) = @_; 350 $pic = reverse $pic; 351 $point = '.' unless defined $point; 352 $sep = ',' unless defined $sep; 353 $pic =~ /(#+)\Q$point/; 354 my $len = length($1); 355 $amount = sprintf('%.' . $len . 'f', $amount); 356 $amount =~ tr/0-9//cd; 357 my (@dig) = split m{}, $amount; 358 $pic =~ s/#/pop(@dig)/eg; 359 $pic =~ s/\Q$sep\E+(?!\d)//; 360 $pic =~ s/\d/*/g if @dig; 361 $amount = reverse $pic; 362 return $amount; 363} 364 365sub setlocale { 366 my ($locale, $currency, $opt) = @_; 367#::logDebug("original locale " . (defined $locale ? $locale : 'undef') ); 368#::logDebug("default locale " . (defined $::Scratch->{mv_locale} ? $::Scratch->{mv_locale} : 'undef') ); 369 370 if($opt->{get}) { 371 my $loc = $Vend::Cfg->{Locale_repository} or return; 372 my $currloc = $Vend::Cfg->{Locale} or return; 373 for(keys %$loc) { 374 return $_ if $loc->{$_} eq $currloc; 375 } 376 return; 377 } 378 379 $locale = $::Scratch->{mv_locale} unless defined $locale; 380#::logDebug("locale is now " . (defined $locale ? $locale : 'undef') ); 381 382 if ( $locale and not defined $Vend::Cfg->{Locale_repository}{$locale}) { 383 ::logError( "attempt to set non-existant locale '%s'" , $locale ); 384 return ''; 385 } 386 387 if ( $currency and not defined $Vend::Cfg->{Locale_repository}{$currency}) { 388 ::logError("attempt to set non-existant currency '%s'" , $currency); 389 return ''; 390 } 391 392 if($locale) { 393 my $loc = $Vend::Cfg->{Locale} = $Vend::Cfg->{Locale_repository}{$locale}; 394 395 for(@Vend::Config::Locale_directives_scalar) { 396 $Vend::Cfg->{$_} = $loc->{$_} 397 if defined $loc->{$_}; 398 } 399 400 for(@Vend::Config::Locale_directives_ary) { 401 @{$Vend::Cfg->{$_}} = split (/\s+/, $loc->{$_}) 402 if $loc->{$_}; 403 } 404 405 for(@Vend::Config::Locale_directives_code) { 406 next unless $loc->{$_->[0]}; 407 my ($routine, $args) = @{$_}[1,2]; 408 if($args) { 409 $routine->(@$args); 410 } 411 else { 412 $routine->(); 413 } 414 } 415 416 no strict 'refs'; 417 for(qw/LC_COLLATE LC_CTYPE LC_TIME/) { 418 next unless $loc->{$_}; 419 POSIX::setlocale(&{"POSIX::$_"}, $loc->{$_}); 420 } 421 } 422 423 if ($currency) { 424 my $curr = $Vend::Cfg->{Currency_repository}{$currency}; 425 426 for(@Vend::Config::Locale_directives_currency) { 427 $Vend::Cfg->{$_} = $curr->{$_} 428 if defined $curr->{$_}; 429 } 430 431 for(@Vend::Config::Locale_keys_currency) { 432 $Vend::Cfg->{Locale}{$_} = $curr->{$_} 433 if defined $curr->{$_}; 434 } 435 } 436 437 if(my $ref = $Vend::Cfg->{CodeDef}{LocaleChange}) { 438 $ref = $ref->{Routine}; 439 if($ref->{all}) { 440 $ref->{all}->($locale, $opt); 441 } 442 if($ref->{lc $locale}) { 443 $ref->{lc $locale}->($locale, $opt); 444 } 445 } 446 447 if($opt->{persist}) { 448 $::Scratch->{mv_locale} = $locale if $locale; 449 delete $::Scratch->{mv_currency_tmp}; 450 delete $::Scratch->{mv_currency}; 451 $::Scratch->{mv_currency} = $currency if $currency; 452 } 453 elsif($currency) { 454 Vend::Interpolate::set_tmp('mv_currency_tmp') 455 unless defined $::Scratch->{mv_currency_tmp}; 456 $::Scratch->{mv_currency_tmp} = $currency; 457 } 458 else { 459 delete $::Scratch->{mv_currency_tmp}; 460 delete $::Scratch->{mv_currency}; 461 } 462 463 return ''; 464} 465 466 467sub currency { 468 my($amount, $noformat, $convert, $opt) = @_; 469 $opt = {} unless $opt; 470 $convert ||= $opt->{convert}; 471 472 my $pd = $Vend::Cfg->{PriceDivide}; 473 if($opt->{locale}) { 474 $convert = 1 unless length($convert); 475 $pd = $Vend::Cfg->{Locale_repository}{$opt->{locale}}{PriceDivide}; 476 } 477 478 if($pd and $convert) { 479 $amount = $amount / $pd; 480 } 481 482 my $hash; 483 if( 484 $noformat =~ /\w+=\w\w/ 485 and 486 ref($hash = get_option_hash($noformat)) eq 'HASH' 487 ) 488 { 489 $opt->{display} ||= $hash->{display}; 490 $noformat = $opt->{noformat} = $hash->{noformat}; 491 } 492 493 return $amount if $noformat; 494 my $sep; 495 my $dec; 496 my $fmt; 497 my $precede = ''; 498 my $succede = ''; 499 500 my $loc = $opt->{locale} 501 || $::Scratch->{mv_currency_tmp} 502 || $::Scratch->{mv_currency} 503 || $Vend::Cfg->{Locale}; 504 505 if(ref($loc)) { 506 ## Do nothing, is a hash reference 507 } 508 elsif($loc) { 509 $loc = $Vend::Cfg->{Locale_repository}{$loc}; 510 } 511 512 if (! $loc) { 513 $fmt = "%.2f"; 514 } 515 else { 516 $sep = $loc->{mon_thousands_sep} || $loc->{thousands_sep} || ','; 517 $dec = $loc->{mon_decimal_point} || $loc->{decimal_point} || '.'; 518 return picture_format($amount, $loc->{price_picture}, $sep, $dec) 519 if defined $loc->{price_picture}; 520 if (defined $loc->{frac_digits}) { 521 $fmt = "%." . $loc->{frac_digits} . "f"; 522 } else { 523 $fmt = "%.2f"; 524 } 525 my $cs; 526 my $display = lc($opt->{display}) || 'symbol'; 527 my $sep_by_space = $loc->{p_sep_by_space}; 528 my $cs_precedes = $loc->{p_cs_precedes}; 529 530 if( $loc->{int_currency_symbol} && $display eq 'text' ) { 531 $cs = $loc->{int_currency_symbol}; 532 $cs_precedes = 1; 533 534 if (length($cs) > 3 || $cs =~ /\W$/) { 535 $sep_by_space = 0; 536 } 537 else { 538 $sep_by_space = 1; 539 } 540 } 541 elsif ( $display eq 'none' ) { 542 $cs = ''; 543 } 544 elsif ( $display eq 'symbol' ) { 545 $cs = $loc->{currency_symbol} || ''; 546 } 547 if($cs) { 548 if ($cs_precedes) { 549 $precede = $cs; 550 $precede = "$precede " if $sep_by_space; 551 } 552 else { 553 $succede = $cs; 554 $succede = " $succede" if $sep_by_space; 555 } 556 } 557 } 558 559 $amount = safe_sprintf($fmt, $amount); 560 $amount =~ s/\./$dec/ if defined $dec; 561 $amount = commify($amount, $sep || undef) 562 if $Vend::Cfg->{PriceCommas}; 563 return "$precede$amount$succede"; 564} 565 566## random_string 567 568# leaving out 0, O and 1, l 569my $random_chars = "ABCDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz23456789"; 570 571# Return a string of random characters. 572 573sub random_string { 574 my ($len) = @_; 575 $len = 8 unless $len; 576 my ($r, $i); 577 578 $r = ''; 579 for ($i = 0; $i < $len; ++$i) { 580 $r .= substr($random_chars, int(rand(length($random_chars))), 1); 581 } 582 $r; 583} 584 585# To generate a unique key for caching 586# Not very good without MD5 587# 588my $Md; 589my $Keysub; 590 591eval {require Digest::MD5 }; 592 593if(! $@) { 594 $Md = new Digest::MD5; 595 $Keysub = sub { 596 @_ = time() unless @_; 597 $Md->reset(); 598 $Md->add(@_); 599 $Md->hexdigest(); 600 }; 601} 602else { 603 $Keysub = sub { 604 my $out = ''; 605 @_ = time() unless @_; 606 for(@_) { 607 $out .= unpack "%32c*", $_; 608 $out .= unpack "%32c*", substr($_,5); 609 $out .= unpack "%32c*", substr($_,-1,5); 610 } 611 $out; 612 }; 613} 614 615sub generate_key { &$Keysub(@_) } 616 617sub hexify { 618 my $string = shift; 619 $string =~ s/(\W)/sprintf '%%%02x', ord($1)/ge; 620 return $string; 621} 622 623sub unhexify { 624 my $s = shift; 625 $s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/ge; 626 return $s; 627} 628 629*unescape_chars = \&unhexify; 630 631sub unescape_full { 632 my $url = shift; 633 $url =~ tr/+/ /; 634 $url =~ s/<!--.*?-->//sg; 635 return unhexify($url); 636} 637 638## UNEVAL 639 640# Returns a string representation of an anonymous array, hash, or scaler 641# that can be eval'ed to produce the same value. 642# uneval([1, 2, 3, [4, 5]]) -> '[1,2,3,[4,5,],]' 643# Uses either Storable::freeze or Data::Dumper::DumperX or uneval 644# in 645 646sub uneval_it { 647 my($o) = @_; # recursive 648 my($r, $s, $i, $key, $value); 649 650 local($^W) = 0; 651 $r = ref $o; 652 if (!$r) { 653 $o =~ s/([\\"\$@])/\\$1/g; 654 $s = '"' . $o . '"'; 655 } elsif ($r eq 'ARRAY') { 656 $s = "["; 657 foreach $i (0 .. $#$o) { 658 $s .= uneval_it($o->[$i]) . ","; 659 } 660 $s .= "]"; 661 } elsif ($r eq 'HASH') { 662 $s = "{"; 663 while (($key, $value) = each %$o) { 664 $s .= "'$key' => " . uneval_it($value) . ","; 665 } 666 $s .= "}"; 667 } else { 668 $s = "'something else'"; 669 } 670 671 $s; 672} 673 674use subs 'uneval_fast'; 675 676sub uneval_it_file { 677 my ($ref, $fn) = @_; 678 open(UNEV, ">$fn") 679 or die "Can't create $fn: $!\n"; 680 print UNEV uneval_fast($ref); 681 close UNEV; 682} 683 684sub eval_it_file { 685 my ($fn) = @_; 686 local($/) = undef; 687 open(UNEV, "< $fn") or return undef; 688 my $ref = evalr(<UNEV>); 689 close UNEV; 690 return $ref; 691} 692 693# See if we have Storable and the user has OKed its use 694# If so, session storage/write will be about 5x faster 695eval { 696 die unless $ENV{MINIVEND_STORABLE}; 697 require Storable; 698 import Storable 'freeze'; 699 $Fast_uneval = \&Storable::freeze; 700 $Fast_uneval_file = \&Storable::store; 701 $Eval_routine = \&Storable::thaw; 702 $Eval_routine_file = \&Storable::retrieve; 703}; 704 705# See if Data::Dumper is installed with XSUB 706# If it is, session writes will be about 25-30% faster 707eval { 708 die if $ENV{MINIVEND_NO_DUMPER}; 709 require Data::Dumper; 710 import Data::Dumper 'DumperX'; 711 $Data::Dumper::Indent = 1; 712 $Data::Dumper::Terse = 1; 713 $Data::Dumper::Deepcopy = 1; 714 if(defined $Fast_uneval) { 715 $Pretty_uneval = \&Data::Dumper::Dumper; 716 } 717 else { 718 $Pretty_uneval = \&Data::Dumper::DumperX; 719 $Fast_uneval = \&Data::Dumper::DumperX 720 } 721}; 722 723*uneval_fast = defined $Fast_uneval ? $Fast_uneval : \&uneval_it; 724*evalr = defined $Eval_routine ? $Eval_routine : sub { eval shift }; 725*eval_file = defined $Eval_routine_file ? $Eval_routine_file : \&eval_it_file; 726*uneval_file = defined $Fast_uneval_file ? $Fast_uneval_file : \&uneval_it_file; 727*uneval = defined $Pretty_uneval ? $Pretty_uneval : \&uneval_it; 728 729 730 731# Log data fields to a data file. 732 733sub logData { 734 my($file,@msg) = @_; 735 my $prefix = ''; 736 737 $file = ">>$file" unless $file =~ /^[|>]/; 738 739 my $msg = tabbed @msg; 740 741 eval { 742 unless($file =~ s/^[|]\s*//) { 743 # We have checked for beginning > or | previously 744 open(MVLOGDATA, $file) or die "open\n"; 745 lockfile(\*MVLOGDATA, 1, 1) or die "lock\n"; 746 seek(MVLOGDATA, 0, 2) or die "seek\n"; 747 print(MVLOGDATA "$msg\n") or die "write to\n"; 748 unlockfile(\*MVLOGDATA) or die "unlock\n"; 749 } 750 else { 751 my (@args) = grep /\S/, Text::ParseWords::shellwords($file); 752 open(MVLOGDATA, "|-") || exec @args; 753 print(MVLOGDATA "$msg\n") or die "pipe to\n"; 754 } 755 close(MVLOGDATA) or die "close\n"; 756 }; 757 if ($@) { 758 759 if($::Limit->{logdata_error_length} > 0) { 760 $msg = substr($msg, 0, $::Limit->{logdata_error_length}); 761 } 762 763 logError ("Could not %s log file '%s': %s\nto log this data:\n%s", 764 $@, 765 $file, 766 $!, 767 $msg, 768 ); 769 return 0; 770 } 771 1; 772} 773 774 775 776sub quoted_comma_string { 777 my ($text) = @_; 778 my (@fields); 779 push(@fields, $+) while $text =~ m{ 780 "([^\"\\]*(?:\\.[^\"\\]*)*)"[\s,]? ## std quoted string, w/possible space-comma 781 | ([^\s,]+)[\s,]? ## anything else, w/possible space-comma 782 | [,\s]+ ## any comma or whitespace 783 }gx; 784 @fields; 785} 786 787# Modified from old, old module called Ref.pm 788sub copyref { 789 my($x,$r) = @_; 790 791 my($z, $y); 792 793 my $rt = ref $x; 794 795 if ($rt =~ /SCALAR/) { 796 # Would \$$x work? 797 $z = $$x; 798 return \$z; 799 } elsif ($rt =~ /HASH/) { 800 $r = {} unless defined $r; 801 for $y (sort keys %$x) { 802 $r->{$y} = ©ref($x->{$y}, $r->{$y}); 803 } 804 return $r; 805 } elsif ($rt =~ /ARRAY/) { 806 $r = [] unless defined $r; 807 for ($y = 0; $y <= $#{$x}; $y++) { 808 $r->[$y] = ©ref($x->[$y]); 809 } 810 return $r; 811 } elsif ($rt =~ /REF/) { 812 $z = ©ref($x); 813 return \$z; 814 } elsif (! $rt) { 815 return $x; 816 } else { 817 die "do not know how to copy $x"; 818 } 819} 820 821sub check_gate { 822 my($f, $gatedir) = @_; 823 824 my $gate; 825 if ($gate = readfile("$gatedir/.access_gate") ) { 826 $f =~ s:.*/::; 827 $gate = Vend::Interpolate::interpolate_html($gate); 828 if($gate =~ m!^$f(?:\.html?)?[ \t]*:!m ) { 829 $gate =~ s!.*(\n|^)$f(?:\.html?)?[ \t]*:!!s; 830 $gate =~ s/\n[\S].*//s; 831 $gate =~ s/^\s+//; 832 } 833 elsif($gate =~ m{^\*(?:\.html?)?[: \t]+(.*)}m) { 834 $gate = $1; 835 } 836 else { 837 undef $gate; 838 } 839 } 840 return $gate; 841} 842 843sub string_to_ref { 844 my ($string) = @_; 845 if($MVSAFE::Safe) { 846 return eval $string; 847 } 848 my $safe = $Vend::Interpolate::safe_safe || new Safe; 849 return $safe->reval($string); 850} 851 852sub is_hash { 853 return ref($_[0]) eq 'HASH'; 854} 855 856sub dotted_hash { 857 my($hash, $key, $value, $delete_empty) = @_; 858 $hash = get_option_hash($hash) unless is_hash($hash); 859 unless (is_hash($hash)) { 860 return undef unless defined $value; 861 $hash = {}; 862 } 863 my @keys = split /[\.:]+/, $key; 864 my $final; 865 my $ref; 866 867 if(! defined $value) { 868 # Retrieving 869 $ref = $hash->{shift @keys}; 870 for(@keys) { 871 return undef unless is_hash($ref); 872 $ref = $ref->{$_}; 873 } 874 return $ref; 875 } 876 877 # Storing 878 $final = pop @keys; 879 $ref = $hash; 880 881 for(@keys) { 882 $ref->{$_} = {} unless is_hash($ref->{$_}); 883 $ref = $ref->{$_}; 884 } 885 886 if($delete_empty and ! length($value)) { 887 delete $ref->{$final}; 888 } 889 else { 890 $ref->{$final} = $value; 891 } 892 893 $hash = uneval_it($hash); 894 return $hash; 895} 896 897sub get_option_hash { 898 my $string = shift; 899 my $merge = shift; 900 if (ref $string eq 'HASH') { 901 my $ref = { %$string }; 902 return $ref unless ref $merge; 903 for(keys %{$merge}) { 904 $ref->{$_} = $merge->{$_} 905 unless defined $ref->{$_}; 906 } 907 return $ref; 908 } 909 return {} unless $string and $string =~ /\S/; 910 $string =~ s/^\s+//; 911 $string =~ s/\s+$//; 912 if($string =~ /^{/ and $string =~ /}/) { 913 return string_to_ref($string); 914 } 915 916 my @opts; 917 unless ($string =~ /,/) { 918 @opts = grep $_ ne "=", Text::ParseWords::shellwords($string); 919 for(@opts) { 920 s/^(\w[-\w]*\w)=(["'])(.*)\2$/$1$3/; 921 } 922 } 923 else { 924 @opts = split /\s*,\s*/, $string; 925 } 926 927 my %hash; 928 for(@opts) { 929 my ($k, $v) = split /[\s=]+/, $_, 2; 930 $k =~ s/-/_/g; 931 $hash{$k} = $v; 932 } 933 if($merge) { 934 return \%hash unless ref $merge; 935 for(keys %$merge) { 936 $hash{$_} = $merge->{$_} 937 unless defined $hash{$_}; 938 } 939 } 940 return \%hash; 941} 942 943sub word2ary { 944 my $val = shift; 945 return $val if ref($val) eq 'ARRAY'; 946 my @ary = grep /\w/, split /[\s,\0]+/, $val; 947 return \@ary; 948} 949 950sub ary2word { 951 my $val = shift; 952 return $val if ref($val) ne 'ARRAY'; 953 @$val = grep /\w/, @$val; 954 return join " ", @$val; 955} 956 957## Takes an IC scalar form value (parm=val\nparm2=val) and translates it 958## to a reference 959 960sub scalar_to_hash { 961 my $val = shift; 962 963 $val =~ s/^\s+//mg; 964 $val =~ s/\s+$//mg; 965 my @args; 966 967 @args = split /\n+/, $val; 968 969 my $ref = {}; 970 971 for(@args) { 972 m!([^=]+)=(.*)! 973 and $ref->{$1} = $2; 974 } 975 return $ref; 976} 977 978## Takes a form reference (i.e. from \%CGI::values) and makes into a 979## scalar value value (i.e. parm=val\nparm2=val). Also translates it 980## via HTML entities -- it is designed to make it into a hidden 981## form value 982 983sub hash_to_scalar { 984 my $ref = shift 985 or return ''; 986 987 unless (ref($ref) eq 'HASH') { 988 die __PACKAGE__ . " hash_to_scalar routine got bad reference.\n"; 989 } 990 991 my @parms; 992 while( my($k, $v) = each %$ref ) { 993 $v =~ s/\r?\n/\r/g; 994 push @parms, HTML::Entities::encode("$k=$v"); 995 } 996 return join "\n", @parms; 997} 998 999## This simply returns a hash of words, which may be quoted shellwords 1000## Replaces most of parse_hash in Vend::Config 1001sub hash_string { 1002 my($settings, $ref) = @_; 1003 1004 return $ref if ! $settings or $settings !~ /\S/; 1005 1006 $ref ||= {}; 1007 1008 $settings =~ s/^\s+//; 1009 $settings =~ s/\s+$//; 1010 my(@setting) = Text::ParseWords::shellwords($settings); 1011 1012 my $i; 1013 for ($i = 0; $i < @setting; $i += 2) { 1014 $ref->{$setting[$i]} = $setting[$i + 1]; 1015 } 1016 return $ref; 1017} 1018 1019## READIN 1020 1021my $Lang; 1022 1023sub find_locale_bit { 1024 my $text = shift; 1025 unless (defined $Lang) { 1026 $Lang = $::Scratch->{mv_locale} || $Vend::Cfg->{DefaultLocale}; 1027 } 1028 $text =~ m{\[$Lang\](.*)\[/$Lang\]}s 1029 and return $1; 1030 $text =~ s{\[(\w+)\].*\[/\1\].*}{}s; 1031 return $text; 1032} 1033 1034sub parse_locale { 1035 my ($input) = @_; 1036 1037 return if $::Pragma->{no_locale_parse}; 1038 1039 # avoid copying big strings 1040 my $r = ref($input) ? $input : \$input; 1041 1042 if($Vend::Cfg->{Locale}) { 1043 my $key; 1044 $$r =~ s~\[L(\s+([^\]]+))?\]([\000-\377]*?)\[/L\]~ 1045 $key = $2 || $3; 1046 defined $Vend::Cfg->{Locale}{$key} 1047 ? ($Vend::Cfg->{Locale}{$key}) : $3 ~eg; 1048 $$r =~ s~\[LC\]([\000-\377]*?)\[/LC\]~ 1049 find_locale_bit($1) ~eg; 1050 undef $Lang; 1051 } 1052 else { 1053 $$r =~ s~\[L(?:\s+[^\]]+)?\]([\000-\377]*?)\[/L\]~$1~g; 1054 } 1055 1056 # return scalar string if one get passed initially 1057 return ref($input) ? $input : $$r; 1058} 1059 1060sub teleport_name { 1061 my ($file, $teleport, $table) = @_; 1062 my $db; 1063 return $file 1064 unless $teleport 1065 and $db = Vend::Data::database_exists_ref($table); 1066 1067 my @f = qw/code base_code expiration_date show_date page_text/; 1068 my ($c, $bc, $ed, $sd, $pt) = @{$Vend::Cfg->{PageTableMap}}{@f}; 1069 my $q = qq{ 1070 SELECT $c from $table 1071 WHERE $bc = '$file' 1072 AND $ed < $teleport 1073 AND $sd >= $teleport 1074 ORDER BY $sd DESC 1075 }; 1076 my $ary = $db->query($q); 1077 if($ary and $ary->[0]) { 1078 $file = $ary->[0][0]; 1079 } 1080 return $file; 1081} 1082 1083# Reads in a page from the page directory with the name FILE and ".html" 1084# appended. If the HTMLsuffix configuration has changed (because of setting in 1085# catalog.cfg or Locale definitions) it will substitute that. Returns the 1086# entire contents of the page, or undef if the file could not be read. 1087# Substitutes Locale bits as necessary. 1088 1089sub readin { 1090 my($file, $only, $locale) = @_; 1091 1092 ## We don't want to try if we are forcing a flypage 1093 return undef if $Vend::ForceFlypage; 1094 1095 my($fn, $contents, $gate, $pathdir, $dir, $level); 1096 local($/); 1097 1098 if($file =~ m{[\[<]}) { 1099 ::logGlobal("Possible code/SQL injection attempt with file name '%s'", $file); 1100 $file = escape_chars($file); 1101 ::logGlobal("Suspect file changed to '%s'", $file); 1102 } 1103 1104 $Global::Variable->{MV_PREV_PAGE} = $Global::Variable->{MV_PAGE} 1105 if defined $Global::Variable->{MV_PAGE}; 1106 $Global::Variable->{MV_PAGE} = $file; 1107 1108 $file =~ s#^\s+##; 1109 $file =~ s#\s+$##; 1110 $file =~ s#\.html?$##; 1111 if($file =~ m{\.\.} and $file =~ /\.\..*\.\./) { 1112 logError( "Too many .. in file path '%s' for security.", $file ); 1113 $file = find_special_page('violation'); 1114 } 1115 1116 if(index($file, '/') < 0) { 1117 $pathdir = ''; 1118 } 1119 else { 1120 $file =~ s#//+#/#g; 1121 $file =~ s#/+$##g; 1122 ($pathdir = $file) =~ s#/[^/]*$##; 1123 $pathdir =~ s:^/+::; 1124 } 1125 1126 my $try; 1127 my $suffix = $Vend::Cfg->{HTMLsuffix}; 1128 my $db_tried; 1129 $locale = 1 unless defined $locale; 1130 my $record; 1131 FINDPAGE: { 1132 ## If PageTables is set, we try to find the page in the table first 1133 ## but only once, without the suffix 1134 if(! $db_tried++ and $Vend::Cfg->{PageTables}) { 1135 my $teleport = $Vend::Session->{teleport}; 1136 my $field = $Vend::Cfg->{PageTableMap}{page_text}; 1137 foreach my $t (@{$Vend::Cfg->{PageTables}}) { 1138 my $db = Vend::Data::database_exists_ref($t); 1139 next unless $db; 1140 1141 if($teleport) { 1142 $file = teleport_name($file, $teleport, $t); 1143 } 1144 $record = $db->row_hash($file) 1145 or next; 1146 $contents = $record->{$field}; 1147 last FINDPAGE if length $contents; 1148 undef $contents; 1149 } 1150 } 1151 1152 my @dirs = ($Vend::Cfg->{PreviewDir}, 1153 $Vend::Cfg->{PageDir}, 1154 @{$Vend::Cfg->{TemplateDir} || []}, 1155 @{$Global::TemplateDir || []}); 1156 1157 foreach $try (@dirs) { 1158 next unless $try; 1159 $dir = $try . "/" . $pathdir; 1160 if (-f "$dir/.access") { 1161 if (-s _) { 1162 $level = 3; 1163 } 1164 else { 1165 $level = ''; 1166 } 1167 if(-f "$dir/.autoload") { 1168 my $status = ::interpolate_html( readfile("$dir/.autoload") ); 1169 $status =~ s/\s+//g; 1170 undef $level if $status; 1171 } 1172 $gate = check_gate($file,$dir) 1173 if defined $level; 1174 } 1175 1176 if( defined $level and ! check_security($file, $level, $gate) ){ 1177 my $realm = $::Variable->{COMPANY} || $Vend::Cat; 1178 if(-f "$try/violation$suffix") { 1179 $fn = "$try/violation$suffix"; 1180 } 1181 else { 1182 $file = find_special_page('violation'); 1183 $fn = $try . "/" . escape_chars($file) . $suffix; 1184 } 1185 } 1186 else { 1187 $fn = $try . "/" . escape_chars($file) . $suffix; 1188 } 1189 1190 if (open(MVIN, "< $fn")) { 1191 binmode(MVIN) if $Global::Windows; 1192 binmode(MVIN, ":utf8") if $::Variable->{MV_UTF8}; 1193 undef $/; 1194 $contents = <MVIN>; 1195 close(MVIN); 1196 last; 1197 } 1198 last if defined $only; 1199 } 1200 if(! defined $contents) { 1201 last FINDPAGE if $suffix eq '.html'; 1202 $suffix = '.html'; 1203 redo FINDPAGE; 1204 } 1205 } 1206 1207 if(! defined $contents) { 1208 $contents = readfile_db("pages/$file"); 1209 } 1210 1211 return unless defined $contents; 1212 1213 parse_locale(\$contents); 1214 1215 return $contents unless wantarray; 1216 return ($contents, $record); 1217} 1218 1219sub is_yes { 1220 return( defined($_[0]) && ($_[0] =~ /^[yYtT1]/)); 1221} 1222 1223sub is_no { 1224 return( !defined($_[0]) || ($_[0] =~ /^[nNfF0]/)); 1225} 1226 1227# Returns a URL which will run the ordering system again. Each URL 1228# contains the session ID as well as a unique integer to avoid caching 1229# of pages by the browser. 1230 1231my @scratches = qw/ 1232 add_dot_html 1233 add_source 1234 link_relative 1235 match_security 1236 no_count 1237 no_session 1238 /; 1239 1240sub vendUrl { 1241 my($path, $arguments, $r, $opt) = @_; 1242 1243 $opt ||= {}; 1244 1245 if($opt->{auto_format}) { 1246 return $path if $path =~ m{^/}; 1247 $path =~ s:#([^/.]+)$:: 1248 and $opt->{anchor} = $1; 1249 $path =~ s/\.html?$//i 1250 and $opt->{add_dot_html} = 1; 1251 } 1252 1253 $r = $Vend::Cfg->{VendURL} 1254 unless defined $r; 1255 1256 my $secure; 1257 my @parms; 1258 1259 my %skip = qw/form 1 href 1 reparse 1/; 1260 1261 for(@scratches) { 1262 next if defined $opt->{$_}; 1263 next unless defined $::Scratch->{"mv_$_"}; 1264 $skip{$_} = 1; 1265 $opt->{$_} = $::Scratch->{"mv_$_"}; 1266 } 1267 1268 my $extra; 1269 if($opt->{form}) { 1270 $path = $Vend::Cfg->{ProcessPage} unless $path; 1271 if($opt->{form} eq 'auto') { 1272 my $form = ''; 1273 while( my ($k, $v) = each %$opt) { 1274 next if $skip{$k}; 1275 $k =~ s/^__//; 1276 $form .= "$k=$v\n"; 1277 } 1278 $opt->{form} = $form; 1279 } 1280 push @parms, Vend::Interpolate::escape_form($opt->{form}); 1281 } 1282 1283 my($id, $ct); 1284 $id = $Vend::SessionID 1285 unless $opt->{no_session_id} 1286 or ($Vend::Cookie and $::Scratch->{mv_no_session_id}); 1287 $ct = ++$Vend::Session->{pageCount} 1288 unless $opt->{no_count}; 1289 1290 if($opt->{no_session}) { 1291 undef $id; 1292 undef $ct; 1293 } 1294 1295 if($opt->{link_relative}) { 1296 my $cur = $Global::Variable->{MV_PAGE}; 1297 $cur =~ s{/[^/]+$}{} 1298 and $path = "$cur/$path"; 1299 } 1300 1301 if($opt->{match_security}) { 1302 $opt->{secure} = $CGI::secure; 1303 } 1304 1305 if($opt->{secure} or exists $Vend::Cfg->{AlwaysSecure}{$path}) { 1306 $r = $Vend::Cfg->{SecureURL}; 1307 } 1308 1309 $path = escape_chars_url($path) 1310 if $path =~ $need_escape; 1311 $r .= '/' . $path; 1312 $r .= '.html' if $opt->{add_dot_html} and $r !~ m{(?:/|\.html?)$}; 1313 1314 if($opt->{add_source} and $Vend::Session->{source}) { 1315 my $sn = hexify($Vend::Session->{source}); 1316 push @parms, "$::VN->{mv_source}=$sn"; 1317 } 1318 1319 push @parms, "$::VN->{mv_session_id}=$id" if $id; 1320 push @parms, "$::VN->{mv_arg}=" . hexify($arguments) if defined $arguments; 1321 push @parms, "$::VN->{mv_pc}=$ct" if $ct; 1322 push @parms, "$::VN->{mv_cat}=$Vend::Cat" if $Vend::VirtualCat; 1323 1324 $r .= '?' . join($Global::UrlJoiner, @parms) if @parms; 1325 if($opt->{anchor}) { 1326 $opt->{anchor} =~ s/^#//; 1327 $r .= '#' . $opt->{anchor}; 1328 } 1329 return $r; 1330} 1331 1332sub secure_vendUrl { 1333 return vendUrl($_[0], $_[1], $Vend::Cfg->{SecureURL}, $_[3]); 1334} 1335 1336my %strip_vars; 1337my $strip_init; 1338 1339sub change_url { 1340 my $url = shift; 1341 return $url if $url =~ m{^\w+:}; 1342 return $url if $url =~ m{^/}; 1343 if(! $strip_init) { 1344 for(qw/mv_session_id mv_pc/) { 1345 $strip_vars{$_} = 1; 1346 $strip_vars{$::IV->{$_}} = 1; 1347 } 1348 } 1349 my $arg; 1350 my @args; 1351 ($url, $arg) = split /[?&]/, $url, 2; 1352 @args = grep ! $strip_vars{$_}, split $Global::UrlSplittor, $arg; 1353 return Vend::Interpolate::tag_area( $url, '', { 1354 form => join "\n", @args, 1355 } ); 1356} 1357 1358sub resolve_links { 1359 my $html = shift; 1360 $html =~ s/(<a\s+[^>]*href\s*=\s*)(["'])([^'"]+)\2/$1 . $2 . change_url($3) . $2/gei; 1361 return $html; 1362} 1363 1364### flock locking 1365 1366# sys/file.h: 1367my $flock_LOCK_SH = 1; # Shared lock 1368my $flock_LOCK_EX = 2; # Exclusive lock 1369my $flock_LOCK_NB = 4; # Don't block when locking 1370my $flock_LOCK_UN = 8; # Unlock 1371 1372# Returns the total number of items ordered. 1373# Uses the current cart if none specified. 1374 1375sub tag_nitems { 1376 my($ref, $opt) = @_; 1377 my($cart, $total, $item); 1378 1379 if($ref) { 1380 $cart = $::Carts->{$ref} 1381 or return 0; 1382 } 1383 else { 1384 $cart = $Vend::Items; 1385 } 1386 1387 my ($attr, $sub); 1388 if($opt->{qualifier}) { 1389 $attr = $opt->{qualifier}; 1390 my $qr; 1391 eval { 1392 $qr = qr{$opt->{compare}} if $opt->{compare}; 1393 }; 1394 if($qr) { 1395 $sub = sub { 1396 $_[0] =~ $qr; 1397 }; 1398 } 1399 else { 1400 $sub = sub { return $_[0] }; 1401 } 1402 } 1403 1404 $total = 0; 1405 foreach $item (@$cart) { 1406 next if $attr and ! $sub->($item->{$attr}); 1407 $total += $item->{'quantity'}; 1408 } 1409 $total; 1410} 1411 1412sub dump_structure { 1413 my ($ref, $name) = @_; 1414 my $save; 1415 $name =~ s/\.cfg$//; 1416 $name .= '.structure'; 1417 open(UNEV, ">$name") or die "Couldn't write structure $name: $!\n"; 1418 local($Data::Dumper::Indent); 1419 $Data::Dumper::Indent = 2; 1420 print UNEV uneval($ref); 1421 close UNEV; 1422} 1423 1424# Do an internal HTTP authorization check 1425sub check_authorization { 1426 my($auth, $pwinfo) = @_; 1427 1428 $auth =~ s/^\s*basic\s+//i or return undef; 1429 my ($user, $pw) = split( 1430 ":", 1431 MIME::Base64::decode_base64($auth), 1432 2, 1433 ); 1434 my $cmp_pw; 1435 my $use_crypt = 1; 1436 if(!defined $Vend::Cfg) { 1437 $pwinfo = $Global::AdminUser; 1438 $pwinfo =~ s/^\s+//; 1439 $pwinfo =~ s/\s+$//; 1440 my (%compare) = split /[\s:]+/, $pwinfo; 1441 return undef unless $compare{$user}; 1442 $cmp_pw = $compare{$user}; 1443 undef $use_crypt if $Global::Variable->{MV_NO_CRYPT}; 1444 } 1445 elsif( $user eq $Vend::Cfg->{RemoteUser} and 1446 $Vend::Cfg->{Password} ) 1447 { 1448 $cmp_pw = $Vend::Cfg->{Password}; 1449 undef $use_crypt if $::Variable->{MV_NO_CRYPT}; 1450 } 1451 else { 1452 $pwinfo = $Vend::Cfg->{UserDatabase} unless $pwinfo; 1453 undef $use_crypt if $::Variable->{MV_NO_CRYPT}; 1454 $cmp_pw = Vend::Interpolate::tag_data($pwinfo, 'password', $user) 1455 if defined $Vend::Cfg->{Database}{$pwinfo}; 1456 } 1457 1458 return undef unless $cmp_pw; 1459 1460 if(! $use_crypt) { 1461 return $user if $pw eq $cmp_pw; 1462 } 1463 else { 1464 my $test = crypt($pw, $cmp_pw); 1465 return $user 1466 if $test eq $cmp_pw; 1467 } 1468 return undef; 1469} 1470 1471# Check that the user is authorized by one or all of the 1472# configured security checks 1473sub check_security { 1474 my($item, $reconfig, $gate) = @_; 1475 1476 my $msg; 1477 if(! $reconfig) { 1478# If using the new USERDB access control you may want to remove this next line 1479# for anyone with an HTTP basic auth will have access to everything 1480 #return 1 if $CGI::user and ! $Global::Variable->{MV_USERDB}; 1481 if($gate) { 1482 $gate =~ s/\s+//g; 1483 return 1 if is_yes($gate); 1484 } 1485 elsif($Vend::Session->{logged_in}) { 1486 return 1 if $::Variable->{MV_USERDB_REMOTE_USER}; 1487 my $db; 1488 my $field; 1489 if ($db = $::Variable->{MV_USERDB_ACL_TABLE}) { 1490 $field = $::Variable->{MV_USERDB_ACL_COLUMN}; 1491 my $access = Vend::Data::database_field( 1492 $db, 1493 $Vend::Session->{username}, 1494 $field, 1495 ); 1496 return 1 if $access =~ m{(^|\s)$item(\s|$)}; 1497 } 1498 } 1499 if($Vend::Cfg->{UserDB} and $Vend::Cfg->{UserDB}{log_failed}) { 1500 my $besthost = $CGI::remote_host || $CGI::remote_addr; 1501 logError("auth error host=%s ip=%s script=%s page=%s", 1502 $besthost, 1503 $CGI::remote_addr, 1504 $CGI::script_name, 1505 $CGI::path_info, 1506 ); 1507 } 1508 return ''; 1509 } 1510 elsif($reconfig eq '1') { 1511 $msg = 'reconfigure catalog'; 1512 } 1513 elsif ($reconfig eq '2') { 1514 $msg = "access protected database $item"; 1515 return 1 if is_yes($gate); 1516 } 1517 elsif ($reconfig eq '3') { 1518 $msg = "access administrative function $item"; 1519 } 1520 1521 # Check if host IP is correct when MasterHost is set to something 1522 if ( $Vend::Cfg->{MasterHost} 1523 and 1524 ( $CGI::remote_host !~ /^($Vend::Cfg->{MasterHost})$/ 1525 and 1526 $CGI::remote_addr !~ /^($Vend::Cfg->{MasterHost})$/ ) ) 1527 { 1528 my $fmt = <<'EOF'; 1529ALERT: Attempt to %s at %s from: 1530 1531 REMOTE_ADDR %s 1532 REMOTE_USER %s 1533 USER_AGENT %s 1534 SCRIPT_NAME %s 1535 PATH_INFO %s 1536EOF 1537 logGlobal ({level => 'auth'}, $fmt, 1538 $msg, 1539 $CGI::script_name, 1540 $CGI::host, 1541 $CGI::user, 1542 $CGI::useragent, 1543 $CGI::script_name, 1544 $CGI::path_info, 1545 ); 1546 return ''; 1547 } 1548 1549 # Check to see if password enabled, then check 1550 if ( 1551 $reconfig eq '1' and 1552 !$CGI::user and 1553 $Vend::Cfg->{Password} and 1554 crypt($CGI::reconfigure_catalog, $Vend::Cfg->{Password}) 1555 ne $Vend::Cfg->{Password}) 1556 { 1557 ::logGlobal( 1558 {level => 'auth'}, 1559 "ALERT: Password mismatch, attempt to %s at %s from %s", 1560 $msg, 1561 $CGI::script_name, 1562 $CGI::host, 1563 ); 1564 return ''; 1565 } 1566 1567 # Finally check to see if remote_user match enabled, then check 1568 if ($Vend::Cfg->{RemoteUser} and 1569 $CGI::user ne $Vend::Cfg->{RemoteUser}) 1570 { 1571 my $fmt = <<'EOF'; 1572ALERT: Attempt to %s %s per user name: 1573 1574 REMOTE_HOST %s 1575 REMOTE_ADDR %s 1576 REMOTE_USER %s 1577 USER_AGENT %s 1578 SCRIPT_NAME %s 1579 PATH_INFO %s 1580EOF 1581 1582 ::logGlobal( 1583 {level => 'auth'}, 1584 $fmt, 1585 $CGI::script_name, 1586 $msg, 1587 $CGI::remote_host, 1588 $CGI::remote_addr, 1589 $CGI::user, 1590 $CGI::useragent, 1591 $CGI::script_name, 1592 $CGI::path_info, 1593 ); 1594 return ''; 1595 } 1596 1597 # Don't allow random reconfigures without one of the three checks 1598 unless ($Vend::Cfg->{MasterHost} or 1599 $Vend::Cfg->{Password} or 1600 $Vend::Cfg->{RemoteUser}) 1601 { 1602 my $fmt = <<'EOF'; 1603Attempt to %s on %s, secure operations disabled. 1604 1605 REMOTE_ADDR %s 1606 REMOTE_USER %s 1607 USER_AGENT %s 1608 SCRIPT_NAME %s 1609 PATH_INFO %s 1610EOF 1611 ::logGlobal ( 1612 {level => 'auth'}, 1613 $fmt, 1614 $msg, 1615 $CGI::script_name, 1616 $CGI::host, 1617 $CGI::user, 1618 $CGI::useragent, 1619 $CGI::script_name, 1620 $CGI::path_info, 1621 ); 1622 return ''; 1623 1624 } 1625 1626 # Authorized if got here 1627 return 1; 1628} 1629 1630 1631# Checks the Locale for a special page definintion mv_special_$key and 1632# returns it if found, otherwise goes to the default Vend::Cfg->{Special} array 1633sub find_special_page { 1634 my $key = shift; 1635 my $dir = ''; 1636 $dir = "../$Vend::Cfg->{SpecialPageDir}/" 1637 if $Vend::Cfg->{SpecialPageDir}; 1638 return $Vend::Cfg->{Special}{$key} || "$dir$key"; 1639} 1640 1641## ERROR 1642 1643# Log the error MSG to the error file. 1644 1645sub logDebug { 1646 return unless $Global::DebugFile; 1647 if(my $re = $Vend::Cfg->{DebugHost}) { 1648 return unless 1649 Net::IP::Match::Regexp::match_ip($CGI::remote_addr, $re); 1650 } 1651 1652 if(my $sub = $Vend::Cfg->{SpecialSub}{debug_qualify}) { 1653 return unless $sub->(); 1654 } 1655 1656 if(my $tpl = $Global::DebugTemplate) { 1657 my %debug; 1658 $tpl = POSIX::strftime($tpl, localtime()); 1659 $tpl =~ s/\s*$/\n/; 1660 $debug{page} = $Global::Variable->{MV_PAGE}; 1661 $debug{tag} = $Vend::CurrentTag; 1662 $debug{host} = $CGI::host || $CGI::remote_addr; 1663 $debug{remote_addr} = $CGI::remote_addr; 1664 $debug{catalog} = $Vend::Cat; 1665 if($tpl =~ /\{caller\d+\}/i) { 1666 my @caller = caller(); 1667 for(my $i = 0; $i < @caller; $i++) { 1668 $debug{"caller$i"} = $caller[$i]; 1669 } 1670 } 1671 $debug{message} = errmsg(@_); 1672 1673 print Vend::Interpolate::tag_attr_list($tpl, \%debug, 1); 1674 } 1675 else { 1676 print caller() . ":debug: ", errmsg(@_), "\n"; 1677 } 1678 return; 1679} 1680 1681sub errmsg { 1682 my($fmt, @strings) = @_; 1683 my $location; 1684 if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) { 1685 $location = $Vend::Cfg->{Locale}; 1686 } 1687 elsif($Global::Locale and defined $Global::Locale->{$fmt}) { 1688 $location = $Global::Locale; 1689 } 1690 if($location) { 1691 if(ref $location->{$fmt}) { 1692 $fmt = $location->{$fmt}[0]; 1693 @strings = @strings[ @{ $location->{$fmt}[1] } ]; 1694 } 1695 else { 1696 $fmt = $location->{$fmt}; 1697 } 1698 } 1699 return scalar(@strings) ? sprintf $fmt, @strings : $fmt; 1700} 1701 1702*l = \&errmsg; 1703 1704sub show_times { 1705 my $message = shift || 'time mark'; 1706 my @times = times(); 1707 for( my $i = 0; $i < @times; $i++) { 1708 $times[$i] -= $Vend::Times[$i]; 1709 } 1710 logDebug("$message: " . join " ", @times); 1711} 1712 1713sub logGlobal { 1714 return 1 if $Vend::ExternalProgram; 1715 my($msg) = shift; 1716 my $opt; 1717 if(ref $msg) { 1718 $opt = $msg; 1719 $msg = shift; 1720 } 1721 if(@_) { 1722 $msg = errmsg($msg, @_); 1723 } 1724 my $nolock; 1725 1726 my $fn = $Global::ErrorFile; 1727 my $flags; 1728 if($opt and $Global::SysLog) { 1729 $fn = "|" . ($Global::SysLog->{command} || 'logger'); 1730 1731 my $prioritized; 1732 my $tagged; 1733 my $facility = 'local3'; 1734 if($opt->{level} and defined $Global::SysLog->{$opt->{level}}) { 1735 my $stuff = $Global::SysLog->{$opt->{level}}; 1736 if($stuff =~ /\./) { 1737 $facility = $stuff; 1738 } 1739 else { 1740 $facility .= ".$stuff"; 1741 } 1742 $prioritized = 1; 1743 } 1744 1745 my $tag = $Global::SysLog->{tag} || 'interchange'; 1746 1747 $facility .= ".info" unless $prioritized; 1748 1749 $fn .= " -p $facility"; 1750 $fn .= " -t $tag" unless "\L$tag" eq 'none'; 1751 1752 if($opt->{socket}) { 1753 $fn .= " -u $opt->{socket}"; 1754 } 1755 } 1756 1757 my $nl = ($opt and $opt->{strip}) ? '' : "\n"; 1758 1759 print "$msg$nl" if $Global::Foreground and ! $Vend::Log_suppress && ! $Vend::Quiet; 1760 1761 $fn =~ s/^([^|>])/>>$1/ 1762 or $nolock = 1; 1763 1764 $msg = format_log_msg($msg) if ! $nolock; 1765 1766 $Vend::Errors .= $msg if $Global::DisplayErrors; 1767 1768 eval { 1769 # We have checked for beginning > or | previously 1770 open(MVERROR, $fn) or die "open\n"; 1771 if(! $nolock) { 1772 lockfile(\*MVERROR, 1, 1) or die "lock\n"; 1773 seek(MVERROR, 0, 2) or die "seek\n"; 1774 } 1775 print(MVERROR $msg, "\n") or die "write to\n"; 1776 if(! $nolock) { 1777 unlockfile(\*MVERROR) or die "unlock\n"; 1778 } 1779 close(MVERROR) or die "close\n"; 1780 }; 1781 if ($@) { 1782 chomp $@; 1783 print "\nCould not $@ error file '"; 1784 print $Global::ErrorFile, "':\n$!\n"; 1785 print "to report this error:\n", $msg; 1786 exit 1; 1787 } 1788} 1789 1790 1791# Log the error MSG to the error file. 1792 1793sub logError { 1794 my $msg = shift; 1795 return unless $Vend::Cfg; 1796 1797 my $opt; 1798 if(ref $_[0]) { 1799 $opt = shift(@_); 1800 } 1801 else { 1802 $opt = {}; 1803 } 1804 1805 if(! $opt->{file}) { 1806 my $tag = $opt->{tag} || $msg; 1807 if(my $dest = $Vend::Cfg->{ErrorDestination}{$tag}) { 1808 $opt->{file} = $dest; 1809 } 1810 } 1811 1812 $opt->{file} ||= $Vend::Cfg->{ErrorFile}; 1813 1814 if(@_) { 1815 $msg = errmsg($msg, @_); 1816 } 1817 1818 print "$msg\n" if $Global::Foreground and ! $Vend::Log_suppress && ! $Vend::Quiet; 1819 1820 $Vend::Session->{last_error} = $msg; 1821 1822 $msg = format_log_msg($msg) unless $msg =~ s/^\\//; 1823 1824 $Vend::Errors .= $msg 1825 if $Vend::Cfg->{DisplayErrors} || $Global::DisplayErrors; 1826 1827 my $reason; 1828 if (! allowed_file($opt->{file}, 1)) { 1829 $@ = 'access'; 1830 $reason = 'prohibited by global configuration'; 1831 } 1832 else { 1833 eval { 1834 open(MVERROR, ">> $opt->{file}") 1835 or die "open\n"; 1836 lockfile(\*MVERROR, 1, 1) or die "lock\n"; 1837 seek(MVERROR, 0, 2) or die "seek\n"; 1838 print(MVERROR $msg, "\n") or die "write to\n"; 1839 unlockfile(\*MVERROR) or die "unlock\n"; 1840 close(MVERROR) or die "close\n"; 1841 }; 1842 } 1843 if ($@) { 1844 chomp $@; 1845 logGlobal ({ level => 'info' }, 1846 "Could not %s error file %s: %s\nto report this error: %s", 1847 $@, 1848 $opt->{file}, 1849 $reason || $!, 1850 $msg, 1851 ); 1852 } 1853} 1854 1855# Front-end to log routines that ignores repeated identical 1856# log messages after the first occurrence 1857my %logOnce_cache; 1858my %log_sub_map = ( 1859 data => \&logData, 1860 debug => \&logDebug, 1861 error => \&logError, 1862 global => \&logGlobal, 1863); 1864 1865# First argument should be log type (see above map). 1866# Rest of arguments are same as if calling log routine directly. 1867sub logOnce { 1868 my $tag = join "", @_; 1869 return if exists $logOnce_cache{$tag}; 1870 my $log_sub = $log_sub_map{ lc(shift) } || $log_sub_map{error}; 1871 my $status = $log_sub->(@_); 1872 $logOnce_cache{$tag} = 1; 1873 return $status; 1874} 1875 1876 1877# Here for convenience in calls 1878sub set_cookie { 1879 my ($name, $value, $expire, $domain, $path) = @_; 1880 1881 # Set expire to now + some time if expire string is something like 1882 # "30 days" or "7 weeks" or even "60 minutes" 1883 if($expire =~ /^\s*\d+[\s\0]*[A-Za-z]\S*\s*$/) { 1884 my $add = Vend::Config::time_to_seconds($expire); 1885 $expire = time() + $add if $add; 1886 } 1887 1888 if (! $::Instance->{Cookies}) { 1889 $::Instance->{Cookies} = [] 1890 } 1891 else { 1892 @{$::Instance->{Cookies}} = 1893 grep $_->[0] ne $name, @{$::Instance->{Cookies}}; 1894 } 1895 push @{$::Instance->{Cookies}}, [$name, $value, $expire, $domain, $path]; 1896 return; 1897} 1898 1899# Here for convenience in calls 1900sub read_cookie { 1901 my ($lookfor, $string) = @_; 1902 $string = $CGI::cookie 1903 unless defined $string; 1904 return undef unless $string =~ /\b$lookfor=([^\s;]+)/i; 1905 return unescape_chars($1); 1906} 1907 1908sub send_mail { 1909 my($to, $subject, $body, $reply, $use_mime, @extra_headers) = @_; 1910 1911 if(ref $to) { 1912 my $head = $to; 1913 1914 for(my $i = $#$head; $i > 0; $i--) { 1915 if($head->[$i] =~ /^\s/) { 1916 my $new = splice @$head, $i, 1; 1917 $head->[$i - 1] .= "\n$new"; 1918 } 1919 } 1920 1921 $body = $subject; 1922 undef $subject; 1923 for(@$head) { 1924 s/\s+$//; 1925 if (/^To:\s*(.+)/si) { 1926 $to = $1; 1927 } 1928 elsif (/^Reply-to:\s*(.+)/si) { 1929 $reply = $_; 1930 } 1931 elsif (/^subj(?:ect)?:\s*(.+)/si) { 1932 $subject = $1; 1933 } 1934 elsif($_) { 1935 push @extra_headers, $_; 1936 } 1937 } 1938 } 1939 1940 # If configured, intercept all outgoing email and re-route 1941 if ( 1942 my $intercept = $::Variable->{MV_EMAIL_INTERCEPT} 1943 || $Global::Variable->{MV_EMAIL_INTERCEPT} 1944 ) { 1945 my @info_headers; 1946 $to = "To: $to"; 1947 for ($to, @extra_headers) { 1948 next unless my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si; 1949 logError( 1950 "Intercepting outgoing email (%s: %s) and instead sending to '%s'", 1951 $header, $value, $intercept 1952 ); 1953 $_ = "$header: $intercept"; 1954 push @info_headers, "X-Intercepted-$header: $value"; 1955 } 1956 $to =~ s/^To: //; 1957 push @extra_headers, @info_headers; 1958 } 1959 1960 my($ok); 1961#::logDebug("send_mail: to=$to subj=$subject r=$reply mime=$use_mime\n"); 1962 1963 unless (defined $use_mime) { 1964 $use_mime = $::Instance->{MIME} || undef; 1965 } 1966 1967 if(!defined $reply) { 1968 $reply = $::Values->{mv_email} 1969 ? "Reply-To: $::Values->{mv_email}\n" 1970 : ''; 1971 } 1972 elsif ($reply) { 1973 $reply = "Reply-To: $reply\n" 1974 unless $reply =~ /^reply-to:/i; 1975 $reply =~ s/\s+$/\n/; 1976 } 1977 1978 $ok = 0; 1979 my $none; 1980 my $using = $Vend::Cfg->{SendMailProgram}; 1981 1982 if($using =~ /^(none|Net::SMTP)$/i) { 1983 $none = 1; 1984 $ok = 1; 1985 } 1986 1987 SEND: { 1988#::logDebug("testing sendmail send none=$none"); 1989 last SEND if $none; 1990#::logDebug("in Sendmail send $using"); 1991 open(MVMAIL,"|$Vend::Cfg->{SendMailProgram} -t") or last SEND; 1992 my $mime = ''; 1993 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime; 1994 print MVMAIL "To: $to\n", $reply, "Subject: $subject\n" 1995 or last SEND; 1996 for(@extra_headers) { 1997 s/\s*$/\n/; 1998 print MVMAIL $_ 1999 or last SEND; 2000 } 2001 $mime =~ s/\s*$/\n/; 2002 print MVMAIL $mime 2003 or last SEND; 2004 print MVMAIL $body 2005 or last SEND; 2006 print MVMAIL Vend::Interpolate::do_tag('mime boundary') . '--' 2007 if $use_mime; 2008 print MVMAIL "\r\n\cZ" if $Global::Windows; 2009 close MVMAIL or last SEND; 2010 $ok = ($? == 0); 2011 } 2012 2013 SMTP: { 2014 my $mhost = $::Variable->{MV_SMTPHOST} || $Global::Variable->{MV_SMTPHOST}; 2015 my $helo = $Global::Variable->{MV_HELO} || $::Variable->{SERVER_NAME}; 2016 last SMTP unless $none and $mhost; 2017 eval { 2018 require Net::SMTP; 2019 }; 2020 last SMTP if $@; 2021 $ok = 0; 2022 $using = "Net::SMTP (mail server $mhost)"; 2023#::logDebug("using $using"); 2024 undef $none; 2025 2026 my $smtp = Net::SMTP->new($mhost, Debug => $Global::Variable->{DEBUG}, Hello => $helo) or last SMTP; 2027#::logDebug("smtp object $smtp"); 2028 2029 my $from = $::Variable->{MV_MAILFROM} 2030 || $Global::Variable->{MV_MAILFROM} 2031 || $Vend::Cfg->{MailOrderTo}; 2032 2033 for(@extra_headers) { 2034 s/\s*$/\n/; 2035 next unless /^From:\s*(\S.+)$/mi; 2036 $from = $1; 2037 } 2038 push @extra_headers, "From: $from" unless (grep /^From:\s/i, @extra_headers); 2039 push @extra_headers, 'Date: ' . POSIX::strftime('%a, %d %b %Y %H:%M:%S %Z', localtime(time())) unless (grep /^Date:\s/i, @extra_headers); 2040 2041 my $mime = ''; 2042 $mime = Vend::Interpolate::mime('header', {}, '') if $use_mime; 2043 $smtp->mail($from) 2044 or last SMTP; 2045#::logDebug("smtp accepted from=$from"); 2046 2047 my @to; 2048 my @addr = split /\s*,\s*/, $to; 2049 for (@addr) { 2050 if(/\s/) { 2051 ## Uh-oh. Try to handle 2052 if ( m{( <.+?> | [^\s,]+\@[^\s,]+ ) }x ) { 2053 push @to, $1 2054 } 2055 else { 2056 logError("Net::SMTP sender skipping unparsable address %s", $_); 2057 } 2058 } 2059 else { 2060 push @to, $_; 2061 } 2062 } 2063 2064 @addr = $smtp->recipient(@to, { SkipBad => 1 }); 2065 if(scalar(@addr) != scalar(@to)) { 2066 logError( 2067 "Net::SMTP not able to send to all addresses of %s", 2068 join(", ", @to), 2069 ); 2070 } 2071 2072#::logDebug("smtp accepted to=" . join(",", @addr)); 2073 2074 $smtp->data(); 2075 2076 push @extra_headers, $reply if $reply; 2077 for ("To: $to", "Subject: $subject", @extra_headers) { 2078 next unless $_; 2079 s/\s*$/\n/; 2080#::logDebug(do { my $it = $_; $it =~ s/\s+$//; "datasend=$it" }); 2081 $smtp->datasend($_) 2082 or last SMTP; 2083 } 2084 2085 if($use_mime) { 2086 $mime =~ s/\s*$/\n/; 2087 $smtp->datasend($mime) 2088 or last SMTP; 2089 } 2090 $smtp->datasend("\n"); 2091 $smtp->datasend($body) 2092 or last SMTP; 2093 $smtp->datasend(Vend::Interpolate::do_tag('mime boundary') . '--') 2094 if $use_mime; 2095 $smtp->dataend() 2096 or last SMTP; 2097 $ok = $smtp->quit(); 2098 } 2099 2100 if ($none or !$ok) { 2101 logError("Unable to send mail using %s\nTo: %s\nSubject: %s\n%s\n\n%s", 2102 $using, 2103 $to, 2104 $subject, 2105 $reply, 2106 $body, 2107 ); 2108 } 2109 2110 $ok; 2111} 2112 2113sub codedef_routine { 2114 my ($tag, $routine, $modifier) = @_; 2115 2116 my $area = $Vend::Config::tagCanon{lc $tag} 2117 or do { 2118 logError("Unknown CodeDef type %s", $tag); 2119 return undef; 2120 }; 2121 2122 $routine =~ s/-/_/g; 2123 my @tries; 2124 if ($tag eq 'UserTag') { 2125 @tries = ($Vend::Cfg->{UserTag}, $Global::UserTag); 2126 } 2127 else { 2128 @tries = ($Vend::Cfg->{CodeDef}{$area}, $Global::CodeDef->{$area}); 2129 } 2130 2131 no strict 'refs'; 2132 2133 my $ref; 2134 2135 for my $base (@tries) { 2136 next unless $base; 2137 $ref = $base->{Routine}{$routine} 2138 and return $ref; 2139 $ref = $base->{MapRoutine}{$routine} 2140 and return \&{"$ref"}; 2141 } 2142 2143 return undef unless $Global::AccumulateCode; 2144#::logDebug("trying code_from file for area=$area routine=$routine"); 2145 $ref = Vend::Config::code_from_file($area, $routine) 2146 or return undef; 2147#::logDebug("returning ref=$ref for area=$area routine=$routine"); 2148 return $ref; 2149} 2150 2151sub codedef_options { 2152 my ($tag, $modifier) = @_; 2153 2154 my @out; 2155 my $empty; 2156 2157 my @keys = keys %{$Vend::Cfg->{CodeDef}}; 2158 push @keys, keys %{$Global::CodeDef}; 2159 2160 my %gate = ( public => 1 ); 2161 2162 my @mod = grep /\w/, split /[\s\0,]+/, $modifier; 2163 for(@mod) { 2164 if($_ eq 'all') { 2165 $gate{private} = 1; 2166 } 2167 2168 if($_ eq 'empty') { 2169 $empty = ['', errmsg('--select--')]; 2170 } 2171 2172 if($_ eq 'admin') { 2173 $gate{admin} = 1; 2174 } 2175 } 2176 2177 for(@keys) { 2178 if(lc($tag) eq lc($_)) { 2179 $tag = $_; 2180 last; 2181 } 2182 } 2183 2184 my %seen; 2185 2186 for my $repos ( $Vend::Cfg->{CodeDef}{$tag}, $Global::CodeDef->{$tag} ) { 2187 if(my $desc = $repos->{Description}) { 2188 my $vis = $repos->{Visibility} || {}; 2189 my $help = $repos->{Help} || {}; 2190 while( my($k, $v) = each %$desc) { 2191 next if $seen{$k}++; 2192 if(my $perm = $vis->{$k}) { 2193 if($perm =~ /^with\s+([\w:]+)/) { 2194 my $mod = $1; 2195 no strict 'refs'; 2196 next unless ${$mod . "::VERSION"}; 2197 } 2198 else { 2199 next unless $gate{$perm}; 2200 } 2201 } 2202 push @out, [$k, $v, $help->{$k}]; 2203 } 2204 } 2205 } 2206 2207 if(@out) { 2208 @out = sort { $a->[1] cmp $b->[1] } @out; 2209 unshift @out, $empty if $empty; 2210 } 2211 else { 2212 push @out, ['', errmsg('--none--') ]; 2213 } 2214 return \@out; 2215} 2216 2217 2218# Adds a timestamp to the end of a binary timecard file. You can specify the timestamp 2219# as the second arg (unixtime) or just leave it out (or undefined) and it will be set 2220# to the current time. 2221sub timecard_stamp { 2222 my ($filename,$timestamp) = @_; 2223 $timestamp ||= time; 2224 2225 open(FH, '>>', $filename) or die "Can't open $filename for append: $!"; 2226 lockfile(\*FH, 1, 1); 2227 binmode FH; 2228 print FH pack('N',time); 2229 unlockfile(\*FH); 2230 close FH; 2231} 2232 2233 2234# Reads a timestamp from a binary timecard file. If $index is negative indexes back from 2235# the end of the file, otherwise indexes from the front of the file so that 0 is the first 2236# (oldest) timestamp and -1 the last (most recent). Returns the timestamp or undefined if 2237# the file doesn't exist or the index falls outside of the bounds of the timecard file. 2238sub timecard_read { 2239 my ($filename,$index) = @_; 2240 $index *= 4; 2241 my $limit = $index >= 0 ? $index + 4 : $index * -1; 2242 2243 if (-f $filename && (stat(_))[7] % 4) { 2244 # The file is corrupt, delete it and start over. 2245 ::logError("Counter file $filename found to be corrupt, deleting."); 2246 unlink($filename); 2247 return; 2248 } 2249 return unless (-f _ && (stat(_))[7] > $limit); 2250 2251 # The file exists and is big enough to cover the $index. Seek to the $index 2252 # and return the timestamp from that position. 2253 2254 open (FH, '<', $filename) or die "Can't open $filename for read: $!"; 2255 lockfile(\*FH, 0, 1); 2256 binmode FH; 2257 seek(FH, $index, $index >= 0 ? 0 : 2) or die "Can't seek $filename to $index: $!"; 2258 my $rtime; 2259 read(FH,$rtime,4) or die "Can't read from $filename: $!"; 2260 unlockfile(\*FH); 2261 close FH; 2262 2263 return unpack('N',$rtime); 2264} 2265 2266sub backtrace { 2267 my $msg = "Backtrace:\n\n"; 2268 my $frame = 1; 2269 2270 my $assertfile = ''; 2271 my $assertline = 0; 2272 2273 while (my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require) = caller($frame++) ) { 2274 $msg .= sprintf(" frame %d: $subroutine ($filename line $line)\n", $frame - 2); 2275 if ($subroutine =~ /assert$/) { 2276 $assertfile = $filename; 2277 $assertline = $line; 2278 } 2279 } 2280 if ($assertfile) { 2281 open(SRC, $assertfile) and do { 2282 my $line; 2283 my $line_n = 0; 2284 2285 $msg .= "\nProblem in $assertfile line $assertline:\n\n"; 2286 2287 while ($line = <SRC>) { 2288 $line_n++; 2289 $msg .= "$line_n\t$line" if (abs($assertline - $line_n) <= 10); 2290 } 2291 close(SRC); 2292 }; 2293 } 2294 2295 ::logGlobal($msg); 2296 undef; 2297} 2298 2299sub header_data_scrub { 2300 my ($head_data) = @_; 2301 2302 ## "HTTP Response Splitting" Exploit Fix 2303 ## http://www.securiteam.com/securityreviews/5WP0E2KFGK.html 2304 $head_data =~ s/(?:%0[da]|[\r\n]+)+//ig; 2305 2306 return $head_data; 2307} 2308 2309### Provide stubs for former Vend::Util functions relocated to Vend::File 2310*canonpath = \&Vend::File::canonpath; 2311*catdir = \&Vend::File::catdir; 2312*catfile = \&Vend::File::catfile; 2313*exists_filename = \&Vend::File::exists_filename; 2314*file_modification_time = \&Vend::File::file_modification_time; 2315*file_name_is_absolute = \&Vend::File::file_name_is_absolute; 2316*get_filename = \&Vend::File::get_filename; 2317*lockfile = \&Vend::File::lockfile; 2318*path = \&Vend::File::path; 2319*readfile = \&Vend::File::readfile; 2320*readfile_db = \&Vend::File::readfile_db; 2321*set_lock_type = \&Vend::File::set_lock_type; 2322*unlockfile = \&Vend::File::unlockfile; 2323*writefile = \&Vend::File::writefile; 2324 23251; 2326__END__ 2327