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

   1 package BSE::UI::AdminShop;
   2 use strict;
   3 use base 'BSE::UI::AdminDispatch';
   4 use Products;
   5 use Product;
   6 use BSE::TB::Orders;
   7 use BSE::TB::OrderItems;
   8 use BSE::Template;
   9 #use Squirrel::ImageEditor;
  10 use Constants qw(:shop $SHOPID $PRODUCTPARENT
  11                  $SHOP_URI $CGI_URI $IMAGES_URI $AUTO_GENERATE);
  12 use BSE::TB::Images;
  13 use Articles;
  14 use BSE::Sort;
  15 use BSE::Util::Tags qw(tag_hash tag_error_img tag_object_plain tag_object);
  16 use BSE::Util::Iterate;
  17 use BSE::WebUtil 'refresh_to_admin';
  18 use BSE::Util::HTML qw(:default popup_menu);
  19 use BSE::Arrows;
  20 use BSE::Shop::Util qw(:payment order_item_opts nice_options);
  21
  22 our $VERSION = "1.008";
  23
  24 my %actions =
  25   (
  26    order_list => 'shop_order_list',
  27    order_list_filled => 'shop_order_list',
  28    order_list_unfilled => 'shop_order_list',
  29    order_list_unpaid => 'shop_order_list',
  30    order_list_incomplete => 'shop_order_list',
  31    order_detail => 'shop_order_detail',
  32    order_filled => 'shop_order_filled',
  33    order_paid => 'shop_order_paid',
  34    order_unpaid => 'shop_order_unpaid',
  35    order_save => 'shop_order_save',
  36    product_detail => '',
  37    product_list => '',
  38    paypal_refund => 'bse_shop_order_refund_paypal',
  39   );
  40
  41 sub actions {
  42   \%actions;
  43 }
  44
  45 sub rights {
  46   \%actions;
  47 }
  48
  49 sub default_action {
  50   'product_list'
  51 }
  52
  53 sub action_prefix {
  54   ''
  55 }
  56
  57 #####################
  58 # product management
  59
  60 sub embedded_catalog {
  61   my ($req, $catalog, $template) = @_;
  62
  63   my $session = $req->session;
  64   use POSIX 'strftime';
  65   my $products = Products->new;
  66   my @list;
  67   if ($session->{showstepkids}) {
  68     my @allkids = $catalog->allkids;
  69     my %allgen = map { $_->{generator} => 1 } @allkids;
  70     for my $gen (keys %allgen) {
  71       (my $file = $gen . ".pm") =~ s!::!/!g;
  72       require $file;
  73     }
  74     @list = grep UNIVERSAL::isa($_->{generator}, 'Generate::Product'), $catalog->allkids;
  75     @list = map { $products->getByPkey($_->{id}) } @list;
  76   }
  77   else {
  78     @list = sort { $b->{displayOrder} <=> $a->{displayOrder} }
  79       $products->getBy(parentid=>$catalog->{id});
  80   }
  81   my $list_index = -1;
  82   my $subcat_index = -1;
  83   my @subcats = sort { $b->{displayOrder} <=> $a->{displayOrder} }
  84     grep $_->{generator} eq 'Generate::Catalog',
  85     Articles->children($catalog->{id});
  86
  87   my $blank = qq!<img src="$IMAGES_URI/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
  88
  89   my %acts;
  90   %acts =
  91     (
  92      $req->admin_tags,
  93      catalog => [ \&tag_hash, $catalog ],
  94      date => sub { display_date($list[$list_index]{$_[0]}) },
  95      money => sub { sprintf("%.2f", $list[$list_index]{$_[0]}/100.0) },
  96      iterate_products_reset => sub { $list_index = -1; },
  97      iterate_products =>
  98      sub {
  99        return ++$list_index < @list;
 100      },
 101      product =>
 102      sub {
 103        $list_index >= 0 && $list_index < @list
 104          or return '** outside products iterator **';
 105        my $value = $list[$list_index]{$_[0]};
 106        defined $value or return '';
 107        return escape_html($value)
 108      },
 109      ifProducts => sub { @list },
 110      iterate_subcats_reset =>
 111      sub {
 112        $subcat_index = -1;
 113      },
 114      iterate_subcats => sub { ++$subcat_index < @subcats },
 115      subcat => sub { escape_html($subcats[$subcat_index]{$_[0]}) },
 116      ifSubcats => sub { @subcats },
 117      hiddenNote =>
 118      sub { $list[$list_index]{listed} == 0 ? "Hidden" : "&nbsp;" },
 119      move =>
 120      sub {
 121        my ($arg, $acts, $funcname, $templater) = @_;
 122
 123        $req->user_can(edit_reorder_children => $catalog)
 124          or return '';
 125        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 126        defined $img_prefix or $img_prefix = '';
 127        defined $urladd or $urladd = '';
 128        @list > 1 or return '';
 129        # links to move products up/down
 130        my $refreshto = $ENV{SCRIPT_NAME}."$urladd#cat".$catalog->{id};
 131        my $down_url = '';
 132        if ($list_index < $#list) {
 133          if ($session->{showstepkids}) {
 134            $down_url = "$CGI_URI/admin/move.pl?stepparent=$catalog->{id}&d=swap&id=$list[$list_index]{id}&other=$list[$list_index+1]{id}";
 135          }
 136          else {
 137            $down_url = "$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=swap&other=$list[$list_index+1]{id}";
 138          }
 139        }
 140        my $up_url = '';
 141        if ($list_index > 0) {
 142          if ($session->{showstepkids}) {
 143            $up_url = "$CGI_URI/admin/move.pl?stepparent=$catalog->{id}&d=swap&id=$list[$list_index]{id}&other=$list[$list_index-1]{id}";
 144          }
 145          else {
 146            $up_url = "$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=swap&other=$list[$list_index-1]{id}";
 147          }
 148        }
 149        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 150      },
 151      script=>sub { $ENV{SCRIPT_NAME} },
 152      embed =>
 153      sub {
 154        my ($which, $template) = split ' ', $_[0];
 155        $which eq 'subcat' or return "Unknown object $which embedded";
 156        return embedded_catalog($req, $subcats[$subcat_index], $template);
 157      },
 158      movecat =>
 159      sub {
 160        my ($arg, $acts, $funcname, $templater) = @_;
 161
 162        $req->user_can(edit_reorder_children => $catalog)
 163          or return '';
 164        @subcats > 1 or return '';
 165        # links to move catalogs up/down
 166        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 167        defined $img_prefix or $img_prefix = '';
 168        defined $urladd or $urladd = '';
 169        my $refreshto = $ENV{SCRIPT_NAME}.$urladd;
 170        my $down_url = "";
 171        if ($subcat_index < $#subcats) {
 172          $down_url = "$CGI_URI/admin/move.pl?id=$subcats[$subcat_index]{id}&d=swap&other=$subcats[$subcat_index+1]{id}&all=1";
 173        }
 174        my $up_url = "";
 175        if ($subcat_index > 0) {
 176          $up_url = "$CGI_URI/admin/move.pl?id=$subcats[$subcat_index]{id}&d=swap&other=$subcats[$subcat_index-1]{id}&all=1";
 177        }
 178        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 179      },
 180     );
 181
 182   return BSE::Template->get_page('admin/'.$template, $req->cfg, \%acts);
 183 }
 184
 185 sub req_product_list {
 186   my ($class, $req, $message) = @_;
 187
 188   my $cgi = $req->cgi;
 189   my $session = $req->session;
 190   my $shopid = $req->cfg->entryErr('articles', 'shop');
 191   my $shop = Articles->getByPkey($shopid);
 192   my @catalogs = sort { $b->{displayOrder} <=> $a->{displayOrder} }
 193     grep $_->{generator} eq 'Generate::Catalog', Articles->children($shopid);
 194   my $catalog_index = -1;
 195   $message ||= $cgi->param('m') || $cgi->param('message') || '';
 196   if (defined $cgi->param('showstepkids')) {
 197     $session->{showstepkids} = $cgi->param('showstepkids');
 198   }
 199   exists $session->{showstepkids} or $session->{showstepkids} = 1;
 200   my $products = Products->new;
 201   my @products = sort { $b->{displayOrder} <=> $a->{displayOrder} }
 202     $products->getBy(parentid => $shopid);
 203   my $product_index;
 204
 205   my $blank = qq!<img src="$IMAGES_URI/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
 206
 207   my $it = BSE::Util::Iterate->new;
 208
 209   my %acts;
 210   %acts =
 211     (
 212      $req->admin_tags,
 213      catalog=> sub { escape_html($catalogs[$catalog_index]{$_[0]}) },
 214      iterate_catalogs => sub { ++$catalog_index < @catalogs  },
 215      shopid=>sub { $shopid },
 216      shop => [ \&tag_hash, $shop ],
 217      script=>sub { $ENV{SCRIPT_NAME} },
 218      message => sub { $message },
 219      embed =>
 220      sub {
 221        my ($which, $template) = split ' ', $_[0];
 222        $which eq 'catalog' or return "Unknown object $which embedded";
 223        return embedded_catalog($req, $catalogs[$catalog_index], $template);
 224      },
 225      movecat =>
 226      sub {
 227        my ($arg, $acts, $funcname, $templater) = @_;
 228
 229        $req->user_can(edit_reorder_children => $shopid)
 230          or return '';
 231        @catalogs > 1 or return '';
 232        # links to move catalogs up/down
 233        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 234        defined $img_prefix or $img_prefix = '';
 235        defined $urladd or $urladd = '';
 236        my $refreshto = $ENV{SCRIPT_NAME} . $urladd;
 237        my $down_url = '';
 238        if ($catalog_index < $#catalogs) {
 239          $down_url = "$CGI_URI/admin/move.pl?id=$catalogs[$catalog_index]{id}&d=swap&other=$catalogs[$catalog_index+1]{id}";
 240        }
 241        my $up_url = '';
 242        if ($catalog_index > 0) {
 243          $up_url = "$CGI_URI/admin/move.pl?id=$catalogs[$catalog_index]{id}&d=swap&other=$catalogs[$catalog_index-1]{id}";
 244        }
 245        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 246      },
 247      ifShowStepKids => sub { $session->{showstepkids} },
 248      $it->make_iterator(undef, 'product', 'products', \@products, \$product_index),
 249      move =>
 250      sub {
 251        my ($arg, $acts, $funcname, $templater) = @_;
 252
 253        $req->user_can(edit_reorder_children => $shop)
 254          or return '';
 255        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 256        defined $img_prefix or $img_prefix = '';
 257        defined $urladd or $urladd = '';
 258        @products > 1 or return '';
 259        # links to move products up/down
 260        my $refreshto = $ENV{SCRIPT_NAME}."$urladd#cat".$shop->{id};
 261        my $down_url = '';
 262        if ($product_index < $#products) {
 263          if ($session->{showstepkids}) {
 264            $down_url = "$CGI_URI/admin/move.pl?stepparent=$shop->{id}&d=swap&id=$products[$product_index]{id}&other=$products[$product_index+1]{id}";
 265          }
 266          else {
 267            $down_url = "$CGI_URI/admin/move.pl?id=$products[$product_index]{id}&d=swap&other=$products[$product_index+1]{id}";
 268          }
 269        }
 270        my $up_url = '';
 271        if ($product_index > 0) {
 272          if ($session->{showstepkids}) {
 273            $up_url = "$CGI_URI/admin/move.pl?stepparent=$shop->{id}&d=swap&id=$products[$product_index]{id}&other=$products[$product_index-1]{id}";
 274          }
 275          else {
 276            $up_url = "$CGI_URI/admin/move.pl?id=$products[$product_index]{id}&d=swap&other=$products[$product_index-1]{id}";
 277          }
 278        }
 279        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 280      },
 281     );
 282
 283   return $req->dyn_response('admin/product_list', \%acts);
 284 }
 285
 286 sub req_product_detail {
 287   my ($class, $req) = @_;
 288
 289   my $cgi = $req->cgi;
 290   my $id = $cgi->param('id');
 291   if ($id and
 292       my $product = Products->getByPkey($id)) {
 293     return product_form($req, $product, '', '', 'admin/product_detail');
 294   }
 295   else {
 296     return $class->req_product_list($req);
 297   }
 298 }
 299
 300 sub product_form {
 301   my ($req, $product, $action, $message, $template) = @_;
 302
 303   my $cgi = $req->cgi;
 304   $message ||= $cgi->param('m') || $cgi->param('message') || '';
 305   $template ||= 'admin/product_detail';
 306   my @catalogs;
 307   my $shopid = $req->cfg->entryErr('articles', 'shop');
 308   my @work = [ $shopid, '' ];
 309   while (@work) {
 310     my ($parent, $title) = @{shift @work};
 311
 312     push(@catalogs, { id=>$parent, display=>$title }) if $title;
 313     my @kids = sort { $b->{displayOrder} <=> $a->{displayOrder} }
 314       grep $_->{generator} eq 'Generate::Catalog',
 315       Articles->children($parent);
 316     $title .= ' / ' if $title;
 317     unshift(@work, map [ $_->{id}, $title.$_->{title} ], @kids);
 318   }
 319   my @files;
 320   if ($product->{id}) {
 321     require BSE::TB::ArticleFiles;
 322     @files = BSE::TB::ArticleFiles->getBy(articleId=>$product->{id});
 323   }
 324   my $file_index;
 325
 326   my @templates;
 327   push(@templates, "shopitem.tmpl")
 328     if grep -e "$_/shopitem.tmpl", BSE::Template->template_dirs($req->cfg);
 329   for my $dir (BSE::Template->template_dirs($req->cfg)) {
 330     if (opendir PROD_TEMPL, "$dir/products") {
 331       push @templates, map "products/$_",
 332         grep -f "$dir/products/$_" && /\.tmpl$/i, readdir PROD_TEMPL;
 333       closedir PROD_TEMPL;
 334     }
 335   }
 336   my %seen_templates;
 337   @templates = sort { lc($a) cmp lc($b) }
 338     grep !$seen_templates{$_}++, @templates;
 339
 340   my $stepcat_index;
 341   use OtherParents;
 342   # ugh
 343   my $realproduct;
 344   $realproduct = UNIVERSAL::isa($product, 'Product') ? $product : Products->getByPkey($product->{id});
 345   my @stepcats;
 346   @stepcats = OtherParents->getBy(childId=>$product->{id})
 347     if $product->{id};
 348   my @stepcat_targets = $realproduct->step_parents if $realproduct;
 349   my %stepcat_targets = map { $_->{id}, $_ } @stepcat_targets;
 350   my @stepcat_possibles = grep !$stepcat_targets{$_->{id}}, @catalogs;
 351   my @images;
 352   @images = $product->images
 353     if $product->{id};
 354 #    @images = $imageEditor->images()
 355 #      if $product->{id};
 356   my $image_index;
 357
 358   my $blank = qq!<img src="$IMAGES_URI/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
 359
 360   my %acts;
 361   %acts =
 362     (
 363      BSE::Util::Tags->basic(\%acts, $cgi, $req->cfg),
 364      BSE::Util::Tags->admin(\%acts, $req->cfg),
 365      BSE::Util::Tags->secure($req),
 366      catalogs =>
 367      sub {
 368        return popup_menu(-name=>'parentid',
 369                          -values=>[ map $_->{id}, @catalogs ],
 370                          -labels=>{ map { @$_{qw/id display/} } @catalogs },
 371                          -default=>($product->{parentid} || $PRODUCTPARENT));
 372      },
 373      product => [ \&tag_hash, $product ],
 374      action => sub { $action },
 375      message => sub { $message },
 376      script=>sub { $ENV{SCRIPT_NAME} },
 377      ifImage => sub { $product->{imageName} },
 378      hiddenNote => sub { $product->{listed} ? "&nbsp;" : "Hidden" },
 379      templates =>
 380      sub {
 381        return popup_menu(-name=>'template', -values=>\@templates,
 382                          -default=>$product->{id} ? $product->{template} :
 383                          $templates[0]);
 384      },
 385      ifStepcats => sub { @stepcats },
 386      iterate_stepcats_reset => sub { $stepcat_index = -1; },
 387      iterate_stepcats => sub { ++$stepcat_index < @stepcats },
 388      stepcat => sub { escape_html($stepcats[$stepcat_index]{$_[0]}) },
 389      stepcat_targ =>
 390      sub {
 391        escape_html($stepcat_targets[$stepcat_index]{$_[0]});
 392      },
 393      movestepcat =>
 394      sub {
 395        my ($arg, $acts, $funcname, $templater) = @_;
 396        return ''
 397          unless $req->user_can(edit_reorder_stepparents => $product),
 398        @stepcats > 1 or return '';
 399        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 400        $img_prefix = '' unless defined $img_prefix;
 401        $urladd = '' unless defined $urladd;
 402        my $refreshto = escape_uri($ENV{SCRIPT_NAME}
 403                                    ."?id=$product->{id}&$template=1$urladd#step");
 404        my $down_url = "";
 405        if ($stepcat_index < $#stepcats) {
 406          $down_url = "$CGI_URI/admin/move.pl?stepchild=$product->{id}&id=$stepcats[$stepcat_index]{parentId}&d=swap&other=$stepcats[$stepcat_index+1]{parentId}&all=1";
 407        }
 408        my $up_url = "";
 409        if ($stepcat_index > 0) {
 410          $up_url = "$CGI_URI/admin/move.pl?stepchild=$product->{id}&id=$stepcats[$stepcat_index]{parentId}&d=swap&other=$stepcats[$stepcat_index-1]{parentId}&all=1";
 411        }
 412        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 413      },
 414      ifStepcatPossibles => sub { @stepcat_possibles },
 415      stepcat_possibles => sub {
 416        popup_menu(-name=>'stepcat',
 417                   -values=>[ map $_->{id}, @stepcat_possibles ],
 418                   -labels=>{ map { $_->{id}, $_->{display}} @catalogs });
 419      },
 420      BSE::Util::Tags->
 421      make_iterator(\@files, 'file', 'files', \$file_index),
 422      BSE::Util::Tags->
 423      make_iterator(\@images, 'image', 'images', \$image_index),
 424     );
 425
 426   return $req->dyn_response($template, \%acts);
 427 }
 428
 429 =item tag all_order_count
 430 X<tags, shop admin, all_order_count>C<all_order_count>
 431
 432 Returns a count of orders matching a set of conditions.
 433
 434 =cut
 435
 436 sub tag_all_order_count {
 437   my ($args, $acts, $funcname, $templater) = @_;
 438
 439   my $query;
 440   if ($args =~ /\S/) {
 441     if (eval "\$query = [ $args ]; 1 ") {
 442       return BSE::TB::Orders->getCount($query);
 443     }
 444     else {
 445       return "<!-- error handling args: $@ -->";
 446     }
 447   }
 448   else {
 449     return BSE::TB::Orders->getCount();
 450   }
 451 }
 452
 453 #####################
 454 # order management
 455
 456 sub order_list_low {
 457   my ($req, $template, $title, $conds, $options) = @_;
 458
 459   my $cgi = $req->cgi;
 460
 461   $options ||= {};
 462   my $order = delete $options->{order};
 463   defined $order or $order = 'id desc';
 464   my $datelimit = delete $options->{datelimit};
 465   defined $datelimit or $datelimit = 1;
 466
 467   my $from = $cgi->param('from');
 468   my $to = $cgi->param('to');
 469   use BSE::Util::SQL qw/now_sqldate sql_to_date date_to_sql sql_date/;
 470   use BSE::Util::Valid qw/valid_date/;
 471   my $today = now_sqldate();
 472   for my $what ($from, $to) {
 473     if (defined $what) {
 474       if ($what eq 'today') {
 475         $what = $today;
 476       }
 477       elsif (valid_date($what)) {
 478         $what = date_to_sql($what);
 479       }
 480       else {
 481         undef $what;
 482       }
 483     }
 484   }
 485   if ($datelimit) {
 486     $from ||= sql_date(time() - 30 * 86_400);
 487   }
 488   if (defined $from || defined $to) {
 489     $from ||= '1900-01-01';
 490     $to ||= '2999-12-31';
 491     $cgi->param('from', sql_to_date($from));
 492     $cgi->param('to', sql_to_date($to));
 493     push @$conds,
 494       [ between => 'orderDate', $from, $to." 23:59:59" ];
 495   }
 496   my @ids = BSE::TB::Orders->getColumnBy
 497     (
 498      "id",
 499      $conds,
 500      { order => $order }
 501     );
 502
 503   my $search_param;
 504   {
 505     my @param;
 506     for my $key (qw(from to)) {
 507       my $value = $cgi->param($key);
 508       if (defined $value) {
 509         push @param, "$key=" . escape_uri($value);
 510       }
 511     }
 512     $search_param = join('&amp;', map escape_html($_), @param);
 513   }
 514
 515   my $message = $cgi->param('m');
 516   defined $message or $message = '';
 517   $message = escape_html($message);
 518
 519   my $it = BSE::Util::Iterate::Objects->new;
 520   my %acts;
 521   %acts =
 522     (
 523      $req->admin_tags,
 524      $it->make_paged
 525      (
 526       data => \@ids,
 527       fetch => [ getByPkey => 'BSE::TB::Orders' ],
 528       cgi => $req->cgi,
 529       single => "order",
 530       plural => "orders",
 531       session => $req->session,
 532       name => "orderlist",
 533       perpage_parm => "pp=50",
 534      ),
 535      title => sub { $title },
 536      ifHaveParam => sub { defined $cgi->param($_[0]) },
 537      ifParam => sub { $cgi->param($_[0]) },
 538      message => $message,
 539      ifError => 0,
 540      all_order_count => \&tag_all_order_count,
 541      search_param => $search_param,
 542     );
 543   $req->dyn_response("admin/$template", \%acts);
 544 }
 545
 546 sub iter_orders {
 547   my ($orders, $args) = @_;
 548
 549   return bse_sort({ id => 'n', total => 'n', filled=>'n' }, $args, @$orders);
 550 }
 551
 552 =item target order_list
 553 X<shopadmin targets, order_list>X<order_list target>
 554
 555 List all completed orders.
 556
 557 By default limits to the last 30 days.
 558
 559 =cut
 560
 561 sub req_order_list {
 562   my ($class, $req) = @_;
 563
 564   my $template = $req->cgi->param('template');
 565   unless (defined $template && $template =~ /^\w+$/) {
 566     $template = 'order_list';
 567   }
 568
 569   my @conds =
 570     (
 571      [ '<>', complete => 0 ],
 572     );
 573
 574   return order_list_low($req, $template, 'Order list', \@conds);
 575 }
 576
 577 =item target order_list_filled
 578 X<shopadmin targets, order_list_filled>X<order_list_filled target>
 579
 580 List all filled orders.
 581
 582 By default limits to the last 30 days.
 583
 584 =cut
 585
 586 sub req_order_list_filled {
 587   my ($class, $req) = @_;
 588
 589   my @conds =
 590     (
 591      [ '<>', complete => 0 ],
 592      [ '<>', filled => 0 ],
 593      #[ '<>', paidFor => 0 ],
 594     );
 595
 596   return order_list_low($req, 'order_list_filled', 'Order list - Filled orders',
 597                        \@conds);
 598 }
 599
 600 =item target order_list_unfilled
 601 X<shopadmin targets, order_list_unfilled>X<order_list_unfilled target>
 602
 603 List completed but unfilled orders.
 604
 605 Unlike the other order lists, this lists oldest order first, and does
 606 not limit to the last 30 days.
 607
 608 =cut
 609
 610 sub req_order_list_unfilled {
 611   my ($class, $req) = @_;
 612
 613   my @conds =
 614     (
 615      [ '<>', complete => 0 ],
 616      [ filled => 0 ],
 617     );
 618
 619   return order_list_low($req, 'order_list_unfilled',
 620                         'Order list - Unfilled orders',
 621                         \@conds, { order => 'id asc', datelimit => 0 });
 622 }
 623
 624 sub req_order_list_unpaid {
 625   my ($class, $req) = @_;
 626
 627   my @conds =
 628     (
 629      [ '<>', complete => 0 ],
 630      [ paidFor => 0 ],
 631     );
 632
 633   return order_list_low($req, 'order_list_unpaid',
 634                         'Order list - Unpaid orders', \@conds);
 635 }
 636
 637 =item target order_list_incomplete
 638 X<shopadmin targets, order_list_incomplete>X<order_list_incomplete>
 639
 640 List incomplete orders, ie. orders that the user abandoned before the
 641 payment step was complete.
 642
 643 By default limits to the last 30 days.
 644
 645 =cut
 646
 647 sub req_order_list_incomplete {
 648   my ($class, $req) = @_;
 649
 650   my @conds =
 651     (
 652      [ complete => 0 ]
 653     );
 654
 655   return order_list_low($req, 'order_list_incomplete',
 656                         'Order list - Incomplete orders', \@conds);
 657 }
 658
 659 sub tag_siteuser {
 660   my ($order, $rsiteuser, $arg) = @_;
 661
 662   unless ($$rsiteuser) {
 663     $$rsiteuser = $order->siteuser || {};
 664   }
 665
 666   my $siteuser = $$rsiteuser;
 667   return '' unless $siteuser->{id};
 668
 669   my $value = $siteuser->{$arg};
 670   defined $value or $value = '';
 671
 672   return escape_html($value);
 673 }
 674
 675 sub tag_shipping_method_select {
 676   my ($self, $order) = @_;
 677
 678   my @methods = BSE::TB::Orders->dummy_shipping_methods;
 679
 680   return popup_menu
 681     (
 682      -name => "shipping_name",
 683      -values => [ map $_->{id}, @methods ],
 684      -labels => { map { $_->{id} => $_->{name} } @methods },
 685      -id => "shipping_name",
 686      -default => $order->shipping_name,
 687     );
 688 }
 689
 690 sub tag_stage_select {
 691   my ($self, $req, $order) = @_;
 692
 693   my @stages = BSE::TB::Orders->settable_stages;
 694
 695   my %stage_labels = BSE::TB::Orders->stage_labels;
 696   return popup_menu
 697     (
 698      -name => "stage",
 699      -values => \@stages,
 700      -default => $order->stage,
 701      -labels => \%stage_labels,
 702     );
 703 }
 704
 705 sub req_order_detail {
 706   my ($class, $req, $errors) = @_;
 707
 708   my $cgi = $req->cgi;
 709   my $id = $cgi->param('id');
 710   if ($id and
 711       my $order = BSE::TB::Orders->getByPkey($id)) {
 712     my $message = $req->message($errors);
 713     my @lines = $order->items;
 714     my @products = map { Products->getByPkey($_->{productId}) } @lines;
 715     my $line_index = -1;
 716     my $product;
 717     my @options;
 718     my $option_index = -1;
 719     my $siteuser;
 720     my $it = BSE::Util::Iterate->new;
 721
 722     my %acts;
 723     %acts =
 724       (
 725        $req->admin_tags,
 726        item => sub { escape_html($lines[$line_index]{$_[0]}) },
 727        iterate_items_reset => sub { $line_index = -1 },
 728        iterate_items =>
 729        sub {
 730          if (++$line_index < @lines ) {
 731            $option_index = -1;
 732            @options = order_item_opts($req,
 733                                       $lines[$line_index],
 734                                       $products[$line_index]);
 735            return 1;
 736          }
 737          return 0;
 738        },
 739        order => [ \&tag_object, $order ],
 740        extension =>
 741        sub {
 742          sprintf("%.2f", $lines[$line_index]{units} * $lines[$line_index]{$_[0]}/100.0)
 743        },
 744        product => sub { escape_html($products[$line_index]{$_[0]}) },
 745        script => sub { $ENV{SCRIPT_NAME} },
 746        iterate_options_reset => sub { $option_index = -1 },
 747        iterate_options => sub { ++$option_index < @options },
 748        option => sub { escape_html($options[$option_index]{$_[0]}) },
 749        ifOptions => sub { @options },
 750        options => sub { nice_options(@options) },
 751        message => $message,
 752        error_img => [ \&tag_error_img, $errors ],
 753        siteuser => [ \&tag_siteuser, $order, \$siteuser, ],
 754        $it->make
 755        (
 756         single => "shipping_method",
 757         plural => "shipping_methods",
 758         code => [ dummy_shipping_methods => "BSE::TB::Orders" ],
 759        ),
 760        shipping_method_select =>
 761        [ tag_shipping_method_select => $class, $order ],
 762        stage_select =>
 763        [ tag_stage_select => $class, $req, $order ],
 764        stage_description => escape_html($order->stage_description($req->language)),
 765       );
 766
 767     return $req->dyn_response('admin/order_detail', \%acts);
 768   }
 769   else {
 770     return $class->req_order_list($req);
 771   }
 772 }
 773
 774 sub req_order_filled {
 775   my ($class, $req) = @_;
 776
 777   my $id = $req->cgi->param('id');
 778   if ($id and
 779       my $order = BSE::TB::Orders->getByPkey($id)) {
 780     my $filled = $req->cgi->param('filled');
 781     $order->{filled} = $filled;
 782     if ($order->{filled}) {
 783       $order->{whenFilled} = epoch_to_sql_datetime(time);
 784       my $user = $req->user;
 785       if ($user) {
 786         $order->{whoFilled} = $user->{logon};
 787       }
 788       else {
 789         $order->{whoFilled} = defined($ENV{REMOTE_USER})
 790           ? $ENV{REMOTE_USER} : "-unknown-";
 791       }
 792     }
 793     $order->save();
 794     if ($req->cgi->param('detail')) {
 795       return $class->req_order_detail($req);
 796     }
 797     else {
 798       return $class->req_order_list($req);
 799     }
 800   }
 801   else {
 802     return $class->req_order_list($req);
 803   }
 804 }
 805
 806 sub req_order_paid {
 807   my ($class, $req) = @_;
 808
 809   return $class->_set_order_paid($req, 1);
 810 }
 811
 812 sub req_order_unpaid {
 813   my ($class, $req) = @_;
 814
 815   return $class->_set_order_paid($req, 0);
 816 }
 817
 818 sub _set_order_paid {
 819   my ($class, $req, $value) = @_;
 820
 821   my $id = $req->cgi->param('id');
 822   if ($id and
 823       my $order = BSE::TB::Orders->getByPkey($id)) {
 824     if ($order->paidFor != $value) {
 825       if ($value) {
 826         $order->set_paymentType(PAYMENT_MANUAL);
 827       }
 828       else {
 829         $order->paymentType == PAYMENT_MANUAL
 830           or return $class->req_order_detail($req, "You can only unpay manually paid orders");
 831       }
 832
 833       $order->set_paidFor($value);
 834       my $user = $req->user;
 835       my $name = $user ? $user->logon : "--unknown--";
 836       require POSIX;
 837       $order->{instructions} .= "\nMarked " . ($value ? "paid" : "unpaid" ) . " by $name " . POSIX::strftime("%H:%M %d/%m/%Y", localtime);
 838       $order->save();
 839     }
 840
 841     return $req->get_refresh
 842       ($req->url("shopadmin", { a_order_detail => 1, id => $id }));
 843   }
 844   else {
 845     return $class->req_order_list($req);
 846   }
 847 }
 848
 849 sub req_paypal_refund {
 850   my ($self, $req) = @_;
 851
 852   my $id = $req->cgi->param('id');
 853   if ($id and
 854       my $order = BSE::TB::Orders->getByPkey($id)) {
 855     require BSE::PayPal;
 856     my $msg;
 857     unless (BSE::PayPal->refund_order(order => $order,
 858                                       req => $req,
 859                                       msg => \$msg)) {
 860       return $self->req_order_detail($req, $msg);
 861     }
 862
 863     return $req->get_refresh($req->url(shopadmin => { "a_order_detail" => 1, id => $id }));
 864   }
 865   else {
 866     $req->flash_error("Missing or invalid order id");
 867     return $self->req_order_list($req);
 868   }
 869 }
 870
 871 =item order_save
 872
 873 Make changes to an order, only a limited set of fields can be changed.
 874
 875 Parameters, all optional:
 876
 877 =over
 878
 879 =item *
 880
 881 id - id of the order.  Required.
 882
 883 =item *
 884
 885 shipping_method - if automated shipping calculations are disabled, the
 886 id of the dummy shipping method to set for the order.
 887
 888 =item *
 889
 890 freight_tracking - the freight tracking code for the shipment.
 891
 892 =item *
 893
 894 stage - order stage, one of unprocessed, backorder, picked, shipped,
 895 cancelled.
 896
 897 =back
 898
 899 Requires csrfp token C<shop_order_save>.
 900
 901 =cut
 902
 903 sub req_order_save {
 904   my ($self, $req) = @_;
 905
 906   $req->check_csrf("shop_order_save")
 907     or return $self->req_product_list($req, "Bad or missing csrf token: " . $req->csrf_error);
 908
 909   my $cgi = $req->cgi;
 910   my $id = $cgi->param("id");
 911   $id && $id =~ /^[0-9]+$/
 912     or return $self->req_product_list($req, "No order id supplied");
 913
 914   my $order = BSE::TB::Orders->getByPkey($id)
 915     or return $self->req_product_list($req, "No such order id");
 916
 917   my %errors;
 918   my $save = 0;
 919
 920   my $new_freight_tracking = 0;
 921   my $code = $cgi->param("freight_tracking");
 922   if (defined $code && $code ne $order->freight_tracking) {
 923     $order->set_freight_tracking($code);
 924     ++$new_freight_tracking;
 925     ++$save;
 926   }
 927
 928   my $new_shipping_name = 0;
 929   unless ($req->cfg->entry("shop", "shipping", 0)) {
 930     my $shipping_name = $cgi->param("shipping_name");
 931     if (defined $shipping_name
 932         && $shipping_name ne $order->shipping_name) {
 933       my @ship = BSE::TB::Orders->dummy_shipping_methods();
 934       my ($entry) = grep $_->{id} eq $shipping_name, @ship;
 935       if ($entry) {
 936         $order->set_shipping_name($entry->{id});
 937         $order->set_shipping_method($entry->{name});
 938         ++$new_shipping_name;
 939         ++$save;
 940       }
 941       else {
 942         $errors{shipping_method} = "msg:bse/admin/shop/saveorder/badmethod:$shipping_name";
 943       }
 944     }
 945   }
 946
 947   my $new_stage = 0;
 948   my ($stage) = $cgi->param("stage");
 949   my ($stage_note) = $cgi->param("stage_note");
 950   if (defined $stage && $stage ne $order->stage
 951      || defined $stage_note && $stage_note =~ /\S/) {
 952     my @stages = BSE::TB::Orders->settable_stages;
 953     if (grep $_ eq $stage, @stages) {
 954       ++$new_stage;
 955       ++$save;
 956     }
 957     else {
 958       $errors{stage} = "msg:bse/admin/shop/saveorder/badstage:$stage";
 959     }
 960   }
 961
 962   keys %errors
 963     and return $self->req_order_detail($req, \%errors);
 964
 965   if ($save) {
 966     if ($new_freight_tracking) {
 967       $req->audit
 968         (
 969          component => "shopadmin:orders:saveorder",
 970          object => $order,
 971          msg => "New freight tracking code set: '" . $order->freight_tracking . "'",
 972          level => "info",
 973         );
 974     }
 975     if ($new_shipping_name) {
 976       $req->audit
 977         (
 978          component => "shopadmin:orders:saveorder",
 979          object => $order,
 980          msg => "New shippping method set: '" . $order->shipping_name . "/" . $order->shipping_method . "'",
 981          level => "info",
 982         );
 983     }
 984     if ($new_stage) {
 985       $order->new_stage(scalar $req->user, $stage, $stage_note);
 986     }
 987
 988     $order->save;
 989     $req->flash("msg:bse/admin/shop/saveorder/saved");
 990   }
 991   else {
 992     $req->flash("msg:bse/admin/shop/saveorder/nochanges");
 993   }
 994
 995   my $url = $cgi->param("r") || $req->url("shopadmin", { a_order_detail => 1, id => $order->id });
 996
 997   return $req->get_refresh($url);
 998 }
 999
