1# Vend::Interpolate - Interpret Interchange tags 2# 3# $Id: Interpolate.pm,v 2.303.2.3 2008-07-28 21:27:03 mheins Exp $ 4# 5# Copyright (C) 2002-2008 Interchange Development Group 6# Copyright (C) 1996-2002 Red Hat, Inc. 7# 8# This program was originally based on Vend 0.2 and 0.3 9# Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com> 10# 11# This program is free software; you can redistribute it and/or modify 12# it under the terms of the GNU General Public License as published by 13# the Free Software Foundation; either version 2 of the License, or 14# (at your option) any later version. 15# 16# This program is distributed in the hope that it will be useful, 17# but WITHOUT ANY WARRANTY; without even the implied warranty of 18# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19# GNU General Public License for more details. 20# 21# You should have received a copy of the GNU General Public 22# License along with this program; if not, write to the Free 23# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, 24# MA 02110-1301 USA. 25 26package Vend::Interpolate; 27 28require Exporter; 29@ISA = qw(Exporter); 30 31$VERSION = substr(q$Revision: 2.303.2.3 $, 10); 32 33@EXPORT = qw ( 34 35interpolate_html 36subtotal 37tag_data 38tag_attr_list 39$Tag 40$CGI 41$Session 42$Values 43$Discounts 44$Sub 45); 46 47=head1 NAME 48 49Vend::Interpolate -- Interchange tag interpolation routines 50 51=head1 SYNOPSIS 52 53(no external use) 54 55=head1 DESCRIPTION 56 57The Vend::Interpolate contains the majority of the Interchange Tag 58Language implementation rouines. Historically, it contained the entire 59tag language implementation for MiniVend, accounting for its name. 60 61It contains most of the handler routines pointed to by Vend::Parse, which 62accepts the parsing output of Vend::Parser. (Vend::Parser was originally based 63on HTML::Parser 1.x). 64 65There are two interpolative parsers in Vend::Interpolate, 66iterate_array_list() and iterate_hash_list() -- these routines parse 67the lists used in the widely employed [loop ..], [search-region ...], 68[item-list], and [query ..] ITL tag constructs. 69 70This module makes heavy use of precompiled regexes. You will notice variables 71being used in the regular expression constructs. For example, C<$All> is a 72a synonym for C<[\000-\377]*>, C<$Some> is equivalent to C<[\000-\377]*?>, etc. 73This is not only for clarity of the regular expression, but for speed. 74 75=cut 76 77# SQL 78push @EXPORT, 'tag_sql_list'; 79# END SQL 80 81use Safe; 82 83my $hole; 84BEGIN { 85 eval { 86 require Safe::Hole; 87 $hole = new Safe::Hole; 88 }; 89} 90 91# We generally know when we are testing these things, but be careful 92no warnings qw(uninitialized numeric); 93 94use strict; 95use Vend::Util; 96use Vend::File; 97use Vend::Data; 98use Vend::Form; 99require Vend::Cart; 100 101use HTML::Entities; 102use Vend::Server; 103use Vend::Scan; 104use Vend::Tags; 105use Vend::Subs; 106use Vend::Document; 107use Vend::Parse; 108use POSIX qw(ceil strftime LC_CTYPE); 109 110use vars qw(%Data_cache); 111 112my $wantref = 1; 113 114# MVASP 115 116my @Share_vars; 117my @Share_routines; 118 119BEGIN { 120 @Share_vars = qw/ 121 $s 122 $q 123 $item 124 $CGI_array 125 $CGI 126 $Discounts 127 $Document 128 %Db 129 $DbSearch 130 %Filter 131 $Search 132 $Carts 133 $Config 134 %Sql 135 $Items 136 $Row 137 $Scratch 138 $Shipping 139 $Session 140 $Tag 141 $Tmp 142 $TextSearch 143 $Values 144 $Variable 145 $Sub 146 /; 147 @Share_routines = qw/ 148 &tag_data 149 &errmsg 150 &Log 151 &Debug 152 &uneval 153 &get_option_hash 154 &dotted_hash 155 &encode_entities 156 &HTML 157 &interpolate_html 158 /; 159} 160 161use vars @Share_vars, @Share_routines, 162 qw/$ready_safe $safe_safe/; 163use vars qw/%Filter %Ship_handler $Safe_data/; 164 165$ready_safe = new Safe; 166$ready_safe->trap(qw/:base_io/); 167$ready_safe->untrap(qw/sort ftfile/); 168 169sub reset_calc { 170#::logDebug("reset_state=$Vend::Calc_reset -- resetting calc from " . caller); 171 if(! $Global::Foreground and $Vend::Cfg->{ActionMap}{_mvsafe}) { 172#::logDebug("already made"); 173 $ready_safe = $Vend::Cfg->{ActionMap}{_mvsafe}; 174 } 175 else { 176 my $pkg = 'MVSAFE' . int(rand(100000)); 177 undef $MVSAFE::Safe; 178 $ready_safe = new Safe $pkg; 179 $ready_safe->share_from('MVSAFE', ['$safe']); 180#::logDebug("new safe made=$ready_safe->{Root}"); 181 182 Vend::CharSet->utf8_safe_regex_workaround($ready_safe) 183 if $::Variable->{MV_UTF8}; 184 185 $ready_safe->trap(@{$Global::SafeTrap}); 186 $ready_safe->untrap(@{$Global::SafeUntrap}); 187 no strict 'refs'; 188 $Document = new Vend::Document; 189 *Log = \&Vend::Util::logError; 190 *Debug = \&Vend::Util::logDebug; 191 *uneval = \&Vend::Util::uneval_it; 192 *HTML = \&Vend::Document::HTML; 193 $ready_safe->share(@Share_vars, @Share_routines); 194 $DbSearch = new Vend::DbSearch; 195 $TextSearch = new Vend::TextSearch; 196 $Tag = new Vend::Tags; 197 $Sub = new Vend::Subs; 198 } 199 $Tmp = {}; 200 undef $s; 201 undef $q; 202 undef $item; 203 %Db = (); 204 %Sql = (); 205 undef $Shipping; 206 $Vend::Calc_reset = 1; 207 undef $Vend::Calc_initialized; 208 return $ready_safe; 209} 210 211sub init_calc { 212#::logDebug("reset_state=$Vend::Calc_reset init_state=$Vend::Calc_initialized -- initting calc from " . caller); 213 reset_calc() unless $Vend::Calc_reset; 214 $CGI_array = \%CGI::values_array; 215 $CGI = \%CGI::values; 216 $Carts = $::Carts; 217 $Discounts = $::Discounts; 218 $Items = $Vend::Items; 219 $Config = $Vend::Cfg; 220 $Scratch = $::Scratch; 221 $Values = $::Values; 222 $Session = $Vend::Session; 223 $Search = $::Instance->{SearchObject} ||= {}; 224 $Variable = $::Variable; 225 $Vend::Calc_initialized = 1; 226 return; 227} 228 229# Define conditional ops 230my %cond_op = ( 231 eq => sub { $_[0] eq $_[1] }, 232 ne => sub { $_[0] ne $_[1] }, 233 gt => sub { $_[0] gt $_[1] }, 234 ge => sub { $_[0] ge $_[1] }, 235 le => sub { $_[0] le $_[1] }, 236 lt => sub { $_[0] lt $_[1] }, 237 '>' => sub { $_[0] > $_[1] }, 238 '<' => sub { $_[0] < $_[1] }, 239 '>=' => sub { $_[0] >= $_[1] }, 240 '<=' => sub { $_[0] <= $_[1] }, 241 '==' => sub { $_[0] == $_[1] }, 242 '!=' => sub { $_[0] != $_[1] }, 243 '=~' => sub { 244 my $re; 245 $_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:; 246 $2 and substr($_[1], 0, 0) = "(?$2)"; 247 eval { $re = qr/$_[1]/ }; 248 if($@) { 249 logError("bad regex %s in if-PREFIX-data", $_[1]); 250 return undef; 251 } 252 return $_[0] =~ $re; 253 }, 254 '!~' => sub { 255 my $re; 256 $_[1] =~ s:^/(.*)/([imsx]*)\s*$:$1:; 257 $2 and substr($_[1], 0, 0) = "(?$2)"; 258 eval { $re = qr/$_[1]/ }; 259 if($@) { 260 logError("bad regex %s in if-PREFIX-data", $_[1]); 261 return undef; 262 } 263 return $_[0] !~ $re; 264 }, 265 'filter' => sub { 266 my ($string, $filter) = @_; 267 my $newval = filter_value($filter, $string); 268 return $string eq $newval ? 1 : 0; 269 }, 270 'length' => sub { 271 my ($string, $lenspec) = @_; 272 my ($min,$max) = split /-/, $lenspec; 273 if($min and length($string) < $min) { 274 return 0; 275 } 276 elsif($max and length($string) > $max) { 277 return 0; 278 } 279 else { 280 return 0 unless length($string) > 0; 281 } 282 return 1; 283 }, 284); 285 286my %file_op = ( 287 A => sub { -A $_[0] }, 288 B => sub { -B $_[0] }, 289 d => sub { -d $_[0] }, 290 e => sub { -e $_[0] }, 291 f => sub { -f $_[0] }, 292 g => sub { -g $_[0] }, 293 l => sub { -l $_[0] }, 294 M => sub { -M $_[0] }, 295 r => sub { -r $_[0] }, 296 s => sub { -s $_[0] }, 297 T => sub { -T $_[0] }, 298 u => sub { -u $_[0] }, 299 w => sub { -w $_[0] }, 300 x => sub { -x $_[0] }, 301); 302 303 304$cond_op{len} = $cond_op{length}; 305 306# Regular expression pre-compilation 307my %T; 308my %QR; 309 310my $All = '[\000-\377]*'; 311my $Some = '[\000-\377]*?'; 312my $Codere = '[-\w#/.]+'; 313my $Coderex = '[-\w:#=/.%]+'; 314my $Filef = '(?:%20|\s)+([^]]+)'; 315my $Mandx = '\s+([-\w:#=/.%]+)'; 316my $Mandf = '(?:%20|\s)+([-\w#/.]+)'; 317my $Spacef = '(?:%20|\s)+'; 318my $Spaceo = '(?:%20|\s)*'; 319 320my $Optx = '\s*([-\w:#=/.%]+)?'; 321my $Optr = '(?:\s+([^]]+))?'; 322my $Mand = '\s+([-\w#/.]+)'; 323my $Opt = '\s*([-\w#/.]+)?'; 324my $T = '\]'; 325my $D = '[-_]'; 326 327my $XAll = qr{[\000-\377]*}; 328my $XSome = qr{[\000-\377]*?}; 329my $XCodere = qr{[-\w#/.]+}; 330my $XCoderex = qr{[-\w:#=/.%]+}; 331my $XMandx = qr{\s+([-\w:#=/.%]+)}; 332my $XMandf = qr{(?:%20|\s)+([-\w#/.]+)}; 333my $XSpacef = qr{(?:%20|\s)+}; 334my $XSpaceo = qr{(?:%20|\s)*}; 335my $XOptx = qr{\s*([-\w:#=/.%]+)?}; 336my $XMand = qr{\s+([-\w#/.]+)}; 337my $XOpt = qr{\s*([-\w#/.]+)?}; 338my $XD = qr{[-_]}; 339my $Gvar = qr{\@\@([A-Za-z0-9]\w+[A-Za-z0-9])\@\@}; 340my $Evar = qr{\@_([A-Za-z0-9]\w+[A-Za-z0-9])_\@}; 341my $Cvar = qr{__([A-Za-z0-9]\w*?[A-Za-z0-9])__}; 342 343 344my @th = (qw! 345 346 /_alternate 347 /_calc 348 /_change 349 /_exec 350 /_filter 351 /_header_param 352 /_last 353 /_modifier 354 /_next 355 /_param 356 /_pos 357 /_sub 358 /col 359 /comment 360 /condition 361 /else 362 /elsif 363 /more_list 364 /no_match 365 /on_match 366 /sort 367 /then 368 _accessories 369 _alternate 370 _calc 371 _change 372 _code 373 _common 374 _data 375 _description 376 _discount 377 _exec 378 _field 379 _filter 380 _header_param 381 _include 382 _increment 383 _last 384 _line 385 _match 386 _modifier 387 _next 388 _options 389 _param 390 _parent 391 _pos 392 _price 393 _quantity 394 _sku 395 _subtotal 396 _sub 397 col 398 comment 399 condition 400 discount_price 401 _discount_price 402 _discount_subtotal 403 _difference 404 else 405 elsif 406 matches 407 match_count 408 _modifier_name 409 more 410 more_list 411 no_match 412 on_match 413 _quantity_name 414 sort 415 then 416 417 ! ); 418 419 my $shown = 0; 420 my $tag; 421 for (@th) { 422 $tag = $_; 423 s/([A-Za-z0-9])/[\u$1\l$1]/g; 424 s/[-_]/[-_]/g; 425 $T{$tag} = $_; 426 next if $tag =~ m{^_}; 427 $T{$tag} = "\\[$T{$tag}"; 428 next unless $tag =~ m{^/}; 429 $T{$tag} = "$T{$tag}\]"; 430 } 431 432%QR = ( 433 '/_alternate' => qr($T{_alternate}\]), 434 '/_calc' => qr($T{_calc}\]), 435 '/_change' => qr([-_]change\s+)i, 436 '/_data' => qr($T{_data}\]), 437 '/_exec' => qr($T{_exec}\]), 438 '/_field' => qr($T{_field}\]), 439 '/_filter' => qr($T{_filter}\]), 440 '/_last' => qr($T{_last}\]), 441 '/_modifier' => qr($T{_modifier}\]), 442 '/_next' => qr($T{_next}\]), 443 '/_pos' => qr($T{_pos}\]), 444 '/_sub' => qr($T{_sub}\]), 445 '_accessories' => qr($T{_accessories}($Spacef[^\]]+)?\]), 446 '_alternate' => qr($T{_alternate}$Opt\]($Some)), 447 '_calc' => qr($T{_calc}\]($Some)), 448 '_exec' => qr($T{_exec}$Mand\]($Some)), 449 '_filter' => qr($T{_filter}\s+($Some)\]($Some)), 450 '_sub' => qr($T{_sub}$Mand\]($Some)), 451 '_change' => qr($T{_change}$Mand$Opt\] \s* 452 $T{condition}\] 453 ($Some) 454 $T{'/condition'} 455 ($Some))xi, 456 '_code' => qr($T{_code}\]), 457 '_sku' => qr($T{_sku}\]), 458 'col' => qr(\[col(?:umn)?\s+ 459 ([^\]]+) 460 \] 461 ($Some) 462 \[/col(?:umn)?\] )ix, 463 464 'comment' => qr($T{comment}(?:\s+$Some)?\] 465 (?!$All$T{comment}\]) 466 $Some 467 $T{'/comment'})x, 468 469 '_description' => qr($T{_description}\]), 470 '_difference' => qr($T{_difference}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]), 471 '_discount' => qr($T{_discount}(?:\s+(?:quantity=)?"?(\d+)"?)?$Optx\]), 472 '_field_if' => qr($T{_field}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), 473 '_field_if_wo' => qr($T{_field}$Spacef(!?)\s*($Codere$Optr)\]), 474 '_field' => qr($T{_field}$Mandf\]), 475 '_common' => qr($T{_common}$Mandf\]), 476 '_include' => qr($T{_include}$Filef\]), 477 '_increment' => qr($T{_increment}\]), 478 '_last' => qr($T{_last}\]\s*($Some)\s*), 479 '_line' => qr($T{_line}$Opt\]), 480 '_next' => qr($T{_next}\]\s*($Some)\s*), 481 '_options' => qr($T{_options}($Spacef[^\]]+)?\]), 482 '_header_param' => qr($T{_header_param}$Mandf$Optr\]), 483 '_header_param_if' => qr($T{_header_param}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), 484 '_param_if' => qr((?:$T{_param}|$T{_modifier})(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), 485 '_param' => qr((?:$T{_param}|$T{_modifier})$Mandf\]), 486 '_parent_if' => qr($T{_parent}(\d*)$Spacef(!?)\s*($Codere)$Optr\]($Some)), 487 '_parent' => qr($T{_parent}$Mandf\]), 488 '_pos_if' => qr($T{_pos}(\d*)$Spacef(!?)\s*(-?\d+)$Optr\]($Some)), 489 '_pos' => qr($T{_pos}$Spacef(-?\d+)\]), 490 '_price' => qr!$T{_price}(?:\s+(\d+))?$Optx\]!, 491 '_quantity' => qr($T{_quantity}\]), 492 '_subtotal' => qr($T{_subtotal}$Optx\]), 493 '_tag' => qr([-_] tag [-_] ([-\w]+) \s+)x, 494 'condition' => qr($T{condition}$T($Some)$T{'/condition'}), 495 'condition_begin' => qr(^\s*$T{condition}\]($Some)$T{'/condition'}), 496 '_discount_price' => qr($T{_discount_price}(?:\s+(\d+))?$Optx\]), 497 'discount_price' => qr($T{discount_price}(?:\s+(\d+))?$Optx\]), 498 '_discount_subtotal' => qr($T{_discount_subtotal}$Optx\]), 499 'has_else' => qr($T{'/else'}\s*$), 500 'else_end' => qr($T{else}\]($All)$T{'/else'}\s*$), 501 'elsif_end' => qr($T{elsif}\s+($All)$T{'/elsif'}\s*$), 502 'matches' => qr($T{matches}\]), 503 'match_count' => qr($T{match_count}\]), 504 'more' => qr($T{more}\]), 505 'more_list' => qr($T{more_list}$Optx$Optx$Optx$Optx$Optx\]($Some)$T{'/more_list'}), 506 'no_match' => qr($T{no_match}\]($Some)$T{'/no_match'}), 507 'on_match' => qr($T{on_match}\]($Some)$T{'/on_match'}), 508 '_quantity_name' => qr($T{_quantity_name}\]), 509 '_modifier_name' => qr($T{_modifier_name}$Spacef(\w+)\]), 510 'then' => qr(^\s*$T{then}$T($Some)$T{'/then'}), 511); 512 513FINTAG: { 514 for(keys %T) { 515 $QR{$_} = qr($T{$_}) 516 if ! defined $QR{$_}; 517 } 518} 519 520undef @th; 521undef %T; 522 523sub get_joiner { 524 my ($joiner, $default) = @_; 525 return $default unless defined $joiner and length $joiner; 526 if($joiner eq '\n') { 527 $joiner = "\n"; 528 } 529 elsif($joiner =~ m{\\}) { 530 $joiner = $safe_safe->reval("qq{$joiner}"); 531 } 532 return length($joiner) ? $joiner : $default; 533} 534 535sub substitute_image { 536 my ($text) = @_; 537 538 ## Allow no substitution of downloads 539 return if $::Pragma->{download}; 540 541 ## If post_page routine processor returns true, return. Otherwise, 542 ## continue image rewrite 543 if($::Pragma->{post_page}) { 544 Vend::Dispatch::run_macro($::Pragma->{post_page}, $text) 545 and return; 546 } 547 548 unless ( $::Pragma->{no_image_rewrite} ) { 549 my $dir = $CGI::secure ? 550 ($Vend::Cfg->{ImageDirSecure} || $Vend::Cfg->{ImageDir}) : 551 $Vend::Cfg->{ImageDir}; 552 553 if ($dir) { 554 $$text =~ s#(<i\w+\s+[^>]*?src=")(?!\w+:)([^/'][^"]+)# 555 $1 . $dir . $2#ige; 556 $$text =~ s#(<body\s+[^>]*?background=")(?!\w+:)([^/'][^"]+)# 557 $1 . $dir . $2#ige; 558 $$text =~ s#(<t(?:[dhr]|able)\s+[^>]*?background=")(?!\w+:)([^/'][^"]+)# 559 $1 . $dir . $2#ige; 560 } 561 } 562 563 if($Vend::Cfg->{ImageAlias}) { 564 for (keys %{$Vend::Cfg->{ImageAlias}} ) { 565 $$text =~ s#(<i\w+\s+[^>]*?src=")($_)# 566 $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige; 567 $$text =~ s#(<body\s+[^>]*?background=")($_)# 568 $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige; 569 $$text =~ s#(<t(?:[dhr]|able)\s+[^>]*?background=")($_)# 570 $1 . ($Vend::Cfg->{ImageAlias}->{$2} || $2)#ige; 571 } 572 } 573} 574 575sub dynamic_var { 576 my $varname = shift; 577 578 return readfile($Vend::Cfg->{DirConfig}{Variable}{$varname}) 579 if $Vend::Cfg->{DirConfig} 580 and defined $Vend::Cfg->{DirConfig}{Variable}{$varname}; 581 582 VARDB: { 583 last VARDB if $::Pragma->{dynamic_variables_file_only}; 584 last VARDB unless $Vend::Cfg->{VariableDatabase}; 585 if($Vend::VarDatabase) { 586 last VARDB unless $Vend::VarDatabase->record_exists($varname); 587 return $Vend::VarDatabase->field($varname, 'Variable'); 588 } 589 else { 590 $Vend::VarDatabase = database_exists_ref($Vend::Cfg->{VariableDatabase}) 591 or undef $Vend::Cfg->{VariableDatabase}; 592 redo VARDB; 593 } 594 } 595 return $::Variable->{$varname}; 596} 597 598sub vars_and_comments { 599 my $html = shift; 600 ## We never want to interpolate vars if in restricted mode 601 return if $Vend::restricted; 602 local($^W) = 0; 603 604 # Set whole-page pragmas from [pragma] tags 605 1 while $$html =~ s/\[pragma\s+(\w+)(?:\s+(\w+))?\]/ 606 $::Pragma->{$1} = (length($2) ? $2 : 1), ''/ige; 607 608 undef $Vend::PageInit unless $::Pragma->{init_page}; 609 610 if(defined $Vend::PageInit and ! $Vend::PageInit++) { 611 Vend::Dispatch::run_macro($::Pragma->{init_page}, $html); 612 } 613 614 # Substitute in Variable values 615 $$html =~ s/$Gvar/$Global::Variable->{$1}/g; 616 if($::Pragma->{dynamic_variables}) { 617 $$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge 618 and 619 $$html =~ s/$Evar/dynamic_var($1) || $Global::Variable->{$1}/ge; 620 $$html =~ s/$Cvar/dynamic_var($1)/ge; 621 } 622 else { 623 $$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge 624 and 625 $$html =~ s/$Evar/$::Variable->{$1} || $Global::Variable->{$1}/ge; 626 $$html =~ s/$Cvar/$::Variable->{$1}/g; 627 } 628 629 if($::Pragma->{pre_page}) { 630 Vend::Dispatch::run_macro($::Pragma->{pre_page}, $html); 631 } 632 633 # Strip out [comment] [/comment] blocks 634 1 while $$html =~ s%$QR{comment}%%go; 635 636 # Translate Interchange tags embedded in HTML comments like <!--[tag ...]--> 637 ! $::Pragma->{no_html_comment_embed} 638 and 639 $$html =~ s/<!--+\[/[/g 640 and $$html =~ s/\]--+>/]/g; 641 642 return; 643} 644 645sub interpolate_html { 646 my ($html, $wantref, $opt) = @_; 647 return undef if $Vend::NoInterpolate; 648 my ($name, @post); 649 my ($bit, %post); 650 651 local($^W); 652 653 my $toplevel; 654 if(defined $Vend::PageInit and ! $Vend::PageInit) { 655 defined $::Variable->{MV_AUTOLOAD} 656 and $html =~ s/^/$::Variable->{MV_AUTOLOAD}/; 657 $toplevel = 1; 658 } 659#::logDebug("opt=" . uneval($opt)); 660 661 vars_and_comments(\$html) 662 unless $opt and $opt->{onfly}; 663 664 $^W = 1 if $::Pragma->{perl_warnings_in_page}; 665 666 # Returns, could be recursive 667 my $parse = new Vend::Parse $wantref; 668 $parse->parse($html); 669 while($parse->{_buf}) { 670 if($toplevel and $parse->{SEND}) { 671 delete $parse->{SEND}; 672 ::response(); 673 $parse->destination($parse->{_current_output}); 674 } 675 $parse->parse(''); 676 } 677 return $parse->{OUT} if defined $wantref; 678 return ${$parse->{OUT}}; 679} 680 681sub filter_value { 682 my($filter, $value, $tag, @passed_args) = @_; 683#::logDebug("filter_value: filter='$filter' value='$value' tag='$tag'"); 684 my @filters = Text::ParseWords::shellwords($filter); 685 my @args; 686 687 if(! $Vend::Filters_initted++ and my $ref = $Vend::Cfg->{CodeDef}{Filter}) { 688 while (my($k, $v) = each %{$ref->{Routine}}) { 689 $Filter{$k} = $v; 690 } 691 } 692 693 for (@filters) { 694 next unless length($_); 695 @args = @passed_args; 696 if(/^[^.]*%/) { 697 $value = sprintf($_, $value); 698 next; 699 } 700 if (/^(\d+)([\.\$]?)$/) { 701 my $len; 702 return $value unless ($len = length($value)) > $1; 703 my ($limit, $mod) = ($1, $2); 704 unless($mod) { 705 substr($value, $limit) = ''; 706 } 707 elsif($mod eq '.') { 708 substr($value, $1) = '...'; 709 } 710 elsif($mod eq '$') { 711 substr($value, 0, $len - $limit) = '...'; 712 } 713 return $value; 714 next; 715 } 716 while( s/\.([^.]+)$//) { 717 unshift @args, $1; 718 } 719 if(/^\d+$/) { 720 substr($value , $_) = '' 721 if length($value) > $_; 722 next; 723 } 724 if ( /^words(\d+)(\.?)$/ ) { 725 my @str = (split /\s+/, $value); 726 if (scalar @str > $1) { 727 my $num = $1; 728 $value = join(' ', @str[0..--$num]); 729 $value .= $2 ? '...' : ''; 730 } 731 next; 732 } 733 my $sub; 734 unless ($sub = $Filter{$_} || Vend::Util::codedef_routine('Filter', $_) ) { 735 logError ("Unknown filter '%s'", $_); 736 next; 737 } 738 unshift @args, $value, $tag; 739 $value = $sub->(@args); 740 } 741#::logDebug("filter_value returns: value='$value'"); 742 return $value; 743} 744 745sub try { 746 my ($label, $opt, $body) = @_; 747 $label = 'default' unless $label; 748 $Vend::Session->{try}{$label} = ''; 749 my $out; 750 my $save; 751 $save = delete $SIG{__DIE__} if defined $SIG{__DIE__}; 752 $Vend::Try = $label; 753 eval { 754 $out = interpolate_html($body); 755 }; 756 undef $Vend::Try; 757 $SIG{__DIE__} = $save if defined $save; 758 if($@) { 759 $Vend::Session->{try}{$label} .= "\n" 760 if $Vend::Session->{try}{$label}; 761 $Vend::Session->{try}{$label} .= $@; 762 } 763 if ($opt->{status}) { 764 return ($Vend::Session->{try}{$label}) ? 0 : 1; 765 } 766 elsif ($opt->{hide}) { 767 return ''; 768 } 769 elsif ($opt->{clean}) { 770 return ($Vend::Session->{try}{$label}) ? '' : $out; 771 } 772 773 return $out; 774} 775 776# Returns the text of a configurable database field or a 777# session variable 778sub tag_data { 779 my($selector,$field,$key,$opt,$flag) = @_; 780 781 local($Safe_data); 782 $Safe_data = 1 if $opt->{safe_data}; 783 784 my $db; 785 786 if ( not $db = database_exists_ref($selector) ) { 787 if($selector eq 'session') { 788 if(defined $opt->{value}) { 789 $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field) 790 if $opt->{filter}; 791 if ($opt->{increment}) { 792 $Vend::Session->{$field} += (+ $opt->{value} || 1); 793 } 794 elsif ($opt->{append}) { 795 $Vend::Session->{$field} .= $opt->{value}; 796 } 797 else { 798 $Vend::Session->{$field} = $opt->{value}; 799 } 800 return ''; 801 } 802 else { 803 my $value = $Vend::Session->{$field} || ''; 804 $value = filter_value($opt->{filter}, $value, $field) 805 if $opt->{filter}; 806 return $value; 807 } 808 } 809 else { 810 logError( "Bad data selector='%s' field='%s' key='%s'", 811 $selector, 812 $field, 813 $key, 814 ); 815 return ''; 816 } 817 } 818 elsif($opt->{increment}) { 819#::logDebug("increment_field: key=$key field=$field value=$opt->{value}"); 820 return increment_field($Vend::Database{$selector},$key,$field,$opt->{value} || 1); 821 } 822 elsif (defined $opt->{value}) { 823#::logDebug("alter table: table=$selector alter=$opt->{alter} field=$field value=$opt->{value}"); 824 if ($opt->{alter}) { 825 $opt->{alter} =~ s/\W+//g; 826 $opt->{alter} = lc($opt->{alter}); 827 if ($opt->{alter} eq 'change') { 828 return $db->change_column($field, $opt->{value}); 829 } 830 elsif($opt->{alter} eq 'add') { 831 return $db->add_column($field, $opt->{value}); 832 } 833 elsif ($opt->{alter} eq 'delete') { 834 return $db->delete_column($field, $opt->{value}); 835 } 836 else { 837 logError("alter function '%s' not found", $opt->{alter}); 838 return undef; 839 } 840 } 841 else { 842 $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field) 843 if $opt->{filter}; 844#::logDebug("set_field: table=$selector key=$key field=$field foreign=$opt->{foreign} value=$opt->{value}"); 845 my $orig = $opt->{value}; 846 if($opt->{serial}) { 847 $field =~ s/\.(.*)//; 848 my $hk = $1; 849 my $current = database_field($selector,$key,$field,$opt->{foreign}); 850 $opt->{value} = dotted_hash($current, $hk, $orig); 851 } 852 my $result = set_field( 853 $selector, 854 $key, 855 $field, 856 $opt->{value}, 857 $opt->{append}, 858 $opt->{foreign}, 859 ); 860 return $orig if $opt->{serial}; 861 return $result 862 } 863 } 864 elsif ($opt->{serial}) { 865 $field =~ s/\.(.*)//; 866 my $hk = $1; 867 return ed( 868 dotted_hash( 869 database_field($selector,$key,$field,$opt->{foreign}), 870 $hk, 871 ) 872 ); 873 } 874 elsif ($opt->{hash}) { 875 return undef unless $db->record_exists($key); 876 return $db->row_hash($key); 877 } 878 elsif ($opt->{filter}) { 879 return filter_value( 880 $opt->{filter}, 881 ed(database_field($selector,$key,$field,$opt->{foreign})), 882 $field, 883 ); 884 } 885 886 #The most common , don't enter a block, no accoutrements 887 return ed(database_field($selector,$key,$field,$opt->{foreign})); 888} 889 890sub input_filter_do { 891 my($varname, $opt, $routine) = @_; 892#::logDebug("filter var=$varname opt=" . uneval_it($opt)); 893 return undef unless defined $CGI::values{$varname}; 894#::logDebug("before filter=$CGI::values{$varname}"); 895 $routine = $opt->{routine} || '' 896 if ! $routine; 897 if($routine =~ /\S/) { 898 $routine = interpolate_html($routine); 899 $CGI::values{$varname} = tag_calc($routine); 900 } 901 if ($opt->{op}) { 902 $CGI::values{$varname} = filter_value($opt->{op}, $CGI::values{$varname}, $varname); 903 } 904#::logDebug("after filter=$CGI::values{$varname}"); 905 return; 906} 907 908sub input_filter { 909 my ($varname, $opt, $routine) = @_; 910 if($opt->{remove}) { 911 return if ! ref $Vend::Session->{Filter}; 912 delete $Vend::Session->{Filter}{$_}; 913 return; 914 } 915 $opt->{routine} = $routine if $routine =~ /\S/; 916 $Vend::Session->{Filter} = {} if ! $Vend::Session->{Filter}; 917 $Vend::Session->{Filter}{$varname} = $opt->{op} if $opt->{op}; 918 return; 919} 920 921sub conditional { 922 my($base,$term,$operator,$comp, @addl) = @_; 923 my $reverse; 924 925 # Only lowercase the first word-characters part of the conditional so that 926 # file-T doesn't turn into file-t (which is something different). 927 $base =~ s/(\w+)/\L$1/; 928 929 $base =~ s/^!// and $reverse = 1; 930 my ($op, $status); 931 my $noop; 932 $noop = 1, $operator = '' unless defined $operator; 933 934 my $sub; 935 my $newcomp; 936 937 if($operator =~ /^([^\s.]+)\.(.+)/) { 938 $operator = $1; 939 my $tag = $2; 940 my $arg; 941 if($comp =~ /^\w[-\w]+=/) { 942 $arg = get_option_hash($comp); 943 } 944 else { 945 $arg = $comp; 946 } 947 948 $Tag ||= new Vend::Tags; 949#::logDebug("ready to call tag=$tag with arg=$arg"); 950 $comp = $Tag->$tag($arg); 951 } 952 953 if($sub = $cond_op{$operator}) { 954 $noop = 1; 955 $newcomp = $comp; 956 undef $comp; 957 $newcomp =~ s/^(["'])(.*)\1$/$2/s or 958 $newcomp =~ s/^qq?([{(])(.*)[})]$/$2/s or 959 $newcomp =~ s/^qq?(\S)(.*)\1$/$2/s; 960 } 961 962 local($^W) = 0; 963 undef $@; 964#::logDebug("cond: base=$base term=$term op=$operator comp=$comp newcomp=$newcomp nooop=$noop\n"); 965#::logDebug (($reverse ? '!' : '') . "cond: base=$base term=$term op=$operator comp=$comp"); 966 967#::logDebug ("cond: base=$base term=$term op=$operator comp=$comp\n"); 968 969 my $total; 970 if($base eq 'total') { 971 $base = $term; 972 $total = 1; 973 } 974 975 if($base eq 'session') { 976 $op = qq%$Vend::Session->{$term}%; 977 $op = "q{$op}" unless defined $noop; 978 $op .= qq% $operator $comp% 979 if defined $comp; 980 } 981 elsif($base eq 'scratch') { 982 $op = qq%$::Scratch->{$term}%; 983 $op = "q{$op}" unless defined $noop; 984 $op .= qq% $operator $comp% 985 if defined $comp; 986 } 987 elsif($base eq 'scratchd') { 988 $op = qq%$::Scratch->{$term}%; 989 $op = "q{$op}" unless defined $noop; 990 $op .= qq% $operator $comp% 991 if defined $comp; 992 delete $::Scratch->{$term}; 993 } 994 elsif($base =~ /^value/) { 995 $op = qq%$::Values->{$term}%; 996 $op = "q{$op}" unless defined $noop; 997 $op .= qq% $operator $comp% 998 if defined $comp; 999 } 1000 elsif($base eq 'cgi') { 1001 $op = qq%$CGI::values{$term}%; 1002 $op = "q{$op}" unless defined $noop; 1003 $op .= qq% $operator $comp% 1004 if defined $comp; 1005 } 1006 elsif($base eq 'pragma') { 1007 $op = qq%$::Pragma->{$term}%; 1008 $op = "q{$op}" unless defined $noop; 1009 $op .= qq% $operator $comp% 1010 if defined $comp; 1011 } 1012 elsif($base eq 'explicit') { 1013 undef $noop; 1014 $status = $ready_safe->reval($comp); 1015 } 1016 elsif($base =~ /^var(?:iable)?$/) { 1017 $op = qq%$::Variable->{$term}%; 1018 $op = "q{$op}" unless defined $noop; 1019 $op .= qq% $operator $comp% 1020 if defined $comp; 1021 } 1022 elsif($base eq 'global') { 1023 $op = qq%$Global::Variable->{$term}%; 1024 $op = "q{$op}" unless defined $noop; 1025 $op .= qq% $operator $comp% 1026 if defined $comp; 1027 } 1028 elsif($base eq 'items') { 1029 my $cart; 1030 if($term) { 1031 $cart = $::Carts->{$term} || undef; 1032 } 1033 else { 1034 $cart = $Vend::Items; 1035 } 1036 $op = defined $cart ? scalar @{$cart} : 0; 1037 1038 $op .= qq% $operator $comp% 1039 if defined $comp; 1040 } 1041 elsif($base eq 'data') { 1042 my($d,$f,$k) = split /::/, $term, 3; 1043 $op = database_field($d,$k,$f); 1044#::logDebug ("tag_if db=$d fld=$f key=$k\n"); 1045 $op = "q{$op}" unless defined $noop; 1046 $op .= qq% $operator $comp% 1047 if defined $comp; 1048 } 1049 elsif($base eq 'field') { 1050 my($f,$k) = split /::/, $term; 1051 $op = product_field($f,$k); 1052#::logDebug("tag_if field fld=$f key=$k\n"); 1053 $op = "q{$op}" unless defined $noop; 1054 $op .= qq% $operator $comp% 1055 if defined $comp; 1056 } 1057 elsif($base eq 'discount') { 1058 # Use switch_discount_space to ensure that the hash is set properly. 1059 switch_discount_space($Vend::DiscountSpaceName) 1060 unless ref $::Discounts eq 'HASH'; 1061 $op = qq%$::Discounts->{$term}%; 1062 $op = "q{$op}" unless defined $noop; 1063 $op .= qq% $operator $comp% 1064 if defined $comp; 1065 } 1066 elsif($base eq 'ordered') { 1067 $operator = 'main' unless $operator; 1068 my ($attrib, $i); 1069 $op = ''; 1070 unless ($comp) { 1071 $attrib = 'quantity'; 1072 } 1073 else { 1074 ($attrib,$comp) = split /\s+/, $comp; 1075 } 1076 foreach $i (@{$::Carts->{$operator}}) { 1077 next unless $i->{code} eq $term; 1078 ($op++, next) if $attrib eq 'lines'; 1079 $op = $i->{$attrib}; 1080 last; 1081 } 1082 $op = "q{$op}" unless defined $noop; 1083 $op .= qq% $comp% if $comp; 1084 } 1085 elsif($base =~ /^file(-([A-Za-z]))?$/) { 1086 #$op =~ s/[^rwxezfdTsB]//g; 1087 #$op = substr($op,0,1) || 'f'; 1088 my $fop = $2 || 'f'; 1089 if(! $file_op{$fop}) { 1090 logError("Unrecognized file test '%s'. Returning false.", $fop); 1091 $status = 0; 1092 } 1093 else { 1094 $op = $file_op{$fop}->($term); 1095 } 1096 } 1097 elsif($base =~ /^errors?$/) { 1098 my $err; 1099 if(! $term or $total) { 1100 $err = is_hash($Vend::Session->{errors}) 1101 ? scalar (keys %{$Vend::Session->{errors}}) 1102 : 0; 1103 } 1104 else { 1105 $err = is_hash($Vend::Session->{errors}) 1106 ? $Vend::Session->{errors}{$term} 1107 : 0; 1108 } 1109 $op = $err; 1110 $op .= qq% $operator $comp% 1111 if defined $comp; 1112 } 1113 elsif($base =~ /^warnings?$/) { 1114 my $warn = 0; 1115 if(my $ary = $Vend::Session->{warnings}) { 1116 ref($ary) eq 'ARRAY' and $warn = scalar(@$ary); 1117 } 1118 $op = $warn; 1119 } 1120 elsif($base eq 'validcc') { 1121 no strict 'refs'; 1122 $status = Vend::Order::validate_whole_cc($term, $operator, $comp); 1123 } 1124 elsif($base eq 'config') { 1125 my @terms = split /::|->|\./, $term; 1126 eval { 1127 $op = $Vend::Cfg; 1128 while(my $t = shift(@terms)) { 1129 $op = $op->{$t}; 1130 } 1131 }; 1132 1133 $op = "q{$op}" unless defined $noop; 1134 $op .= qq% $operator $comp% 1135 if defined $comp; 1136 } 1137 elsif($base =~ /^module.version/) { 1138 eval { 1139 no strict 'refs'; 1140 $op = ${"${term}::VERSION"}; 1141 $op = "q{$op}" unless defined $noop; 1142 $op .= qq% $operator $comp% 1143 if defined $comp; 1144 }; 1145 } 1146 elsif($base =~ /^accessor/) { 1147 if ($comp) { 1148 $op = qq%$Vend::Cfg->{Accessories}->{$term}%; 1149 $op = "q{$op}" unless defined $noop; 1150 $op .= qq% $operator $comp%; 1151 } 1152 else { 1153 for(@{$Vend::Cfg->{UseModifier}}) { 1154 next unless product_field($_,$term); 1155 $status = 1; 1156 last; 1157 } 1158 } 1159 } 1160 elsif($base eq 'control') { 1161 $op = 0; 1162 if (defined $::Scratch->{control_index} 1163 and defined $::Control->[$Scratch->{control_index}]) { 1164 $op = qq%$::Control->[$::Scratch->{control_index}]{$term}%; 1165 $op = "q{$op}" 1166 unless defined $noop; 1167 $op .= qq% $operator $comp% 1168 if defined $comp; 1169 } 1170 } 1171 elsif($base eq 'env') { 1172 my $env; 1173 if (my $h = ::http()) { 1174 $env = $h->{env}; 1175 } 1176 else { 1177 $env = \%ENV; 1178 } 1179 $op = qq%$env->{$term}%; 1180 $op = "q{$op}" unless defined $noop; 1181 $op .= qq% $operator $comp% 1182 if defined $comp; 1183 } 1184 else { 1185 $op = qq%$term%; 1186 $op = "q{$op}" unless defined $noop; 1187 $op .= qq% $operator $comp% 1188 if defined $comp; 1189 } 1190 1191#::logDebug("noop='$noop' op='$op'"); 1192 1193 RUNSAFE: { 1194 last RUNSAFE if defined $status; 1195 1196 if($sub) { 1197 $status = $sub->($op, $newcomp); 1198 last RUNSAFE; 1199 } 1200 elsif ($noop) { 1201 $status = $op ? 1 : 0; 1202 last RUNSAFE; 1203 } 1204 1205 Vend::CharSet->utf8_safe_regex_workaround($ready_safe) 1206 if $::Variable->{MV_UTF8}; 1207 $ready_safe->trap(@{$Global::SafeTrap}); 1208 $ready_safe->untrap(@{$Global::SafeUntrap}); 1209 $status = $ready_safe->reval($op) ? 1 : 0; 1210 if ($@) { 1211 logError "Bad if '@_': $@"; 1212 $status = 0; 1213 } 1214 } 1215 1216 $status = $reverse ? ! $status : $status; 1217 1218 for(@addl) { 1219 my $chain = /^\[[Aa]/; 1220 last if ($chain ^ $status); 1221 $status = ${(new Vend::Parse)->parse($_)->{OUT}} ? 1 : 0; 1222 } 1223#::logDebug("if status=$status"); 1224 1225 return $status; 1226} 1227 1228sub find_close_square { 1229 my $chunk = shift; 1230 my $first = index($chunk, ']'); 1231 return undef if $first < 0; 1232 my $int = index($chunk, '['); 1233 my $pos = 0; 1234 while( $int > -1 and $int < $first) { 1235 $pos = $int + 1; 1236 $first = index($chunk, ']', $first + 1); 1237 $int = index($chunk, '[', $pos); 1238 } 1239 return substr($chunk, 0, $first); 1240} 1241 1242sub find_andor { 1243 my($text) = @_; 1244 return undef 1245 unless $$text =~ s# \s* \[ 1246 ( (?:[Aa][Nn][Dd]|[Oo][Rr]) \s+ 1247 $All) 1248 #$1#x; 1249 my $expr = find_close_square($$text); 1250 return undef unless defined $expr; 1251 $$text = substr( $$text,length($expr) + 1 ); 1252 return "[$expr]"; 1253} 1254 1255sub split_if { 1256 my ($body) = @_; 1257 1258 my ($then, $else, $elsif, $andor, @addl); 1259 $else = $elsif = ''; 1260 1261 push (@addl, $andor) while $andor = find_andor(\$body); 1262 1263 $body =~ s#$QR{then}##o 1264 and $then = $1; 1265 1266 $body =~ s#$QR{has_else}##o 1267 and $else = find_matching_else(\$body); 1268 1269 $body =~ s#$QR{elsif_end}##o 1270 and $elsif = $1; 1271 1272 $body = $then if defined $then; 1273 1274 return($body, $elsif, $else, @addl); 1275} 1276 1277sub tag_if { 1278 my ($cond,$body,$negate) = @_; 1279#::logDebug("Called tag_if: $cond\n$body\n"); 1280 my ($base, $term, $op, $operator, $comp); 1281 my ($else, $elsif, $else_present, @addl); 1282 1283 ($base, $term, $operator, $comp) = split /\s+/, $cond, 4; 1284 if ($base eq 'explicit') { 1285 $body =~ s#$QR{condition_begin}##o 1286 and ($comp = $1, $operator = ''); 1287 } 1288#::logDebug("tag_if: base=$base term=$term op=$operator comp=$comp"); 1289 1290 #Handle unless 1291 ($base =~ s/^\W+// or $base = "!$base") if $negate; 1292 1293 $else_present = 1 if 1294 $body =~ /\[[EeTtAaOo][hHLlNnRr][SsEeDd\s]/; 1295 1296 ($body, $elsif, $else, @addl) = split_if($body) 1297 if $else_present; 1298 1299#::logDebug("Additional ops found:\n" . join("\n", @addl) ) if @addl; 1300 1301 unless(defined $operator) { 1302 undef $operator; 1303 undef $comp; 1304 } 1305 1306 my $status = conditional ($base, $term, $operator, $comp, @addl); 1307 1308#::logDebug("Result of if: $status\n"); 1309 1310 my $out; 1311 if($status) { 1312 $out = $body; 1313 } 1314 elsif ($elsif) { 1315 $else = '[else]' . $else . '[/else]' if length $else; 1316 my $pertinent = Vend::Parse::find_matching_end('elsif', \$elsif); 1317 unless(defined $pertinent) { 1318 $pertinent = $elsif; 1319 $elsif = ''; 1320 } 1321 $elsif .= '[/elsif]' if $elsif =~ /\S/; 1322 $out = '[if ' . $pertinent . $elsif . $else . '[/if]'; 1323 } 1324 elsif (length $else) { 1325 $out = $else; 1326 } 1327 return $out; 1328} 1329 1330# This generates a *session-based* Autoload routine based 1331# on the contents of a preset Profile (see the Profile directive). 1332# 1333# Normally used for setting pricing profiles with CommonAdjust, 1334# ProductFiles, etc. 1335# 1336sub restore_profile { 1337 my $save; 1338 return unless $save = $Vend::Session->{Profile_save}; 1339 for(keys %$save) { 1340 $Vend::Cfg->{$_} = $save->{$_}; 1341 } 1342 return; 1343} 1344 1345sub tag_profile { 1346 my($profile, $opt) = @_; 1347#::logDebug("in tag_profile=$profile opt=" . uneval_it($opt)); 1348 1349 $opt = {} if ! $opt; 1350 my $tag = $opt->{tag} || 'default'; 1351 1352 if(! $profile) { 1353 if($opt->{restore}) { 1354 restore_profile(); 1355 if(ref $Vend::Session->{Autoload}) { 1356 @{$Vend::Session->{Autoload}} = 1357 grep $_ !~ /^$tag-/, @{$Vend::Session->{Autoload}}; 1358 } 1359 } 1360 return if ! ref $Vend::Session->{Autoload}; 1361 $opt->{joiner} = ' ' unless defined $opt->{joiner}; 1362 return join $opt->{joiner}, 1363 grep /^\w+-\w+$/, @{ $Vend::Session->{Autoload} }; 1364 } 1365 1366 if($profile =~ s/(\w+)-//) { 1367 $opt->{tag} = $1; 1368 $opt->{run} = 1; 1369 } 1370 elsif (! $opt->{set} and ! $opt->{run}) { 1371 $opt->{set} = $opt->{run} = 1; 1372 } 1373 1374 if( "$profile$tag" =~ /\W/ ) { 1375 logError( 1376 "profile: invalid characters (tag=%s profile=%s), must be [A-Za-z_]+", 1377 $tag, 1378 $profile, 1379 ); 1380 return $opt->{failure}; 1381 } 1382 1383 if($opt->{run}) { 1384#::logDebug("running profile=$profile tag=$tag"); 1385 my $prof = $Vend::Cfg->{Profile_repository}{$profile}; 1386 if (not $prof) { 1387 logError( "profile %s (%s) non-existant.", $profile, $tag ); 1388 return $opt->{failure}; 1389 } 1390#::logDebug("found profile=$profile"); 1391 $Vend::Cfg->{Profile} = $prof; 1392 restore_profile(); 1393#::logDebug("restored profile"); 1394 PROFSET: 1395 for my $one (keys %$prof) { 1396#::logDebug("doing profile $one"); 1397 next unless defined $Vend::Cfg->{$one}; 1398 my $string; 1399 my $val = $prof->{$one}; 1400 if( ! ref $Vend::Cfg->{$one} ) { 1401 # Do nothing 1402 } 1403 elsif( ref($Vend::Cfg->{$one}) eq 'HASH') { 1404 if( ref($val) ne 'HASH') { 1405 $string = '{' . $prof->{$one} . '}' 1406 unless $prof->{$one} =~ /^{/ 1407 and $prof->{$one} =~ /}\s*$/; 1408 } 1409 } 1410 elsif( ref($Vend::Cfg->{$one}) eq 'ARRAY') { 1411 if( ref($val) ne 'ARRAY') { 1412 $string = '[' . $prof->{$one} . ']' 1413 unless $prof->{$one} =~ /^\[/ 1414 and $prof->{$one} =~ /]\s*$/; 1415 } 1416 } 1417 else { 1418 logError( "profile: cannot handle object of type %s.", 1419 $Vend::Cfg->{$one}, 1420 ); 1421 logError("profile: profile for $one not changed."); 1422 next; 1423 } 1424 1425#::logDebug("profile value=$val, string=$string"); 1426 undef $@; 1427 $val = $ready_safe->reval($string) if $string; 1428 1429 if($@) { 1430 logError( "profile: bad object %s: %s", $one, $string ); 1431 next; 1432 } 1433 $Vend::Session->{Profile_save}{$one} = $Vend::Cfg->{$one} 1434 unless defined $Vend::Session->{Profile_save}{$one}; 1435 1436#::logDebug("set $one to value=$val, string=$string"); 1437 $Vend::Cfg->{$one} = $val; 1438 } 1439 return $opt->{success} 1440 unless $opt->{set}; 1441 } 1442 1443#::logDebug("setting profile=$profile tag=$tag"); 1444 my $al; 1445 if(! $Vend::Session->{Autoload}) { 1446 # Do nothing.... 1447 } 1448 elsif(ref $Vend::Session->{Autoload}) { 1449 $al = $Vend::Session->{Autoload}; 1450 } 1451 else { 1452 $al = [ $Vend::Session->{Autoload} ]; 1453 } 1454 1455 if($al) { 1456 @$al = grep $_ !~ m{^$tag-\w+$}, @$al; 1457 } 1458 $al = [] if ! $al; 1459 push @$al, "$tag-$profile"; 1460#::logDebug("profile=$profile Autoload=" . uneval_it($al)); 1461 $Vend::Session->{Autoload} = $al; 1462 1463 return $opt->{success}; 1464} 1465 1466*tag_options = \&Vend::Options::tag_options; 1467 1468sub produce_range { 1469 my ($ary, $max) = @_; 1470 $max = $::Limit->{option_list} if ! $max; 1471 my @do; 1472 for (my $i = 0; $i < scalar(@$ary); $i++) { 1473 $ary->[$i] =~ /^\s* ([a-zA-Z0-9]+) \s* \.\.+ \s* ([a-zA-Z0-9]+) \s* $/x 1474 or next; 1475 my @new = $1 .. $2; 1476 if(@new > $max) { 1477 logError( 1478 "Refuse to add %d options to option list via range, max %d.", 1479 scalar(@new), 1480 $max, 1481 ); 1482 next; 1483 } 1484 push @do, $i, \@new; 1485 } 1486 my $idx; 1487 my $new; 1488 while($new = pop(@do)) { 1489 my $idx = pop(@do); 1490 splice @$ary, $idx, 1, @$new; 1491 } 1492 return; 1493} 1494 1495sub tag_accessories { 1496 my($code,$extra,$opt,$item) = @_; 1497 1498 my $ishash; 1499 if(ref $item) { 1500#::logDebug("tag_accessories: item is a hash"); 1501 $ishash = 1; 1502 } 1503 1504 # Had extra if got here 1505#::logDebug("tag_accessories: code=$code opt=" . uneval_it($opt) . " item=" . uneval_it($item) . " extra=$extra"); 1506 my($attribute, $type, $field, $db, $name, $outboard, $passed); 1507 $opt = {} if ! $opt; 1508 if($extra) { 1509 $extra =~ s/^\s+//; 1510 $extra =~ s/\s+$//; 1511 @{$opt}{qw/attribute type column table name outboard passed/} = 1512 split /\s*,\s*/, $extra; 1513 } 1514 ($attribute, $type, $field, $db, $name, $outboard, $passed) = 1515 @{$opt}{qw/attribute type column table name outboard passed/}; 1516 1517 ## Code only passed when we are a product 1518 if($code) { 1519 GETACC: { 1520 my $col = $opt->{column} || $opt->{attribute}; 1521 my $key = $opt->{outboard} || $code; 1522 last GETACC if ! $col; 1523 if($opt->{table}) { 1524 $opt->{passed} ||= tag_data($opt->{table}, $col, $key); 1525 } 1526 else { 1527 $opt->{passed} ||= product_field($col, $key); 1528 } 1529 } 1530 1531 return unless $opt->{passed} || $opt->{type}; 1532 $opt->{type} ||= 'select'; 1533 return unless 1534 $opt->{passed} 1535 or 1536 $opt->{type} =~ /^(text|password|hidden)/i; 1537 } 1538 1539 return Vend::Form::display($opt, $item); 1540} 1541 1542# MVASP 1543 1544sub mvasp { 1545 my ($tables, $opt, $text) = @_; 1546 my @code; 1547 $opt->{no_return} = 1 unless defined $opt->{no_return}; 1548 1549 while ( $text =~ s/(.*?)<%//s || $text =~ s/(.+)//s ) { 1550 push @code, <<EOF; 1551; my \$html = <<'_MV_ASP_EOF$^T'; 1552$1 1553_MV_ASP_EOF$^T 1554chop(\$html); 1555 HTML( \$html ); 1556EOF 1557 $text =~ s/(.*?)%>//s 1558 or last;; 1559 my $bit = $1; 1560 if ($bit =~ s/^\s*=\s*//) { 1561 $bit =~ s/;\s*$//; 1562 push @code, "; HTML( $bit );" 1563 } 1564 else { 1565 push @code, $bit, ";\n"; 1566 } 1567 } 1568 my $asp = join "", @code; 1569#::logDebug("ASP CALL:\n$asp\n"); 1570 return tag_perl ($tables, $opt, $asp); 1571} 1572 1573# END MVASP 1574 1575$safe_safe = new Safe; 1576 1577sub tag_perl { 1578 my ($tables, $opt,$body) = @_; 1579 my ($result,@share); 1580#::logDebug("tag_perl MVSAFE=$MVSAFE::Safe opts=" . uneval($opt)); 1581 1582 if($Vend::NoInterpolate) { 1583 logGlobal({ level => 'alert' }, 1584 "Attempt to interpolate perl/ITL from RPC, no permissions." 1585 ); 1586 return undef; 1587 } 1588 1589 if ($MVSAFE::Safe) { 1590#::logDebug("tag_perl: Attempt to call perl from within Safe."); 1591 return undef; 1592 } 1593 1594#::logDebug("tag_perl: tables=$tables opt=" . uneval($opt) . " body=$body"); 1595#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts)); 1596 if($opt->{subs} or $opt->{arg} =~ /\bsub\b/) { 1597 no strict 'refs'; 1598 for(keys %{$Global::GlobalSub}) { 1599#::logDebug("tag_perl share subs: GlobalSub=$_"); 1600 next if defined $Global::AdminSub->{$_} 1601 and ! $Global::AllowGlobal->{$Vend::Cat}; 1602 *$_ = \&{$Global::GlobalSub->{$_}}; 1603 push @share, "&$_"; 1604 } 1605 for(keys %{$Vend::Cfg->{Sub} || {}}) { 1606#::logDebug("tag_perl share subs: Sub=$_"); 1607 *$_ = \&{$Vend::Cfg->{Sub}->{$_}}; 1608 push @share, "&$_"; 1609 } 1610 } 1611 1612 if($tables) { 1613 my (@tab) = grep /\S/, split /\s+/, $tables; 1614 foreach my $tab (@tab) { 1615 next if $Db{$tab}; 1616 my $db = database_exists_ref($tab); 1617 next unless $db; 1618 my $dbh; 1619 $db = $db->ref(); 1620 if($db->config('type') == 10) { 1621 my @extra_tabs = $db->_shared_databases(); 1622 push (@tab, @extra_tabs); 1623 $dbh = $db->dbh(); 1624 } elsif ($db->can('dbh')) { 1625 $dbh = $db->dbh(); 1626 } 1627 1628 if($hole) { 1629 if ($dbh) { 1630 $Sql{$tab} = $hole->wrap($dbh); 1631 } 1632 $Db{$tab} = $hole->wrap($db); 1633 if($db->config('name') ne $tab) { 1634 $Db{$db->config('name')} = $Db{$tab}; 1635 } 1636 } 1637 else { 1638 $Sql{$tab} = $db->[$Vend::Table::DBI::DBI] 1639 if $db =~ /::DBI/; 1640 $Db{$tab} = $db; 1641 } 1642 } 1643 } 1644 1645 $Tag = $hole->wrap($Tag) if $hole and ! $Vend::TagWrapped++; 1646 1647 init_calc() if ! $Vend::Calc_initialized; 1648 $ready_safe->share(@share) if @share; 1649 1650 if($Vend::Cfg->{Tie_Watch}) { 1651 eval { 1652 for(@{$Vend::Cfg->{Tie_Watch}}) { 1653 logGlobal("touching $_"); 1654 my $junk = $Config->{$_}; 1655 } 1656 }; 1657 } 1658 1659 $Items = $Vend::Items; 1660 1661 $body = readfile($opt->{file}) . $body 1662 if $opt->{file}; 1663 1664 # Skip costly eval of code entirely if perl tag was called with no code, 1665 # likely used only for the side-effect of opening database handles 1666 return if $body !~ /\S/; 1667 1668 $body =~ tr/\r//d if $Global::Windows; 1669 1670 $MVSAFE::Safe = 1; 1671 if ( 1672 $opt->{global} 1673 and 1674 $Global::AllowGlobal->{$Vend::Cat} 1675 ) 1676 { 1677 $MVSAFE::Safe = 0 unless $MVSAFE::Unsafe; 1678 } 1679 1680 if(! $MVSAFE::Safe) { 1681 $result = eval($body); 1682 } 1683 else { 1684 $result = $ready_safe->reval($body); 1685 } 1686 1687 undef $MVSAFE::Safe; 1688 1689 if ($@) { 1690#::logDebug("tag_perl failed $@"); 1691 my $msg = $@; 1692 if($Vend::Try) { 1693 $Vend::Session->{try}{$Vend::Try} .= "\n" 1694 if $Vend::Session->{try}{$Vend::Try}; 1695 $Vend::Session->{try}{$Vend::Try} .= $@; 1696 } 1697 if($opt->{number_errors}) { 1698 my @lines = split("\n",$body); 1699 my $counter = 1; 1700 map { $_ = sprintf("% 4d %s",$counter++,$_); } @lines; 1701 $body = join("\n",@lines); 1702 } 1703 if($opt->{trim_errors}) { 1704 if($msg =~ /line (\d+)\.$/) { 1705 my @lines = split("\n",$body); 1706 my $start = $1 - $opt->{trim_errors} - 1; 1707 my $length = (2 * $opt->{trim_errors}) + 1; 1708 @lines = splice(@lines,$start,$length); 1709 $body = join("\n",@lines); 1710 } 1711 } 1712 if($opt->{eval_label}) { 1713 $msg =~ s/\(eval \d+\)/($opt->{eval_label})/g; 1714 } 1715 if($opt->{short_errors}) { 1716 chomp($msg); 1717 logError( "Safe: %s" , $msg ); 1718 logGlobal({ level => 'debug' }, "Safe: %s" , $msg ); 1719 } else { 1720 logError( "Safe: %s\n%s\n" , $msg, $body ); 1721 logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body ); 1722 } 1723 return $opt->{failure}; 1724 } 1725#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts)); 1726 1727 if ($opt->{no_return}) { 1728 $Vend::Session->{mv_perl_result} = $result; 1729 $result = join "", @Vend::Document::Out; 1730 @Vend::Document::Out = (); 1731 } 1732#::logDebug("tag_perl succeeded result=$result\nEND"); 1733 return $result; 1734} 1735 1736sub ed { 1737 return $_[0] if ! $_[0] or $Safe_data or $::Pragma->{safe_data}; 1738 $_[0] =~ s/\[/[/g; 1739 return $_[0]; 1740} 1741 1742sub show_tags { 1743 my($type, $opt, $text) = @_; 1744 1745 $type = 'html interchange' unless $type; 1746 $type =~ s/minivend/interchange/g; 1747 1748 if ($type =~ /interchange/i) { 1749 $text =~ s/\[/[/g; 1750 } 1751 if($type =~ /html/i) { 1752 $text =~ s/\</</g; 1753 } 1754 return $text; 1755} 1756 1757sub pragma { 1758 my($pragma, $opt, $text) = @_; 1759 $pragma =~ s/\W+//g; 1760 1761 my $value = defined $opt->{value} ? $opt->{value} : 1; 1762 if(! defined $opt->{value} and $text =~ /\S/) { 1763 $value = $text; 1764 } 1765 1766 $::Pragma->{$pragma} = $value; 1767 return; 1768} 1769 1770sub flag { 1771 my($flag, $opt, $text) = @_; 1772 $flag = lc $flag; 1773 1774 if(! $text) { 1775 ($flag, $text) = split /\s+/, $flag; 1776 } 1777 my $value = defined $opt->{value} ? $opt->{value} : 1; 1778 my $fmt = $opt->{status} || ''; 1779 my @status; 1780 1781#::logDebug("tag flag=$flag text=$text value=$value opt=". uneval_it($opt)); 1782 if($flag eq 'write' || $flag eq 'read') { 1783 my $arg = $opt->{table} || $text; 1784 $value = 0 if $flag eq 'read'; 1785 my (@args) = Text::ParseWords::shellwords($arg); 1786 my $dbname; 1787 foreach $dbname (@args) { 1788 # Handle table:column:key 1789 $dbname =~ s/:.*//; 1790#::logDebug("tag flag write $dbname=$value"); 1791 $Vend::WriteDatabase{$dbname} = $value; 1792 } 1793 } 1794 elsif($flag =~ /^transactions?/i) { 1795 my $arg = $opt->{table} || $text; 1796 my (@args) = Text::ParseWords::shellwords($arg); 1797 my $dbname; 1798 foreach $dbname (@args) { 1799 # Handle table:column:key 1800 $dbname =~ s/:.*//; 1801 $Vend::TransactionDatabase{$dbname} = $value; 1802 $Vend::WriteDatabase{$dbname} = $value; 1803 1804 # we can't do anything else if in Safe 1805 next if $MVSAFE::Safe; 1806 1807 # Now we close and reopen 1808 my $db = database_exists_ref($dbname) 1809 or next; 1810 if($db->isopen()) { 1811 # need to reopen in transactions mode. 1812 $db->close_table(); 1813 $db->suicide(); 1814 $db = database_exists_ref($dbname); 1815 $db = $db->ref(); 1816 } 1817 $Db{$dbname} = $db; 1818 $Sql{$dbname} = $db->dbh() 1819 if $db->can('dbh'); 1820 } 1821 } 1822 elsif($flag eq 'commit' || $flag eq 'rollback') { 1823 my $arg = $opt->{table} || $text; 1824 $value = 0 if $flag eq 'rollback'; 1825 my $method = $value ? 'commit' : 'rollback'; 1826 my (@args) = Text::ParseWords::shellwords($arg); 1827 my $dbname; 1828 foreach $dbname (@args) { 1829 # Handle table:column:key 1830 $dbname =~ s/:.*//; 1831#::logDebug("tag commit $dbname=$value"); 1832 my $db = database_exists_ref($dbname); 1833 next unless $db->isopen(); 1834 next unless $db->config('Transactions'); 1835 if( ! $db ) { 1836 logError("attempt to $method on unknown database: %s", $dbname); 1837 return undef; 1838 } 1839 if( ! $db->$method() ) { 1840 logError("problem doing $method for table: %s", $dbname); 1841 return undef; 1842 } 1843 } 1844 } 1845 elsif($flag eq 'checkhtml') { 1846 $Vend::CheckHTML = $value; 1847 @status = ("Set CheckHTML flag: %s", $value); 1848 } 1849 else { 1850 @status = ("Unknown flag operation '%s', ignored.", $flag); 1851 $status[0] = $opt->{status} if $opt->{status}; 1852 logError( @status ); 1853 } 1854 return '' unless $opt->{show}; 1855 $status[0] = $opt->{status} if $opt->{status}; 1856 return errmsg(@status); 1857} 1858 1859sub tag_export { 1860 my ($args, $opt, $text) = @_; 1861 $opt->{base} = $opt->{table} || $opt->{database} || undef 1862 unless defined $opt->{base}; 1863 unless (defined $opt->{base}) { 1864 @{$opt}{ qw/base file type/ } = split /\s+/, $args; 1865 } 1866 if($opt->{delete}) { 1867 undef $opt->{delete} unless $opt->{verify}; 1868 } 1869#::logDebug("exporting " . join (",", @{$opt}{ qw/base file type field delete/ })); 1870 my $status = Vend::Data::export_database( 1871 @{$opt}{ qw/base file type/ }, $opt, 1872 ); 1873 return $status unless $opt->{hide}; 1874 return ''; 1875} 1876 1877sub export { 1878 my ($table, $opt, $text) = @_; 1879 if($opt->{delete}) { 1880 undef $opt->{delete} unless $opt->{verify}; 1881 } 1882#::logDebug("exporting " . join (",", @{$opt}{ qw/table file type field delete/ })); 1883 my $status = Vend::Data::export_database( 1884 @{$opt}{ qw/table file type/ }, $opt, 1885 ); 1886 return $status unless $opt->{hide}; 1887 return ''; 1888} 1889 1890sub mime { 1891 my ($option, $opt, $text) = @_; 1892 my $id; 1893 1894 my $out; 1895 1896#::logDebug("mime call, opt=" . uneval($opt)); 1897 $Vend::TIMESTAMP = POSIX::strftime("%y%m%d%H%M%S", localtime()) 1898 unless defined $Vend::TIMESTAMP; 1899 1900 $::Instance->{MIME_BOUNDARY} = 1901 $::Instance->{MIME_TIMESTAMP} . '-' . 1902 $Vend::SessionID . '-' . 1903 $Vend::Session->{pageCount} . 1904 ':=' . $$ 1905 unless defined $::Instance->{MIME_BOUNDARY}; 1906 1907 my $msg_type = $opt->{type} || "multipart/mixed"; 1908 if($option eq 'reset') { 1909 undef $::Instance->{MIME_TIMESTAMP}; 1910 undef $::Instance->{MIME_BOUNDARY}; 1911 $out = ''; 1912 } 1913 elsif($option eq 'boundary') { 1914 $out = "--$::Instance->{MIME_BOUNDARY}"; 1915 } 1916 elsif($option eq 'id') { 1917 $::Instance->{MIME} = 1; 1918 $out = _mime_id(); 1919 } 1920 elsif($option eq 'header') { 1921 $id = _mime_id(); 1922 $out = <<EndOFmiMe; 1923MIME-Version: 1.0 1924Content-Type: $msg_type; BOUNDARY="$::Instance->{MIME_BOUNDARY}" 1925Content-ID: $id 1926EndOFmiMe 1927 } 1928 elsif ( $text !~ /\S/) { 1929 $out = ''; 1930 } 1931 else { 1932 $id = _mime_id(); 1933 $::Instance->{MIME} = 1; 1934 my $desc = $opt->{description} || $option; 1935 my $type = $opt->{type} || 'text/plain; charset=US-ASCII'; 1936 my $disposition = $opt->{attach_only} 1937 ? qq{attachment; filename="$desc"} 1938 : "inline"; 1939 my $encoding = $opt->{transfer_encoding}; 1940 my @headers; 1941 push @headers, "Content-Type: $type"; 1942 push @headers, "Content-ID: $id"; 1943 push @headers, "Content-Disposition: $disposition"; 1944 push @headers, "Content-Description: $desc"; 1945 push @headers, "Content-Transfer-Encoding: $opt->{transfer_encoding}" 1946 if $opt->{transfer_encoding}; 1947 my $head = join "\n", @headers; 1948 $out = <<EndOFmiMe; 1949--$::Instance->{MIME_BOUNDARY} 1950$head 1951 1952$text 1953EndOFmiMe 1954 1955 } 1956#::logDebug("tag mime returns:\n$out"); 1957 return $out; 1958} 1959 1960sub log { 1961 my($file, $opt, $data) = @_; 1962 my(@lines); 1963 my(@fields); 1964 1965 my $status; 1966 1967 $file = $opt->{file} || $Vend::Cfg->{LogFile}; 1968 if($file =~ s/^\s*>\s*//) { 1969 $opt->{create} = 1; 1970 } 1971 1972 $file = Vend::Util::escape_chars($file); 1973 unless(Vend::File::allowed_file($file)) { 1974 Vend::File::log_file_violation($file, 'log'); 1975 return undef; 1976 } 1977 1978 $file = ">$file" if $opt->{create}; 1979 1980 unless($opt->{process} and $opt->{process} =~ /\bnostrip\b/i) { 1981 $data =~ s/\r\n/\n/g; 1982 $data =~ s/^\s+//; 1983 $data =~ s/\s+$/\n/; 1984 } 1985 1986 my ($delim, $record_delim); 1987 for(qw/delim record_delim/) { 1988 next unless defined $opt->{$_}; 1989 $opt->{$_} = $ready_safe->reval(qq{$opt->{$_}}); 1990 } 1991 1992 if($opt->{type}) { 1993 if($opt->{type} =~ /^text/) { 1994 $status = Vend::Util::writefile($file, $data, $opt); 1995 } 1996 elsif($opt->{type} =~ /^\s*quot/) { 1997 $record_delim = $opt->{record_delim} || "\n"; 1998 @lines = split /$record_delim/, $data; 1999 for(@lines) { 2000 @fields = Text::ParseWords::shellwords $_; 2001 $status = logData($file, @fields) 2002 or last; 2003 } 2004 } 2005 elsif($opt->{type} =~ /^(?:error|debug)/) { 2006 if ($opt->{file}) { 2007 $data = format_log_msg($data) unless $data =~ s/^\\//;; 2008 $status = Vend::Util::writefile($file, $data, $opt); 2009 } 2010 elsif ($opt->{type} =~ /^debug/) { 2011 $status = Vend::Util::logDebug($data); 2012 } 2013 else { 2014 $status = Vend::Util::logError($data); 2015 } 2016 } 2017 } 2018 else { 2019 $record_delim = $opt->{record_delim} || "\n"; 2020 $delim = $opt->{delimiter} || "\t"; 2021 @lines = split /$record_delim/, $data; 2022 for(@lines) { 2023 @fields = split /$delim/, $_; 2024 $status = logData($file, @fields) 2025 or last; 2026 } 2027 } 2028 2029 return $status unless $opt->{hide}; 2030 return ''; 2031} 2032 2033sub _mime_id { 2034 '<Interchange.' . $::VERSION . '.' . 2035 $Vend::TIMESTAMP . '.' . 2036 $Vend::SessionID . '.' . 2037 ++$Vend::Session->{pageCount} . '@' . 2038 $Vend::Cfg->{VendURL} . '>'; 2039} 2040 2041sub http_header { 2042 shift; 2043 my ($opt, $text) = @_; 2044 $text =~ s/^\s+//; 2045 if($opt->{name}) { 2046 my $name = lc $opt->{name}; 2047 $name =~ s/-/_/g; 2048 $name =~ s/\W+//g; 2049 $name =~ tr/_/-/s; 2050 $name =~ s/(\w+)/\u$1/g; 2051 my $content = $opt->{content} || $text; 2052 $content =~ s/^\s+//; 2053 $content =~ s/\s+$//; 2054 $content =~ s/[\r\n]/; /g; 2055 $text = "$name: $content"; 2056 } 2057 if($Vend::StatusLine and ! $opt->{replace}) { 2058 $Vend::StatusLine =~ s/\s*$/\r\n/; 2059 $Vend::StatusLine .= $text; 2060 } 2061 else { 2062 $Vend::StatusLine = $text; 2063 } 2064 return $text if $opt->{show}; 2065 return ''; 2066} 2067 2068sub mvtime { 2069 my ($locale, $opt, $fmt) = @_; 2070 my $current; 2071 2072 if($locale) { 2073 $current = POSIX::setlocale(&POSIX::LC_TIME); 2074 POSIX::setlocale(&POSIX::LC_TIME, $locale); 2075 } 2076 2077 local($ENV{TZ}) = $opt->{tz} if $opt->{tz}; 2078 2079 my $now = $opt->{time} || time(); 2080 $fmt = '%Y%m%d' if $opt->{sortable}; 2081 2082 if($opt->{adjust}) { 2083 my $neg = $opt->{adjust} =~ s/^\s*-\s*//; 2084 my $diff; 2085 $opt->{adjust} =~ s/^\s*\+\s*//; 2086 if($opt->{hours}) { 2087 $diff = (60 * 60) * ($opt->{adjust} || $opt->{hours}); 2088 } 2089 elsif($opt->{adjust} !~ /[A-Za-z]/) { 2090 $opt->{adjust} =~ s:(\d+)(\d[05])$:$1 + $2 / 60:e; 2091 $opt->{adjust} =~ s/00$//; 2092 $diff = (60 * 60) * $opt->{adjust}; 2093 } 2094 else { 2095 $diff = Vend::Config::time_to_seconds($opt->{adjust}); 2096 } 2097 $now = $neg ? $now - $diff : $now + $diff; 2098 } 2099 2100 $fmt ||= $opt->{format} || $opt->{fmt} || '%c'; 2101 my $out = $opt->{gmt} ? ( POSIX::strftime($fmt, gmtime($now) )) 2102 : ( POSIX::strftime($fmt, localtime($now) )); 2103 $out =~ s/\b0(\d)\b/$1/g if $opt->{zerofix}; 2104 POSIX::setlocale(&POSIX::LC_TIME, $current) if defined $current; 2105 return $out; 2106} 2107 2108use vars qw/ %Tag_op_map /; 2109%Tag_op_map = ( 2110 PRAGMA => \&pragma, 2111 FLAG => \&flag, 2112 LOG => \&log, 2113 TIME => \&mvtime, 2114 HEADER => \&http_header, 2115 EXPORT => \&tag_export, 2116 TOUCH => sub {1}, 2117 EACH => sub { 2118 my $table = shift; 2119 my $opt = shift; 2120 $opt->{search} = "ra=yes\nst=db\nml=100000\nfi=$table"; 2121#::logDebug("tag each: table=$table opt=" . uneval($opt)); 2122 return tag_loop_list('', $opt, shift); 2123 }, 2124 MIME => \&mime, 2125 SHOW_TAGS => \&show_tags, 2126 ); 2127 2128sub do_tag { 2129 my $op = uc $_[0]; 2130#::logDebug("tag op: op=$op opt=" . uneval(\@_)); 2131 return $_[3] if ! defined $Tag_op_map{$op}; 2132 shift; 2133#::logDebug("tag args now: op=$op opt=" . uneval(\@_)); 2134 return &{$Tag_op_map{$op}}(@_); 2135} 2136 2137sub tag_counter { 2138 my $file = shift || 'etc/counter'; 2139 my $opt = shift; 2140#::logDebug("counter: file=$file start=$opt->{start} sql=$opt->{sql} routine=$opt->{inc_routine} caller=" . scalar(caller()) ); 2141 if($opt->{sql}) { 2142 my ($tab, $seq) = split /:+/, $opt->{sql}, 2; 2143 my $db = database_exists_ref($tab); 2144 my $dbh; 2145 my $dsn; 2146 if($opt->{bypass}) { 2147 $dsn = $opt->{dsn} || $ENV{DBI_DSN}; 2148 $dbh = DBI->connect( 2149 $dsn, 2150 $opt->{user}, 2151 $opt->{pass}, 2152 $opt->{attr}, 2153 ); 2154 } 2155 elsif($db) { 2156 $dbh = $db->dbh(); 2157 $dsn = $db->config('DSN'); 2158 } 2159 2160 my $val; 2161 2162 eval { 2163 my $diemsg = errmsg( 2164 "Counter sequence '%s' failed, using file.\n", 2165 $opt->{sql}, 2166 ); 2167 if(! $dbh) { 2168 die errmsg( 2169 "No database handle for counter sequence '%s', using file.", 2170 $opt->{sql}, 2171 ); 2172 } 2173 elsif($seq =~ /^\s*SELECT\W/i) { 2174#::logDebug("found custom SQL SELECT for sequence: $seq"); 2175 my $sth = $dbh->prepare($seq) or die $diemsg; 2176 $sth->execute or die $diemsg; 2177 ($val) = $sth->fetchrow_array; 2178 } 2179 elsif($dsn =~ /^dbi:mysql:/i) { 2180 $seq ||= $tab; 2181 $dbh->do("INSERT INTO $seq VALUES (0)") or die $diemsg; 2182 my $sth = $dbh->prepare("select LAST_INSERT_ID()") 2183 or die $diemsg; 2184 $sth->execute() or die $diemsg; 2185 ($val) = $sth->fetchrow_array; 2186 } 2187 elsif($dsn =~ /^dbi:Pg:/i) { 2188 my $sth = $dbh->prepare("select nextval('$seq')") 2189 or die $diemsg; 2190 $sth->execute() 2191 or die $diemsg; 2192 ($val) = $sth->fetchrow_array; 2193 } 2194 elsif($dsn =~ /^dbi:Oracle:/i) { 2195 my $sth = $dbh->prepare("select $seq.nextval from dual") 2196 or die $diemsg; 2197 $sth->execute() 2198 or die $diemsg; 2199 ($val) = $sth->fetchrow_array; 2200 } 2201 2202 }; 2203 2204 logOnce('error', $@) if $@; 2205 2206 return $val if defined $val; 2207 } 2208 2209 unless (allowed_file($file)) { 2210 log_file_violation ($file, 'counter'); 2211 return undef; 2212 } 2213 2214 $file = $Vend::Cfg->{VendRoot} . "/$file" 2215 unless Vend::Util::file_name_is_absolute($file); 2216 2217 for(qw/inc_routine dec_routine/) { 2218 my $routine = $opt->{$_} 2219 or next; 2220 2221 if( ! ref($routine) ) { 2222 $opt->{$_} = $Vend::Cfg->{Sub}{$routine}; 2223 $opt->{$_} ||= $Global::GlobalSub->{$routine}; 2224 } 2225 } 2226 2227 my $ctr = new Vend::CounterFile 2228 $file, 2229 $opt->{start} || undef, 2230 $opt->{date}, 2231 $opt->{inc_routine}, 2232 $opt->{dec_routine}; 2233 return $ctr->value() if $opt->{value}; 2234 return $ctr->dec() if $opt->{decrement}; 2235 return $ctr->inc(); 2236} 2237 2238# Returns the text of a user entered field named VAR. 2239sub tag_value_extended { 2240 my($var, $opt) = @_; 2241 2242 my $vspace = $opt->{values_space}; 2243 my $vref; 2244 if (defined $vspace) { 2245 if ($vspace eq '') { 2246 $vref = $Vend::Session->{values}; 2247 } 2248 else { 2249 $vref = $Vend::Session->{values_repository}{$vspace} ||= {}; 2250 } 2251 } 2252 else { 2253 $vref = $::Values; 2254 } 2255 2256 my $yes = $opt->{yes} || 1; 2257 my $no = $opt->{'no'} || ''; 2258 2259 if($opt->{test}) { 2260 $opt->{test} =~ /(?:is)?put/i 2261 and 2262 return defined $CGI::put_ref ? $yes : $no; 2263 $opt->{test} =~ /(?:is)?file/i 2264 and 2265 return defined $CGI::file{$var} ? $yes : $no; 2266 $opt->{test} =~ /defined/i 2267 and 2268 return defined $CGI::values{$var} ? $yes : $no; 2269 return length $CGI::values{$var} 2270 if $opt->{test} =~ /length|size/i; 2271 return ''; 2272 } 2273 2274 if($opt->{put_contents}) { 2275 return undef if ! defined $CGI::put_ref; 2276 return $$CGI::put_ref; 2277 } 2278 2279 my $val = $CGI::values{$var} || $vref->{$var} || return undef; 2280 $val =~ s/</</g unless $opt->{enable_html}; 2281 $val =~ s/\[/[/g unless $opt->{enable_itl}; 2282 2283 if($opt->{file_contents}) { 2284 return '' if ! defined $CGI::file{$var}; 2285 return $CGI::file{$var}; 2286 } 2287 2288 if($opt->{put_ref}) { 2289 return $CGI::put_ref; 2290 } 2291 2292 if($opt->{outfile}) { 2293 my $file = $opt->{outfile}; 2294 $file =~ s/^\s+//; 2295 $file =~ s/\s+$//; 2296 2297 unless (Vend::File::allowed_file($file)) { 2298 Vend::File::log_file_violation($file, 'value-extended'); 2299 return ''; 2300 } 2301 2302 if($opt->{ascii}) { 2303 my $replace = $^O =~ /win32/i ? "\r\n" : "\n"; 2304 if($CGI::file{$var} !~ /\n/) { 2305 # Must be a mac file. 2306 $CGI::file{$var} =~ s/\r/$replace/g; 2307 } 2308 elsif ( $CGI::file{$var} =~ /\r\n/) { 2309 # Probably a PC file 2310 $CGI::file{$var} =~ s/\r\n/$replace/g; 2311 } 2312 else { 2313 $CGI::file{$var} =~ s/\n/$replace/g; 2314 } 2315 } 2316 if($opt->{maxsize} and length($CGI::file{$var}) > $opt->{maxsize}) { 2317 logError( 2318 "Uploaded file write of %s bytes greater than maxsize %s. Aborted.", 2319 length($CGI::file{$var}), 2320 $opt->{maxsize}, 2321 ); 2322 return $no; 2323 } 2324#::logDebug(">$file \$CGI::file{$var}" . uneval($opt)); 2325 Vend::Util::writefile(">$file", \$CGI::file{$var}, $opt) 2326 and return $yes; 2327 return $no; 2328 } 2329 2330 my $joiner; 2331 if (defined $opt->{joiner}) { 2332 $joiner = $opt->{joiner}; 2333 if($joiner eq '\n') { 2334 $joiner = "\n"; 2335 } 2336 elsif($joiner =~ m{\\}) { 2337 $joiner = $ready_safe->reval("qq{$joiner}"); 2338 } 2339 } 2340 else { 2341 $joiner = ' '; 2342 } 2343 2344 my $index = defined $opt->{'index'} ? $opt->{'index'} : '*'; 2345 2346 $index = '*' if $index =~ /^\s*\*?\s*$/; 2347 2348 my @ary; 2349 if (!ref $val) { 2350 @ary = split /\0/, $val; 2351 } 2352 elsif($val =~ /ARRAY/) { 2353 @ary = @$val; 2354 } 2355 else { 2356 logError( "value-extended %s: passed non-scalar, non-array object", $var); 2357 } 2358 2359 return join " ", 0 .. $#ary if $opt->{elements}; 2360 2361 eval { 2362 @ary = @ary[$ready_safe->reval( $index eq '*' ? "0 .. $#ary" : $index )]; 2363 }; 2364 logError("value-extended $var: bad index") if $@; 2365 2366 if($opt->{filter}) { 2367 for(@ary) { 2368 $_ = filter_value($opt->{filter}, $_, $var); 2369 } 2370 } 2371 return join $joiner, @ary; 2372} 2373 2374sub format_auto_transmission { 2375 my $ref = shift; 2376 2377 ## Auto-transmission from Vend::Data::update_data 2378 ## Looking for structure like: 2379 ## 2380 ## [ '### BEGIN submission from', 'ckirk' ], 2381 ## [ 'username', 'ckirk' ], 2382 ## [ 'field2', 'value2' ], 2383 ## [ 'field1', 'value1' ], 2384 ## [ '### END submission from', 'ckirk' ], 2385 ## [ 'mv_data_fields', [ username, field1, field2 ]], 2386 ## 2387 2388 return $ref unless ref($ref); 2389 2390 my $body = ''; 2391 my %message; 2392 my $header = shift @$ref; 2393 my $fields = pop @$ref; 2394 my $trailer = pop @$ref; 2395 2396 $body .= "$header->[0]: $header->[1]\n"; 2397 2398 for my $line (@$ref) { 2399 $message{$line->[0]} = $line->[1]; 2400 } 2401 2402 my @order; 2403 if(ref $fields->[1]) { 2404 @order = @{$fields->[1]}; 2405 } 2406 else { 2407 @order = sort keys %message; 2408 } 2409 2410 for (@order) { 2411 $body .= "$_: "; 2412 if($message{$_} =~ s/\r?\n/\n/g) { 2413 $body .= "\n$message{$_}\n"; 2414 } 2415 else { 2416 $body .= $message{$_}; 2417 } 2418 $body .= "\n"; 2419 } 2420 2421 $body .= "$trailer->[0]: $trailer->[1]\n"; 2422 return $body; 2423} 2424 2425sub tag_mail { 2426 my($to, $opt, $body) = @_; 2427 my($ok); 2428 2429 my @todo = ( 2430 qw/ 2431 From 2432 To 2433 Subject 2434 Reply-To 2435 Errors-To 2436 / 2437 ); 2438 2439 my $abort; 2440 my $check; 2441 2442 my $setsub = sub { 2443 my $k = shift; 2444 return if ! defined $CGI::values{"mv_email_$k"}; 2445 $abort = 1 if ! $::Scratch->{mv_email_enable}; 2446 $check = 1 if $::Scratch->{mv_email_enable}; 2447 return $CGI::values{"mv_email_$k"}; 2448 }; 2449 2450 my @headers; 2451 my %found; 2452 2453 unless($opt->{raw}) { 2454 for my $header (@todo) { 2455 logError("invalid email header: %s", $header) 2456 if $header =~ /[^-\w]/; 2457 my $key = lc $header; 2458 $key =~ tr/-/_/; 2459 my $val = $opt->{$key} || $setsub->($key); 2460 if($key eq 'subject' and ! length($val) ) { 2461 $val = errmsg('<no subject>'); 2462 } 2463 next unless length $val; 2464 $found{$key} = $val; 2465 $val =~ s/^\s+//; 2466 $val =~ s/\s+$//; 2467 $val =~ s/[\r\n]+\s*(\S)/\n\t$1/g; 2468 push @headers, "$header: $val"; 2469 } 2470 unless($found{to} or $::Scratch->{mv_email_enable} =~ /\@/) { 2471 return 2472 error_opt($opt, "Refuse to send email message with no recipient."); 2473 } 2474 elsif (! $found{to}) { 2475 $::Scratch->{mv_email_enable} =~ s/\s+/ /g; 2476 $found{to} = $::Scratch->{mv_email_enable}; 2477 push @headers, "To: $::Scratch->{mv_email_enable}"; 2478 } 2479 } 2480 2481 if($opt->{extra}) { 2482 $opt->{extra} =~ s/^\s+//mg; 2483 $opt->{extra} =~ s/\s+$//mg; 2484 push @headers, grep /^\w[-\w]*:/, split /\n/, $opt->{extra}; 2485 } 2486 2487 $body ||= $setsub->('body'); 2488 unless($body) { 2489 return error_opt($opt, "Refuse to send email message with no body."); 2490 } 2491 2492 $body = format_auto_transmission($body) if ref $body; 2493 2494 push(@headers, '') if @headers; 2495 2496 return error_opt("mv_email_enable not set, required.") if $abort; 2497 if($check and $found{to} ne $Scratch->{mv_email_enable}) { 2498 return error_opt( 2499 "mv_email_enable to address (%s) doesn't match enable (%s)", 2500 $found{to}, 2501 $Scratch->{mv_email_enable}, 2502 ); 2503 } 2504 2505 SEND: { 2506 $ok = send_mail(\@headers, $body); 2507 } 2508 2509 if (!$ok) { 2510 close MAIL; 2511 $body = substr($body, 0, 2000) if length($body) > 2000; 2512 return error_opt( 2513 "Unable to send mail using %s\n%s", 2514 $Vend::Cfg->{SendMailProgram}, 2515 join("\n", @headers, $body), 2516 ); 2517 } 2518 2519 delete $Scratch->{mv_email_enable} if $check; 2520 return if $opt->{hide}; 2521 return join("\n", @headers, $body) if $opt->{show}; 2522 return ($opt->{success} || $ok); 2523} 2524 2525# Returns the text of a user entered field named VAR. 2526sub tag_value { 2527 my($var,$opt) = @_; 2528#::logDebug("called value args=" . uneval(\@_)); 2529 local($^W) = 0; 2530 2531 my $vspace = $opt->{values_space}; 2532 my $vref; 2533 if (defined $vspace) { 2534 if ($vspace eq '') { 2535 $vref = $Vend::Session->{values}; 2536 } 2537 else { 2538 $vref = $Vend::Session->{values_repository}{$vspace} ||= {}; 2539 } 2540 } 2541 else { 2542 $vref = $::Values; 2543 } 2544 2545 $vref->{$var} = $opt->{set} if defined $opt->{set}; 2546 2547 my $value = defined $vref->{$var} ? $vref->{$var} : ''; 2548 $value =~ s/\[/[/g unless $opt->{enable_itl}; 2549 if($opt->{filter}) { 2550 $value = filter_value($opt->{filter}, $value, $var); 2551 $vref->{$var} = $value unless $opt->{keep}; 2552 } 2553 $::Scratch->{$var} = $value if $opt->{scratch}; 2554 return '' if $opt->{hide}; 2555 return $opt->{default} if ! $value and defined $opt->{default}; 2556 $value =~ s/</</g unless $opt->{enable_html}; 2557 return $value; 2558} 2559 2560sub esc { 2561 my $string = shift; 2562 $string =~ s!(\W)!'%' . sprintf '%02x', ord($1)!eg; 2563 return $string; 2564} 2565 2566# Escapes a scan reliably in three different possible ways 2567sub escape_scan { 2568 my ($scan, $ref) = @_; 2569#::logDebug("escape_scan: scan=$scan"); 2570 if (ref $scan) { 2571 for(@$scan) { 2572 my $add = ''; 2573 $_ = "se=$_" unless /[=\n]/; 2574 $add .= "\nos=0" unless m{^\s*os=}m; 2575 $add .= "\nne=0" unless m{^\s*ne=}m; 2576 $add .= "\nop=rm" unless m{^\s*op=}m; 2577 $add .= "\nbs=0" unless m{^\s*bs=}m; 2578 $add .= "\nsf=*" unless m{^\s*sf=}m; 2579 $add .= "\ncs=0" unless m{^\s*cs=}m; 2580 $add .= "\nsg=0" unless m{^\s*sg=}m; 2581 $add .= "\nnu=0" unless m{^\s*nu=}m; 2582 $_ .= $add; 2583 } 2584 $scan = join "\n", @$scan; 2585 $scan .= "\nco=yes" unless m{^\s*co=}m; 2586#::logDebug("escape_scan: scan=$scan"); 2587 } 2588 2589 if($scan =~ /^\s*(?:sq\s*=\s*)?select\s+/im) { 2590 eval { 2591 $scan = Vend::Scan::sql_statement($scan, $ref || \%CGI::values) 2592 }; 2593 if($@) { 2594 my $msg = errmsg("SQL query failed: %s\nquery was: %s", $@, $scan); 2595 logError($msg); 2596 $scan = 'se=BAD_SQL'; 2597 } 2598 } 2599 2600 return join '/', 'scan', escape_mv('/', $scan); 2601} 2602 2603sub escape_form { 2604 my $val = shift; 2605 2606 $val =~ s/^\s+//mg; 2607 $val =~ s/\s+$//mg; 2608 2609 ## Already escaped, return 2610 return $val if $val =~ /^\S+=\S+=\S*$/; 2611 2612 my @args = split /\n+/, $val; 2613 2614 for(@args) { 2615 s/^(.*?=)(.+)/$1 . Vend::Util::unhexify($2)/ge; 2616 } 2617 2618 for(@args) { 2619 next if /^[\w=]+$/; 2620 s!\0!-_NULL_-!g; 2621 s!([^=]+)=(.*)!esc($1) . '=' . esc($2)!eg 2622 or (undef $_, next); 2623 } 2624 return join $Global::UrlJoiner, grep length($_), @args; 2625} 2626 2627sub escape_mv { 2628 my ($joiner, $scan, $not_scan, $esc) = @_; 2629 2630 my @args; 2631 2632 if(index($scan, "\n") != -1) { 2633 $scan =~ s/^\s+//mg; 2634 $scan =~ s/\s+$//mg; 2635 @args = split /\n+/, $scan; 2636 } 2637 elsif($scan =~ /&\w\w=/) { 2638 @args = split /&/, $scan; 2639 } 2640 else { 2641 $scan =~ s!::!__SLASH__!g; 2642 @args = split m:/:, $scan; 2643 } 2644 @args = grep $_, @args; 2645 for(@args) { 2646 s!/!__SLASH__!g unless defined $not_scan; 2647 s!\0!-_NULL_-!g; 2648 m!\w=! 2649 or (undef $_, next); 2650 s!__SLASH__!::!g unless defined $not_scan; 2651 } 2652 return join $joiner, grep(defined $_, @args); 2653} 2654 2655PAGELINK: { 2656 2657my ($urlroutine, $page, $arg, $opt); 2658 2659sub tag_page { 2660 my ($page, $arg, $opt) = @_; 2661 2662 my $url = tag_area(@_); 2663 2664 my $extra; 2665 if($extra = ($opt ||= {})->{extra} || '') { 2666 $extra =~ s/^(\w+)$/class=$1/; 2667 $extra = " $extra"; 2668 } 2669 return qq{<a href="$url"$extra>}; 2670} 2671 2672# Returns an href which will call up the specified PAGE. 2673 2674sub tag_area { 2675 ($page, $arg, $opt) = @_; 2676 2677 $page = '' if ! defined $page; 2678 2679 if( $page and $opt->{alias}) { 2680 my $aloc = $opt->{once} ? 'one_time_path_alias' : 'path_alias'; 2681 $Vend::Session->{$aloc}{$page} = {} 2682 if not defined $Vend::Session->{path_alias}{$page}; 2683 $Vend::Session->{$aloc}{$page} = $opt->{alias}; 2684 } 2685 2686 my $r; 2687 2688 if ($opt->{search}) { 2689 $page = escape_scan($opt->{search}); 2690 } 2691 elsif ($page =~ /^[a-z][a-z]+:/) { 2692 ### Javascript or absolute link 2693 return $page unless $opt->{form}; 2694 $page =~ s{(\w+://[^/]+)/}{} 2695 or return $page; 2696 my $intro = $1; 2697 my @pieces = split m{/}, $page, 9999; 2698 $page = pop(@pieces); 2699 if(! length($page)) { 2700 $page = pop(@pieces); 2701 if(! length($page)) { 2702 $r = $intro; 2703 $r =~ s{/([^/]+)}{}; 2704 $page = "$1/"; 2705 } 2706 else { 2707 $page .= "/"; 2708 } 2709 } 2710 $r = join "/", $intro, @pieces unless $r; 2711 $opt->{add_dot_html} = 0; 2712 $opt->{no_session} = 1; 2713 $opt->{secure} = 0; 2714 $opt->{no_count} = 1; 2715 } 2716 elsif ($page eq 'scan') { 2717 $page = escape_scan($arg); 2718 undef $arg; 2719 } 2720 2721 $urlroutine = $opt->{secure} ? \&secure_vendUrl : \&vendUrl; 2722 2723 return $urlroutine->($page, $arg, undef, $opt); 2724} 2725 2726} 2727 2728*form_link = \&tag_area; 2729 2730# Sets the default shopping cart for display 2731sub tag_cart { 2732 $Vend::CurrentCart = shift; 2733 return ''; 2734} 2735 2736# Sets the discount namespace. 2737sub switch_discount_space { 2738 my $dspace = shift || 'main'; 2739 2740 if (! $Vend::Cfg->{DiscountSpacesOn}) { 2741 $::Discounts 2742 = $Vend::Session->{discount} 2743 ||= {}; 2744 return $Vend::DiscountSpaceName = 'main'; 2745 } 2746 2747 my $oldspace = $Vend::DiscountSpaceName || 'main'; 2748#::logDebug("switch_discount_space: called for space '$dspace'; current space is $oldspace."); 2749 unless ($Vend::Session->{discount} and $Vend::Session->{discount_space}) { 2750 $::Discounts 2751 = $Vend::Session->{discount} 2752 = $Vend::Session->{discount_space}{main} 2753 ||= ($Vend::Session->{discount} || {}); 2754 $Vend::DiscountSpaceName = 'main'; 2755#::logDebug('switch_discount_space: initialized discount space hash.'); 2756 } 2757 if ($dspace ne $oldspace) { 2758 $::Discounts 2759 = $Vend::Session->{discount} 2760 = $Vend::Session->{discount_space}{$Vend::DiscountSpaceName = $dspace} 2761 ||= {}; 2762#::logDebug("switch_discount_space: changed discount space from '$oldspace' to '$Vend::DiscountSpaceName'"); 2763 } 2764 else { 2765 # Make certain the hash is set, in case app programmer manipulated the session directly. 2766 $::Discounts 2767 = $Vend::Session->{discount} 2768 = $Vend::Session->{discount_space}{$Vend::DiscountSpaceName} 2769 unless ref $::Discounts eq 'HASH'; 2770 } 2771 return $oldspace; 2772} 2773 2774sub tag_calc { 2775 my($body) = @_; 2776 my $result; 2777 if($Vend::NoInterpolate) { 2778 logGlobal({ level => 'alert' }, 2779 "Attempt to interpolate perl/ITL from RPC, no permissions." 2780 ); 2781 } 2782 2783 $Items = $Vend::Items; 2784 2785 if($MVSAFE::Safe) { 2786 $result = eval($body); 2787 } 2788 else { 2789 init_calc() if ! $Vend::Calc_initialized; 2790 $result = $ready_safe->reval($body); 2791 } 2792 2793 if ($@) { 2794 my $msg = $@; 2795 $Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try; 2796 logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body); 2797 logError("Safe: %s\n%s\n" , $msg, $body); 2798 return $MVSAFE::Safe ? '' : 0; 2799 } 2800 return $result; 2801} 2802 2803sub tag_unless { 2804 return tag_self_contained_if(@_, 1) if defined $_[4]; 2805 return tag_if(@_, 1); 2806} 2807 2808sub tag_self_contained_if { 2809 my($base, $term, $operator, $comp, $body, $negate) = @_; 2810 2811 my ($else,$elsif,@addl); 2812 2813 local($^W) = 0; 2814#::logDebug("self_if: base=$base term=$term op=$operator comp=$comp"); 2815 if ($body =~ s#$QR{condition_begin}##) { 2816 $comp = $1; 2817 } 2818#::logDebug("self_if: base=$base term=$term op=$operator comp=$comp"); 2819 2820 if ( $body =~ /\[[EeTtAaOo][hHLlNnRr][SsEeDd\s]/ ) { 2821 ($body, $elsif, $else, @addl) = split_if($body); 2822 } 2823 2824#::logDebug("Additional ops found:\n" . join("\n", @addl) ) if @addl; 2825 2826 unless(defined $operator || defined $comp) { 2827 $comp = ''; 2828 undef $operator; 2829 undef $comp; 2830 } 2831 2832 ($base =~ s/^\W+// or $base = "!$base") if $negate; 2833 2834 my $status = conditional ($base, $term, $operator, $comp, @addl); 2835 2836 my $out; 2837 if($status) { 2838 $out = $body; 2839 } 2840 elsif ($elsif) { 2841 $else = '[else]' . $else . '[/else]' if length $else; 2842 $elsif =~ s#(.*?)$QR{'/elsif'}(.*)#$1${2}[/elsif]#s; 2843 $out = '[if ' . $elsif . $else . '[/if]'; 2844 } 2845 elsif (length $else) { 2846 $out = $else; 2847 } 2848 else { 2849 return ''; 2850 } 2851 2852 return $out; 2853} 2854 2855sub pull_cond { 2856 my($string, $reverse, $cond, $lhs) = @_; 2857#::logDebug("pull_cond string='$string' rev='$reverse' cond='$cond' lhs='$lhs'"); 2858 my ($op, $rhs) = split /\s+/, $cond, 2; 2859 $rhs =~ s/^(["'])(.*)\1$/$2/; 2860 if(! defined $cond_op{$op} ) { 2861 logError("bad conditional operator %s in if-PREFIX-data", $op); 2862 return pull_else($string, $reverse); 2863 } 2864 return $cond_op{$op}->($lhs, $rhs) 2865 ? pull_if($string, $reverse) 2866 : pull_else($string, $reverse); 2867} 2868 2869sub pull_if { 2870 return pull_cond(@_) if $_[2]; 2871 my($string, $reverse) = @_; 2872 return pull_else($string) if $reverse; 2873 find_matching_else(\$string) if $string =~ s:$QR{has_else}::; 2874 return $string; 2875} 2876 2877sub pull_else { 2878 return pull_cond(@_) if $_[2]; 2879 my($string, $reverse) = @_; 2880 return pull_if($string) if $reverse; 2881 return find_matching_else(\$string) if $string =~ s:$QR{has_else}::; 2882 return; 2883} 2884 2885## ORDER PAGE 2886 2887my (@Opts); 2888my (@Flds); 2889my %Sort = ( 2890 2891 '' => sub { $_[0] cmp $_[1] }, 2892 none => sub { $_[0] cmp $_[1] }, 2893 f => sub { (lc $_[0]) cmp (lc $_[1]) }, 2894 fr => sub { (lc $_[1]) cmp (lc $_[0]) }, 2895 l => sub { 2896 my ($a1,$a2) = split /[,.]/, $_[0], 2; 2897 my ($b1,$b2) = split /[,.]/, $_[1], 2; 2898 return $a1 <=> $b1 || $a2 <=> $b2; 2899 }, 2900 lr => sub { 2901 my ($a1,$a2) = split /[,.]/, $_[0], 2; 2902 my ($b1,$b2) = split /[,.]/, $_[1], 2; 2903 return $b1 <=> $a1 || $b2 <=> $a2; 2904 }, 2905 n => sub { $_[0] <=> $_[1] }, 2906 nr => sub { $_[1] <=> $_[0] }, 2907 r => sub { $_[1] cmp $_[0] }, 2908); 2909 2910@Sort{qw/rf rl rn/} = @Sort{qw/fr lr nr/}; 2911 2912use vars qw/%Sort_field/; 2913%Sort_field = %Sort; 2914 2915sub tag_sort_ary { 2916 my($opts, $list) = (@_); 2917 $opts =~ s/^\s+//; 2918 $opts =~ s/\s+$//; 2919#::logDebug("tag_sort_ary: opts=$opts list=" . uneval($list)); 2920 my @codes; 2921 my $key = 0; 2922 2923 my ($start, $end, $num); 2924 my $glob_opt = 'none'; 2925 2926 my @opts = split /\s+/, $opts; 2927 my @option; my @bases; my @fields; 2928 2929 for(@opts) { 2930 my ($base, $fld, $opt) = split /:/, $_; 2931 2932 if($base =~ /^(\d+)$/) { 2933 $key = $1; 2934 $glob_opt = $fld || $opt || 'none'; 2935 next; 2936 } 2937 if($base =~ /^([-=+])(\d+)-?(\d*)/) { 2938 my $op = $1; 2939 if ($op eq '-') { $start = $2 } 2940 elsif ($op eq '+') { $num = $2 } 2941 elsif ($op eq '=') { 2942 $start = $2; 2943 $end = ($3 || undef); 2944 } 2945 next; 2946 } 2947 2948 push @bases, $base; 2949 push @fields, $fld; 2950 push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none'); 2951 } 2952 2953 if(defined $end) { 2954 $num = 1 + $end - $start; 2955 $num = undef if $num < 1; 2956 } 2957 2958 my $i; 2959 my $routine = 'sub { '; 2960 for( $i = 0; $i < @bases; $i++) { 2961 $routine .= '&{$Vend::Interpolate::Sort_field{"' . 2962 $option[$i] . 2963 '"}}(' . "\n"; 2964 $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->[$key]),\n"; 2965 $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->[$key]) ) or "; 2966 } 2967 $routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!; 2968 $routine .= '($_[0]->[$key],$_[1]->[$key]); }'; 2969#::logDebug("tag_sort_ary routine: $routine\n"); 2970 2971 my $code = eval $routine; 2972 die "Bad sort routine\n" if $@; 2973 2974 #Prime the sort? Prevent variable suicide?? 2975 #&{$Vend::Interpolate::Sort_field{'n'}}('31', '30'); 2976 2977 use locale; 2978 if($::Scratch->{mv_locale}) { 2979 POSIX::setlocale(POSIX::LC_COLLATE(), 2980 $::Scratch->{mv_locale}); 2981 } 2982 2983 @codes = sort {&$code($a, $b)} @$list; 2984 2985 if($start > 1) { 2986 splice(@codes, 0, $start - 1); 2987 } 2988 2989 if(defined $num) { 2990 splice(@codes, $num); 2991 } 2992#::logDebug("tag_sort_ary routine returns: " . uneval(\@codes)); 2993 return \@codes; 2994} 2995 2996sub tag_sort_hash { 2997 my($opts, $list) = (@_); 2998 $opts =~ s/^\s+//; 2999 $opts =~ s/\s+$//; 3000#::logDebug("tag_sort_hash: opts=$opts list=" . uneval($list)); 3001 my @codes; 3002 my $key = 'code'; 3003 3004 my ($start, $end, $num); 3005 my $glob_opt = 'none'; 3006 3007 my @opts = split /\s+/, $opts; 3008 my @option; my @bases; my @fields; 3009 3010 for(@opts) { 3011 3012 if(/^(\w+)(:([flnr]+))?$/) { 3013 $key = $1; 3014 $glob_opt = $3 || 'none'; 3015 next; 3016 } 3017 if(/^([-=+])(\d+)-?(\d*)/) { 3018 my $op = $1; 3019 if ($op eq '-') { $start = $2 } 3020 elsif ($op eq '+') { $num = $2 } 3021 elsif ($op eq '=') { 3022 $start = $2; 3023 $end = ($3 || undef); 3024 } 3025 next; 3026 } 3027 my ($base, $fld, $opt) = split /:/, $_; 3028 3029 push @bases, $base; 3030 push @fields, $fld; 3031 push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none'); 3032 } 3033 3034 if(defined $end) { 3035 $num = 1 + $end - $start; 3036 $num = undef if $num < 1; 3037 } 3038 3039 if (! defined $list->[0]->{$key}) { 3040 logError("sort key '$key' not defined in list. Skipping sort."); 3041 return $list; 3042 } 3043 3044 my $i; 3045 my $routine = 'sub { '; 3046 for( $i = 0; $i < @bases; $i++) { 3047 $routine .= '&{$Vend::Interpolate::Sort_field{"' . 3048 $option[$i] . 3049 '"}}(' . "\n"; 3050 $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->{$key}),\n"; 3051 $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->{$key}) ) or "; 3052 } 3053 $routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!; 3054 $routine .= '($a->{$key},$_[1]->{$key}); }'; 3055 3056#::logDebug("tag_sort_hash routine: $routine\n"); 3057 my $code = eval $routine; 3058 die "Bad sort routine\n" if $@; 3059 3060 #Prime the sort? Prevent variable suicide?? 3061 #&{$Vend::Interpolate::Sort_field{'n'}}('31', '30'); 3062 3063 use locale; 3064 if($::Scratch->{mv_locale}) { 3065 POSIX::setlocale(POSIX::LC_COLLATE(), 3066 $::Scratch->{mv_locale}); 3067 } 3068 3069 @codes = sort {&$code($a,$b)} @$list; 3070 3071 if($start > 1) { 3072 splice(@codes, 0, $start - 1); 3073 } 3074 3075 if(defined $num) { 3076 splice(@codes, $num); 3077 } 3078#::logDebug("tag_sort_hash routine returns: " . uneval(\@codes)); 3079 return \@codes; 3080} 3081 3082my %Prev; 3083 3084sub check_change { 3085 my($name, $value, $text, $substr) = @_; 3086 # $value is case-sensitive flag if passed text; 3087 if(defined $text) { 3088 $text =~ s:$QR{condition}::; 3089 $value = $value ? lc $1 : $1; 3090 } 3091 $value = substr($value, 0, $substr) if $substr; 3092 my $prev = $Prev{$name}; 3093 $Prev{$name} = $value; 3094 if(defined $text) { 3095 return pull_if($text) if ! defined $prev or $value ne $prev; 3096 return pull_else($text); 3097 } 3098 return 1 unless defined $prev; 3099 return $value eq $prev ? 0 : 1; 3100} 3101 3102sub list_compat { 3103 my $prefix = shift; 3104 my $textref = shift; 3105 3106 $$textref =~ s:\[quantity[-_]name:[$prefix-quantity-name:gi; 3107 $$textref =~ s:\[modifier[-_]name\s:[$prefix-modifier-name :gi; 3108 3109 $$textref =~ s:\[if[-_]data\s:[if-$prefix-data :gi 3110 and $$textref =~ s:\[/if[-_]data\]:[/if-$prefix-data]:gi; 3111 3112 $$textref =~ s:\[if[-_]modifier\s:[if-$prefix-param :gi 3113 and $$textref =~ s:\[/if[-_]modifier\]:[/if-$prefix-param]:gi; 3114 3115 $$textref =~ s:\[if[-_]field\s:[if-$prefix-field :gi 3116 and $$textref =~ s:\[/if[-_]field\]:[/if-$prefix-field]:gi; 3117 3118 $$textref =~ s:\[on[-_]change\s:[$prefix-change :gi 3119 and $$textref =~ s:\[/on[-_]change\s:[/$prefix-change :gi; 3120 3121 return; 3122} 3123 3124sub tag_search_region { 3125 my($params, $opt, $text) = @_; 3126 $opt->{search} = $params if $params; 3127 $opt->{prefix} ||= 'item'; 3128 $opt->{list_prefix} ||= 'search[-_]list'; 3129# LEGACY 3130 list_compat($opt->{prefix}, \$text) if $text; 3131# END LEGACY 3132 return region($opt, $text); 3133} 3134 3135sub find_sort { 3136 my($text) = @_; 3137 return undef unless defined $$text and $$text =~ s#\[sort(([\s\]])[\000-\377]+)#$1#io; 3138 my $options = find_close_square($$text); 3139 $$text = substr( $$text,length($options) + 1 ) 3140 if defined $options; 3141 $options = interpolate_html($options) if index($options, '[') != -1; 3142 return $options || ''; 3143} 3144 3145# Artificial for better variable passing 3146{ 3147 my( $next_anchor, 3148 $prev_anchor, 3149 $page_anchor, 3150 $border, 3151 $border_selected, 3152 $opt, 3153 $r, 3154 $chunk, 3155 $perm, 3156 $total, 3157 $current, 3158 $page, 3159 $prefix, 3160 $more_id, 3161 $session, 3162 $link_template, 3163 ); 3164 3165sub more_link_template { 3166 my ($anchor, $arg, $form_arg) = @_; 3167 3168 my $url = tag_area("scan/MM=$arg", '', { 3169 form => $form_arg, 3170 secure => $CGI::secure, 3171 }); 3172 3173 my $lt = $link_template; 3174 $lt =~ s/\$URL\$/$url/g; 3175 $lt =~ s/\$ANCHOR\$/$anchor/g; 3176 return $lt; 3177} 3178 3179sub more_link { 3180 my($inc, $pa) = @_; 3181 my ($next, $last, $arg); 3182 my $list = ''; 3183 $pa =~ s/__PAGE__/$inc/g; 3184 my $form_arg = "mv_more_ip=1\nmv_nextpage=$page"; 3185 $form_arg .= "\npf=$prefix" if $prefix; 3186 $form_arg .= "\n$opt->{form}" if $opt->{form}; 3187 $form_arg .= "\nmi=$more_id" if $more_id; 3188 $next = ($inc-1) * $chunk; 3189#::logDebug("more_link: inc=$inc current=$current"); 3190 $last = $next + $chunk - 1; 3191 $last = ($last+1) < $total ? $last : ($total - 1); 3192 $pa =~ s/__PAGE__/$inc/g; 3193 $pa =~ s/__MINPAGE__/$next + 1/eg; 3194 $pa =~ s/__MAXPAGE__/$last + 1/eg; 3195 if($inc == $current) { 3196 $pa =~ s/__BORDER__/$border_selected || $border || ''/e; 3197 $list .= qq|<strong>$pa</strong> | ; 3198 } 3199 else { 3200 $pa =~ s/__BORDER__/$border/e; 3201 $arg = "$session:$next:$last:$chunk$perm"; 3202 $list .= more_link_template($pa, $arg, $form_arg) . ' '; 3203 } 3204 return $list; 3205} 3206 3207sub tag_more_list { 3208 ( 3209 $next_anchor, 3210 $prev_anchor, 3211 $page_anchor, 3212 $border, 3213 $border_selected, 3214 $opt, 3215 $r, 3216 ) = @_; 3217 3218 if(my $name = $opt->{more_routine}) { 3219 my $sub = $Vend::Cfg->{Sub}{$name} || $Global::GlobalSub->{$name}; 3220 return $sub->(@_) if $sub; 3221 } 3222#::logDebug("more_list: opt=$opt label=$opt->{label}"); 3223 return undef if ! $opt; 3224 $q = $opt->{object} || $::Instance->{SearchObject}{$opt->{label}}; 3225 return '' unless $q->{matches} > $q->{mv_matchlimit} 3226 and $q->{mv_matchlimit} > 0; 3227 my($arg,$inc,$last,$m); 3228 my($adder,$pages); 3229 my($first_anchor,$last_anchor); 3230 my %hash; 3231 3232 3233 $session = $q->{mv_cache_key}; 3234 my $first = $q->{mv_first_match} || 0; 3235 $chunk = $q->{mv_matchlimit}; 3236 $perm = $q->{mv_more_permanent} ? ':1' : ''; 3237 $total = $q->{matches}; 3238 my $next = defined $q->{mv_next_pointer} 3239 ? $q->{mv_next_pointer} 3240 : $first + $chunk; 3241 $page = $q->{mv_search_page} || $Global::Variable->{MV_PAGE}; 3242 $prefix = $q->{prefix} || ''; 3243 my $form_arg = "mv_more_ip=1\nmv_nextpage=$page"; 3244 $form_arg .= "\npf=$q->{prefix}" if $q->{prefix}; 3245 $form_arg .= "\n$opt->{form}" if $opt->{form}; 3246 if($q->{mv_more_id}) { 3247 $more_id = $q->{mv_more_id}; 3248 $form_arg .= "\nmi=$more_id"; 3249 } 3250 else { 3251 $more_id = undef; 3252 } 3253 3254 my $more_joiner = $opt->{more_link_joiner} || ' '; 3255 3256 if($r =~ s:\[border\]($All)\[/border\]::i) { 3257 $border = $1; 3258 $border =~ s/\D//g; 3259 } 3260 if($r =~ s:\[border[-_]selected\]($All)\[/border[-_]selected\]::i) { 3261 $border = $1; 3262 $border =~ s/\D//g; 3263 } 3264 3265 undef $link_template; 3266 $r =~ s:\[link[-_]template\]($All)\[/link[-_]template\]::i 3267 and $link_template = $1; 3268 $link_template ||= q{<a href="$URL$">$ANCHOR$</a>}; 3269 3270 if(! $chunk or $chunk >= $total) { 3271 return ''; 3272 } 3273 3274 $border = qq{ border="$border"} if defined $border; 3275 $border_selected = qq{ border="$border_selected"} 3276 if defined $border_selected; 3277 3278 $adder = ($total % $chunk) ? 1 : 0; 3279 $pages = int($total / $chunk) + $adder; 3280 $current = int($next / $chunk) || $pages; 3281 3282 if($first) { 3283 $first = 0 if $first < 0; 3284 3285 # First link may appear when prev link is valid 3286 if($r =~ s:\[first[-_]anchor\]($All)\[/first[-_]anchor\]::i) { 3287 $first_anchor = $1; 3288 } 3289 else { 3290 $first_anchor = errmsg('First'); 3291 } 3292 unless ($first_anchor eq 'none') { 3293 $arg = $session; 3294 $arg .= ':0:'; 3295 $arg .= $chunk - 1; 3296 $arg .= ":$chunk$perm"; 3297 $hash{first_link} = more_link_template($first_anchor, $arg, $form_arg); 3298 } 3299 3300 unless ($prev_anchor) { 3301 if($r =~ s:\[prev[-_]anchor\]($All)\[/prev[-_]anchor\]::i) { 3302 $prev_anchor = $1; 3303 } 3304 else { 3305 $prev_anchor = errmsg('Previous'); 3306 } 3307 } 3308 elsif ($prev_anchor ne 'none') { 3309 $prev_anchor = qq%<img src="$prev_anchor"$border>%; 3310 } 3311 unless ($prev_anchor eq 'none') { 3312 $arg = $session; 3313 $arg .= ':'; 3314 $arg .= $first - $chunk; 3315 $arg .= ':'; 3316 $arg .= $first - 1; 3317 $arg .= ":$chunk$perm"; 3318 $hash{prev_link} = more_link_template($prev_anchor, $arg, $form_arg); 3319 } 3320 3321 } 3322 else { 3323 $r =~ s:\[(prev|first)[-_]anchor\]$All\[/\1[-_]anchor\]::ig; 3324 } 3325 3326 if($next) { 3327 3328 unless ($next_anchor) { 3329 if($r =~ s:\[next[-_]anchor\]($All)\[/next[-_]anchor\]::i) { 3330 $next_anchor = $1; 3331 } 3332 else { 3333 $next_anchor = errmsg('Next'); 3334 } 3335 } 3336 else { 3337 $next_anchor = qq%<img src="$next_anchor"$border>%; 3338 } 3339 $last = $next + $chunk - 1; 3340 $last = $last > ($total - 1) ? $total - 1 : $last; 3341 $arg = "$session:$next:$last:$chunk$perm"; 3342 $hash{next_link} = more_link_template($next_anchor, $arg, $form_arg); 3343 3344 # Last link can appear when next link is valid 3345 if($r =~ s:\[last[-_]anchor\]($All)\[/last[-_]anchor\]::i) { 3346 $last_anchor = $1; 3347 } 3348 else { 3349 $last_anchor = errmsg('Last'); 3350 } 3351 unless ($last_anchor eq 'none') { 3352 $last = $total - 1; 3353 my $last_beg_idx = $total - ($total % $chunk || $chunk); 3354 $arg = "$session:$last_beg_idx:$last:$chunk$perm"; 3355 $hash{last_link} = more_link_template($last_anchor, $arg, $form_arg); 3356 } 3357 } 3358 else { 3359 $r =~ s:\[(last|next)[-_]anchor\]$All\[/\1[-_]anchor\]::gi; 3360 } 3361 3362 unless ($page_anchor) { 3363 if($r =~ s:\[page[-_]anchor\]($All)\[/page[-_]anchor\]::i) { 3364 $page_anchor = $1; 3365 } 3366 else { 3367 $page_anchor = '__PAGE__'; 3368 } 3369 } 3370 elsif ($page_anchor ne 'none') { 3371 $page_anchor = qq%<img src="$page_anchor?__PAGE__"__BORDER__>%; 3372 } 3373 3374 $page_anchor =~ s/\$(MIN|MAX)?PAGE\$/__${1}PAGE__/g; 3375 3376 my $more_string = errmsg('more'); 3377 my ($decade_next, $decade_prev, $decade_div); 3378 if( $q->{mv_more_decade} or $r =~ m:\[decade[-_]next\]:) { 3379 $r =~ s:\[decade[-_]next\]($All)\[/decade[-_]next\]::i 3380 and $decade_next = $1; 3381 $decade_next = "<small>[$more_string>>]</small>" 3382 if ! $decade_next; 3383 $r =~ s:\[decade[-_]prev\]($All)\[/decade[-_]prev\]::i 3384 and $decade_prev = $1; 3385 $decade_prev = "<small>[<<$more_string]</small>" 3386 if ! $decade_prev; 3387 $decade_div = $q->{mv_more_decade} > 1 ? $q->{mv_more_decade} : 10; 3388 } 3389 3390 my ($begin, $end); 3391 if(defined $decade_div and $pages > $decade_div) { 3392 if($current > $decade_div) { 3393 $begin = ( int ($current / $decade_div) * $decade_div ) + 1; 3394 $hash{decade_prev} = more_link($begin - $decade_div, $decade_prev); 3395 } 3396 else { 3397 $begin = 1; 3398 } 3399 if($begin + $decade_div <= $pages) { 3400 $end = $begin + $decade_div; 3401 $hash{decade_next} = more_link($end, $decade_next); 3402 $end--; 3403 } 3404 else { 3405 $end = $pages; 3406 delete $hash{$decade_next}; 3407 } 3408#::logDebug("more_list: decade found pages=$pages current=$current begin=$begin end=$end next=$next last=$last decade_div=$decade_div"); 3409 } 3410 else { 3411 ($begin, $end) = (1, $pages); 3412 delete $hash{$decade_next}; 3413 } 3414#::logDebug("more_list: pages=$pages current=$current begin=$begin end=$end next=$next last=$last decade_div=$decade_div page_anchor=$page_anchor"); 3415 3416 my @more_links; 3417 if ($q->{mv_alpha_list}) { 3418 for my $record (@{$q->{mv_alpha_list}}) { 3419 $arg = "$session:$record->[2]:$record->[3]:" . ($record->[3] - $record->[2] + 1); 3420 my $letters = substr($record->[0], 0, $record->[1]); 3421 push @more_links, more_link_template($letters, $arg, $form_arg); 3422 } 3423 $hash{more_alpha} = join $more_joiner, @more_links; 3424 } 3425 else { 3426 foreach $inc ($begin .. $end) { 3427 last if $page_anchor eq 'none'; 3428 push @more_links, more_link($inc, $page_anchor); 3429 } 3430 $hash{more_numeric} = join $more_joiner, @more_links; 3431 } 3432 3433 $hash{more_list} = join $more_joiner, @more_links; 3434 3435 $first = $first + 1; 3436 $last = $first + $chunk - 1; 3437 $last = $last > $total ? $total : $last; 3438 $m = $first . '-' . $last; 3439 $hash{matches} = $m; 3440 $hash{first_match} = $first; 3441 $hash{last_match} = $last; 3442 $hash{decade_first} = $begin; 3443 $hash{decade_last} = $end; 3444 $hash{last_page} = $hash{total_pages} = $pages; 3445 $hash{current_page} = $current; 3446 $hash{match_count} = $q->{matches}; 3447 3448 if($r =~ /{[A-Z][A-Z_]+[A-Z]}/ and $r !~ $QR{more}) { 3449 return tag_attr_list($r, \%hash, 1); 3450 } 3451 else { 3452 my $tpl = qq({FIRST_LINK?}{FIRST_LINK} {/FIRST_LINK?}{PREV_LINK?}{PREV_LINK} {/PREV_LINK?}{DECADE_PREV?}{DECADE_PREV} {/DECADE_PREV?}{MORE_LIST}{DECADE_NEXT?} {DECADE_NEXT}{/DECADE_NEXT?}{NEXT_LINK?} {NEXT_LINK}{/NEXT_LINK?}{LAST_LINK?} {LAST_LINK}{/LAST_LINK?}); 3453 $tpl =~ s/\s+$//; 3454 my $list = tag_attr_list($opt->{more_template} || $tpl, \%hash, 1); 3455 $r =~ s,$QR{more},$list,g; 3456 $r =~ s,$QR{matches},$m,g; 3457 $r =~ s,$QR{match_count},$q->{matches},g; 3458 return $r; 3459 } 3460 3461} 3462 3463} 3464 3465# Naming convention 3466# Ld Label Data 3467# B Begin 3468# E End 3469# D Data 3470# I If 3471my $LdD = qr{\s+([-\w:#/.]+)\]}; 3472my $LdI = qr{\s+([-\w:#/.]+)$Optr\]($Some)}; 3473my $LdB; 3474my $LdIB; 3475my $LdIE; 3476my $LdExpr; 3477my $B; 3478my $E; 3479my $IB; 3480my $IE; 3481my $Prefix; 3482my $Orig_prefix; 3483 3484sub tag_labeled_data_row { 3485 my ($key, $text) = @_; 3486 my ($row, $table, $tabRE); 3487 my $done; 3488 my $prefix; 3489 3490 if(defined $Prefix) { 3491 $prefix = $Prefix; 3492 undef $Prefix; 3493 $LdB = qr(\[$prefix[-_]data$Spacef)i; 3494 $LdIB = qr(\[if[-_]$prefix[-_]data(\d*)$Spacef(!?)(?:%20|\s)*)i; 3495 $LdIE = qr(\[/if[-_]$prefix[-_]data)i; 3496 $LdExpr = qr{ \[(?:$prefix[-_]data|if[-_]$prefix[-_]data(\d*)) 3497 \s+ !?\s* ($Codere) \s 3498 (?!$All\[(?:$prefix[-_]data|if[-_]$prefix[-_]data\1)) }xi; 3499 %Data_cache = (); 3500 } 3501 # Want the last one 3502#::logDebug(<<EOF); 3503#tag_labeled_data_row: 3504# prefix=$prefix 3505# LdB =$LdB 3506# LdIB =$LdIB 3507# LdIE =$LdIE 3508# LdD =$LdD 3509# LdI =$LdI 3510# LdExpr=$LdExpr 3511#EOF 3512 3513 while($$text =~ $LdExpr) { 3514 $table = $2; 3515 $tabRE = qr/$table/; 3516 $row = $Data_cache{"$table.$key"} 3517 || ( $Data_cache{"$table.$key"} 3518 = Vend::Data::database_row($table, $key) 3519 ) 3520 || {}; 3521 $done = 1; 3522 $$text =~ s#$LdIB$tabRE$LdI$LdIE\1\]# 3523 $row->{$3} ? pull_if($5,$2,$4,$row->{$3}) 3524 : pull_else($5,$2,$4,$row->{$3})#ge 3525 and undef $done; 3526#::logDebug("after if: table=$table 1=$1 2=$2 3=$3 $$text =~ s#$LdIB $tabRE $LdI $LdIE#"); 3527 3528 $$text =~ s/$LdB$tabRE$LdD/ed($row->{$1})/eg 3529 and undef $done; 3530 last if $done; 3531 } 3532 return $_; 3533} 3534 3535sub random_elements { 3536 my($ary, $wanted) = @_; 3537 return (0 .. $#$ary) unless $wanted > 0; 3538 $wanted = 1 if $wanted =~ /\D/; 3539 return undef unless ref $ary; 3540 3541 my %seen; 3542 my ($j, @out); 3543 my $count = scalar @$ary; 3544 $wanted = $count if $wanted > $count; 3545 for($j = 0; $j < $wanted; $j++) { 3546 my $cand = int rand($count); 3547 redo if $seen{$cand}++; 3548 push(@out, $cand); 3549 } 3550 return (@out); 3551} 3552 3553my $opt_select; 3554my $opt_table; 3555my $opt_field; 3556my $opt_value; 3557 3558sub labeled_list { 3559 my($opt, $text, $obj) = @_; 3560 my($count); 3561 $obj = $opt->{object} if ! $obj; 3562 return '' if ! $obj; 3563 3564 my $ary = $obj->{mv_results}; 3565 return '' if (! $ary or ! ref $ary or ! defined $ary->[0]); 3566 3567 my $save_unsafe = $MVSAFE::Unsafe || ''; 3568 $MVSAFE::Unsafe = 1; 3569 3570 # This allows left brackets to be output by the data tags 3571 local($Safe_data); 3572 $Safe_data = 1 if $opt->{safe_data}; 3573 3574# if($opt->{prefix} eq 'item') { 3575#::logDebug("labeled list: opt:\n" . uneval($opt) . "\nobj:" . uneval($obj) . "text:" . substr($text,0,100)); 3576# } 3577 $Orig_prefix = $Prefix = $opt->{prefix} || 'item'; 3578 3579 $B = qr(\[$Prefix)i; 3580 $E = qr(\[/$Prefix)i; 3581 $IB = qr(\[if[-_]$Prefix)i; 3582 $IE = qr(\[/if[-_]$Prefix)i; 3583 3584 my $end; 3585 # List more 3586 if ( defined $CGI::values{mv_more_matches} 3587 and $CGI::values{mv_more_matches} eq 'loop' ) 3588 { 3589 undef $CGI::values{mv_more_matches}; 3590 $opt->{fm} = $CGI::values{mv_next_pointer} + 1; 3591 $end = $CGI::values{mv_last_pointer} 3592 if defined $CGI::values{mv_last_pointer}; 3593 $opt->{ml} = $CGI::values{mv_matchlimit} 3594 if defined $CGI::values{mv_matchlimit}; 3595 } 3596 # get the number to start the increment from 3597 my $i = 0; 3598 if (defined $obj->{more_in_progress} and $obj->{mv_first_match}) { 3599 $i = $obj->{mv_first_match}; 3600 } 3601 elsif (defined $opt->{random} && !is_no($opt->{random})) { 3602 $opt->{random} = scalar(@$ary) if $opt->{random} =~ /^[yYtT]/; 3603 @$ary = @$ary[random_elements($ary, $opt->{random})]; 3604 $i = 0; $end = $#$ary; 3605 undef $obj->{mv_matchlimit}; 3606 } 3607 elsif (defined $opt->{fm}) { 3608 $i = $opt->{fm} - 1; 3609 } 3610 3611 $count = $obj->{mv_first_match} || $i; 3612 $count++; 3613 # Zero the on-change hash 3614 undef %Prev; 3615 3616 if(defined $opt->{option}) { 3617 $opt_value = $opt->{option}; 3618 my $optref = $opt->{cgi} ? (\%CGI::values) : $::Values; 3619 3620 if($opt_value =~ s/\s*($Codere)::($Codere)\s*//) { 3621 $opt_table = $1; 3622 $opt_field = $2; 3623 $opt_value = lc($optref->{$opt_value}) || undef; 3624 $opt_select = sub { 3625 return lc(tag_data($opt_table, $opt_field, shift)) eq $opt_value; 3626 } 3627 if $opt_value; 3628 } 3629 elsif(defined $optref->{$opt_value} and length $optref->{$opt_value} ) { 3630 $opt_value = lc($optref->{$opt_value}); 3631 $opt_select = ! $opt->{multiple} 3632 ? sub { return "\L$_[0]" eq $opt_value } 3633 : sub { $opt_value =~ /^$_[0](?:\0|$)/i or 3634 $opt_value =~ /\0$_[0](?:\0|$)/i 3635 }; 3636 } 3637 } 3638 else { 3639 undef $opt_select; 3640 } 3641 3642 my $return; 3643 if($Vend::OnlyProducts) { 3644 $text =~ s#$B$QR{_field}#[$Prefix-data $Vend::OnlyProducts $1]#g 3645 and $text =~ s#$E$QR{'/_field'}#[/$Prefix-data]#g; 3646 $text =~ s,$IB$QR{_field_if_wo},[if-$Prefix-data $1$Vend::OnlyProducts $2],g 3647 and $text =~ s,$IE$QR{'/_field'},[/if-$Prefix-data],g; 3648 } 3649#::logDebug("Past only products."); 3650 $end = ($obj->{mv_matchlimit} and $obj->{mv_matchlimit} > 0) 3651 ? $i + ($opt->{ml} || $obj->{mv_matchlimit}) - 1 3652 : $#$ary; 3653 $end = $#$ary if $#$ary < $end; 3654 3655# LEGACY 3656 $text =~ /^\s*\[sort\s+.*/si 3657 and $opt->{sort} = find_sort(\$text); 3658# END LEGACY 3659 3660 my $r; 3661 if($ary->[0] =~ /HASH/) { 3662 $ary = tag_sort_hash($opt->{sort}, $ary) if $opt->{sort}; 3663 $r = iterate_hash_list($i, $end, $count, $text, $ary, $opt_select, $opt); 3664 } 3665 else { 3666 my $fa = $obj->{mv_return_fields} || undef; 3667 my $fh = $obj->{mv_field_hash} || undef; 3668 my $fn = $obj->{mv_field_names} || undef; 3669 my $row_fields = $fa; 3670 $ary = tag_sort_ary($opt->{sort}, $ary) if $opt->{sort}; 3671 if ($fa and $fn) { 3672 my $idx = 0; 3673 $fh = {}; 3674 $row_fields = []; 3675 @$row_fields = @{$fn}[@$fa]; 3676 for(@$fa) { 3677 $fh->{$fn->[$_]} = $idx++; 3678 } 3679 } 3680 elsif (! $fh and $fn) { 3681 my $idx = 0; 3682 $fh = {}; 3683 $row_fields = $fn; 3684 for(@$fn) { 3685 $fh->{$_} = $idx++; 3686 } 3687 } 3688 $opt->{mv_return_fields} = $fa; 3689#::logDebug("Missing mv_field_hash and/or mv_field_names in Vend::Interpolate::labeled_list") unless ref $fh eq 'HASH'; 3690 # Pass the field arrayref ($row_fields) for support in iterate_array_list of new $Row object... 3691 $r = iterate_array_list($i, $end, $count, $text, $ary, $opt_select, $fh, $opt, $row_fields); 3692 } 3693 $MVSAFE::Unsafe = $save_unsafe; 3694 return $r; 3695} 3696 3697sub tag_attr_list { 3698 my ($body, $hash, $ucase) = @_; 3699 3700 if(! ref $hash) { 3701 $hash = string_to_ref($hash); 3702 if($@) { 3703 logDebug("eval error: $@"); 3704 } 3705 return undef if ! ref $hash; 3706 } 3707 if($ucase) { 3708 my $Marker = '[A-Z_]\\w+'; 3709 $body =~ s!\{($Marker)\}!$hash->{"\L$1"}!g; 3710 $body =~ s!\{($Marker)\?($Marker)\:($Marker)\}! 3711 length($hash->{lc $1}) ? $hash->{lc $2} : $hash->{lc $3} 3712 !eg; 3713 $body =~ s!\{($Marker)\|($Some)\}!$hash->{lc $1} || $2!eg; 3714 $body =~ s!\{($Marker)\s+($Some)\}! $hash->{lc $1} ? $2 : ''!eg; 3715 1 while $body =~ s!\{($Marker)\?\}($Some){/\1\?\}! $hash->{lc $1} ? $2 : ''!eg; 3716 1 while $body =~ s!\{($Marker)\:\}($Some){/\1\:\}! $hash->{lc $1} ? '' : $2!eg; 3717 $body =~ s!\{(\w+)\:+(\w+)\:+(.*?)\}! tag_data($1, $2, $3) !eg; 3718 } 3719 else { 3720 $body =~ s!\{($Codere)\}!$hash->{$1}!g; 3721 $body =~ s!\{($Codere)\?($Codere)\:($Codere)\}! 3722 length($hash->{$1}) ? $hash->{$2} : $hash->{$3} 3723 !eg; 3724 $body =~ s!\{($Codere)\|($Some)\}!$hash->{$1} || $2!eg; 3725 $body =~ s!\{($Codere)\s+($Some)\}! $hash->{$1} ? $2 : ''!eg; 3726 1 while $body =~ s!\{($Codere)\?\}($Some){/\1\?\}! $hash->{$1} ? $2 : ''!eg; 3727 1 while $body =~ s!\{($Codere)\:\}($Some){/\1\:\}! $hash->{$1} ? '' : $2!eg; 3728 $body =~ s!\{(\w+)\:+(\w+)\:+(.*?)\}! tag_data($1, $2, $3) !eg; 3729 } 3730 return $body; 3731} 3732 3733sub tag_address { 3734 my ($count, $item, $hash, $opt, $body) = @_; 3735#::logDebug("in ship_address"); 3736 return pull_else($body) if defined $opt->{if} and ! $opt->{if}; 3737 return pull_else($body) if ! $Vend::username || ! $Vend::Session->{logged_in}; 3738#::logDebug("logged in with usernam=$Vend::username"); 3739 3740 my $tag = 'address'; 3741 my $attr = 'mv_ad'; 3742 my $nattr = 'mv_an'; 3743 my $pre = ''; 3744 if($opt->{billing}) { 3745 $tag = 'b_address'; 3746 $attr = 'mv_bd'; 3747 $nattr = 'mv_bn'; 3748 $pre = 'b_'; 3749 } 3750 3751# if($item->{$attr} and ! $opt->{set}) { 3752# my $pre = $opt->{prefix}; 3753# $pre =~ s/[-_]/[-_]/g; 3754# $body =~ s:\[$pre\]($Some)\[/$pre\]:$item->{$attr}:g; 3755# return pull_if($body); 3756# } 3757 3758 my $nick = $opt->{nick} || $opt->{nickname} || $item->{$nattr}; 3759 3760#::logDebug("nick=$nick"); 3761 3762 my $user; 3763 if(not $user = $Vend::user_object) { 3764 $user = new Vend::UserDB username => ($opt->{username} || $Vend::username); 3765 } 3766#::logDebug("user=$user"); 3767 ! $user and return pull_else($body); 3768 3769 my $blob = $user->get_hash('SHIPPING') or return pull_else($body); 3770#::logDebug("blob=$blob"); 3771 my $addr = $blob->{$nick}; 3772 3773 if (! $addr) { 3774 %$addr = %{ $::Values }; 3775 } 3776 3777#::logDebug("addr=" . uneval($addr)); 3778 3779 $addr->{mv_an} = $nick; 3780 my @nick = sort keys %$blob; 3781 my $label; 3782 if($label = $opt->{address_label}) { 3783 @nick = sort { $blob->{$a}{$label} cmp $blob->{$a}{$label} } @nick; 3784 @nick = map { "$_=" . ($blob->{$_}{$label} || $_) } @nick; 3785 for(@nick) { 3786 s/,/,/g; 3787 } 3788 } 3789 $opt->{blank} = '--select--' unless $opt->{blank}; 3790 unshift(@nick, "=$opt->{blank}"); 3791 $opt->{address_book} = join ",", @nick 3792 unless $opt->{address_book}; 3793 3794 my $joiner = get_joiner($opt->{joiner}, "<br$Vend::Xtrailer>"); 3795 if(! $opt->{no_address}) { 3796 my @vals = map { $addr->{$_} } 3797 grep /^address_?\d*$/ && length($addr->{$_}), keys %$addr; 3798 $addr->{address} = join $joiner, @vals; 3799 } 3800 3801 if($opt->{widget}) { 3802 $addr->{address_book} = tag_accessories( 3803 $item->{code}, 3804 undef, 3805 { 3806 attribute => $nattr, 3807 type => $opt->{widget}, 3808 passed => $opt->{address_book}, 3809 form => $opt->{form}, 3810 }, 3811 $item 3812 ); 3813 } 3814 3815 if($opt->{set} || ! $item->{$attr}) { 3816 my $template = ''; 3817 if($::Variable->{MV_SHIP_ADDRESS_TEMPLATE}) { 3818 $template .= $::Variable->{MV_SHIP_ADDRESS_TEMPLATE}; 3819 } 3820 else { 3821 $template .= "{company}\n" if $addr->{"${pre}company"}; 3822 $template .= <<EOF; 3823{address} 3824{city}, {state} {zip} 3825{country} -- {phone_day} 3826EOF 3827 } 3828 $template =~ s/{(\w+.*?)}/{$pre$1}/g if $pre; 3829 $addr->{mv_ad} = $item->{$attr} = tag_attr_list($template, $addr); 3830 } 3831 else { 3832 $addr->{mv_ad} = $item->{$attr}; 3833 } 3834 3835 if($opt->{textarea}) { 3836 $addr->{textarea} = tag_accessories( 3837 $item->{code}, 3838 undef, 3839 { 3840 attribute => $attr, 3841 type => 'textarea', 3842 rows => $opt->{rows} || '4', 3843 cols => $opt->{cols} || '40', 3844 }, 3845 $item 3846 ); 3847 } 3848 3849 $body =~ s:\[$tag\]($Some)\[/$tag\]:tag_attr_list($1, $addr):eg; 3850 return pull_if($body); 3851} 3852 3853sub tag_object { 3854 my ($count, $item, $hash, $opt, $body) = @_; 3855 my $param = delete $hash->{param} 3856 or return undef; 3857 my $method; 3858 my $out = ''; 3859 eval { 3860 if(not $method = delete $hash->{method}) { 3861 $out = $item->{$param}->(); 3862 } 3863 else { 3864 $out = $item->{$param}->$method(); 3865 } 3866 }; 3867 return $out; 3868} 3869 3870my %Dispatch_hash = ( 3871 address => \&tag_address, 3872 object => \&tag_object, 3873); 3874 3875sub find_matching_else { 3876 my($buf) = @_; 3877 my $out; 3878 my $canon; 3879 3880 my $open = '[else]'; 3881 my $close = '[/else]'; 3882 my $first; 3883 my $pos; 3884 3885 $$buf =~ s{\[else\]}{[else]}igo; 3886 $first = index($$buf, $open); 3887#::logDebug("first=$first"); 3888 return undef if $first < 0; 3889 my $int = $first; 3890 my $begin = $first; 3891 $$buf =~ s{\[/else\]}{[/else]}igo 3892 or $int = -1; 3893 3894 while($int > -1) { 3895 $pos = $begin + 1; 3896 $begin = index($$buf, $open, $pos); 3897 $int = index($$buf, $close, $int + 1); 3898 last if $int < 1; 3899 if($begin > $int) { 3900 $first = $int = $begin; 3901 $int = $begin; 3902 } 3903#::logDebug("pos=$pos int=$int first=$first begin=$begin"); 3904 } 3905 $first = $begin if $begin > -1; 3906 substr($$buf, $first) =~ s/(.*)//s; 3907 $out = $1; 3908 substr($out, 0, 6) = ''; 3909 return $out; 3910} 3911 3912sub tag_dispatch { 3913 my($tag, $count, $item, $hash, $chunk) = @_; 3914 $tag = lc $tag; 3915 $tag =~ tr/-/_/; 3916 my $full = lc "$Orig_prefix-tag-$tag"; 3917 $full =~ tr/-/_/; 3918#::logDebug("tag_dispatch: tag=$tag count=$count chunk=$chunk"); 3919 my $attrseq = []; 3920 my $attrhash = {}; 3921 my $eaten; 3922 my $this_tag; 3923 3924 $eaten = Vend::Parse::_find_tag(\$chunk, $attrhash, $attrseq); 3925 substr($chunk, 0, 1) = ''; 3926 3927 $this_tag = Vend::Parse::find_matching_end($full, \$chunk); 3928 3929 $attrhash->{prefix} = $tag unless $attrhash->{prefix}; 3930 3931 my $out; 3932 if(defined $Dispatch_hash{$tag}) { 3933 $out = $Dispatch_hash{$tag}->($count, $item, $hash, $attrhash, $this_tag); 3934 } 3935 else { 3936 $attrhash->{body} = $this_tag unless defined $attrhash->{body}; 3937#::logDebug("calling tag tag=$tag this_tag=$this_tag attrhash=" . uneval($attrhash)); 3938 $Tag ||= new Vend::Tags; 3939 $out = $Tag->$tag($attrhash); 3940 } 3941 return $out . $chunk; 3942} 3943 3944my $rit = 1; 3945 3946sub resolve_nested_if { 3947 my ($where, $what) = @_; 3948 $where =~ s~\[$what\s+(?!.*\[$what\s)(.*?)\[/$what\]~ 3949 '[' . $what . $rit . " $1" . '[/' . $what . $rit++ . ']'~seg; 3950#::logDebug("resolved?\n$where\n"); 3951 return $where; 3952} 3953 3954use vars qw/%Ary_code/; 3955%Ary_code = ( 3956 accessories => \&tag_accessories, 3957 common => \&Vend::Data::product_common, 3958 description => \&Vend::Data::product_description, 3959 field => \&Vend::Data::product_field, 3960 last => \&interpolate_html, 3961 next => \&interpolate_html, 3962 options => \&Vend::Options::tag_options, 3963); 3964 3965use vars qw/%Hash_code/; 3966%Hash_code = ( 3967 accessories => \&tag_accessories, 3968 common => \&Vend::Data::item_common, 3969 description => \&Vend::Data::item_description, 3970 field => \&Vend::Data::item_field, 3971 last => \&interpolate_html, 3972 next => \&interpolate_html, 3973 options => \&tag_options, 3974); 3975 3976sub map_list_routines { 3977 my($type, $opt) = @_; 3978 3979 ### This allows mapping of new routines to 3980 ## PREFIX-options 3981 ## PREFIX-accessories 3982 ## PREFIX-description 3983 ## PREFIX-common 3984 ## PREFIX-field 3985 ## PREFIX-price 3986 ## PREFIX-tag 3987 ## PREFIX-last 3988 ## PREFIX-next 3989 3990 my $nc; 3991 3992 my $ac; 3993 for $ac ($Global::CodeDef->{$type}, $Vend::Cfg->{CodeDef}{$type}) { 3994 next unless $ac and $ac->{Routine}; 3995 $nc ||= {}; 3996 for(keys %{$ac->{Routine}}) { 3997 $nc->{$_} = $ac->{Routine}{$_}; 3998 } 3999 } 4000 4001 if($ac = $opt->{maproutine}) { 4002 $nc ||= {}; 4003 if(! ref($ac) ) { 4004 $ac =~ s/[\s'",=>\0]+$//; 4005 $ac =~ s/^[\s'",=>\0]+//; 4006 $ac = { split /[\s'",=>\0]+/, $ac }; 4007 } 4008 $ac = {} if ref($ac) ne 'HASH'; 4009 while( my($k,$v) = each %$ac) { 4010 $nc->{$k} = $Vend::Cfg->{Sub}{$v} || $Global::GlobalSub->{$v} 4011 or do { 4012 logError("%s: non-existent mapped routine %s.", $type, $_); 4013 delete $nc->{$_}; 4014 }; 4015 } 4016 } 4017 return $nc; 4018} 4019 4020sub alternate { 4021 my ($count, $inc, $end, $page_start, $array_last) = @_; 4022 4023 if(! length($inc)) { 4024 $inc ||= $::Values->{mv_item_alternate} || 2; 4025 } 4026 4027 return $count % $inc if $inc >= 1; 4028 4029 my $status; 4030 if($inc == -1 or $inc eq 'except_last') { 4031 $status = 1 unless $count - 1 == $end; 4032 } 4033 elsif($inc eq '0' or $inc eq 'first_only') { 4034 $status = 1 if $count == 1 || $count == ($page_start + 1); 4035 } 4036 elsif($inc eq 'except_first') { 4037 $status = 1 unless $count == 1 || $count == ($page_start + 1); 4038 } 4039 elsif($inc eq 'last_only') { 4040 $status = 1 if $count - 1 == $end; 4041 } 4042 elsif($inc eq 'absolute_last') { 4043 $status = 1 if $count == $array_last; 4044 } 4045 elsif($inc eq 'absolute_first') { 4046 $status = 1 if $count == 1; 4047 } 4048 return ! $status; 4049} 4050 4051sub iterate_array_list { 4052 my ($i, $end, $count, $text, $ary, $opt_select, $fh, $opt, $fa) = @_; 4053#::logDebug("passed opt=" . ::uneval($opt)); 4054 my $page_start = $i; 4055 my $array_last = scalar @{$ary || []}; 4056 my $r = ''; 4057 $opt ||= {}; 4058 4059 # The $Row object needs to be built per-row, so undef it initially. 4060 $fa ||= []; 4061 @$fa = sort { $fh->{$a} <=> $fh->{$b} } keys %$fh 4062 if ! @$fa and ref $fh eq 'HASH'; 4063 undef $Row; 4064 4065 my $lim; 4066 if($lim = $::Limit->{list_text_size} and length($text) > $lim) { 4067 my $len = length($text); 4068 my $caller = join "|", caller(); 4069 my $msg = "Large list text encountered, length=$len, caller=$caller"; 4070 logError($msg); 4071 return undef if $::Limit->{list_text_overflow} eq 'abort'; 4072 } 4073 4074 # Optimize for no-match, on-match, etc 4075 if(! $opt->{iterator} and $text !~ /\[(?:if-)?$Prefix-/) { 4076 for(; $i <= $end; $i++) { 4077 $r .= $text; 4078 } 4079 return $r; 4080 } 4081 4082 my $nc = map_list_routines('ArrayCode', $opt); 4083 4084 $nc and local(@Ary_code{keys %$nc}) = values %$nc; 4085 4086 my ($run, $row, $code, $return); 4087my $once = 0; 4088#::logDebug("iterating array $i to $end. count=$count opt_select=$opt_select ary=" . uneval($ary)); 4089 4090 $text =~ s{ 4091 $B$QR{_include} 4092 }{ 4093 my $filename = $1; 4094 4095 $Data_cache{"/$filename"} or do { 4096 my $content = Vend::Util::readfile($filename); 4097 vars_and_comments(\$content); 4098 $Data_cache{"/$filename"} = $content; 4099 }; 4100 }igex; 4101 4102 if($text =~ m/^$B$QR{_line}\s*$/is) { 4103 my $i = $1 || 0; 4104 my $fa = $opt->{mv_return_fields}; 4105 $r .= join "\t", @$fa[$i .. $#$fa]; 4106 $r .= "\n"; 4107 } 4108 1 while $text =~ s#$IB$QR{_header_param_if}$IE[-_]header[-_]param\1\]# 4109 (defined $opt->{$3} ? $opt->{$3} : '') 4110 ? pull_if($5,$2,$4,$opt->{$3}) 4111 : pull_else($5,$2,$4,$opt->{$3})#ige; 4112 $text =~ s#$B$QR{_header_param}#defined $opt->{$1} ? ed($opt->{$1}) : ''#ige; 4113 while($text =~ s#$B$QR{_sub}$E$QR{'/_sub'}##i) { 4114 my $name = $1; 4115 my $routine = $2; 4116 ## Not necessary? 4117 ## $Vend::Cfg->{Sub}{''} = sub { errmsg('undefined sub') } 4118 ## unless defined $Vend::Cfg->{Sub}{''}; 4119 $routine = 'sub { ' . $routine . ' }' unless $routine =~ /^\s*sub\s*{/; 4120 my $sub; 4121 eval { 4122 $sub = $ready_safe->reval($routine); 4123 }; 4124 if($@) { 4125 logError( errmsg("syntax error on %s-sub %s]: $@", $B, $name) ); 4126 $sub = sub { errmsg('ERROR') }; 4127 } 4128#::logDebug("sub $name: $sub --> $routine"); 4129 $Vend::Cfg->{Sub}{$name} = $sub; 4130 } 4131 4132 my $oexec = { %$opt }; 4133 4134 if($opt->{iterator}) { 4135 my $sub; 4136 $sub = $opt->{iterator} if ref($opt->{iterator}) eq 'CODE'; 4137 $sub ||= $Vend::Cfg->{Sub}{$opt->{iterator}} 4138 || $Global::GlobalSub->{$opt->{iterator}}; 4139 if(! $sub) { 4140 logError( 4141 "list iterator subroutine '%s' called but not defined. Skipping.", 4142 $opt->{iterator}, 4143 ); 4144 return ''; 4145 } 4146 for( ; $i <= $end ; $i++ ) { 4147 $r .= $sub->($text, $ary->[$i], $oexec); 4148 } 4149 return $r; 4150 } 4151 4152 1 while $text =~ s{(\[(if[-_]$Prefix[-_][a-zA-Z]+)(?=.*\[\2)\s.*\[/\2\])} 4153 { 4154 resolve_nested_if($1, $2) 4155 }se; 4156 4157 # log helpful errors if any unknown field names are 4158 # used in if-prefix-param or prefix-param tags 4159 my @field_msg = ('error', "Unknown field name '%s' used in tag %s"); 4160 $run = $text; 4161 if(! $opt->{ignore_undefined}) { 4162 $run =~ s#$B$QR{_param}# defined $fh->{$1} || 4163 logOnce(@field_msg, $1, "$Orig_prefix-param") #ige; 4164 $run =~ s#$IB$QR{_param_if}# defined $fh->{$3} || 4165 logOnce(@field_msg, $3, "if-$Orig_prefix-param") #ige; 4166 } 4167 4168 for( ; $i <= $end ; $i++, $count++ ) { 4169 $row = $ary->[$i]; 4170 last unless defined $row; 4171 $code = $row->[0]; 4172 4173#::logDebug("Doing $code substitution, count $count++"); 4174#::logDebug("Doing '" . substr($code, 0, index($code, "\n") + 1) . "' substitution, count $count++"); 4175 4176 $run = $text; 4177 $run =~ s#$B$QR{_alternate}$E$QR{'/_alternate'}# 4178 alternate($count, $1, $end, $page_start, $array_last) 4179 ? pull_else($2) 4180 : pull_if($2)#ige; 4181 1 while $run =~ s#$IB$QR{_param_if}$IE[-_](?:param|modifier)\1\]# 4182 (defined $fh->{$3} ? $row->[$fh->{$3}] : '') 4183 ? pull_if($5,$2,$4,$row->[$fh->{$3}]) 4184 : pull_else($5,$2,$4,$row->[$fh->{$3}])#ige; 4185 $run =~ s#$B$QR{_param}#defined $fh->{$1} ? ed($row->[$fh->{$1}]) : ''#ige; 4186 1 while $run =~ s#$IB$QR{_pos_if}$IE[-_]pos\1\]# 4187 $row->[$3] 4188 ? pull_if($5,$2,$4,$row->[$3]) 4189 : pull_else($5,$2,$4,$row->[$3])#ige; 4190 $run =~ s#$B$QR{_pos}#ed($row->[$1])#ige; 4191#::logDebug("fh: " . uneval($fh) . uneval($row)) unless $once++; 4192 1 while $run =~ s#$IB$QR{_field_if}$IE[-_]field\1\]# 4193 my $tmp = product_field($3, $code); 4194 $tmp ? pull_if($5,$2,$4,$tmp) 4195 : pull_else($5,$2,$4,$tmp)#ige; 4196 $run =~ s:$B$QR{_line}:join "\t", @{$row}[ ($1 || 0) .. $#$row]:ige; 4197 $run =~ s:$B$QR{_increment}:$count:ig; 4198 $run =~ s:$B$QR{_accessories}: 4199 $Ary_code{accessories}->($code,$1,{}):ige; 4200 $run =~ s:$B$QR{_options}: 4201 $Ary_code{options}->($code,$1):ige; 4202 $run =~ s:$B$QR{_code}:$code:ig; 4203 $run =~ s:$B$QR{_description}:ed($Ary_code{description}->($code)):ige; 4204 $run =~ s:$B$QR{_field}:ed($Ary_code{field}->($1, $code)):ige; 4205 $run =~ s:$B$QR{_common}:ed($Ary_code{common}->($1, $code)):ige; 4206 tag_labeled_data_row($code, \$run); 4207 $run =~ s!$B$QR{_price}! 4208 currency(product_price($code,$1), $2)!ige; 4209 4210 1 while $run =~ s!$B$QR{_change}$E$QR{'/_change'}\1\]! 4211 check_change($1,$3,undef,$2) 4212 ? pull_if($4) 4213 : pull_else($4)!ige; 4214 $run =~ s#$B$QR{_tag}($Some$E[-_]tag[-_]\1\])# 4215 tag_dispatch($1,$count, $row, $ary, $2)#ige; 4216 $run =~ s#$B$QR{_calc}$E$QR{'/_calc'}# 4217 unless ($Row) { 4218 $Row = {}; 4219 @{$Row}{@$fa} = @$row; 4220 } 4221 tag_calc($1) 4222 #ige; 4223 $run =~ s#$B$QR{_exec}$E$QR{'/_exec'}# 4224 init_calc() if ! $Vend::Calc_initialized; 4225 ( 4226 $Vend::Cfg->{Sub}{$1} || 4227 $Global::GlobalSub->{$1} || 4228 sub { logOnce('error', "subroutine $1 missing for PREFIX-exec"); errmsg('ERROR') } 4229 )->($2,$row,$oexec) 4230 #ige; 4231 $run =~ s#$B$QR{_filter}$E$QR{'/_filter'}#filter_value($1,$2)#ige; 4232 $run =~ s#$B$QR{_last}$E$QR{'/_last'}# 4233 my $tmp = $Ary_code{last}->($1); 4234 $tmp =~ s/^\s+//; 4235 $tmp =~ s/\s+$//; 4236 if($tmp && $tmp < 0) { 4237 last; 4238 } 4239 elsif($tmp) { 4240 $return = 1; 4241 } 4242 '' #ixge; 4243 $run =~ s#$B$QR{_next}$E$QR{'/_next'}# 4244 $Ary_code{next}->($1) != 0 ? (undef $Row, next) : '' #ixge; 4245 $run =~ s/<option\s*/<option SELECTED /i 4246 if $opt_select and $opt_select->($code); 4247 undef $Row; 4248 $r .= $run; 4249 last if $return; 4250 } 4251 return $r; 4252} 4253 4254sub iterate_hash_list { 4255 my($i, $end, $count, $text, $hash, $opt_select, $opt) = @_; 4256 4257 my $r = ''; 4258 $opt ||= {}; 4259 4260 # Optimize for no-match, on-match, etc 4261 if(! $opt->{iterator} and $text !~ /\[/) { 4262 for(; $i <= $end; $i++) { 4263 $r .= $text; 4264 } 4265 return $r; 4266 } 4267 4268 my $code_field = $opt->{code_field} || 'mv_sku'; 4269 my ($run, $code, $return, $item); 4270 4271 my $nc = map_list_routines('HashCode', $opt); 4272 4273 $nc and local(@Hash_code{keys %$nc}) = values %$nc; 4274 4275#::logDebug("iterating hash $i to $end. count=$count opt_select=$opt_select hash=" . uneval($hash)); 4276 1 while $text =~ s#$IB$QR{_header_param_if}$IE[-_]header[-_]param\1\]# 4277 (defined $opt->{$3} ? $opt->{$3} : '') 4278 ? pull_if($5,$2,$4,$opt->{$3}) 4279 : pull_else($5,$2,$4,$opt->{$3})#ige; 4280 $text =~ s#$B$QR{_header_param}#defined $opt->{$1} ? ed($opt->{$1}) : ''#ige; 4281 while($text =~ s#$B$QR{_sub}$E$QR{'/_sub'}##i) { 4282 my $name = $1; 4283 my $routine = $2; 4284 ## Not necessary? 4285 ## $Vend::Cfg->{Sub}{''} = sub { errmsg('undefined sub') } 4286 ## unless defined $Vend::Cfg->{Sub}{''}; 4287 $routine = 'sub { ' . $routine . ' }' unless $routine =~ /^\s*sub\s*{/; 4288 my $sub; 4289 eval { 4290 $sub = $ready_safe->reval($routine); 4291 }; 4292 if($@) { 4293 logError( errmsg("syntax error on %s-sub %s]: $@", $B, $name) ); 4294 $sub = sub { errmsg('ERROR') }; 4295 } 4296 $Vend::Cfg->{Sub}{$name} = $sub; 4297 } 4298#::logDebug("subhidden: $opt->{subhidden}"); 4299 4300 my $oexec = { %$opt }; 4301 4302 if($opt->{iterator}) { 4303 my $sub; 4304 $sub = $opt->{iterator} if ref($opt->{iterator}) eq 'CODE'; 4305 $sub ||= $Vend::Cfg->{Sub}{$opt->{iterator}} 4306 || $Global::GlobalSub->{$opt->{iterator}}; 4307 if(! $sub) { 4308 logError( 4309 "list iterator subroutine '%s' called but not defined. Skipping.", 4310 $opt->{iterator}, 4311 ); 4312 return ''; 4313 } 4314 4315 for( ; $i <= $end ; $i++ ) { 4316 $r .= $sub->($text, $hash->[$i], $oexec); 4317 } 4318 return $r; 4319 } 4320 4321 1 while $text =~ s{(\[(if[-_]$Prefix[-_][a-zA-Z]+)(?=.*\[\2)\s.*\[/\2\])} 4322 { 4323 resolve_nested_if($1, $2) 4324 }se; 4325 4326 # undef the $Row object, as it should only be set as needed by [PREFIX-calc] 4327 undef $Row; 4328 4329 for ( ; $i <= $end; $i++, $count++) { 4330 $item = $hash->[$i]; 4331 $item->{mv_ip} = $opt->{reverse} ? ($end - $i) : $i; 4332 if($opt->{modular}) { 4333 if($opt->{master}) { 4334 next unless $item->{mv_mi} eq $opt->{master}; 4335 } 4336 if($item->{mv_mp} and $item->{mv_si} and ! $opt->{subitems}) { 4337# $r .= <<EOF if $opt->{subhidden}; 4338#<INPUT TYPE="hidden" NAME="quantity$item->{mv_ip}" VALUE="$item->{quantity}"> 4339#EOF 4340 next; 4341 } 4342 } 4343 $item->{mv_cache_price} = undef; 4344 $code = $item->{$code_field} || $item->{code}; 4345 $code = '' unless defined $code; 4346 4347#::logDebug("Doing $code (variant $item->{code}) substitution, count $count++"); 4348 4349 $run = $text; 4350 $run =~ s#$B$QR{_alternate}$E$QR{'/_alternate'}# 4351 alternate($i + 1, $1, $end) 4352 ? pull_else($2) 4353 : pull_if($2)#ge; 4354 tag_labeled_data_row($code,\$run); 4355 $run =~ s:$B$QR{_line}:join "\t", @{$hash}:ge; 4356 1 while $run =~ s#$IB$QR{_param_if}$IE[-_](?:param|modifier)\1\]# 4357 $item->{$3} ? pull_if($5,$2,$4,$item->{$3}) 4358 : pull_else($5,$2,$4,$item->{$3})#ige; 4359 1 while $run =~ s#$IB$QR{_parent_if}$IE[-_]parent\1\]# 4360 $item->{$3} ? pull_if($5,$2,$4,$opt->{$3}) 4361 : pull_else($5,$2,$4,$opt->{$3})#ige; 4362 1 while $run =~ s#$IB$QR{_field_if}$IE[-_]field\1\]# 4363 my $tmp = item_field($item, $3); 4364 $tmp ? pull_if($5,$2,$4,$tmp) 4365 : pull_else($5,$2,$4,$tmp)#ge; 4366 $run =~ s:$B$QR{_increment}:$i + 1:ge; 4367 4368 $run =~ s:$B$QR{_accessories}: 4369 $Hash_code{accessories}->($code,$1,{},$item):ge; 4370 $run =~ s:$B$QR{_options}: 4371 $Hash_code{options}->($item,$1):ige; 4372 $run =~ s:$B$QR{_sku}:$code:ig; 4373 $run =~ s:$B$QR{_code}:$item->{code}:ig; 4374 $run =~ s:$B$QR{_quantity}:$item->{quantity}:g; 4375 $run =~ s:$B$QR{_param}:ed($item->{$1}):ge; 4376 $run =~ s:$B$QR{_parent}:ed($opt->{$1}):ge; 4377 $run =~ s:$B$QR{_quantity_name}:quantity$item->{mv_ip}:g; 4378 $run =~ s:$B$QR{_modifier_name}:$1$item->{mv_ip}:g; 4379 $run =~ s!$B$QR{_subtotal}!currency(item_subtotal($item),$1)!ge; 4380 $run =~ s!$B$QR{_discount_subtotal}! 4381 currency( discount_subtotal($item), $1 )!ge; 4382 $run =~ s:$B$QR{_code}:$code:g; 4383 $run =~ s:$B$QR{_field}:ed($Hash_code{field}->($item, $1) || $item->{$1}):ge; 4384 $run =~ s:$B$QR{_common}:ed($Hash_code{common}->($item, $1) || $item->{$1}):ge; 4385 $run =~ s:$B$QR{_description}: 4386 ed($Hash_code{description}->($item) || $item->{description}) 4387 :ge; 4388 $run =~ s!$B$QR{_price}!currency(item_price($item,$1), $2)!ge; 4389 $run =~ s!$B$QR{_discount_price}! 4390 currency( 4391 discount_price($item, item_price($item,$1), $1 || 1) 4392 , $2 4393 )!ge 4394 or 4395 $run =~ s!$QR{discount_price}! 4396 currency( 4397 discount_price($item, item_price($item,$1), $1 || 1) 4398 , $2 4399 )!ge; 4400 $run =~ s!$B$QR{_difference}! 4401 currency( 4402 item_difference( 4403 $item->{code}, 4404 item_price($item, $item->{quantity}), 4405 $item->{quantity}, 4406 $item, 4407 ), 4408 $2, 4409 )!ge; 4410 $run =~ s!$B$QR{_discount}! 4411 currency( 4412 item_discount( 4413 $item->{code}, 4414 item_price($item, $item->{quantity}), 4415 $item->{quantity}, 4416 ), 4417 $2, 4418 )!ge; 4419 1 while $run =~ s!$B$QR{_change}$E$QR{'/_change'}\1\]! 4420 check_change($1,$3,undef,$2) 4421 ? pull_if($4) 4422 : pull_else($4)!ige; 4423 $run =~ s#$B$QR{_tag}($All$E[-_]tag[-_]\1\])# 4424 tag_dispatch($1,$count, $item, $hash, $2)#ige; 4425 $Row = $item; 4426 $run =~ s#$B$QR{_calc}$E$QR{'/_calc'}#tag_calc($1)#ige; 4427 $run =~ s#$B$QR{_exec}$E$QR{'/_exec'}# 4428 init_calc() if ! $Vend::Calc_initialized; 4429 ( 4430 $Vend::Cfg->{Sub}{$1} || 4431 $Global::GlobalSub->{$1} || 4432 sub { 'ERROR' } 4433 )->($2,$item,$oexec) 4434 #ige; 4435 $run =~ s#$B$QR{_filter}$E$QR{'/_filter'}#filter_value($1,$2)#ige; 4436 $run =~ s#$B$QR{_last}$E$QR{'/_last'}# 4437 my $tmp = interpolate_html($1); 4438 if($tmp && $tmp < 0) { 4439 last; 4440 } 4441 elsif($tmp) { 4442 $return = 1; 4443 } 4444 '' #xoge; 4445 $run =~ s#$B$QR{_next}$E$QR{'/_next'}# 4446 interpolate_html($1) != 0 ? next : '' #oge; 4447 $run =~ s/<option\s*/<option SELECTED /i 4448 if $opt_select and $opt_select->($code); 4449 4450 $r .= $run; 4451 undef $Row; 4452#::logDebug("item $code mv_cache_price: $item->{mv_cache_price}"); 4453 delete $item->{mv_cache_price}; 4454 last if $return; 4455 } 4456 4457 return $r; 4458} 4459 4460sub error_opt { 4461 my ($opt, @args) = @_; 4462 return undef unless ref $opt; 4463 my $msg = errmsg(@args); 4464 $msg = "$opt->{error_id}: $msg" if $opt->{error_id}; 4465 if($opt->{log_error}) { 4466 logError($msg); 4467 } 4468 return $msg if $opt->{show_error}; 4469 return undef; 4470} 4471 4472sub query { 4473 if(ref $_[0]) { 4474 unshift @_, ''; 4475 } 4476 my ($query, $opt, $text) = @_; 4477 $opt = {} if ! $opt; 4478 $opt->{prefix} = 'sql' unless $opt->{prefix}; 4479 if($opt->{more} and $Vend::More_in_progress) { 4480 undef $Vend::More_in_progress; 4481 return region($opt, $text); 4482 } 4483 $opt->{table} = $Vend::Cfg->{ProductFiles}[0] 4484 unless $opt->{table}; 4485 my $db = $Vend::Database{$opt->{table}} ; 4486 return $opt->{failure} if ! $db; 4487 4488 $opt->{query} = $query 4489 if $query; 4490 4491 $opt->{query} =~ s: 4492 \[\Q$opt->{prefix}\E[_-]quote\](.*?)\[/\Q$opt->{prefix}\E[_-]quote\] 4493 : 4494 $db->quote($1) 4495 :xisge; 4496 4497 if (! $opt->{wantarray} and ! defined $MVSAFE::Safe) { 4498 my $result = $db->query($opt, $text); 4499 return (ref $result) ? '' : $result; 4500 } 4501 $db->query($opt, $text); 4502} 4503 4504sub html_table { 4505 my($opt, $ary, $na) = @_; 4506 4507 if (!$na) { 4508 $na = [ split /\s+/, $opt->{columns} ]; 4509 } 4510 if(! ref $ary) { 4511 $ary =~ s/^\s+//; 4512 $ary =~ s/\s+$//; 4513 my $delimiter = quotemeta $opt->{delimiter} || "\t"; 4514 my $splittor = quotemeta $opt->{record_delim} || "\n"; 4515 my (@rows) = split /$splittor/, $ary; 4516 $na = [ split /$delimiter/, shift @rows ] if $opt->{th}; 4517 $ary = []; 4518 my $count = scalar @$na || -1; 4519 for (@rows) { 4520 push @$ary, [split /$delimiter/, $_, $count]; 4521 } 4522 } 4523 4524 my ($tr, $td, $th, $fc, $fr) = @{$opt}{qw/tr td th fc fr/}; 4525 4526 for($tr, $td, $th, $fc, $fr) { 4527 next unless defined $_; 4528 s/(.)/ $1/; 4529 } 4530 4531 my $r = ''; 4532 $tr = '' if ! defined $tr; 4533 $td = '' if ! defined $td; 4534 if(! defined $th || $th and scalar @$na ) { 4535 $th = '' if ! defined $th; 4536 $r .= "<tr$tr>"; 4537 for(@$na) { 4538 $r .= "<th$th><b>$_</b></th>"; 4539 } 4540 $r .= "</tr>\n"; 4541 } 4542 my $row; 4543 if($fr) { 4544 $r .= "<tr$fr>"; 4545 my $val; 4546 $row = shift @$ary; 4547 if($fc) { 4548 $val = (shift @$row) || ' '; 4549 $r .= "<td$fc>$val</td>"; 4550 } 4551 foreach (@$row) { 4552 $val = $_ || ' '; 4553 $r .= "<td$td>$val</td>"; 4554 } 4555 $r .= "</tr>\n"; 4556 4557 } 4558 foreach $row (@$ary) { 4559 $r .= "<tr$tr>"; 4560 my $val; 4561 if($fc) { 4562 $val = (shift @$row) || ' '; 4563 $r .= "<td$fc>$val</td>"; 4564 } 4565 foreach (@$row) { 4566 $val = $_ || ' '; 4567 $r .= "<td$td>$val</td>"; 4568 } 4569 $r .= "</tr>\n"; 4570 } 4571 return $r; 4572} 4573 4574# 4575# Tests of above routines 4576# 4577#print html_table( { 4578# td => "BGCOLOR=#FFFFFF", 4579# }, 4580#[ 4581# [qw/ data1a data2a data3a/], 4582# [qw/ data1b data2b data3b/], 4583# [qw/ data1c data2c data3c/], 4584#], 4585#[ qw/cell1 cell2 cell3/ ], 4586#); 4587# 4588#print html_table( { 4589# td => "BGCOLOR=#FFFFFF", 4590# columns => "cell1 cell2 cell3", 4591# }, <<EOF); 4592#data1a data2a data3a 4593#data1b data2b data3b 4594#data1c data2c data3c 4595#EOF 4596 4597 4598# SQL 4599sub tag_sql_list { 4600 my($text,$ary,$nh,$opt,$na) = @_; 4601 $opt = {} unless defined $opt; 4602 $opt->{prefix} = 'sql' if ! defined $opt->{prefix}; 4603 $opt->{list_prefix} = 'sql[-_]list' if ! defined $opt->{prefix}; 4604 4605 my $object = { 4606 mv_results => $ary, 4607 mv_field_hash => $nh, 4608 mv_return_fields => $na, 4609 mv_more_id => $opt->{mv_more_id}, 4610 matches => scalar @$ary, 4611 }; 4612 4613 # Scans the option hash for more search settings if mv_more_alpha 4614 # is set in [query ...] tag.... 4615 if($opt->{ma}) { 4616 # Find the sort field and alpha options.... 4617 Vend::Scan::parse_profile_ref($object, $opt); 4618 # We need to turn the hash reference into a search object 4619 $object = new Vend::Search (%$object); 4620 # Delete this so it will meet conditions for creating a more 4621 delete $object->{mv_matchlimit}; 4622 } 4623 4624 $opt->{object} = $object; 4625 return region($opt, $text); 4626} 4627# END SQL 4628 4629# Displays a search page with the special [search-list] tag evaluated. 4630 4631sub opt_region { 4632 my $opt = pop @_; 4633 my $new = { %$opt }; 4634 my $out = iterate_hash_list(@_,[$new]); 4635 $Prefix = $Orig_prefix; 4636 return $out; 4637} 4638 4639sub region { 4640 4641 my($opt,$page) = @_; 4642 4643 my $obj; 4644 4645 if($opt->{object}) { 4646 ### The caller supplies the object, no search to be done 4647 $obj = $opt->{object}; 4648 } 4649 else { 4650 ### We need to run a search to get an object 4651 my $c; 4652 if($CGI::values{mv_more_matches} || $CGI::values{MM}) { 4653 4654 ### It is a more function, we need to get the parameters 4655 find_search_params(\%CGI::values); 4656 delete $CGI::values{mv_more_matches}; 4657 } 4658 elsif ($opt->{search}) { 4659 ### Explicit search in tag parameter, run just like any 4660 if($opt->{more} and $::Instance->{SearchObject}{''}) { 4661 $obj = $::Instance->{SearchObject}{''}; 4662 #::logDebug("cached search"); 4663 } 4664 else { 4665 $c = { mv_search_immediate => 1, 4666 mv_search_label => $opt->{label} || 'current', 4667 }; 4668 my $params = escape_scan($opt->{search}); 4669 Vend::Scan::find_search_params($c, $params); 4670 $c->{mv_no_more} = ! $opt->{more}; 4671 $obj = perform_search($c); 4672 } 4673 } 4674 else { 4675 ### See if we have a search already done for this label 4676 $obj = $::Instance->{SearchObject}{$opt->{label}}; 4677 } 4678 4679 # If none of the above happen, we need to perform a search 4680 # based on the passed CGI parameters 4681 if(! $obj) { 4682 $obj = perform_search(); 4683 $obj = { 4684 matches => 0, 4685 mv_search_error => [ errmsg('No search was found') ], 4686 } if ! $obj; 4687 } 4688 finish_search($obj); 4689 4690 # Label it for future reference 4691 $::Instance->{SearchObject}{$opt->{label}} = $opt->{object} = $obj; 4692 } 4693 4694 my $lprefix; 4695 my $mprefix; 4696 if($opt->{list_prefix}) { 4697 $lprefix = $opt->{list_prefix}; 4698 $mprefix = "(?:$opt->{list_prefix}-)?"; 4699 } 4700 elsif ($opt->{prefix}) { 4701 $lprefix = "(?:$opt->{prefix}-)?list"; 4702 $mprefix = "(?:$opt->{prefix}-)?"; 4703 } 4704 else { 4705 $lprefix = "list"; 4706 $mprefix = ""; 4707 } 4708 4709#::logDebug("region: opt:\n" . uneval($opt) . "\npage:" . substr($page,0,100)); 4710 4711 if($opt->{ml} and ! defined $obj->{mv_matchlimit} ) { 4712 $obj->{mv_matchlimit} = $opt->{ml}; 4713 $obj->{mv_more_decade} = $opt->{md}; 4714 $obj->{matches} = scalar @{$obj->{mv_results}}; 4715 $obj->{mv_cache_key} = generate_key($opt->{query} || substr($page,0,100)); 4716 $obj->{mv_more_permanent} = $opt->{pm}; 4717 $obj->{mv_first_match} = $opt->{fm} if $opt->{fm}; 4718 $obj->{mv_search_page} = $opt->{sp} if $opt->{sp}; 4719 $obj->{prefix} = $opt->{prefix} if $opt->{prefix}; 4720 my $out = delete $obj->{mv_results}; 4721 Vend::Search::save_more($obj, $out); 4722 $obj->{mv_results} = $out; 4723 } 4724 4725 $opt->{prefix} = $obj->{prefix} if $obj->{prefix}; 4726 4727 $Orig_prefix = $Prefix = $opt->{prefix} || 'item'; 4728 4729 $B = qr(\[$Prefix)i; 4730 $E = qr(\[/$Prefix)i; 4731 $IB = qr(\[if[-_]$Prefix)i; 4732 $IE = qr(\[/if[-_]$Prefix)i; 4733 4734 my $new; 4735 $page =~ s! 4736 \[ ( $mprefix more[-_]list ) $Optx$Optx$Optx$Optx$Optx \] 4737 ($Some) 4738 \[/\1\] 4739 ! 4740 tag_more_list($2,$3,$4,$5,$6,$opt,$7) 4741 !xige; 4742 $page =~ s! 4743 \[ ( $mprefix on[-_]match )\] 4744 ($Some) 4745 \[/\1\] 4746 ! 4747 $obj->{matches} > 0 ? opt_region(0,0,1,$2,$opt) : '' 4748 !xige; 4749 $page =~ s! 4750 \[ ( $mprefix no[-_]match )\] 4751 ($Some) 4752 \[/\1\] 4753 ! 4754 $obj->{matches} > 0 ? '' : opt_region(0,0,1,$2,$opt) 4755 !xige; 4756 4757 $page =~ s:\[($lprefix)\]($Some)\[/\1\]:labeled_list($opt,$2,$obj):ige 4758 or $page = labeled_list($opt,$page,$obj); 4759#::logDebug("past labeled_list"); 4760 4761 return $page; 4762} 4763 4764sub tag_loop_list { 4765 my ($list, $opt, $text) = @_; 4766 4767 my $fn; 4768 my @rows; 4769 4770 $opt->{prefix} ||= 'loop'; 4771 $opt->{label} ||= "loop" . ++$::Instance->{List_it} . $Global::Variable->{MV_PAGE}; 4772 4773#::logDebug("list is: " . uneval($list) ); 4774 4775 ## Thanks to Kaare Rasmussen for this suggestion 4776 ## about passing embedded Perl objects to a list 4777 4778 # Can pass object.mv_results=$ary object.mv_field_names=$ary 4779 if ($opt->{object}) { 4780 my $obj = $opt->{object}; 4781 # ensure that number of matches is always set 4782 # so [on-match] / [no-match] works 4783 $obj->{matches} = scalar(@{$obj->{mv_results}}); 4784 return region($opt, $text); 4785 } 4786 4787 # Here we can take the direct results of an op like 4788 # @set = $db->query() && return \@set; 4789 # Called with 4790 # [loop list=`$Scratch->{ary}`] [loop-code] 4791 # [/loop] 4792 if (ref $list) { 4793#::logDebug("opt->list in: " . uneval($list) ); 4794 unless (ref $list eq 'ARRAY' and ref $list->[0] eq 'ARRAY') { 4795 logError("loop was passed invalid list=`...` argument"); 4796 return; 4797 } 4798 my ($ary, $fh, $fa) = @$list; 4799 my $obj = $opt->{object} ||= {}; 4800 $obj->{mv_results} = $ary; 4801 $obj->{matches} = scalar @$ary; 4802 $obj->{mv_field_names} = $fa if $fa; 4803 $obj->{mv_field_hash} = $fh if $fh; 4804 if($opt->{ml}) { 4805 $obj->{mv_matchlimit} = $opt->{ml}; 4806 $obj->{mv_no_more} = ! $opt->{more}; 4807 $obj->{mv_first_match} = $opt->{mv_first_match} || 0; 4808 $obj->{mv_next_pointer} = $opt->{mv_first_match} + $opt->{ml}; 4809 } 4810 return region($opt, $text); 4811 } 4812 4813 my $delim; 4814 4815 if($opt->{search}) { 4816#::logDebug("loop resolve search"); 4817 if($opt->{more} and $Vend::More_in_progress) { 4818 undef $Vend::More_in_progress; 4819 return region($opt, $text); 4820 } 4821 else { 4822 return region($opt, $text); 4823 } 4824 } 4825 elsif ($opt->{file}) { 4826#::logDebug("loop resolve file"); 4827 $list = Vend::Util::readfile($opt->{file}); 4828 $opt->{lr} = 1 unless 4829 defined $opt->{lr} 4830 or $opt->{quoted}; 4831 } 4832 elsif ($opt->{extended}) { 4833 ### 4834 ### This returns 4835 ### 4836 my ($view, $tab, $key) = split /:+/, $opt->{extended}, 3; 4837 if(! $key) { 4838 $key = $tab; 4839 $tab = $view; 4840 undef $view; 4841 } 4842 my $id = $tab; 4843 $id .= "::$key" if $key; 4844 my $meta = Vend::Table::Editor::meta_record( 4845 $id, 4846 $view, 4847 $opt->{table}, 4848 $opt->{extended_only}, 4849 ); 4850 if(! $meta) { 4851 $opt->{object} = { 4852 matches => 1, 4853 mv_results => [], 4854 mv_field_names => [], 4855 }; 4856 } 4857 else { 4858 $opt->{object} = { 4859 matches => 1, 4860 mv_results => [ $meta ], 4861 }; 4862 } 4863 return region($opt, $text); 4864 } 4865 4866 if ($fn = $opt->{fn} || $opt->{mv_field_names}) { 4867 $fn = [ grep /\S/, split /[\s,]+/, $fn ]; 4868 } 4869 4870 if ($opt->{lr}) { 4871#::logDebug("loop resolve line"); 4872 $list =~ s/^\s+//; 4873 $list =~ s/\s+$//; 4874 if ($list) { 4875 $delim = $opt->{delimiter} || "\t"; 4876 my $splittor = $opt->{record_delim} || "\n"; 4877 if ($splittor eq "\n") { 4878 $list =~ s/\r\n/\n/g; 4879 } 4880 4881 eval { 4882 @rows = map { [ split /\Q$delim/, $_ ] } split /\Q$splittor/, $list; 4883 }; 4884 } 4885 } 4886 elsif($opt->{acclist}) { 4887#::logDebug("loop resolve acclist"); 4888 $fn = [ qw/option label/ ] unless $fn; 4889 eval { 4890 my @items = split /\s*,\s*/, $list; 4891 for(@items) { 4892 my ($o, $l) = split /=/, $_; 4893 $l = $o unless $l; 4894 push @rows, [ $o, $l ]; 4895 } 4896 }; 4897#::logDebug("rows:" . uneval(\@rows)); 4898 } 4899 elsif($opt->{quoted}) { 4900#::logDebug("loop resolve quoted"); 4901 my @l = Text::ParseWords::shellwords($list); 4902 produce_range(\@l) if $opt->{ranges}; 4903 eval { 4904 @rows = map { [$_] } @l; 4905 }; 4906 } 4907 else { 4908#::logDebug("loop resolve default"); 4909 $delim = $opt->{delimiter} || '[,\s]+'; 4910 my @l = split /$delim/, $list; 4911 produce_range(\@l) if $opt->{ranges}; 4912 eval { 4913 @rows = map { [$_] } @l; 4914 }; 4915 } 4916 4917 if($@) { 4918 logError("bad split delimiter in loop list: $@"); 4919#::logDebug("loop resolve error $@"); 4920 } 4921 4922 # head_skip pulls rows off the top, and uses the last row to 4923 # set the field names if mv_field_names/fn option was not set 4924 if ($opt->{head_skip}) { 4925 my $i = 0; 4926 my $last_row; 4927 $last_row = shift(@rows) while $i++ < $opt->{head_skip}; 4928 $fn ||= $last_row; 4929 } 4930 4931 $opt->{object} = { 4932 matches => scalar(@rows), 4933 mv_results => \@rows, 4934 mv_field_names => $fn, 4935 }; 4936 4937#::logDebug("loop object: " . uneval($opt)); 4938 return region($opt, $text); 4939} 4940 4941# Tries to display the on-the-fly page if page is missing 4942sub fly_page { 4943 my($code, $opt, $page) = @_; 4944 4945 my ($selector, $subname, $base, $listref); 4946 4947 return $page if (! $code and $Vend::Flypart eq $Vend::FinalPath); 4948 4949 $code = $Vend::FinalPath 4950 unless $code; 4951 4952 $Vend::Flypart = $code; 4953 4954 if ($subname = $Vend::Cfg->{SpecialSub}{flypage}) { 4955 my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname}; 4956 $listref = $sub->($code); 4957 $listref = { mv_results => [[$listref]] } unless ref($listref); 4958 $base = $listref; 4959 } 4960 else { 4961 $base = product_code_exists_ref($code); 4962 $listref = {mv_results => [[$code]]}; 4963 } 4964 4965#::logDebug("fly_page: code=$code base=$base page=" . substr($page, 0, 100)); 4966 return undef unless $base || $opt->{onfly}; 4967 4968 $base = $Vend::Cfg->{ProductFiles}[0] unless $base; 4969 4970 if($page) { 4971 $selector = 'passed in tag'; 4972 } 4973 elsif( $Vend::ForceFlypage ) { 4974 $selector = $Vend::ForceFlypage; 4975 undef $Vend::ForceFlypage; 4976 } 4977 elsif( $selector = $Vend::Cfg->{PageSelectField} 4978 and db_column_exists($base,$selector) 4979 ) 4980 { 4981 $selector = database_field($base, $code, $selector) 4982 } 4983 4984 $selector = find_special_page('flypage') 4985 unless $selector; 4986#::logDebug("fly_page: selector=$selector"); 4987 4988 unless (defined $page) { 4989 unless( allowed_file($selector) ) { 4990 log_file_violation($selector, 'fly_page'); 4991 return undef; 4992 } 4993 $page = readin($selector); 4994 if (defined $page) { 4995 vars_and_comments(\$page); 4996 } else { 4997 logError("attempt to display code=$code with bad flypage '$selector'"); 4998 return undef; 4999 } 5000 } 5001 5002 # This allows access from embedded Perl 5003 $Tmp->{flycode} = $code; 5004# TRACK 5005 $Vend::Track->view_product($code) if $Vend::Track; 5006# END TRACK 5007 5008 $opt->{prefix} ||= 'item'; 5009# LEGACY 5010 list_compat($opt->{prefix}, \$page) if $page; 5011# END LEGACY 5012 5013 return labeled_list( $opt, $page, $listref); 5014} 5015 5016sub item_difference { 5017 my($code,$price,$q,$item) = @_; 5018 return $price - discount_price($item || $code,$price,$q); 5019} 5020 5021sub item_discount { 5022 my($code,$price,$q) = @_; 5023 return ($price * $q) - discount_price($code,$price,$q) * $q; 5024} 5025 5026sub discount_subtotal { 5027 my ($item, $price) = @_; 5028 5029 unless (ref $item) { 5030 ::logError("Bad call to discount price, item is not reference: %s", $item); 5031 return 0; 5032 } 5033 5034 my $quantity = $item->{quantity} || 1; 5035 5036 $price ||= item_price($item); 5037 my $new_price = discount_price($item, $price); 5038 5039 return $new_price * $quantity; 5040} 5041 5042sub discount_price { 5043 my ($item, $price, $quantity) = @_; 5044 my $extra; 5045 my $code; 5046 5047 unless (ref $item) { 5048 $code = $item; 5049 $item = { code => $code, quantity => ($quantity || 1) }; 5050 } 5051 5052 5053 ($code, $extra) = ($item->{code}, $item->{mv_discount}); 5054 5055 if ($extra and ! $::Discounts) { 5056 my $dspace = $Vend::DiscountSpaceName ||= 'main'; 5057 $Vend::Session->{discount_space}{main} 5058 = $Vend::Session->{discount} 5059 ||= {} unless $Vend::Session->{discount_space}{main}; 5060 $::Discounts 5061 = $Vend::Session->{discount} 5062 = $Vend::Session->{discount_space}{$dspace} 5063 ||= {} if $Vend::Cfg->{DiscountSpacesOn}; 5064 } 5065 5066 return $price unless $extra or $::Discounts && %$::Discounts; 5067 5068 $quantity = $item->{quantity}; 5069 5070 $Vend::Interpolate::item = $item; 5071 $Vend::Interpolate::q = $quantity || 1; 5072 $Vend::Interpolate::s = $price; 5073 5074 my $subtotal = $price * $quantity; 5075 5076#::logDebug("quantity=$q code=$item->{code} price=$s"); 5077 5078 my ($discount, $return); 5079 5080 for($code, 'ALL_ITEMS') { 5081 next unless $discount = $::Discounts->{$_}; 5082 $Vend::Interpolate::s = $return ||= $subtotal; 5083 $return = $ready_safe->reval($discount); 5084 if($@) { 5085 ::logError("Bad discount code for %s: %s", $discount); 5086 $return = $subtotal; 5087 next; 5088 } 5089 $price = $return / $q; 5090 } 5091 5092 if($extra) { 5093 EXTRA: { 5094 $return = $ready_safe->reval($extra); 5095 last EXTRA if $@; 5096 $price = $return; 5097 } 5098 } 5099 return $price; 5100} 5101 5102sub apply_discount { 5103 my($item) = @_; 5104 5105 my($formula, $cost); 5106 my(@formulae); 5107 5108 # Check for individual item discount 5109 push(@formulae, $::Discounts->{$item->{code}}) 5110 if defined $::Discounts->{$item->{code}}; 5111 # Check for all item discount 5112 push(@formulae, $::Discounts->{ALL_ITEMS}) 5113 if defined $::Discounts->{ALL_ITEMS}; 5114 push(@formulae, $item->{mv_discount}) 5115 if defined $item->{mv_discount}; 5116 5117 my $subtotal = item_subtotal($item); 5118 5119 init_calc() unless $Vend::Calc_initialized; 5120 # Calculate any formalas found 5121 foreach $formula (@formulae) { 5122 next unless $formula; 5123 $Vend::Interpolate::q = $item->{quantity}; 5124 $Vend::Interpolate::s = $subtotal; 5125 $Vend::Interpolate::item = $item; 5126# $formula =~ s/\$q\b/$item->{quantity}/g; 5127# $formula =~ s/\$s\b/$subtotal/g; 5128 $cost = $ready_safe->reval($formula); 5129 if($@) { 5130 logError 5131 "Discount for $item->{code} has bad formula. Not applied.\n$@"; 5132 next; 5133 } 5134 $subtotal = $cost; 5135 } 5136 $subtotal; 5137} 5138 5139# Stubs for relocated shipping stuff in case of legacy code 5140*read_shipping = \&Vend::Ship::read_shipping; 5141*custom_shipping = \&Vend::Ship::shipping; 5142*tag_shipping_desc = \&Vend::Ship::tag_shipping_desc; 5143*shipping = \&Vend::Ship::shipping; 5144*tag_handling = \&Vend::Ship::tag_handling; 5145*tag_shipping = \&Vend::Ship::tag_shipping; 5146*tag_ups = \&Vend::Ship::tag_ups; 5147 5148# Sets the value of a scratchpad field 5149sub set_scratch { 5150 my($var,$val) = @_; 5151 $::Scratch->{$var} = $val; 5152 return ''; 5153} 5154 5155# Sets the value of a temporary scratchpad field 5156sub set_tmp { 5157 my($var,$val) = @_; 5158 push @Vend::TmpScratch, $var; 5159 $::Scratch->{$var} = $val; 5160 return ''; 5161} 5162 5163sub timed_build { 5164 my $file = shift; 5165 my $opt = shift; 5166 my $abort; 5167 5168 if ($Vend::LockedOut) { 5169 $abort = 1; 5170 delete $opt->{new}; 5171 } 5172 elsif (defined $opt->{if}) { 5173 $abort = 1 if ! $opt->{if}; 5174 } 5175 5176 my $saved_file; 5177 if($opt->{scan}) { 5178 $saved_file = $Vend::ScanPassed; 5179 $abort = 1 if ! $saved_file || $file =~ m:MM=:; 5180 } 5181 5182 $opt->{login} = 1 if $opt->{auto}; 5183 5184 my $save_scratch; 5185 if($opt->{new} and $Vend::new_session and !$Vend::Session->{logged_in}) { 5186#::logDebug("we are new"); 5187 $save_scratch = $::Scratch; 5188 $Vend::Cookie = 1; 5189 $Vend::Session->{scratch} = { %{$Vend::Cfg->{ScratchDefault}}, mv_no_session_id => 1, mv_no_count => 1, mv_force_cache => 1 }; 5190 5191 } 5192 else { 5193 return Vend::Interpolate::interpolate_html($_[0]) 5194 if $abort 5195 or ( ! $opt->{force} 5196 and 5197 ( ! $Vend::Cookie 5198 or ! $opt->{login} && $Vend::Session->{logged_in} 5199 ) 5200 ); 5201 } 5202 5203 local ($Scratch->{mv_no_session_id}); 5204 $Scratch->{mv_no_session_id} = 1; 5205 5206 if($opt->{auto}) { 5207 $opt->{minutes} = 60 unless defined $opt->{minutes}; 5208 my $dir = "$Vend::Cfg->{ScratchDir}/auto-timed"; 5209 unless (allowed_file($dir)) { 5210 log_file_violation($dir, 'timed_build'); 5211 return; 5212 } 5213 if(! -d $dir) { 5214 require File::Path; 5215 File::Path::mkpath($dir); 5216 } 5217 $file = "$dir/" . generate_key(@_); 5218 } 5219 5220 my $secs; 5221 CHECKDIR: { 5222 last CHECKDIR if Vend::File::file_name_is_absolute($file); 5223 last CHECKDIR if $file and $file !~ m:/:; 5224 my $dir; 5225 if ($file) { 5226 $dir = '.'; 5227 } 5228 else { 5229 $dir = 'timed'; 5230 $file = $saved_file || $Vend::Flypart || $Global::Variable->{MV_PAGE}; 5231#::logDebug("static=$file"); 5232 if($saved_file) { 5233 $file = $saved_file; 5234 $file =~ s:^scan/::; 5235 $file = generate_key($file); 5236 $file = "scan/$file"; 5237 } 5238 else { 5239 $saved_file = $file = ($Vend::Flypart || $Global::Variable->{MV_PAGE}); 5240 } 5241 $file .= $Vend::Cfg->{HTMLsuffix}; 5242 } 5243 $dir .= "/$1" 5244 if $file =~ s:(.*)/::; 5245 unless (allowed_file($dir)) { 5246 log_file_violation($dir, 'timed_build'); 5247 return; 5248 } 5249 if(! -d $dir) { 5250 require File::Path; 5251 File::Path::mkpath($dir); 5252 } 5253 $file = Vend::Util::catfile($dir, $file); 5254 } 5255 5256#::logDebug("saved=$saved_file"); 5257#::logDebug("file=$file exists=" . -f $file); 5258 if($opt->{minutes}) { 5259 $secs = int($opt->{minutes} * 60); 5260 } 5261 elsif ($opt->{period}) { 5262 $secs = Vend::Config::time_to_seconds($opt->{period}); 5263 } 5264 5265 $file = Vend::Util::escape_chars($file); 5266 if(! $opt->{auto} and ! allowed_file($file)) { 5267 log_file_violation($file, 'timed_build'); 5268 return undef; 5269 } 5270 5271 if( ! -f $file or $secs && (stat(_))[9] < (time() - $secs) ) { 5272 my $out = Vend::Interpolate::interpolate_html(shift); 5273 $opt->{umask} = '22' unless defined $opt->{umask}; 5274 Vend::Util::writefile(">$file", $out, $opt ); 5275 $Vend::Session->{scratch} = $save_scratch if $save_scratch; 5276 return $out; 5277 } 5278 $Vend::Session->{scratch} = $save_scratch if $save_scratch; 5279 return Vend::Util::readfile($file); 5280} 5281 5282sub update { 5283 my ($func, $opt) = @_; 5284 if($func eq 'quantity') { 5285 Vend::Order::update_quantity(); 5286 } 5287 elsif($func eq 'cart') { 5288 my $cart; 5289 if($opt->{name}) { 5290 $cart = $::Carts->{$opt->{name}}; 5291 } 5292 else { 5293 $cart = $Vend::Items; 5294 } 5295 return if ! ref $cart; 5296 Vend::Cart::toss_cart($cart, $opt->{name}); 5297 } 5298 elsif ($func eq 'process') { 5299 Vend::Dispatch::do_process(); 5300 } 5301 elsif ($func eq 'values') { 5302 Vend::Dispatch::update_user(); 5303 } 5304 elsif ($func eq 'data') { 5305 Vend::Data::update_data(); 5306 } 5307 return; 5308} 5309 5310my $Ship_its = 0; 5311 5312sub push_warning { 5313 $Vend::Session->{warnings} = [$Vend::Session->{warnings}] 5314 if ! ref $Vend::Session->{warnings}; 5315 push @{$Vend::Session->{warnings}}, errmsg(@_); 5316 return; 5317} 5318 5319 5320sub taxable_amount { 5321 my($cart, $dspace) = @_; 5322 my($taxable, $i, $code, $item, $tmp, $quantity); 5323 5324 return subtotal($cart || undef, $dspace || undef) unless $Vend::Cfg->{NonTaxableField}; 5325 5326 my($save, $oldspace); 5327 5328 if ($cart) { 5329 $save = $Vend::Items; 5330 tag_cart($cart); 5331 } 5332 5333 # Support for discount namespaces. 5334 $oldspace = switch_discount_space($dspace) if $dspace; 5335 5336 $taxable = 0; 5337 5338 foreach $i (0 .. $#$Vend::Items) { 5339 $item = $Vend::Items->[$i]; 5340 next if is_yes( $item->{mv_nontaxable} ); 5341 next if is_yes( item_field($item, $Vend::Cfg->{NonTaxableField}) ); 5342 $tmp = item_subtotal($item); 5343 unless (%$::Discounts) { 5344 $taxable += $tmp; 5345 } 5346 else { 5347 $taxable += apply_discount($item); 5348 } 5349 } 5350 5351 if (defined $::Discounts->{ENTIRE_ORDER}) { 5352 $Vend::Interpolate::q = tag_nitems(); 5353 $Vend::Interpolate::s = $taxable; 5354 my $cost = $Vend::Interpolate::ready_safe->reval( 5355 $::Discounts->{ENTIRE_ORDER}, 5356 ); 5357 if($@) { 5358 logError 5359 "Discount ENTIRE_ORDER has bad formula. Returning normal subtotal."; 5360 $cost = $taxable; 5361 } 5362 $taxable = $cost; 5363 } 5364 5365 $Vend::Items = $save if defined $save; 5366 5367 # Restore initial discount namespace if appropriate. 5368 switch_discount_space($oldspace) if defined $oldspace; 5369 5370 return $taxable; 5371} 5372 5373 5374 5375sub fly_tax { 5376 my ($area, $opt) = @_; 5377 5378 if(my $country_check = $::Variable->{TAXCOUNTRY}) { 5379 $country_check =~ /\b$::Values->{country}\b/ 5380 or return 0; 5381 } 5382 5383 if(! $area) { 5384 my $zone = $Vend::Cfg->{SalesTax}; 5385 while($zone =~ m/(\w+)/g) { 5386 last if $area = $::Values->{$1}; 5387 } 5388 } 5389#::logDebug("flytax area=$area"); 5390 return 0 unless $area; 5391 my $rates = $::Variable->{TAXRATE}; 5392 my $taxable_shipping = $::Variable->{TAXSHIPPING} || ''; 5393 my $taxable_handling = $::Variable->{TAXHANDLING} || ''; 5394 $rates =~ s/^\s+//; 5395 $rates =~ s/\s+$//; 5396 $area =~ s/^\s+//; 5397 $area =~ s/\s+$//; 5398 my (@rates) = split /\s*,\s*/, $rates; 5399 my $rate; 5400 for(@rates) { 5401 my ($k,$v) = split /\s*=\s*/, $_, 2; 5402 next unless "\U$k" eq "\U$area"; 5403 $rate = $v; 5404 $rate = $rate / 100 if $rate > 1; 5405 last; 5406 } 5407#::logDebug("flytax rate=$rate"); 5408 return 0 unless $rate; 5409 5410 my ($oldcart, $oldspace); 5411 if ($opt->{cart}) { 5412 $oldcart = $Vend::Items; 5413 tag_cart($opt->{cart}); 5414 } 5415 if ($opt->{discount_space}) { 5416 $oldspace = switch_discount_space($opt->{discount_space}); 5417 } 5418 5419 my $amount = taxable_amount(); 5420#::logDebug("flytax before shipping amount=$amount"); 5421 $amount += tag_shipping() 5422 if $taxable_shipping =~ m{(^|[\s,])$area([\s,]|$)}i; 5423 $amount += tag_handling() 5424 if $taxable_handling =~ m{(^|[\s,])$area([\s,]|$)}i; 5425 5426 $Vend::Items = $oldcart if defined $oldcart; 5427 switch_discount_space($oldspace) if defined $oldspace; 5428 5429#::logDebug("flytax amount=$amount return=" . $amount*$rate); 5430 return $amount * $rate; 5431} 5432 5433sub percent_rate { 5434 my $rate = shift; 5435 $rate =~ s/\s*%\s*$// and $rate /= 100; 5436 return $rate; 5437} 5438 5439sub tax_vat { 5440 my($type, $opt) = @_; 5441#::logDebug("entering VAT, opts=" . uneval($opt)); 5442 my $cfield = $::Variable->{MV_COUNTRY_TAX_VAR} || 'country'; 5443 my $country = $opt->{country} || $::Values->{$cfield}; 5444 5445 return 0 if ! $country; 5446 my $ctable = $opt->{country_table} 5447 || $::Variable->{MV_COUNTRY_TABLE} 5448 || 'country'; 5449 my $c_taxfield = $opt->{country_tax_field} 5450 || $::Variable->{MV_COUNTRY_TAX_FIELD} 5451 || 'tax'; 5452#::logDebug("ctable=$ctable c_taxfield=$c_taxfield country=$country"); 5453 $type ||= tag_data($ctable, $c_taxfield, $country) 5454 or return 0; 5455#::logDebug("tax type=$type"); 5456 $type =~ s/^\s+//; 5457 $type =~ s/\s+$//; 5458 5459 my @taxes; 5460 5461 if($type =~ /^(\w+)$/) { 5462 my $sfield = $1; 5463 my $state = $opt->{state} || $::Values->{$sfield}; 5464 return 0 if ! $state; 5465 my $stable = $opt->{state_table} 5466 || $::Variable->{MV_STATE_TABLE} 5467 || 'state'; 5468 my $s_taxfield = $opt->{state_tax_field} 5469 || $::Variable->{MV_STATE_TAX_FIELD} 5470 || 'tax'; 5471 my $s_taxtype = $opt->{tax_type_field} 5472 || $::Variable->{MV_TAX_TYPE_FIELD} 5473 || 'tax_name'; 5474 my $db = database_exists_ref($stable) 5475 or return 0; 5476 my $addl = ''; 5477 if($opt->{tax_type}) { 5478 $addl = " AND $s_taxtype = " . 5479 $db->quote($opt->{tax_type}, $s_taxtype); 5480 } 5481 my $q = qq{ 5482 SELECT $s_taxfield FROM $stable 5483 WHERE $cfield = '$country' 5484 AND $sfield = '$state' 5485 $addl 5486 }; 5487#::logDebug("tax state query=$q"); 5488 my $ary; 5489 eval { 5490 $ary = $db->query($q); 5491 }; 5492 if($@) { 5493 logError("error on state tax query %s", $q); 5494 } 5495#::logDebug("query returns " . uneval($ary)); 5496 return 0 unless ref $ary; 5497 for(@$ary) { 5498 next unless $_->[0]; 5499 push @taxes, $_->[0]; 5500 } 5501 } 5502 else { 5503 @taxes = $type; 5504 } 5505 5506 my $total = 0; 5507 foreach my $t (@taxes) { 5508 $t =~ s/^\s+//; 5509 $t =~ s/\s+$//; 5510 if ($t =~ /simple:(.*)/) { 5511 $total += fly_tax($::Values->{$1}); 5512 next; 5513 } 5514 elsif ($t =~ /handling:(.*)/) { 5515 my @modes = grep /\S/, split /[\s,]+/, $1; 5516 5517 my $cost = 0; 5518 $cost += tag_handling($_) for @modes; 5519 $total += $cost; 5520 next; 5521 } 5522 my $tax; 5523#::logDebug("tax type=$t"); 5524 if($t =~ /^(\d+(?:\.\d+)?)\s*(\%)$/) { 5525 my $rate = $1; 5526 $rate /= 100 if $2; 5527 $rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive}; 5528 my $amount = Vend::Interpolate::taxable_amount(); 5529 $total += ($rate * $amount); 5530 } 5531 else { 5532 $tax = Vend::Util::get_option_hash($t); 5533 } 5534#::logDebug("tax hash=" . uneval($tax)); 5535 my $pfield = $opt->{tax_category_field} 5536 || $::Variable->{MV_TAX_CATEGORY_FIELD} 5537 || 'tax_category'; 5538 my @pfield = split /:+/, $pfield; 5539 5540 for my $item (@$Vend::Items) { 5541 my $rhash = tag_data($item->{mv_ib}, undef, $item->{code}, { hash => 1}); 5542 my $cat = join ":", @{$rhash}{@pfield}; 5543 my $rate = defined $tax->{$cat} ? $tax->{$cat} : $tax->{default}; 5544#::logDebug("item $item->{code} cat=$cat rate=$rate"); 5545 $rate = percent_rate($rate); 5546 next if $rate <= 0; 5547 $rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive}; 5548 my $sub = discount_subtotal($item); 5549#::logDebug("item $item->{code} subtotal=$sub"); 5550 $total += $sub * $rate; 5551#::logDebug("tax total=$total"); 5552 } 5553 5554 my $tax_shipping_rate = 0; 5555 5556 ## Add some tax on shipping ONLY IF TAXABLE ITEMS 5557 ## if rate for mv_shipping_when_taxable category is set 5558 if ($tax->{mv_shipping_when_taxable} and $total > 0) { 5559 $tax_shipping_rate += percent_rate($tax->{mv_shipping_when_taxable}); 5560 } 5561 5562 ## Add some tax on shipping if rate for mv_shipping category is set 5563 if ($tax->{mv_shipping} > 0) { 5564 $tax_shipping_rate += percent_rate($tax->{mv_shipping}); 5565 } 5566 5567 if($tax_shipping_rate > 0) { 5568 my $rate = $tax_shipping_rate; 5569 $rate =~ s/\s*%\s*$// and $rate /= 100; 5570 my $sub = tag_shipping() * $rate; 5571#::logDebug("applying shipping tax rate of $rate, tax of $sub"); 5572 $total += $sub; 5573 } 5574 5575 ## Add some tax on handling if rate for mv_handling category is set 5576 if ($tax->{mv_handling} > 0) { 5577 my $rate = $tax->{mv_handling}; 5578 $rate =~ s/\s*%\s*$// and $rate /= 100; 5579 $rate = $rate / (1 + $rate) if $Vend::Cfg->{TaxInclusive}; 5580 my $sub = tag_handling() * $rate; 5581#::logDebug("applying handling tax rate of $rate, tax of $sub"); 5582 $total += $sub; 5583 } 5584 5585 } 5586 5587 return $total; 5588} 5589 5590# Calculate the sales tax 5591sub salestax { 5592 my($cart, $opt) = @_; 5593 5594 $opt ||= {}; 5595 5596 my($save, $oldspace); 5597 ### If the user has assigned to salestax, 5598 ### we use their value come what may, no rounding 5599 if($Vend::Session->{assigned}) { 5600 return $Vend::Session->{assigned}{salestax} 5601 if defined $Vend::Session->{assigned}{salestax} 5602 && length( $Vend::Session->{assigned}{salestax}); 5603 } 5604 5605 if ($cart) { 5606 $save = $Vend::Items; 5607 tag_cart($cart); 5608 } 5609 5610 $oldspace = switch_discount_space( $opt->{discount_space} ) if $opt->{discount_space}; 5611 5612#::logDebug("salestax entered, cart=$cart"); 5613 my $tax_hash; 5614 my $cost; 5615 if($Vend::Cfg->{SalesTax} eq 'multi') { 5616 $cost = tax_vat($opt->{type}, $opt); 5617 } 5618 elsif($Vend::Cfg->{SalesTax} =~ /\[/) { 5619 $cost = interpolate_html($Vend::Cfg->{SalesTax}); 5620 } 5621 elsif($Vend::Cfg->{SalesTaxFunction}) { 5622 $tax_hash = tag_calc($Vend::Cfg->{SalesTaxFunction}); 5623#::logDebug("found custom tax function: " . uneval($tax_hash)); 5624 } 5625 else { 5626 $tax_hash = $Vend::Cfg->{SalesTaxTable}; 5627#::logDebug("looking for tax function: " . uneval($tax_hash)); 5628 } 5629 5630# if we have a cost from previous routines, return it 5631 if(defined $cost) { 5632 $Vend::Items = $save if $save; 5633 switch_discount_space($oldspace) if defined $oldspace; 5634 if($cost < 0 and $::Pragma->{no_negative_tax}) { 5635 $cost = 0; 5636 } 5637 return Vend::Util::round_to_frac_digits($cost); 5638 } 5639 5640#::logDebug("got to tax function: " . uneval($tax_hash)); 5641 my $amount = taxable_amount(); 5642 # Restore the original discount namespace if appropriate; no other routines need the discount info. 5643 switch_discount_space($oldspace) if defined $oldspace; 5644 5645 my($r, $code); 5646 # Make it upper case for state and overseas postal 5647 # codes, zips don't matter 5648 my(@code) = map { (uc $::Values->{$_}) || '' } 5649 split /[,\s]+/, $Vend::Cfg->{SalesTax}; 5650 push(@code, 'DEFAULT'); 5651 5652 $tax_hash = { DEFAULT => } if ! ref($tax_hash) =~ /HASH/; 5653 5654 if(! defined $tax_hash->{DEFAULT}) { 5655#::logDebug("Sales tax failed, no tax source, returning 0"); 5656 return 0; 5657 } 5658 5659 CHECKSHIPPING: { 5660 last CHECKSHIPPING unless $Vend::Cfg->{TaxShipping}; 5661 foreach $code (@code) { 5662 next unless $Vend::Cfg->{TaxShipping} =~ /\b\Q$code\E\b/i; 5663 $amount += tag_shipping(); 5664 last; 5665 } 5666 } 5667 5668 foreach $code (@code) { 5669 next unless $code; 5670 # Trim the zip+4 5671#::logDebug("salestax: check code '$code'"); 5672 $code =~ s/(\d{5})-\d{4}/$1/; 5673 next unless defined $tax_hash->{$code}; 5674 my $tax = $tax_hash->{$code}; 5675#::logDebug("salestax: found tax='$tax' for code='$code'"); 5676 if($tax =~ /^-?(?:\d+(?:\.\d*)?|\.\d+)$/) { 5677 $r = $amount * $tax; 5678 } 5679 else { 5680 $r = Vend::Data::chain_cost( 5681 { mv_price => $amount, 5682 code => $code, 5683 quantity => $amount, }, $tax); 5684 } 5685#::logDebug("salestax: final tax='$r' for code='$code'"); 5686 last; 5687 } 5688 5689 $Vend::Items = $save if defined $save; 5690 5691 if($r < 0 and ! $::Pragma->{no_negative_tax}) { 5692 $r = 0; 5693 } 5694 5695 return Vend::Util::round_to_frac_digits($r); 5696} 5697 5698# Returns just subtotal of items ordered, with discounts 5699# applied 5700sub subtotal { 5701 my($cart, $dspace) = @_; 5702 5703 ### If the user has assigned to salestax, 5704 ### we use their value come what may, no rounding 5705 if($Vend::Session->{assigned}) { 5706 return $Vend::Session->{assigned}{subtotal} 5707 if defined $Vend::Session->{assigned}{subtotal} 5708 && length( $Vend::Session->{assigned}{subtotal}); 5709 } 5710 5711 my ($save, $subtotal, $i, $item, $tmp, $cost, $formula, $oldspace); 5712 if ($cart) { 5713 $save = $Vend::Items; 5714 tag_cart($cart); 5715 } 5716 5717 levies() unless $Vend::Levying; 5718 5719 # Use switch_discount_space unconditionally to guarantee existance of proper discount structures. 5720 $oldspace = switch_discount_space($dspace || $Vend::DiscountSpaceName); 5721 5722 my $discount = (ref($::Discounts) eq 'HASH' and %$::Discounts); 5723 5724 $subtotal = 0; 5725 $tmp = 0; 5726 5727 foreach $i (0 .. $#$Vend::Items) { 5728 $item = $Vend::Items->[$i]; 5729 $tmp = Vend::Data::item_subtotal($item); 5730 if($discount || $item->{mv_discount}) { 5731 $subtotal += 5732 apply_discount($item, $tmp); 5733 } 5734 else { $subtotal += $tmp } 5735 } 5736 5737 if (defined $::Discounts->{ENTIRE_ORDER}) { 5738 $formula = $::Discounts->{ENTIRE_ORDER}; 5739 $formula =~ s/\$q\b/tag_nitems()/eg; 5740 $formula =~ s/\$s\b/$subtotal/g; 5741 $cost = $Vend::Interpolate::ready_safe->reval($formula); 5742 if($@) { 5743 logError 5744 "Discount ENTIRE_ORDER has bad formula. Returning normal subtotal.\n$@"; 5745 $cost = $subtotal; 5746 } 5747 $subtotal = $cost; 5748 } 5749 $Vend::Items = $save if defined $save; 5750 $Vend::Session->{latest_subtotal} = $subtotal; 5751 5752 # Switch to original discount space if an actual switch occured. 5753 switch_discount_space($oldspace) if $dspace and defined $oldspace; 5754 5755 return $subtotal; 5756} 5757 5758 5759 5760# Returns the total cost of items ordered. 5761 5762sub total_cost { 5763 my ($cart, $dspace) = @_; 5764 my ($total, $i, $save, $oldspace); 5765 5766 $oldspace = switch_discount_space($dspace) if $dspace; 5767 5768 if ($cart) { 5769 $save = $Vend::Items; 5770 tag_cart($cart); 5771 } 5772 5773 $total = 0; 5774 5775 if($Vend::Cfg->{Levies}) { 5776 $total = subtotal(); 5777 $total += levies(); 5778 } 5779 else { 5780 my $shipping = 0; 5781 $shipping += tag_shipping() 5782 if $::Values->{mv_shipmode}; 5783 $shipping += tag_handling() 5784 if $::Values->{mv_handling}; 5785 $total += subtotal(); 5786 $total += $shipping; 5787 $total += salestax() 5788 unless $Vend::Cfg->{TaxInclusive}; 5789 } 5790 $Vend::Items = $save if defined $save; 5791 $Vend::Session->{latest_total} = $total; 5792 switch_discount_space($oldspace) if defined $oldspace; 5793 return $total; 5794} 5795 5796 5797sub levy_sum { 5798 my ($set, $levies, $repos) = @_; 5799 5800 $set ||= $Vend::CurrentCart || 'main'; 5801 $levies ||= $Vend::Cfg->{Levies}; 5802 $repos ||= $Vend::Cfg->{Levy_repository}; 5803 5804 my $icart = $Vend::Session->{carts}{$set} || []; 5805 5806 my @sums; 5807 for(@$icart) { 5808 push @sums, @{$_}{sort keys %$_}; 5809 } 5810 my $items; 5811 for(@$levies) { 5812 next unless $items = $repos->{$_}{check_status}; 5813 push @sums, @{$::Values}{ split /[\s,\0]/, $items }; 5814 } 5815 return generate_key(@sums); 5816} 5817 5818sub levies { 5819 my($recalc, $set, $opt) = @_; 5820 5821 my $levies; 5822 return unless $levies = $Vend::Cfg->{Levies}; 5823 5824 5825 $opt ||= {}; 5826 my $repos = $Vend::Cfg->{Levy_repository}; 5827#::logDebug("Calling levies, recalc=$recalc group=$opt->{group}"); 5828 5829 if(! $repos) { 5830 logOnce('error', "Levies set but no levies defined! No tax or shipping."); 5831 return; 5832 } 5833 $Vend::Levying = 1; 5834 $set ||= $Vend::CurrentCart; 5835 $set ||= 'main'; 5836 5837 $Vend::Session->{levies} ||= {}; 5838 5839 my $lcheck = $Vend::Session->{latest_levy} ||= {}; 5840 $lcheck = $lcheck->{$set} ||= {}; 5841 5842 if($Vend::LeviedOnce and ! $recalc and ! $opt->{group} and $lcheck->{sum}) { 5843 my $newsum = levy_sum($set, $levies, $repos); 5844#::logDebug("did levy check, new=$newsum old=$lcheck->{sum}"); 5845 if($newsum eq $lcheck->{sum}) { 5846 undef $Vend::Levying; 5847#::logDebug("levy returning cached value"); 5848 return $lcheck->{total}; 5849 } 5850 } 5851 5852 my $lcart = $Vend::Session->{levies}{$set} = []; 5853 5854 my $run = 0; 5855 for my $name (@$levies) { 5856 my $l = $repos->{$name}; 5857#::logDebug("Levying $name, repos => " . uneval($l)); 5858 if(! $l) { 5859 logOnce('error', "Levy '%s' called but not defined. Skipping.", $name); 5860 next; 5861 } 5862 if(my $if = $l->{include_if}) { 5863 if($if =~ /^\w+$/) { 5864 next unless $::Values->{$if}; 5865 } 5866 elsif($if =~ /__[A-Z]\w+__|[[a-zA-Z]/) { 5867 my $val = interpolate_html($if); 5868 $val =~ s/^\s+//; 5869 $val =~ s/^s+$//; 5870 next unless $val; 5871 } 5872 else { 5873 next unless tag_calc($if); 5874 } 5875 } 5876 if(my $if = $l->{exclude_if}) { 5877 if($if =~ /^\w+$/) { 5878 next if $::Values->{$if}; 5879 } 5880 elsif($if =~ /__[A-Z]\w+__|[[a-zA-Z]/) { 5881 my $val = interpolate_html($if); 5882 $val =~ s/^\s+//; 5883 $val =~ s/^s+$//; 5884 next if $val; 5885 } 5886 else { 5887 next if tag_calc($if); 5888 } 5889 } 5890 my $type = $l->{type} || ($name eq 'salestax' ? 'salestax' : 'shipping'); 5891 my $mode; 5892 5893 if($l->{mode_from_values}) { 5894 $mode = $::Values->{$l->{mode_from_values}}; 5895 } 5896 elsif($l->{mode_from_scratch}) { 5897 $mode = $::Scratch->{$l->{mode_from_scratch}}; 5898 } 5899 5900 $mode ||= ($l->{mode} || $name); 5901 my $group = $l->{group} || $type; 5902 my $cost = 0; 5903 my $sort; 5904 my $desc; 5905 my $lab_field = $l->{label_value}; 5906 if($type eq 'salestax') { 5907 my $save; 5908 $sort = $l->{sort} || '010'; 5909 $lab_field ||= $Vend::Cfg->{SalesTax}; 5910 if($l->{tax_fields}) { 5911 $save = $Vend::Cfg->{SalesTax}; 5912 $Vend::Cfg->{SalesTax} = $l->{tax_fields}; 5913 } 5914 elsif ($l->{multi}) { 5915 $save = $Vend::Cfg->{SalesTax}; 5916 $Vend::Cfg->{SalesTax} = 'multi'; 5917 } 5918 $cost = salestax(undef, { tax_type => $l->{tax_type} } ); 5919 $l->{description} ||= 'Sales Tax'; 5920 $Vend::Cfg->{SalesTax} = $save if defined $save; 5921 } 5922 elsif ($type eq 'shipping' or $type eq 'handling') { 5923 if(not $sort = $l->{sort}) { 5924 $sort = $type eq 'handling' ? 100 : 500; 5925 } 5926 5927 my @modes = split /\0/, $mode; 5928 for my $m (@modes) { 5929 $cost += shipping($m); 5930 if($l->{description}) { 5931 if($l->{multi_description}) { 5932 $l->{description} = $l->{multi_description}; 5933 } 5934 else { 5935 $l->{description} .= ', ' if $l->{description}; 5936 $l->{description} .= tag_shipping_desc($m); 5937 } 5938 } 5939 else { 5940 $l->{description} = tag_shipping_desc($m); 5941 } 5942 } 5943 } 5944 elsif($type eq 'custom') { 5945 my $sub; 5946 SUBFIND: { 5947 $sub = $Vend::Cfg->{Sub}{$mode} || $Global::GlobalSub->{$mode} 5948 and last SUBFIND; 5949 eval { 5950 $sub = $Vend::Cfg->{UserTag}{Routine}{$mode}; 5951 }; 5952 last SUBFIND if ! $@ and $sub; 5953 eval { 5954 $sub = $Global::UserTag->{Routine}{$mode}; 5955 }; 5956 } 5957 if( ref($sub) eq 'CODE') { 5958 ($cost, $desc, $sort) = $sub->($l); 5959 } 5960 else { 5961 logError("No subroutine found for custom levy '%s'", $name); 5962 } 5963 } 5964 5965 $desc = errmsg( 5966 $l->{description}, 5967 $::Values->{$lab_field}, 5968 ); 5969 5970 my $cost_format; 5971 5972 my $item = { 5973 code => $name, 5974 mode => $mode, 5975 type => $type, 5976 sort => $sort || $l->{sort}, 5977 cost => round_to_frac_digits($cost), 5978 currency => currency($cost), 5979 group => $group, 5980 inclusive => $l->{inclusive}, 5981 label => $l->{label} || $desc, 5982 part_number => $l->{part_number}, 5983 description => $desc, 5984 }; 5985 if($cost == 0) { 5986 next unless $l->{keep_if_zero}; 5987 $item->{free} = 1; 5988 $item->{free_message} = $l->{free_message} || $cost; 5989 } 5990 5991 if(my $target = $l->{add_to}) { 5992 my $found; 5993 foreach my $lev (@$lcart) { 5994 next unless $lev->{code} eq $target; 5995 $lev->{cost} += $item->{cost}; 5996 $lev->{cost} = round_to_frac_digits($lev->{cost}); 5997 $lev->{currency} = currency($lev->{cost}); 5998 $found = 1; 5999 last; 6000 } 6001 unless($found) { 6002 push @$lcart, $item; 6003 } 6004 } 6005 else { 6006 push @$lcart, $item; 6007 } 6008 } 6009 6010 @$lcart = sort { $a->{sort} cmp $b->{sort} } @$lcart; 6011 6012 for(@$lcart) { 6013 next if $opt->{group} and $opt->{group} ne $_->{group}; 6014 next if $_->{inclusive}; 6015 next if $_->{type} eq 'salestax' and $Vend::Cfg->{TaxInclusive}; 6016 $run += $_->{cost}; 6017 } 6018 6019 $run = round_to_frac_digits($run); 6020 if(! $opt->{group}) { 6021 $lcheck = $Vend::Session->{latest_levy}{$set} = {}; 6022 $lcheck->{sum} = levy_sum($set, $levies, $repos); 6023 $lcheck->{total} = $run; 6024 $Vend::LeviedOnce = 1; 6025 } 6026 6027 undef $Vend::Levying; 6028 return $run; 6029} 6030 60311; 6032