site/cgi-bin/modules/BSE/UI/Shop.pm

   1 package BSE::UI::Shop;
   2 use strict;
   3 use base 'BSE::UI::Dispatch';
   4 use BSE::Util::HTML qw(:default popup_menu);
   5 use BSE::Util::SQL qw(now_sqldate now_sqldatetime);
   6 use BSE::Shop::Util qw(:payment need_logon shop_cart_tags payment_types nice_options
   7                        cart_item_opts basic_tags order_item_opts);
   8 use BSE::CfgInfo qw(custom_class credit_card_class bse_default_country);
   9 use BSE::TB::Orders;
  10 use BSE::TB::OrderItems;
  11 use BSE::Util::Tags qw(tag_error_img tag_hash tag_article);
  12 use Products;
  13 use BSE::TB::Seminars;
  14 use DevHelp::Validate qw(dh_validate dh_validate_hash);
  15 use Digest::MD5 'md5_hex';
  16 use BSE::Shipping;
  17 use BSE::Countries qw(bse_country_code);
  18 use BSE::Util::Secure qw(make_secret);
  19
  20 our $VERSION = "1.006";
  21
  22 use constant MSG_SHOP_CART_FULL => 'Your shopping cart is full, please remove an item and try adding an item again';
  23
  24 my %actions =
  25   (
  26    add => 1,
  27    addmultiple => 1,
  28    cart => 1,
  29    checkout => 1,
  30    checkupdate => 1,
  31    recheckout => 1,
  32    confirm => 1,
  33    recalc=>1,
  34    recalculate => 1,
  35    #purchase => 1,
  36    order => 1,
  37    show_payment => 1,
  38    payment => 1,
  39    orderdone => 1,
  40    location => 1,
  41    paypalret => 1,
  42    paypalcan => 1,
  43    emptycart => 1,
  44   );
  45
  46 my %field_map =
  47   (
  48    name1 => 'delivFirstName',
  49    name2 => 'delivLastName',
  50    address => 'delivStreet',
  51    organization => 'delivOrganization',
  52    city => 'delivSuburb',
  53    postcode => 'delivPostCode',
  54    state => 'delivState',
  55    country => 'delivCountry',
  56    email => 'emailAddress',
  57    cardHolder => 'ccName',
  58    cardType => 'ccType',
  59   );
  60
  61 my %rev_field_map = reverse %field_map;
  62
  63 sub actions { \%actions }
  64
  65 sub default_action { 'cart' }
  66
  67 sub other_action {
  68   my ($class, $cgi) = @_;
  69
  70   for my $key ($cgi->param()) {
  71     if ($key =~ /^delete_(\d+)(?:\.x)?$/) {
  72       return ( remove_item => $1 );
  73     }
  74     elsif ($key =~ /^(?:a_)?addsingle(\d+)(?:\.x)?$/) {
  75       return ( addsingle => $1 );
  76     }
  77   }
  78
  79   return;
  80 }
  81
  82 sub req_cart {
  83   my ($class, $req, $msg) = @_;
  84
  85   my @cart = @{$req->session->{cart} || []};
  86   my @cart_prods;
  87   my @items = $class->_build_items($req, \@cart_prods);
  88   my $item_index = -1;
  89   my @options;
  90   my $option_index;
  91
  92   $req->session->{custom} ||= {};
  93   my %custom_state = %{$req->session->{custom}};
  94
  95   my $cust_class = custom_class($req->cfg);
  96   $cust_class->enter_cart(\@cart, \@cart_prods, \%custom_state, $req->cfg);
  97   $msg = '' unless defined $msg;
  98   $msg = escape_html($msg);
  99
 100   $msg ||= $req->message;
 101
 102   my %acts;
 103   %acts =
 104     (
 105      $cust_class->cart_actions(\%acts, \@cart, \@cart_prods, \%custom_state,
 106                                $req->cfg),
 107      shop_cart_tags(\%acts, \@items, \@cart_prods, $req, 'cart'),
 108      basic_tags(\%acts),
 109      msg => $msg,
 110     );
 111   $req->session->{custom} = \%custom_state;
 112   $req->session->{order_info_confirmed} = 0;
 113
 114   # intended to ajax enable the shop cart with partial templates
 115   my $template = 'cart';
 116   my $embed = $req->cgi->param('embed');
 117   if (defined $embed and $embed =~ /^\w+$/) {
 118     $template = "include/cart_$embed";
 119   }
 120   return $req->response($template, \%acts);
 121 }
 122
 123 =item a_emptycart
 124
 125 Empty the shopping cart.
 126
 127 Refreshes to the URL in C<r> or the cart otherwise.
 128
 129 Flashes msg:bse/shop/cart/empty unless C<r> is supplied.
 130
 131 =cut
 132
 133 sub req_emptycart {
 134   my ($self, $req) = @_;
 135
 136   my $old = $req->session->{cart};;
 137   $req->session->{cart} = [];
 138
 139   my $refresh = $req->cgi->param('r');
 140   unless ($refresh) {
 141     $refresh = $req->user_url(shop => 'cart');
 142     $req->flash("msg:bse/shop/cart/empty");
 143   }
 144
 145   return _add_refresh($refresh, $req, !$old);
 146 }
 147
 148 sub req_add {
 149   my ($class, $req) = @_;
 150
 151   my $cgi = $req->cgi;
 152
 153   my $quantity = $cgi->param('quantity');
 154   $quantity ||= 1;
 155
 156   my $error;
 157   my $refresh_logon;
 158   my ($product, $options, $extras);
 159   my $addid = $cgi->param('id');
 160   if (defined $addid) {
 161     ($product, $options, $extras)
 162       = $class->_validate_add_by_id($req, $addid, $quantity, \$error, \$refresh_logon);
 163   }
 164   else {
 165     my $code = $cgi->param('code');
 166     if (defined $code) {
 167       ($product, $options, $extras)
 168         = $class->_validate_add_by_code($req, $code, $quantity, \$error, \$refresh_logon);
 169     }
 170     else {
 171       return $class->req_cart($req, "No product id or code supplied");
 172     }
 173   }
 174   if ($refresh_logon) {
 175     return $class->_refresh_logon($req, @$refresh_logon);
 176   }
 177   elsif ($error) {
 178     return $class->req_cart($req, $error);
 179   }
 180
 181   if ($cgi->param('empty')) {
 182     $req->session->{cart} = [];
 183   }
 184
 185   $req->session->{cart} ||= [];
 186   my @cart = @{$req->session->{cart}};
 187   my $started_empty = @cart == 0;
 188
 189   my $found;
 190   for my $item (@cart) {
 191     $item->{productId} eq $product->{id} && _same_options($item->{options}, $options)
 192       or next;
 193
 194     ++$found;
 195     $item->{units} += $quantity;
 196     last;
 197   }
 198   unless ($found) {
 199     my $cart_limit = $req->cfg->entry('shop', 'cart_entry_limit');
 200     if (defined $cart_limit && @cart >= $cart_limit) {
 201       return $class->req_cart($req, $req->text('shop/cartfull', MSG_SHOP_CART_FULL));
 202     }
 203     push @cart,
 204       {
 205        productId => $product->{id},
 206        units => $quantity,
 207        price=>$product->{retailPrice},
 208        options=>$options,
 209        %$extras,
 210       };
 211   }
 212
 213   $req->session->{cart} = \@cart;
 214   $req->session->{order_info_confirmed} = 0;
 215
 216   my $refresh = $cgi->param('r');
 217   unless ($refresh) {
 218     $refresh = $req->user_url(shop => 'cart');
 219   }
 220
 221   # speed for ajax
 222   if ($refresh eq 'ajaxcart') {
 223     return $class->req_cart($req);
 224   }
 225
 226   return _add_refresh($refresh, $req, $started_empty);
 227 }
 228
 229 sub req_addsingle {
 230   my ($class, $req, $addid) = @_;
 231
 232   my $cgi = $req->cgi;
 233
 234   $addid ||= '';
 235   my $quantity = $cgi->param("qty$addid");
 236   defined $quantity && $quantity =~ /\S/
 237     or $quantity = 1;
 238
 239   my $error;
 240   my $refresh_logon;
 241   my ($product, $options, $extras)
 242     = $class->_validate_add_by_id($req, $addid, $quantity, \$error, \$refresh_logon);
 243   if ($refresh_logon) {
 244     return $class->_refresh_logon($req, @$refresh_logon);
 245   }
 246   elsif ($error) {
 247     return $class->req_cart($req, $error);
 248   }
 249
 250   if ($cgi->param('empty')) {
 251     $req->session->{cart} = [];
 252   }
 253
 254   $req->session->{cart} ||= [];
 255   my @cart = @{$req->session->{cart}};
 256   my $started_empty = @cart == 0;
 257
 258   my $found;
 259   for my $item (@cart) {
 260     $item->{productId} eq $addid && _same_options($item->{options}, $options)
 261       or next;
 262
 263     ++$found;
 264     $item->{units} += $quantity;
 265     last;
 266   }
 267   unless ($found) {
 268     my $cart_limit = $req->cfg->entry('shop', 'cart_entry_limit');
 269     if (defined $cart_limit && @cart >= $cart_limit) {
 270       return $class->req_cart($req, $req->text('shop/cartfull', MSG_SHOP_CART_FULL));
 271     }
 272     push @cart,
 273       {
 274        productId => $addid,
 275        units => $quantity,
 276        price=>$product->{retailPrice},
 277        options=>$options,
 278        %$extras,
 279       };
 280   }
 281
 282   $req->session->{cart} = \@cart;
 283   $req->session->{order_info_confirmed} = 0;
 284
 285   my $refresh = $cgi->param('r');
 286   unless ($refresh) {
 287     $refresh = $req->user_url(shop => 'cart');
 288   }
 289
 290   # speed for ajax
 291   if ($refresh eq 'ajaxcart') {
 292     return $class->req_cart($req);
 293   }
 294
 295   return _add_refresh($refresh, $req, $started_empty);
 296 }
 297
 298 sub req_addmultiple {
 299   my ($class, $req) = @_;
 300
 301   my $cgi = $req->cgi;
 302   my @qty_keys = map /^qty(\d+)/, $cgi->param;
 303
 304   my @messages;
 305   my %additions;
 306   for my $addid (@qty_keys) {
 307     my $quantity = $cgi->param("qty$addid");
 308     defined $quantity && $quantity =~ /^\s*\d+\s*$/
 309       or next;
 310
 311     my $error;
 312     my $refresh_logon;
 313     my ($product, $options, $extras) =
 314       $class->_validate_add_by_id($req, $addid, $quantity, \$error, \$refresh_logon);
 315     if ($refresh_logon) {
 316       return $class->_refresh_logon($req, @$refresh_logon);
 317     }
 318     elsif ($error) {
 319       return $class->req_cart($req, $error);
 320     }
 321     if ($product->{options}) {
 322       push @messages, "$product->{title} has options, you need to use the product page to add this product";
 323       next;
 324     }
 325     $additions{$addid} =
 326       {
 327        id => $product->{id},
 328        product => $product,
 329        extras => $extras,
 330        quantity => $quantity,
 331       };
 332   }
 333
 334   my @qtys = $cgi->param("qty");
 335   my @ids = $cgi->param("id");
 336   for my $addid (@ids) {
 337     my $quantity = shift @qtys;
 338     $addid =~ /^\d+$/
 339       or next;
 340     $additions{$addid}
 341       and next;
 342     defined $quantity or $quantity = 1;
 343     $quantity =~ /^\d+$/
 344       or next;
 345     $quantity
 346       or next;
 347     my ($error, $refresh_logon);
 348
 349     my ($product, $options, $extras) =
 350       $class->_validate_add_by_id($req, $addid, $quantity, \$error, \$refresh_logon);
 351     if ($refresh_logon) {
 352       return $class->_refresh_logon($req, @$refresh_logon);
 353     }
 354     elsif ($error) {
 355       return $class->req_cart($req, $error);
 356     }
 357     if ($product->{options}) {
 358       push @messages, "$product->{title} has options, you need to use the product page to add this product";
 359       next;
 360     }
 361     $additions{$addid} =
 362       {
 363        id => $product->{id},
 364        product => $product,
 365        extras => $extras,
 366        quantity => $quantity,
 367       };
 368   }
 369
 370   my $started_empty = 0;
 371   if (keys %additions) {
 372     if ($cgi->param('empty')) {
 373       $req->session->{cart} = [];
 374     }
 375     $req->session->{cart} ||= [];
 376     my @cart = @{$req->session->{cart}};
 377     $started_empty = @cart == 0;
 378     for my $item (@cart) {
 379       @{$item->{options}} == 0 or next;
 380
 381       my $addition = delete $additions{$item->{productId}}
 382         or next;
 383
 384       $item->{units} += $addition->{quantity};
 385     }
 386
 387     my $cart_limit = $req->cfg->entry('shop', 'cart_entry_limit');
 388
 389     my @additions = grep $_->{quantity} > 0, values %additions;
 390
 391     my $error;
 392     for my $addition (@additions) {
 393       my $product = $addition->{product};
 394
 395       if (defined $cart_limit && @cart >= $cart_limit) {
 396         $error = $req->text('shop/cartfull', MSG_SHOP_CART_FULL);
 397         last;
 398       }
 399
 400       push @cart,
 401         {
 402          productId => $product->{id},
 403          units => $addition->{quantity},
 404          price=>$product->{retailPrice},
 405          options=>[],
 406          %{$addition->{extras}},
 407         };
 408     }
 409
 410     $req->session->{cart} = \@cart;
 411     $req->session->{order_info_confirmed} = 0;
 412     $error
 413       and return $class->req_cart($req, $error);
 414   }
 415
 416   my $refresh = $cgi->param('r');
 417   unless ($refresh) {
 418     $refresh = $req->user_url(shop => 'cart');
 419   }
 420   if (@messages) {
 421     my $sep = $refresh =~ /\?/ ? '&' : '?';
 422
 423     for my $message (@messages) {
 424       $refresh .= $sep . "m=" . escape_uri($message);
 425       $sep = '&';
 426     }
 427   }
 428
 429   # speed for ajax
 430   if ($refresh eq 'ajaxcart') {
 431     return $class->req_cart($req);
 432   }
 433
 434   return _add_refresh($refresh, $req, $started_empty);
 435 }
 436
 437 sub tag_ifUser {
 438   my ($user, $args) = @_;
 439
 440   if ($args) {
 441     if ($user) {
 442       return defined $user->{$args} && $user->{$args};
 443     }
 444     else {
 445       return 0;
 446     }
 447   }
 448   else {
 449     return defined $user;
 450   }
 451 }
 452
 453 sub req_checkout {
 454   my ($class, $req, $message, $olddata) = @_;
 455
 456   my $errors = {};
 457   if (defined $message) {
 458     if (ref $message) {
 459       $errors = $message;
 460       $message = $req->message($errors);
 461     }
 462   }
 463   else {
 464     $message = '';
 465   }
 466   my $cfg = $req->cfg;
 467   my $cgi = $req->cgi;
 468
 469   $class->update_quantities($req);
 470   my @cart = @{$req->session->{cart}};
 471
 472   @cart or return $class->req_cart($req);
 473
 474   my @cart_prods;
 475   my @items = $class->_build_items($req, \@cart_prods);
 476
 477   if (my ($msg, $id) = $class->_need_logon($req, \@cart, \@cart_prods)) {
 478     return $class->_refresh_logon($req, $msg, $id);
 479     return;
 480   }
 481
 482   my $user = $req->siteuser;
 483
 484   $req->session->{custom} ||= {};
 485   my %custom_state = %{$req->session->{custom}};
 486
 487   my $cust_class = custom_class($cfg);
 488   $cust_class->enter_cart(\@cart, \@cart_prods, \%custom_state, $cfg);
 489
 490   my $affiliate_code = $req->session->{affiliate_code};
 491   defined $affiliate_code or $affiliate_code = '';
 492
 493   my $order_info = $req->session->{order_info};
 494
 495   my $old = sub {
 496     my $value;
 497
 498     if ($olddata) {
 499       $value = $cgi->param($_[0]);
 500       unless (defined $value) {
 501       $value = $user->{$_[0]}
 502         if $user;
 503       }
 504     }
 505     elsif ($order_info && defined $order_info->{$_[0]}) {
 506       $value = $order_info->{$_[0]};
 507     }
 508     else {
 509       my $field = $_[0];
 510       $rev_field_map{$field} and $field = $rev_field_map{$field};
 511       $value = $user && defined $user->{$field} ? $user->{$field} : '';
 512     }
 513
 514     defined $value or $value = '';
 515     return $value;
 516   };
 517
 518   # shipping handling, if enabled
 519   my $shipping_select = ''; # select of shipping types
 520   my ($delivery_in, $shipping_cost, $shipping_method);
 521   my $shipping_error = '';
 522   my $shipping_name = '';
 523   my $prompt_ship = $cfg->entry("shop", "shipping", 0);
 524   if ($prompt_ship) {
 525     # Get a list of couriers
 526     my $sel_cn = $old->("shipping_name") || "";
 527     my %fake_order;
 528     my %fields = BSE::TB::Order->valid_fields($cfg);
 529     for my $name (keys %fields) {
 530       $fake_order{$name} = $old->($name);
 531     }
 532     my $country = $fake_order{delivCountry} || bse_default_country($cfg);
 533     my $country_code = bse_country_code($country);
 534     my $suburb = $fake_order{delivSuburb};
 535     my $postcode = $fake_order{delivPostCode};
 536
 537     $country_code
 538       or $errors->{delivCountry} = "Unknown country name $country";
 539
 540     my @couriers = BSE::Shipping->get_couriers($cfg);
 541
 542     if ($country_code and $postcode) {
 543       @couriers = grep $_->can_deliver(country => $country_code,
 544                                        suburb => $suburb,
 545                                        postcode => $postcode), @couriers;
 546     }
 547
 548     my ($sel_cour) = grep $_->name eq $sel_cn, @couriers;
 549     # if we don't match against the list (perhaps because of a country
 550     # change) the first item in the list will be selected by the
 551     # browser anyway, so select it ourselves and display an
 552     # appropriate shipping cost for the item
 553     unless ($sel_cour) {
 554       $sel_cour = $couriers[0];
 555       $sel_cn = $sel_cour->name;
 556     }
 557     if ($sel_cour and $postcode and $suburb and $country_code) {
 558       my @parcels = BSE::Shipping->package_order($cfg, \%fake_order, \@items);
 559       $shipping_cost = $sel_cour->calculate_shipping
 560         (
 561          parcels => \@parcels,
 562          suburb => $suburb,
 563          postcode => $postcode,
 564          country => $country_code,
 565          products => \@cart_prods,
 566          items => \@items,
 567         );
 568       $delivery_in = $sel_cour->delivery_in();
 569       $shipping_method = $sel_cour->description();
 570       $shipping_name = $sel_cour->name;
 571       unless (defined $shipping_cost) {
 572         $shipping_error = $sel_cour->error_message;
 573         $errors->{shipping_name} = $shipping_error;
 574       }
 575     }
 576
 577     $shipping_select = popup_menu
 578       (
 579        -name => "shipping_name",
 580        -values => [ map $_->name, @couriers ],
 581        -labels => { map { $_->name => $_->description } @couriers },
 582        -default => $sel_cn,
 583       );
 584   }
 585
 586   if (!$message && keys %$errors) {
 587     $message = $req->message($errors);
 588   }
 589
 590   my $item_index = -1;
 591   my @options;
 592   my $option_index;
 593   my %acts;
 594   %acts =
 595     (
 596      shop_cart_tags(\%acts, \@items, \@cart_prods, $req, 'checkout'),
 597      basic_tags(\%acts),
 598      message => $message,
 599      msg => $message,
 600      old => sub { escape_html($old->($_[0])); },
 601      $cust_class->checkout_actions(\%acts, \@cart, \@cart_prods,
 602                                    \%custom_state, $req->cgi, $cfg),
 603      ifUser => [ \&tag_ifUser, $user ],
 604      user => $user ? [ \&tag_hash, $user ] : '',
 605      affiliate_code => escape_html($affiliate_code),
 606      error_img => [ \&tag_error_img, $cfg, $errors ],
 607      ifShipping => $prompt_ship,
 608      shipping_select => $shipping_select,
 609      delivery_in => escape_html($delivery_in),
 610      shipping_cost => $shipping_cost,
 611      shipping_method => escape_html($shipping_method),
 612      shipping_error => escape_html($shipping_error),
 613      shipping_name => $shipping_name,
 614     );
 615   $req->session->{custom} = \%custom_state;
 616   my $tmp = $acts{total};
 617   $acts{total} =
 618     sub {
 619         my $total = &$tmp();
 620         $total += $shipping_cost if $total and $shipping_cost;
 621         return $total;
 622     };
 623
 624   return $req->response('checkoutnew', \%acts);
 625 }
 626
 627 sub req_checkupdate {
 628   my ($class, $req) = @_;
 629
 630   $req->session->{cart} ||= [];
 631   my @cart = @{$req->session->{cart}};
 632   my @cart_prods = map { Products->getByPkey($_->{productId}) } @cart;
 633   $req->session->{custom} ||= {};
 634   my %custom_state = %{$req->session->{custom}};
 635   custom_class($req->cfg)
 636       ->checkout_update($req->cgi, \@cart, \@cart_prods, \%custom_state, $req->cfg);
 637   $req->session->{custom} = \%custom_state;
 638   $req->session->{order_info_confirmed} = 0;
 639
 640   return $class->req_checkout($req, "", 1);
 641 }
 642
 643 sub req_remove_item {
 644   my ($class, $req, $index) = @_;
 645
 646   $req->session->{cart} ||= [];
 647   my @cart = @{$req->session->{cart}};
 648   if ($index >= 0 && $index < @cart) {
 649     splice(@cart, $index, 1);
 650   }
 651   $req->session->{cart} = \@cart;
 652   $req->session->{order_info_confirmed} = 0;
 653
 654   return BSE::Template->get_refresh($req->user_url(shop => 'cart'), $req->cfg);
 655 }
 656
 657 # saves order and refresh to payment page
 658 sub req_order {
 659   my ($class, $req) = @_;
 660
 661   my $cfg = $req->cfg;
 662   my $cgi = $req->cgi;
 663
 664   $req->session->{cart} && @{$req->session->{cart}}
 665     or return $class->req_cart($req, "Your cart is empty");
 666
 667   my $msg;
 668   $class->_validate_cfg($req, \$msg)
 669     or return $class->req_cart($req, $msg);
 670
 671   my @products;
 672   my @items = $class->_build_items($req, \@products);
 673
 674   my $id;
 675   if (($msg, $id) = $class->_need_logon($req, \@items, \@products)) {
 676     return $class->_refresh_logon($req, $msg, $id);
 677   }
 678
 679   # some basic validation, in case the user switched off javascript
 680   my $cust_class = custom_class($cfg);
 681
 682   my %fields = BSE::TB::Order->valid_fields($cfg);
 683   my %rules = BSE::TB::Order->valid_rules($cfg);
 684
 685   my %errors;
 686   my %values;
 687   for my $name (keys %fields) {
 688     ($values{$name}) = $cgi->param($name);
 689   }
 690
 691   my @required =
 692     $cust_class->required_fields($cgi, $req->session->{custom}, $cfg);
 693
 694   for my $name (@required) {
 695     $field_map{$name} and $name = $field_map{$name};
 696
 697     $fields{$name}{required} = 1;
 698   }
 699
 700   dh_validate_hash(\%values, \%errors, { rules=>\%rules, fields=>\%fields },
 701                    $cfg, 'Shop Order Validation');
 702   my $prompt_ship = $cfg->entry("shop", "shipping", 0);
 703   if ($prompt_ship) {
 704     my $country = $values{delivCountry} || bse_default_country($cfg);
 705     my $country_code = bse_country_code($country);
 706     $country_code
 707       or $errors{delivCountry} = "Unknown country name $country";
 708   }
 709   keys %errors
 710     and return $class->req_checkout($req, \%errors, 1);
 711
 712   $class->_fillout_order($req, \%values, \@items, \@products, \$msg, 'payment')
 713     or return $class->req_checkout($req, $msg, 1);
 714
 715   $req->session->{order_info} = \%values;
 716   $req->session->{order_info_confirmed} = 1;
 717
 718   # skip payment page if nothing to pay
 719   if ($values{total} == 0) {
 720     return $class->req_payment($req);
 721   }
 722   else {
 723     return BSE::Template->get_refresh($req->user_url(shop => 'show_payment'), $req->cfg);
 724   }
 725 }
 726
 727 =item a_show_payment
 728
 729 Allows the customer to pay for an existing order.
 730
 731 Parameters:
 732
 733 =over
 734
 735 =item *
 736
 737 orderid - the order id to be paid (Optional, otherwise displays the
 738 cart for payment).
 739
 740 =back
 741
 742 Template: checkoutpay
 743
 744 =cut
 745
 746
 747 sub req_show_payment {
 748   my ($class, $req, $errors) = @_;
 749
 750   my $cfg = $req->cfg;
 751   my $cgi = $req->cgi;
 752
 753   my @items;
 754   my @products;
 755   my $order;
 756
 757   # ideally supply order_id to be consistent with a_payment.
 758   my $order_id = $cgi->param('orderid') || $cgi->param("order_id");
 759   if ($order_id) {
 760     $order_id =~ /^\d+$/
 761       or return $class->req_cart($req, "No or invalid order id supplied");
 762
 763     my $user = $req->siteuser
 764       or return $class->_refresh_logon
 765         ($req, "Please logon before paying your existing order", "logonpayorder",
 766          undef, { a_show_payment => 1, orderid => $order_id });
 767
 768     require BSE::TB::Orders;
 769     $order = BSE::TB::Orders->getByPkey($order_id)
 770       or return $class->req_cart($req, "Unknown order id");
 771
 772     $order->siteuser_id == $user->id
 773       or return $class->req_cart($req, "You can only pay for your own orders");
 774
 775     $order->paidFor
 776       and return $class->req_cart($req, "Order $order->{id} has been paid");
 777
 778     @items = $order->items;
 779     @products = $order->products;
 780   }
 781   else {
 782     $req->session->{order_info_confirmed}
 783       or return $class->req_checkout($req, 'Please proceed via the checkout page');
 784
 785     $req->session->{cart} && @{$req->session->{cart}}
 786       or return $class->req_cart($req, "Your cart is empty");
 787
 788     $order = $req->session->{order_info}
 789       or return $class->req_checkout($req, "You need to enter order information first");
 790
 791     @items = $class->_build_items($req, \@products);
 792   }
 793
 794   $errors ||= {};
 795   my $msg = $req->message($errors);
 796
 797   my @pay_types = payment_types($cfg);
 798   my @payment_types = map $_->{id}, grep $_->{enabled}, @pay_types;
 799   my %types_by_name = map { $_->{name} => $_->{id} } @pay_types;
 800   @payment_types or @payment_types = ( PAYMENT_CALLME );
 801   @payment_types = sort { $a <=> $b } @payment_types;
 802   my %payment_types = map { $_=> 1 } @payment_types;
 803   my $payment;
 804   $errors and $payment = $cgi->param('paymentType');
 805   defined $payment or $payment = $payment_types[0];
 806
 807   my %acts;
 808   %acts =
 809     (
 810      basic_tags(\%acts),
 811      message => $msg,
 812      msg => $msg,
 813      order => [ \&tag_hash, $order ],
 814      shop_cart_tags(\%acts, \@items, \@products, $req, 'payment'),
 815      ifMultPaymentTypes => @payment_types > 1,
 816      checkedPayment => [ \&tag_checkedPayment, $payment, \%types_by_name ],
 817      ifPayments => [ \&tag_ifPayments, \@payment_types, \%types_by_name ],
 818      paymentTypeId => [ \&tag_paymentTypeId, \%types_by_name ],
 819      error_img => [ \&tag_error_img, $cfg, $errors ],
 820      total => $order->{total},
 821      delivery_in => $order->{delivery_in},
 822      shipping_cost => $order->{shipping_cost},
 823      shipping_method => $order->{shipping_method},
 824     );
 825   for my $type (@pay_types) {
 826     my $id = $type->{id};
 827     my $name = $type->{name};
 828     $acts{"if${name}Payments"} = exists $payment_types{$id};
 829     $acts{"if${name}FirstPayment"} = $payment_types[0] == $id;
 830     $acts{"checkedIfFirst$name"} = $payment_types[0] == $id ? "checked " : "";
 831     $acts{"checkedPayment$name"} = $payment == $id ? 'checked="checked" ' : "";
 832   }
 833
 834   return $req->response('checkoutpay', \%acts);
 835 }
 836
 837 my %nostore =
 838   (
 839    cardNumber => 1,
 840    cardExpiry => 1,
 841    delivery_in => 1,
 842   );
 843
 844 sub req_payment {
 845   my ($class, $req, $errors) = @_;
 846
 847   require BSE::TB::Orders;
 848   my $cgi = $req->cgi;
 849   my $order_id = $cgi->param("order_id");
 850   my $user = $req->siteuser;
 851   my $order;
 852   my $order_values;
 853   my $old_order; # true if we're paying an old order
 854   if ($order_id) {
 855     unless ($user) {
 856       return $class->_refresh_logon
 857         (
 858          $req,
 859          "Please logon before paying your existing order",
 860          "logonpayorder",
 861          undef,
 862          { a_show_payment => 1, orderid => $order_id }
 863         );
 864     }
 865     $order_id =~ /^\d+$/
 866       or return $class->req_cart($req, "Invalid order id");
 867     $order = BSE::TB::Orders->getByPkey($order_id)
 868       or return $class->req_cart($req, "Unknown order id");
 869     $order->siteuser_id == $user->id
 870       or return $class->req_cart($req, "You can only pay for your own orders");
 871
 872     $order->paidFor
 873       and return $class->req_cart($req, "Order $order->{id} has been paid");
 874
 875     $order_values = $order;
 876     $old_order = 1;
 877   }
 878   else {
 879     $req->session->{order_info_confirmed}
 880       or return $class->req_checkout($req, 'Please proceed via the checkout page');
 881
 882     $order_values = $req->session->{order_info}
 883       or return $class->req_checkout($req, "You need to enter order information first");
 884     $old_order = 0;
 885   }
 886
 887   my $cfg = $req->cfg;
 888   my $session = $req->session;
 889
 890   my $paymentType;
 891   if ($order_values->{total} != 0) {
 892     my @pay_types = payment_types($cfg);
 893     my @payment_types = map $_->{id}, grep $_->{enabled}, @pay_types;
 894     my %pay_types = map { $_->{id} => $_ } @pay_types;
 895     my %types_by_name = map { $_->{name} => $_->{id} } @pay_types;
 896     @payment_types or @payment_types = ( PAYMENT_CALLME );
 897     @payment_types = sort { $a <=> $b } @payment_types;
 898     my %payment_types = map { $_=> 1 } @payment_types;
 899
 900     $paymentType = $cgi->param('paymentType');
 901     defined $paymentType or $paymentType = $payment_types[0];
 902     $payment_types{$paymentType}
 903       or return $class->req_show_payment($req, { paymentType => "Invalid payment type" } , 1);
 904
 905     my @required;
 906     push @required, @{$pay_types{$paymentType}{require}};
 907
 908     my %fields = BSE::TB::Order->valid_payment_fields($cfg);
 909     my %rules = BSE::TB::Order->valid_payment_rules($cfg);
 910     for my $field (@required) {
 911       if (exists $fields{$field}) {
 912         $fields{$field}{required} = 1;
 913       }
 914       else {
 915         $fields{$field} = { description => $field, required=> 1 };
 916       }
 917     }
 918
 919     my %errors;
 920     dh_validate($cgi, \%errors, { rules => \%rules, fields=>\%fields },
 921                 $cfg, 'Shop Order Validation');
 922     keys %errors
 923       and return $class->req_show_payment($req, \%errors);
 924
 925     for my $field (keys %fields) {
 926       unless ($nostore{$field}) {
 927         my $target = $field_map{$field} || $field;
 928         ($order_values->{$target}) = $cgi->param($field);
 929       }
 930     }
 931
 932   }
 933   else {
 934     $paymentType = -1;
 935   }
 936
 937   $order_values->{paymentType} = $paymentType;
 938   my @dbitems;
 939   my @products;
 940   my %subscribing_to;
 941   if ($order) {
 942     @dbitems = $order->items;
 943     @products = $order->products;
 944     for my $product (@products) {
 945       my $sub = $product->subscription;
 946       if ($sub) {
 947         $subscribing_to{$sub->{text_id}} = $sub;
 948       }
 949     }
 950   }
 951   else {
 952     $order_values->{filled} = 0;
 953     $order_values->{paidFor} = 0;
 954
 955     my @items = $class->_build_items($req, \@products);
 956
 957     my @columns = BSE::TB::Order->columns;
 958     my %columns;
 959     @columns{@columns} = @columns;
 960
 961     for my $col (@columns) {
 962       defined $order_values->{$col} or $order_values->{$col} = '';
 963     }
 964
 965     my @data = @{$order_values}{@columns};
 966     shift @data;
 967
 968     if ($session->{order_work}) {
 969       $order = BSE::TB::Orders->getByPkey($session->{order_work});
 970     }
 971     if ($order && !$order->{complete}) {
 972       print STDERR "Recycling order $order->{id}\n";
 973
 974       my @allbutid = @columns;
 975       shift @allbutid;
 976       @{$order}{@allbutid} = @data;
 977
 978       $order->clear_items;
 979       delete $session->{order_work};
 980       eval {
 981         tied(%$session)->save;
 982       };
 983     }
 984     else {
 985       $order = BSE::TB::Orders->add(@data)
 986         or die "Cannot add order";
 987     }
 988
 989     my @item_cols = BSE::TB::OrderItem->columns;
 990     for my $row_num (0..$#items) {
 991       my $item = $items[$row_num];
 992       my $product = $products[$row_num];
 993       my %item = %$item;
 994       $item{orderId} = $order->{id};
 995       $item{max_lapsed} = 0;
 996       if ($product->{subscription_id} != -1) {
 997         my $sub = $product->subscription;
 998         $item{max_lapsed} = $sub->{max_lapsed} if $sub;
 999       }
1000       defined $item{session_id} or $item{session_id} = 0;
1001       $item{options} = ""; # not used for new orders
1002       my @data = @item{@item_cols};
1003     shift @data;
1004       my $dbitem = BSE::TB::OrderItems->add(@data);
1005       push @dbitems, $dbitem;
1006
1007       if ($item->{options} and @{$item->{options}}) {
1008         require BSE::TB::OrderItemOptions;
1009         my @option_descs = $product->option_descs($cfg, $item->{options});
1010         my $display_order = 1;
1011         for my $option (@option_descs) {
1012           BSE::TB::OrderItemOptions->make
1013               (
1014                order_item_id => $dbitem->{id},
1015                original_id => $option->{id},
1016                name => $option->{desc},
1017                value => $option->{value},
1018                display => $option->{display},
1019                display_order => $display_order++,
1020               );
1021         }
1022       }
1023
1024       my $sub = $product->subscription;
1025       if ($sub) {
1026         $subscribing_to{$sub->{text_id}} = $sub;
1027       }
1028
1029       if ($item->{session_id}) {
1030         require BSE::TB::SeminarSessions;
1031         my $session = BSE::TB::SeminarSessions->getByPkey($item->{session_id});
1032         my $options = join(",", @{$item->{options}});
1033         eval {
1034           $session->add_attendee($user,
1035                                  instructions => $order->{instructions},
1036                                  options => $options);
1037         };
1038       }
1039     }
1040   }
1041
1042   $order->set_randomId(make_secret($cfg));
1043   $order->{ccOnline} = 0;
1044
1045   my $ccprocessor = $cfg->entry('shop', 'cardprocessor');
1046   if ($paymentType == PAYMENT_CC) {
1047     my $ccNumber = $cgi->param('cardNumber');
1048     my $ccExpiry = $cgi->param('cardExpiry');
1049
1050     if ($ccprocessor) {
1051       my $cc_class = credit_card_class($cfg);
1052
1053       $order->{ccOnline} = 1;
1054
1055       $ccExpiry =~ m!^(\d+)\D(\d+)$! or die;
1056       my ($month, $year) = ($1, $2);
1057       $year > 2000 or $year += 2000;
1058       my $expiry = sprintf("%04d%02d", $year, $month);
1059       my $verify = $cgi->param('cardVerify');
1060       defined $verify or $verify = '';
1061       my $result = $cc_class->payment(orderno=>$order->{id},
1062                                       amount => $order->{total},
1063                                       cardnumber => $ccNumber,
1064                                       expirydate => $expiry,
1065                                       cvv => $verify,
1066                                       ipaddress => $ENV{REMOTE_ADDR});
1067       unless ($result->{success}) {
1068         use Data::Dumper;
1069         print STDERR Dumper($result);
1070         # failed, back to payments
1071         $order->{ccSuccess}     = 0;
1072         $order->{ccStatus}      = $result->{statuscode};
1073         $order->{ccStatus2}     = 0;
1074         $order->{ccStatusText}  = $result->{error};
1075         $order->{ccTranId}      = '';
1076         $order->save;
1077         my %errors;
1078         $errors{cardNumber} = $result->{error};
1079         $session->{order_work} = $order->{id};
1080         return $class->req_show_payment($req, \%errors);
1081       }
1082
1083       $order->{ccSuccess}           = 1;
1084       $order->{ccReceipt}           = $result->{receipt};
1085       $order->{ccStatus}            = 0;
1086       $order->{ccStatus2}           = 0;
1087       $order->{ccStatusText}  = '';
1088       $order->{ccTranId}            = $result->{transactionid};
1089       defined $order->{ccTranId} or $order->{ccTranId} = '';
1090       $order->{paidFor}     = 1;
1091     }
1092     else {
1093       $ccNumber =~ tr/0-9//cd;
1094       $order->{ccNumberHash} = md5_hex($ccNumber);
1095       $order->{ccExpiryHash} = md5_hex($ccExpiry);
1096     }
1097   }
1098   elsif ($paymentType == PAYMENT_PAYPAL) {
1099     require BSE::PayPal;
1100     my $msg;
1101     my $url = BSE::PayPal->payment_url(order => $order,
1102                                        user => $user,
1103                                        msg => \$msg);
1104     unless ($url) {
1105       $session->{order_work} = $order->{id};
1106       my %errors;
1107       $errors{_} = "PayPal error: $msg" if $msg;
1108       return $class->req_show_payment($req, \%errors);
1109     }
1110
1111     # have to mark it complete so it doesn't get used by something else
1112     return BSE::Template->get_refresh($url, $req->cfg);
1113   }
1114
1115   # order complete
1116   $order->{complete} = 1;
1117   $order->save;
1118
1119   $class->_finish_order($req, $order);
1120
1121   return BSE::Template->get_refresh($req->user_url(shop => 'orderdone'), $req->cfg);
1122 }
1123
1124 # do final processing of an order after payment
1125 sub _finish_order {
1126   my ($self, $req, $order) = @_;
1127
1128
1129   my $custom = custom_class($req->cfg);
1130   $custom->can("order_complete")
1131     and $custom->order_complete($req->cfg, $order);
1132
1133   # set the order displayed by orderdone
1134   $req->session->{order_completed} = $order->{id};
1135   $req->session->{order_completed_at} = time;
1136
1137   $self->_send_order($req, $order);
1138
1139   # empty the cart ready for the next order
1140   delete @{$req->session}{qw/order_info order_info_confirmed cart order_work/};
1141 }
1142
1143 sub req_orderdone {
1144   my ($class, $req) = @_;
1145
1146   my $session = $req->session;
1147   my $cfg = $req->cfg;
1148
1149   my $id = $session->{order_completed};
1150   my $when = $session->{order_completed_at};
1151   $id && defined $when && time < $when + 500
1152     or return $class->req_cart($req);
1153
1154   my $order = BSE::TB::Orders->getByPkey($id)
1155     or return $class->req_cart($req);
1156   my @items = $order->items;
1157   my @products = map { Products->getByPkey($_->{productId}) } @items;
1158
1159   my @item_cols = BSE::TB::OrderItem->columns;
1160   my %copy_cols = map { $_ => 1 } Product->columns;
1161   delete @copy_cols{@item_cols};
1162   my @copy_cols = keys %copy_cols;
1163   my @showitems;
1164   for my $item_index (0..$#items) {
1165     my $item = $items[$item_index];
1166     my $product = $products[$item_index];
1167     my %entry;
1168     @entry{@item_cols} = @{$item}{@item_cols};
1169     @entry{@copy_cols} = @{$product}{@copy_cols};
1170
1171     push @showitems, \%entry;
1172   }
1173
1174   my $cust_class = custom_class($req->cfg);
1175
1176   my @pay_types = payment_types($cfg);
1177   my @payment_types = map $_->{id}, grep $_->{enabled}, @pay_types;
1178   my %pay_types = map { $_->{id} => $_ } @pay_types;
1179   my %types_by_name = map { $_->{name} => $_->{id} } @pay_types;
1180
1181   my $item_index = -1;
1182   my @options;
1183   my $option_index;
1184   my $item;
1185   my $product;
1186   my $sem_session;
1187   my $location;
1188   require BSE::Util::Iterate;
1189   my $it = BSE::Util::Iterate::Objects->new(cfg => $req->cfg);
1190   my %acts;
1191   %acts =
1192     (
1193      $req->dyn_user_tags(),
1194      $cust_class->purchase_actions(\%acts, \@items, \@products,
1195                                    $session->{custom}, $cfg),
1196      BSE::Util::Tags->static(\%acts, $cfg),
1197      iterate_items_reset => sub { $item_index = -1; },
1198      iterate_items =>
1199      sub {
1200        if (++$item_index < @items) {
1201          $option_index = -1;
1202          @options = order_item_opts($req, $items[$item_index]);
1203          undef $sem_session;
1204          undef $location;
1205          $item = $items[$item_index];
1206          $product = $products[$item_index];
1207          return 1;
1208        }
1209        undef $item;
1210        undef $sem_session;
1211        undef $product;
1212        undef $location;
1213        return 0;
1214      },
1215      item=> sub { escape_html($showitems[$item_index]{$_[0]}); },
1216      product =>
1217      sub {
1218        return tag_article($product, $cfg, $_[0]);
1219      },
1220      extended =>
1221      sub {
1222        my $what = $_[0] || 'retailPrice';
1223        $items[$item_index]{units} * $items[$item_index]{$what};
1224      },
1225      order => sub { escape_html($order->{$_[0]}) },
1226      _format =>
1227      sub {
1228        my ($value, $fmt) = @_;
1229        if ($fmt =~ /^m(\d+)/) {
1230          return sprintf("%$1s", sprintf("%.2f", $value/100));
1231        }
1232        elsif ($fmt =~ /%/) {
1233          return sprintf($fmt, $value);
1234        }
1235      },
1236      iterate_options_reset => sub { $option_index = -1 },
1237      iterate_options => sub { ++$option_index < @options },
1238      option => sub { escape_html($options[$option_index]{$_[0]}) },
1239      ifOptions => sub { @options },
1240      options => sub { nice_options(@options) },
1241      ifPayment => [ \&tag_ifPayment, $order->{paymentType}, \%types_by_name ],
1242      #ifSubscribingTo => [ \&tag_ifSubscribingTo, \%subscribing_to ],
1243      session => [ \&tag_session, \$item, \$sem_session ],
1244      location => [ \&tag_location, \$item, \$location ],
1245      msg => '',
1246      delivery_in => $order->{delivery_in},
1247      shipping_cost => $order->{shipping_cost},
1248      shipping_method => $order->{shipping_method},
1249      $it->make
1250      (
1251       single => "orderpaidfile",
1252       plural => "orderpaidfiles",
1253       code => [ paid_files => $order ],
1254      ),
1255     );
1256   for my $type (@pay_types) {
1257     my $id = $type->{id};
1258     my $name = $type->{name};
1259     $acts{"if${name}Payment"} = $order->{paymentType} == $id;
1260   }
1261
1262   return $req->response('checkoutfinal', \%acts);
1263 }
1264
1265 sub tag_session {
1266   my ($ritem, $rsession, $arg) = @_;
1267
1268   $$ritem or return '';
1269
1270   $$ritem->{session_id} or return '';
1271
1272   unless ($$rsession) {
1273     require BSE::TB::SeminarSessions;
1274     $$rsession = BSE::TB::SeminarSessions->getByPkey($$ritem->{session_id})
1275       or return '';
1276   }
1277
1278   my $value = $$rsession->{$arg};
1279   defined $value or return '';
1280
1281   escape_html($value);
1282 }
1283
1284 sub tag_location {
1285   my ($ritem, $rlocation, $arg) = @_;
1286
1287   $$ritem or return '';
1288
1289   $$ritem->{session_id} or return '';
1290
1291   unless ($$rlocation) {
1292     require BSE::TB::Locations;
1293     ($$rlocation) = BSE::TB::Locations->getSpecial(session_id => $$ritem->{session_id})
1294       or return '';
1295   }
1296
1297   my $value = $$rlocation->{$arg};
1298   defined $value or return '';
1299
1300   escape_html($value);
1301 }
1302
1303 sub tag_ifPayment {
1304   my ($payment, $types_by_name, $args) = @_;
1305
1306   my $type = $args;
1307   if ($type !~ /^\d+$/) {
1308     return '' unless exists $types_by_name->{$type};
1309     $type = $types_by_name->{$type};
1310   }
1311
1312   return $payment == $type;
1313 }
1314
1315 sub tag_paymentTypeId {
1316   my ($types_by_name, $args) = @_;
1317
1318   if (exists $types_by_name->{$args}) {
1319     return $types_by_name->{$args};
1320   }
1321
1322   return '';
1323 }
1324
1325
1326 sub _validate_cfg {
1327   my ($class, $req, $rmsg) = @_;
1328
1329   my $cfg = $req->cfg;
1330   my $from = $cfg->entry('shop', 'from', $Constants::SHOP_FROM);
1331   unless ($from && $from =~ /.\@./) {
1332     $$rmsg = "Configuration error: shop from address not set";
1333     return;
1334   }
1335   my $toEmail = $cfg->entry('shop', 'to_email', $Constants::SHOP_TO_EMAIL);
1336   unless ($toEmail && $toEmail =~ /.\@./) {
1337     $$rmsg = "Configuration error: shop to_email address not set";
1338     return;
1339   }
1340
1341   return 1;
1342 }
1343
1344 sub req_recalc {
1345   my ($class, $req) = @_;
1346
1347   $class->update_quantities($req);
1348   $req->session->{order_info_confirmed} = 0;
1349   return $class->req_cart($req);
1350 }
1351
1352 sub req_recalculate {
1353   my ($class, $req) = @_;
1354
1355   return $class->req_recalc($req);
1356 }
1357
1358 sub _send_order {
1359   my ($class, $req, $order) = @_;
1360
1361   my $cfg = $req->cfg;
1362   my $cgi = $req->cgi;
1363
1364   my $noencrypt = $cfg->entryBool('shop', 'noencrypt', 0);
1365   my $crypto_class = $cfg->entry('shop', 'crypt_module',
1366                                  $Constants::SHOP_CRYPTO);
1367   my $signing_id = $cfg->entry('shop', 'crypt_signing_id',
1368                                $Constants::SHOP_SIGNING_ID);
1369   my $pgp = $cfg->entry('shop', 'crypt_pgp', $Constants::SHOP_PGP);
1370   my $pgpe = $cfg->entry('shop', 'crypt_pgpe', $Constants::SHOP_PGPE);
1371   my $gpg = $cfg->entry('shop', 'crypt_gpg', $Constants::SHOP_GPG);
1372   my $passphrase = $cfg->entry('shop', 'crypt_passphrase',
1373                                $Constants::SHOP_PASSPHRASE);
1374   my $from = $cfg->entry('shop', 'from', $Constants::SHOP_FROM);
1375   my $toName = $cfg->entry('shop', 'to_name', $Constants::SHOP_TO_NAME);
1376   my $toEmail = $cfg->entry('shop', 'to_email', $Constants::SHOP_TO_EMAIL);
1377   my $subject = $cfg->entry('shop', 'subject', $Constants::SHOP_MAIL_SUBJECT);
1378
1379   my $session = $req->session;
1380   my %extras = $cfg->entriesCS('extra tags');
1381   for my $key (keys %extras) {
1382     # follow any links
1383     my $data = $cfg->entryVar('extra tags', $key);
1384     $extras{$key} = sub { $data };
1385   }
1386
1387   my @items = $order->items;
1388   my @products = map $_->product, @items;
1389   my %subscribing_to;
1390   for my $product (@products) {
1391     my $sub = $product->subscription;
1392     if ($sub) {
1393       $subscribing_to{$sub->{text_id}} = $sub;
1394     }
1395   }
1396
1397   my $item_index = -1;
1398   my @options;
1399   my $option_index;
1400   my %acts;
1401   %acts =
1402     (
1403      %extras,
1404      custom_class($cfg)
1405      ->order_mail_actions(\%acts, $order, \@items, \@products,
1406                           $session->{custom}, $cfg),
1407      BSE::Util::Tags->static(\%acts, $cfg),
1408      iterate_items_reset => sub { $item_index = -1; },
1409      iterate_items =>
1410      sub {
1411        if (++$item_index < @items) {
1412          $option_index = -1;
1413          @options = order_item_opts($req,
1414                                     $items[$item_index],
1415                                     $products[$item_index]);
1416          return 1;
1417        }
1418        return 0;
1419      },
1420      item=> sub { $items[$item_index]{$_[0]}; },
1421      product =>
1422      sub {
1423        my $value = $products[$item_index]{$_[0]};
1424        defined($value) or $value = '';
1425        $value;
1426      },
1427      order => sub { $order->{$_[0]} },
1428      extended =>
1429      sub {
1430        $items[$item_index]{units} * $items[$item_index]{$_[0]};
1431      },
1432      _format =>
1433      sub {
1434        my ($value, $fmt) = @_;
1435        if ($fmt =~ /^m(\d+)/) {
1436          return sprintf("%$1s", sprintf("%.2f", $value/100));
1437        }
1438        elsif ($fmt =~ /%/) {
1439          return sprintf($fmt, $value);
1440        }
1441        elsif ($fmt =~ /^\d+$/) {
1442          return substr($value . (" " x $fmt), 0, $fmt);
1443        }
1444        else {
1445          return $value;
1446        }
1447      },
1448      iterate_options_reset => sub { $option_index = -1 },
1449      iterate_options => sub { ++$option_index < @options },
1450      option => sub { escape_html($options[$option_index]{$_[0]}) },
1451      ifOptions => sub { @options },
1452      options => sub { nice_options(@options) },
1453      with_wrap => \&tag_with_wrap,
1454      ifSubscribingTo => [ \&tag_ifSubscribingTo, \%subscribing_to ],
1455     );
1456
1457   my $email_order = $cfg->entryBool('shop', 'email_order', $Constants::SHOP_EMAIL_ORDER);
1458   require BSE::ComposeMail;
1459   if ($email_order) {
1460     unless ($noencrypt) {
1461       $acts{cardNumber} = $cgi->param('cardNumber');
1462       $acts{cardExpiry} = $cgi->param('cardExpiry');
1463       $acts{cardVerify} = $cgi->param('cardVerify');
1464     }
1465
1466     my $mailer = BSE::ComposeMail->new(cfg => $cfg);
1467     $mailer->start
1468       (
1469        to=>$toEmail,
1470        from=>$from,
1471        subject=>'New Order '.$order->{id},
1472        acts => \%acts,
1473        template => "mailorder",
1474        log_component => "shop:sendorder:mailowner",
1475        log_object => $order,
1476        log_msg => "Order $order->{id} sent to site owner",
1477       );
1478
1479     unless ($noencrypt) {
1480       my %crypt_opts;
1481       my $sign = $cfg->entryBool('basic', 'sign', 1);
1482       $sign or $crypt_opts{signing_id} = "";
1483       $crypt_opts{recipient} =
1484         $cfg->entry("shop", "crypt_recipient", "$toName $toEmail");
1485       $mailer->encrypt_body(%crypt_opts);
1486     }
1487
1488     $mailer->done
1489       or print STDERR "Error sending order to admin: ",$mailer->errstr,"\n";
1490
1491     delete @acts{qw/cardNumber cardExpiry cardVerify/};
1492   }
1493   my $to = $order->emailAddress;
1494   my $user = $req->siteuser;
1495   if ($user && $user->email eq $to) {
1496     $to = $user;
1497   }
1498   my $mailer = BSE::ComposeMail->new(cfg => $cfg);
1499   $mailer->send
1500     (
1501      to => $to,
1502      from => $from,
1503      subject => $subject . " " . localtime,
1504      template => "mailconfirm",
1505      acts => \%acts,
1506      log_component => "shop:sendorder:mailbuyer",
1507      log_object => $order,
1508      log_msg => "Order $order->{id} sent to purchaser ".$order->emailAddress,
1509     )
1510     or print STDERR "Error sending order to customer: ",$mailer->errstr,"\n";
1511 }
1512
1513 sub tag_with_wrap {
1514   my ($args, $text) = @_;
1515
1516   my $margin = $args =~ /^\d+$/ && $args > 30 ? $args : 70;
1517
1518   require Text::Wrap;
1519   # do it twice to prevent a warning
1520   $Text::Wrap::columns = $margin;
1521   $Text::Wrap::columns = $margin;
1522
1523   return Text::Wrap::fill('', '', split /\n/, $text);
1524 }
1525
1526 sub _refresh_logon {
1527   my ($class, $req, $msg, $msgid, $r, $parms) = @_;
1528
1529   my $securlbase = $req->cfg->entryVar('site', 'secureurl');
1530   my $url = $securlbase."/cgi-bin/user.pl";
1531   $parms ||= { checkout => 1 };
1532
1533   unless ($r) {
1534     $r = $securlbase."/cgi-bin/shop.pl?"
1535       . join("&", map "$_=" . escape_uri($parms->{$_}), keys %$parms);
1536   }
1537
1538   my %parms;
1539   if ($req->cfg->entry('shop registration', 'all')
1540       || $req->cfg->entry('shop registration', $msgid)) {
1541     $parms{show_register} = 1;
1542   }
1543   $parms{r} = $r;
1544   if ($msgid) {
1545     $msg = $req->cfg->entry('messages', $msgid, $msg);
1546   }
1547   $parms{message} = $msg if $msg;
1548   $parms{mid} = $msgid if $msgid;
1549   $url .= "?" . join("&", map "$_=".escape_uri($parms{$_}), keys %parms);
1550
1551   return BSE::Template->get_refresh($url, $req->cfg);
1552 }
1553
1554 sub _need_logon {
1555   my ($class, $req, $cart, $cart_prods) = @_;
1556
1557   return need_logon($req, $cart, $cart_prods);
1558 }
1559
1560 sub tag_checkedPayment {
1561   my ($payment, $types_by_name, $args) = @_;
1562
1563   my $type = $args;
1564   if ($type !~ /^\d+$/) {
1565     return '' unless exists $types_by_name->{$type};
1566     $type = $types_by_name->{$type};
1567   }
1568
1569   return $payment == $type  ? 'checked="checked"' : '';
1570 }
1571
1572 sub tag_ifPayments {
1573   my ($enabled, $types_by_name, $args) = @_;
1574
1575   my $type = $args;
1576   if ($type !~ /^\d+$/) {
1577     return '' unless exists $types_by_name->{$type};
1578     $type = $types_by_name->{$type};
1579   }
1580
1581   my @found = grep $_ == $type, @$enabled;
1582
1583   return scalar @found;
1584 }
1585
1586 sub update_quantities {
1587   my ($class, $req) = @_;
1588
1589   my $session = $req->session;
1590   my $cgi = $req->cgi;
1591   my $cfg = $req->cfg;
1592   my @cart = @{$session->{cart} || []};
1593   for my $index (0..$#cart) {
1594     my $new_quantity = $cgi->param("quantity_$index");
1595     if (defined $new_quantity) {
1596       if ($new_quantity =~ /^\s*(\d+)/) {
1597         $cart[$index]{units} = $1;
1598       }
1599       elsif ($new_quantity =~ /^\s*$/) {
1600         $cart[$index]{units} = 0;
1601       }
1602     }
1603   }
1604   @cart = grep { $_->{units} != 0 } @cart;
1605   $session->{cart} = \@cart;
1606   $session->{custom} ||= {};
1607   my %custom_state = %{$session->{custom}};
1608   custom_class($cfg)->recalc($cgi, \@cart, [], \%custom_state, $cfg);
1609   $session->{custom} = \%custom_state;
1610 }
1611
1612 sub _build_items {
1613   my ($class, $req, $products) = @_;
1614
1615   my $session = $req->session;
1616   $session->{cart}
1617     or return;
1618   my @msgs;
1619   my @cart = @{$req->session->{cart}}
1620     or return;
1621   my @items;
1622   my @prodcols = Product->columns;
1623   my @newcart;
1624   my $today = now_sqldate();
1625   for my $item (@cart) {
1626     my %work = %$item;
1627     my $product = Products->getByPkey($item->{productId});
1628     if ($product) {
1629       (my $comp_release = $product->{release}) =~ s/ .*//;
1630       (my $comp_expire = $product->{expire}) =~ s/ .*//;
1631       $comp_release le $today
1632         or do { push @msgs, "'$product->{title}' has not been released yet";
1633                 next; };
1634       $today le $comp_expire
1635         or do { push @msgs, "'$product->{title}' has expired"; next; };
1636       $product->{listed}
1637         or do { push @msgs, "'$product->{title}' not available"; next; };
1638
1639       for my $col (@prodcols) {
1640         $work{$col} = $product->$col() unless exists $work{$col};
1641       }
1642       $work{extended_retailPrice} = $work{units} * $work{retailPrice};
1643       $work{extended_gst} = $work{units} * $work{gst};
1644       $work{extended_wholesale} = $work{units} * $work{wholesalePrice};
1645
1646       push @newcart, \%work;
1647       push @$products, $product;
1648     }
1649   }
1650
1651   # we don't use these for anything for now
1652   #if (@msgs) {
1653   #  @$rmsg = @msgs;
1654   #}
1655
1656   return @newcart;
1657 }
1658
1659 sub _fillout_order {
1660   my ($class, $req, $values, $items, $products, $rmsg, $how) = @_;
1661
1662   my $session = $req->session;
1663   my $cfg = $req->cfg;
1664   my $cgi = $req->cgi;
1665
1666   my $total = 0;
1667   my $total_gst = 0;
1668   my $total_wholesale = 0;
1669   for my $item (@$items) {
1670     $total += $item->{extended_retailPrice};
1671     $total_gst += $item->{extended_gst};
1672     $total_wholesale += $item->{extended_wholesale};
1673   }
1674   $values->{total} = $total;
1675   $values->{gst} = $total_gst;
1676   $values->{wholesale} = $total_wholesale;
1677
1678   my $prompt_ship = $cfg->entry("shop", "shipping", 0);
1679   if ($prompt_ship) {
1680     my ($courier) = BSE::Shipping->get_couriers($cfg, $cgi->param("shipping_name"));
1681     my $country_code = bse_country_code($values->{delivCountry});
1682     if ($courier) {
1683       unless ($courier->can_deliver(country => $country_code,
1684                                     suburb => $values->{delivSuburb},
1685                                     postcode => $values->{delivPostCode})) {
1686         $cgi->param("courier", undef);
1687         $$rmsg =
1688           "Can't use the selected courier ".
1689             "(". $courier->description(). ") for this order.";
1690         return;
1691       }
1692       my @parcels = BSE::Shipping->package_order($cfg, $values, $items);
1693       my $cost = $courier->calculate_shipping
1694         (
1695          parcels => \@parcels,
1696          country => $country_code,
1697          suburb => $values->{delivSuburb},
1698          postcode => $values->{delivPostCode},
1699          products => $products,
1700          items => $items,
1701        );
1702       if (!$cost and $courier->name() ne 'contact') {
1703         my $err = $courier->error_message();
1704         $$rmsg = "Error calculating shipping cost";
1705         $$rmsg .= ": $err" if $err;
1706         return;
1707       }
1708       $values->{shipping_method} = $courier->description();
1709       $values->{shipping_name} = $courier->name;
1710       $values->{shipping_cost} = $cost;
1711       $values->{shipping_trace} = $courier->trace;
1712       $values->{delivery_in} = $courier->delivery_in();
1713       $values->{total} += $values->{shipping_cost};
1714     }
1715     else {
1716       # XXX: What to do?
1717       $$rmsg = "Error: no usable courier found.";
1718       return;
1719     }
1720   }
1721
1722   my $cust_class = custom_class($cfg);
1723
1724   eval {
1725     local $SIG{__DIE__};
1726     my %custom = %{$session->{custom}};
1727     $cust_class->order_save($cgi, $values, $items, $items,
1728                             \%custom, $cfg);
1729     $session->{custom} = \%custom;
1730   };
1731   if ($@) {
1732     $$rmsg = $@;
1733     return;
1734   }
1735
1736   $values->{total} +=
1737     $cust_class->total_extras($items, $items,
1738                               $session->{custom}, $cfg, $how);
1739
1740   my $affiliate_code = $session->{affiliate_code};
1741   defined $affiliate_code && length $affiliate_code
1742     or $affiliate_code = $cgi->param('affiliate_code');
1743   defined $affiliate_code or $affiliate_code = '';
1744   $values->{affiliate_code} = $affiliate_code;
1745
1746   my $user = $req->siteuser;
1747   if ($user) {
1748     $values->{userId} = $user->{userId};
1749     $values->{siteuser_id} = $user->{id};
1750   }
1751   else {
1752     $values->{userId} = '';
1753     $values->{siteuser_id} = -1;
1754   }
1755
1756   $values->{orderDate} = now_sqldatetime;
1757
1758   # this should be hard to guess
1759   $values->{randomId} = md5_hex(time().rand().{}.$$);
1760
1761   return 1;
1762 }
1763
1764 sub action_prefix { '' }
1765
1766 sub req_location {
1767   my ($class, $req) = @_;
1768
1769   require BSE::TB::Locations;
1770   my $cgi = $req->cgi;
1771   my $location_id = $cgi->param('location_id');
1772   my $location;
1773   if (defined $location_id && $location_id =~ /^\d+$/) {
1774     $location = BSE::TB::Locations->getByPkey($location_id);
1775     my %acts;
1776     %acts =
1777       (
1778        BSE::Util::Tags->static(\%acts, $req->cfg),
1779        location => [ \&tag_hash, $location ],
1780       );
1781
1782     return $req->response('location', \%acts);
1783   }
1784   else {
1785     return
1786       {
1787        type=>BSE::Template->get_type($req->cfg, 'error'),
1788        content=>"Missing or invalid location_id",
1789       };
1790   }
1791 }
1792
1793 sub _validate_add_by_id {
1794   my ($class, $req, $addid, $quantity, $error, $refresh_logon) = @_;
1795
1796   my $product;
1797   if ($addid) {
1798     $product = BSE::TB::Seminars->getByPkey($addid);
1799     $product ||= Products->getByPkey($addid);
1800   }
1801   unless ($product) {
1802     $$error = "Cannot find product $addid";
1803     return;
1804   }
1805
1806   return $class->_validate_add($req, $product, $quantity, $error, $refresh_logon);
1807 }
1808
1809 sub _validate_add_by_code {
1810   my ($class, $req, $code, $quantity, $error, $refresh_logon) = @_;
1811
1812   my $product;
1813   if (defined $code) {
1814     $product = BSE::TB::Seminars->getBy(product_code => $code);
1815     $product ||= Products->getBy(product_code => $code);
1816   }
1817   unless ($product) {
1818     $$error = "Cannot find product code $code";
1819     return;
1820   }
1821
1822   return $class->_validate_add($req, $product, $quantity, $error, $refresh_logon);
1823 }
1824
1825 sub _validate_add {
1826   my ($class, $req, $product, $quantity, $error, $refresh_logon) = @_;
1827
1828   # collect the product options
1829   my @options;
1830   my @option_descs =  $product->option_descs($req->cfg);
1831   my @option_names = map $_->{name}, @option_descs;
1832   my @not_def;
1833   my $cgi = $req->cgi;
1834   for my $name (@option_names) {
1835     my $value = $cgi->param($name);
1836     push @options, $value;
1837     unless (defined $value) {
1838       push @not_def, $name;
1839     }
1840   }
1841   if (@not_def) {
1842     $$error = "Some product options (@not_def) not supplied";
1843     return;
1844   }
1845
1846   # the product must be non-expired and listed
1847   (my $comp_release = $product->{release}) =~ s/ .*//;
1848   (my $comp_expire = $product->{expire}) =~ s/ .*//;
1849   my $today = now_sqldate();
1850   unless ($comp_release le $today) {
1851     $$error = "Product $product->{title} has not been released yet";
1852     return;
1853   }
1854   unless ($today le $comp_expire) {
1855     $$error = "Product $product->{title} has expired";
1856     return;
1857   }
1858   unless ($product->{listed}) {
1859     $$error = "Product $product->{title} not available";
1860     return;
1861   }
1862
1863   # used to refresh if a logon is needed
1864   my $securlbase = $req->cfg->entryVar('site', 'secureurl');
1865   my $r = $securlbase . $ENV{SCRIPT_NAME} . "?add=1&id=$product->{id}";
1866   for my $opt_index (0..$#option_names) {
1867     $r .= "&$option_names[$opt_index]=".escape_uri($options[$opt_index]);
1868   }
1869
1870   my $user = $req->siteuser;
1871   # need to be logged on if it has any subs
1872   if ($product->{subscription_id} != -1) {
1873     if ($user) {
1874       my $sub = $product->subscription;
1875       if ($product->is_renew_sub_only) {
1876         unless ($user->subscribed_to_grace($sub)) {
1877           $$error = "The product $product->{title} can only be used to renew your subscription to $sub->{title} and you are not subscribed nor within the renewal grace period";
1878           return;
1879         }
1880       }
1881       elsif ($product->is_start_sub_only) {
1882         if ($user->subscribed_to_grace($sub)) {
1883           $$error = "The product $product->{title} can only be used to start your subscription to $sub->{title} and you are already subscribed or within the grace period";
1884           return;
1885         }
1886       }
1887     }
1888     else {
1889       $$refresh_logon =
1890         [  "You must be logged on to add this product to your cart",
1891            'prodlogon', $r ];
1892       return;
1893     }
1894   }
1895   if ($product->{subscription_required} != -1) {
1896     my $sub = $product->subscription_required;
1897     if ($user) {
1898       unless ($user->subscribed_to($sub)) {
1899         $$error = "You must be subscribed to $sub->{title} to purchase this product";
1900         return;
1901       }
1902     }
1903     else {
1904       # we want to refresh back to adding the item to the cart if possible
1905       $$refresh_logon =
1906         [ "You must be logged on and subscribed to $sub->{title} to add this product to your cart",
1907          'prodlogonsub', $r ];
1908       return;
1909     }
1910   }
1911
1912   # we need a natural integer quantity
1913   unless ($quantity =~ /^\d+$/ && $quantity > 0) {
1914     $$error = "Invalid quantity";
1915     return;
1916   }
1917
1918   my %extras;
1919   if ($product->isa('BSE::TB::Seminar')) {
1920     # you must be logged on to add a seminar
1921     unless ($user) {
1922       $$refresh_logon =
1923         [ "You must be logged on to add seminars to your cart",
1924           'seminarlogon', $r ];
1925       return;
1926     }
1927
1928     # get and validate the session
1929     my $session_id = $cgi->param('session_id');
1930     unless (defined $session_id) {
1931       $$error = "Please select a session when adding a seminar";
1932       return;
1933     }
1934
1935     unless ($session_id =~ /^\d+$/) {
1936       $$error = "Invalid session_id supplied";
1937       return;
1938     }
1939
1940     require BSE::TB::SeminarSessions;
1941     my $session = BSE::TB::SeminarSessions->getByPkey($session_id);
1942     unless ($session) {
1943       $$error = "Unknown session id supplied";
1944       return;
1945     }
1946     unless ($session->{seminar_id} == $product->{id}) {
1947       $$error = "Session not for this seminar";
1948       return;
1949     }
1950
1951     # check if the user is already booked for this session
1952     if (grep($_ == $session_id, $user->seminar_sessions_booked($product->{id}))) {
1953       $$error = "You are already booked for this session";
1954       return;
1955     }
1956
1957     $extras{session_id} = $session_id;
1958   }
1959
1960   return ( $product, \@options, \%extras );
1961 }
1962
1963 sub _add_refresh {
1964   my ($refresh, $req, $started_empty) = @_;
1965
1966   my $cfg = $req->cfg;
1967   my $cookie_domain = $cfg->entry('basic', 'cookie_domain');
1968   if ($started_empty && !$cookie_domain) {
1969     my $base_url = $cfg->entryVar('site', 'url');
1970     my $secure_url = $cfg->entryVar('site', 'secureurl');
1971     if ($base_url ne $secure_url) {
1972       my $debug = $cfg->entryBool('debug', 'logon_cookies', 0);
1973
1974       # magical refresh time
1975       # which host are we on?
1976       # first get info about the 2 possible hosts
1977       my ($baseprot, $basehost, $baseport) =
1978         $base_url =~ m!^(\w+)://([\w.-]+)(?::(\d+))?!;
1979       $baseport ||= $baseprot eq 'http' ? 80 : 443;
1980       print STDERR "Base: prot: $baseprot  Host: $basehost  Port: $baseport\n"
1981         if $debug;
1982
1983       #my ($secprot, $sechost, $secport) =
1984       #  $securl =~ m!^(\w+)://([\w.-]+)(?::(\d+))?!;
1985
1986       my $onbase = 1;
1987       # get info about the current host
1988       my $port = $ENV{SERVER_PORT} || 80;
1989       my $ishttps = exists $ENV{HTTPS} || exists $ENV{SSL_CIPHER};
1990       print STDERR "\$ishttps: $ishttps\n" if $debug;
1991       my $protocol = $ishttps ? 'https' : 'http';
1992
1993       if (lc $ENV{SERVER_NAME} ne lc $basehost
1994           || lc $protocol ne $baseprot
1995           || $baseport != $port) {
1996         print STDERR "not on base host ('$ENV{SERVER_NAME}' cmp '$basehost' '$protocol cmp '$baseprot'  $baseport cmp $port\n" if $debug;
1997         $onbase = 0;
1998       }
1999       my $url = $onbase ? $secure_url : $base_url;
2000       my $finalbase = $onbase ? $base_url : $secure_url;
2001       $refresh = $finalbase . $refresh unless $refresh =~ /^\w+:/;
2002       print STDERR "Heading to $url to setcookie\n" if $debug;
2003       $url .= "/cgi-bin/user.pl?setcookie=".$req->session->{_session_id};
2004       $url .= "&r=".CGI::escape($refresh);
2005       return BSE::Template->get_refresh($url, $cfg);
2006     }
2007   }
2008
2009   return BSE::Template->get_refresh($refresh, $cfg);
2010 }
2011
2012 sub _same_options {
2013   my ($left, $right) = @_;
2014
2015   for my $index (0 .. $#$left) {
2016     my $left_value = $left->[$index];
2017     my $right_value = $right->[$index];
2018     defined $right_value
2019       or return;
2020     $left_value eq $right_value
2021       or return;
2022   }
2023
2024   return 1;
2025 }
2026
2027 sub _paypal_order {
2028   my ($self, $req, $rmsg) = @_;
2029
2030   my $id = $req->cgi->param("order");
2031   unless ($id) {
2032     $$rmsg = $req->catmsg("msg:bse/shop/paypal/noorderid");
2033     return;
2034   }
2035   my ($order) = BSE::TB::Orders->getBy(randomId => $id);
2036   unless ($order) {
2037     $$rmsg = $req->catmsg("msg:bse/shop/paypal/unknownorderid");
2038     return;
2039   }
2040
2041   return $order;
2042 }
2043
2044 =item paypalret
2045
2046 Handles PayPal returning control.
2047
2048 Expects:
2049
2050 =over
2051
2052 =item *
2053
2054 order - the randomId of the order
2055
2056 =item *
2057
2058 token - paypal token we originally supplied to paypal.  Supplied by
2059 PayPal.
2060
2061 =item *
2062
2063 PayerID - the paypal user who paid the order.  Supplied by PayPal.
2064
2065 =back
2066
2067 =cut
2068
2069 sub req_paypalret {
2070   my ($self, $req) = @_;
2071
2072   require BSE::PayPal;
2073   BSE::PayPal->configured
2074       or return $self->req_cart($req, { _ => "msg:bse/shop/paypal/unconfigured" });
2075
2076   my $msg;
2077   my $order = $self->_paypal_order($req, \$msg)
2078     or return $self->req_show_payment($req, { _ => $msg });
2079
2080   $order->complete
2081     and return $self->req_cart($req, { _ => "msg:bse/shop/paypal/alreadypaid" });
2082
2083   unless (BSE::PayPal->pay_order(req => $req,
2084                                  order => $order,
2085                                  msg => \$msg)) {
2086     return $self->req_show_payment($req, { _ => $msg });
2087   }
2088
2089   $self->_finish_order($req, $order);
2090
2091   return $req->get_refresh($req->user_url(shop => "orderdone"));
2092 }
2093
2094 sub req_paypalcan {
2095   my ($self, $req) = @_;
2096
2097   require BSE::PayPal;
2098   BSE::PayPal->configured
2099       or return $self->req_cart($req, { _ => "msg:bse/shop/paypal/unconfigured" });
2100
2101   my $msg;
2102   my $order = $self->_paypal_order($req, \$msg)
2103     or return $self->req_show_payment($req, { _ => $msg });
2104
2105   $req->flash("msg:bse/shop/paypal/cancelled");
2106
2107   my $url = $req->user_url(shop => "show_payment");
2108   return $req->get_refresh($url);
2109 }
2110
2111 1;