1000 #####################
1001 # utilities
1002 # perhaps some of these belong in a class...
1003
1004 # format an ANSI SQL date for display
1005 sub display_date {
1006   my ($date) = @_;
1007
1008   if ( my ($year, $month, $day) =
1009        ($date =~ /^(\d+)-(\d+)-(\d+)/)) {
1010     return sprintf("%02d/%02d/%04d", $day, $month, $year);
1011   }
1012   return $date;
1013 }
1014
1015 sub money_to_cents {
1016   my $money = shift;
1017
1018   $$money =~ /^\s*(\d+(\.\d*)|\.\d+)/
1019     or return undef;
1020   return $$money = sprintf("%.0f ", $$money * 100);
1021 }
1022
1023 # convert an epoch time to sql format
1024 sub epoch_to_sql {
1025   use POSIX 'strftime';
1026   my ($time) = @_;
1027
1028   return strftime('%Y-%m-%d', localtime $time);
1029 }
1030
1031 # convert an epoch time to sql format
1032 sub epoch_to_sql_datetime {
1033   use POSIX 'strftime';
1034   my ($time) = @_;
1035
1036   return strftime('%Y-%m-%d %H:%M', localtime $time);
1037 }
1038
1039 1;
1040
1041 __END__
1042
1043 =head1 NAME
1044
1045 shopadmin.pl - administration for the online-store tables
1046
1047 =head1 SYNOPSYS
1048
1049 (This is a CGI script.)
1050
1051 =head1 DESCRIPTION
1052
1053 shopadmin.pl gives a UI to edit the product table, and view the orders and
1054 order_item tables.
1055
1056 =head1 TEMPLATES
1057
1058 shopadmin.pl uses a few templates from the templates/admin directory.
1059
1060 =head2 product_list.tmpl
1061
1062 =over 4
1063
1064 =item product I<name>
1065
1066 Access to product fields.
1067
1068 =item date I<name>
1069
1070 Formats the I<name> field of the product as a date.
1071
1072 =item money I<name>
1073
1074 Formats the I<name> integer field as a 2 decimal place money value.
1075
1076 =item iterator ... products
1077
1078 Iterates over the products database in reverse expire order.
1079
1080 =item script
1081
1082 The name of the current script for use in URLs.
1083
1084 =item message
1085
1086 An error message that may have been passed in the 'message' parameter.
1087
1088 =item hiddenNote
1089
1090 'Deleted' if the expire date of the current product has passed.
1091
1092 =back
1093
1094 =head2 add_product.tmpl
1095 =head2 edit_product.tmpl
1096 =head2 product_detail.tmpl
1097
1098 These use the same tags.
1099
1100 =over 4
1101
1102 =item product I<name>
1103
1104 The specified field of the product.
1105
1106 =item date I<name>
1107
1108 Formats the given field of the product as a date.
1109
1110 =item money I<name>
1111
1112 Formats the given integer field of the product as money.
1113
1114 =item action
1115
1116 Either 'Add New' or 'Edit'.
1117
1118 =item message
1119
1120 The message parameter passed into the script.
1121
1122 =item script
1123
1124 The name of the script, for use in urls.
1125
1126 =item ifImage
1127
1128 Conditional, true if the product has an image.
1129
1130 =item hiddenNote
1131
1132 "Hidden" if the product is hidden.
1133
1134 =back
1135
1136 =head2 order_list.tmpl
1137
1138 Used to display the list of orders.  You can also specify a template
1139 parameter to the order_list target, and perform filtering and sorting
1140 within the template.
1141
1142 =over 4
1143
1144 =item order I<name>
1145
1146 The given field of the order.
1147
1148 =item iterator ... orders [filter-sort-spec]
1149
1150 Iterates over the orders in reverse orderDate order.
1151
1152 The [filter-sort-spec] can contain none, either or both of the following:
1153
1154 =over
1155
1156 =item filter= field op value, ...
1157
1158 filter the data by checking the given expression.
1159
1160 eg. filter= filled == 0
1161
1162 =item sort= [+|-] keyword, ...
1163
1164 Sorts the result by the specified fields, in reverse if preceded by '-'.
1165
1166 =back
1167
1168 =item money I<name>
1169
1170 The given field of the current order formatted as money.
1171
1172 =item date I<name>
1173
1174 The given field of the current order formatted as a date.
1175
1176 =item script
1177
1178 The name of the script, for use in urls.
1179
1180 =back
1181
1182 =head2 order_detail.tmpl
1183
1184 Used to display the details for an order.
1185
1186 =over 4
1187
1188 =item item I<name>
1189
1190 Displays the given field of a line item
1191
1192 =item iterator ... items
1193
1194 Iterates over the line items in the order.
1195
1196 =item order I<name>
1197
1198 The given field of the order.
1199
1200 =item money I<func> I<args>
1201
1202 Formats the given functions return value as money.
1203
1204 =item date I<func> I<args>
1205
1206 Formats the  given function return value as a date.
1207
1208 =item extension I<name>
1209
1210 Takes the given field for the current item multiplied by the units column.
1211
1212 =item product I<name>
1213
1214 The given product field of the product for the current item.
1215
1216 =item script
1217
1218 The name of the current script (for use in urls).
1219
1220 =item iterator ... options
1221
1222 Iterates over the options set for the current order item.
1223
1224 =item option I<field>
1225
1226 Access to a field of the option, any of id, value, desc or label.
1227
1228 =item ifOptions
1229
1230 Conditional tag, true if the current product has any options.
1231
1232 =item options
1233
1234 A laid-out list of the options set for the current order item.
1235
1236 =back
1237
1238 =cut
1239