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);
  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.001";
  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    product_detail => '',
  36    product_list => '',
  37    paypal_refund => 'bse_shop_order_refund_paypal',
  38   );
  39
  40 sub actions {
  41   \%actions;
  42 }
  43
  44 sub rights {
  45   \%actions;
  46 }
  47
  48 sub default_action {
  49   'product_list'
  50 }
  51
  52 sub action_prefix {
  53   ''
  54 }
  55
  56 #####################
  57 # product management
  58
  59 sub embedded_catalog {
  60   my ($req, $catalog, $template) = @_;
  61
  62   my $session = $req->session;
  63   use POSIX 'strftime';
  64   my $products = Products->new;
  65   my @list;
  66   if ($session->{showstepkids}) {
  67     my @allkids = $catalog->allkids;
  68     my %allgen = map { $_->{generator} => 1 } @allkids;
  69     for my $gen (keys %allgen) {
  70       (my $file = $gen . ".pm") =~ s!::!/!g;
  71       require $file;
  72     }
  73     @list = grep UNIVERSAL::isa($_->{generator}, 'Generate::Product'), $catalog->allkids;
  74     @list = map { $products->getByPkey($_->{id}) } @list;
  75   }
  76   else {
  77     @list = sort { $b->{displayOrder} <=> $a->{displayOrder} }
  78       $products->getBy(parentid=>$catalog->{id});
  79   }
  80   my $list_index = -1;
  81   my $subcat_index = -1;
  82   my @subcats = sort { $b->{displayOrder} <=> $a->{displayOrder} }
  83     grep $_->{generator} eq 'Generate::Catalog',
  84     Articles->children($catalog->{id});
  85
  86   my $blank = qq!<img src="$IMAGES_URI/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
  87
  88   my %acts;
  89   %acts =
  90     (
  91      $req->admin_tags,
  92      catalog => [ \&tag_hash, $catalog ],
  93      date => sub { display_date($list[$list_index]{$_[0]}) },
  94      money => sub { sprintf("%.2f", $list[$list_index]{$_[0]}/100.0) },
  95      iterate_products_reset => sub { $list_index = -1; },
  96      iterate_products =>
  97      sub {
  98        return ++$list_index < @list;
  99      },
 100      product =>
 101      sub {
 102        $list_index >= 0 && $list_index < @list
 103          or return '** outside products iterator **';
 104        my $value = $list[$list_index]{$_[0]};
 105        defined $value or return '';
 106        return escape_html($value)
 107      },
 108      ifProducts => sub { @list },
 109      iterate_subcats_reset =>
 110      sub {
 111        $subcat_index = -1;
 112      },
 113      iterate_subcats => sub { ++$subcat_index < @subcats },
 114      subcat => sub { escape_html($subcats[$subcat_index]{$_[0]}) },
 115      ifSubcats => sub { @subcats },
 116      hiddenNote =>
 117      sub { $list[$list_index]{listed} == 0 ? "Hidden" : "&nbsp;" },
 118      move =>
 119      sub {
 120        my ($arg, $acts, $funcname, $templater) = @_;
 121
 122        $req->user_can(edit_reorder_children => $catalog)
 123          or return '';
 124        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 125        defined $img_prefix or $img_prefix = '';
 126        defined $urladd or $urladd = '';
 127        @list > 1 or return '';
 128        # links to move products up/down
 129        my $refreshto = $ENV{SCRIPT_NAME}."$urladd#cat".$catalog->{id};
 130        my $down_url = '';
 131        if ($list_index < $#list) {
 132          if ($session->{showstepkids}) {
 133            $down_url = "$CGI_URI/admin/move.pl?stepparent=$catalog->{id}&d=swap&id=$list[$list_index]{id}&other=$list[$list_index+1]{id}";
 134          }
 135          else {
 136            $down_url = "$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=swap&other=$list[$list_index+1]{id}";
 137          }
 138        }
 139        my $up_url = '';
 140        if ($list_index > 0) {
 141          if ($session->{showstepkids}) {
 142            $up_url = "$CGI_URI/admin/move.pl?stepparent=$catalog->{id}&d=swap&id=$list[$list_index]{id}&other=$list[$list_index-1]{id}";
 143          }
 144          else {
 145            $up_url = "$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=swap&other=$list[$list_index-1]{id}";
 146          }
 147        }
 148        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 149      },
 150      script=>sub { $ENV{SCRIPT_NAME} },
 151      embed =>
 152      sub {
 153        my ($which, $template) = split ' ', $_[0];
 154        $which eq 'subcat' or return "Unknown object $which embedded";
 155        return embedded_catalog($req, $subcats[$subcat_index], $template);
 156      },
 157      movecat =>
 158      sub {
 159        my ($arg, $acts, $funcname, $templater) = @_;
 160
 161        $req->user_can(edit_reorder_children => $catalog)
 162          or return '';
 163        @subcats > 1 or return '';
 164        # links to move catalogs up/down
 165        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 166        defined $img_prefix or $img_prefix = '';
 167        defined $urladd or $urladd = '';
 168        my $refreshto = $ENV{SCRIPT_NAME}.$urladd;
 169        my $down_url = "";
 170        if ($subcat_index < $#subcats) {
 171          $down_url = "$CGI_URI/admin/move.pl?id=$subcats[$subcat_index]{id}&d=swap&other=$subcats[$subcat_index+1]{id}&all=1";
 172        }
 173        my $up_url = "";
 174        if ($subcat_index > 0) {
 175          $up_url = "$CGI_URI/admin/move.pl?id=$subcats[$subcat_index]{id}&d=swap&other=$subcats[$subcat_index-1]{id}&all=1";
 176        }
 177        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 178      },
 179     );
 180
 181   return BSE::Template->get_page('admin/'.$template, $req->cfg, \%acts);
 182 }
 183
 184 sub req_product_list {
 185   my ($class, $req, $message) = @_;
 186
 187   my $cgi = $req->cgi;
 188   my $session = $req->session;
 189   my $shopid = $req->cfg->entryErr('articles', 'shop');
 190   my $shop = Articles->getByPkey($shopid);
 191   my @catalogs = sort { $b->{displayOrder} <=> $a->{displayOrder} }
 192     grep $_->{generator} eq 'Generate::Catalog', Articles->children($shopid);
 193   my $catalog_index = -1;
 194   $message ||= $cgi->param('m') || $cgi->param('message') || '';
 195   if (defined $cgi->param('showstepkids')) {
 196     $session->{showstepkids} = $cgi->param('showstepkids');
 197   }
 198   exists $session->{showstepkids} or $session->{showstepkids} = 1;
 199   my $products = Products->new;
 200   my @products = sort { $b->{displayOrder} <=> $a->{displayOrder} }
 201     $products->getBy(parentid => $shopid);
 202   my $product_index;
 203
 204   my $blank = qq!<img src="$IMAGES_URI/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
 205
 206   my $it = BSE::Util::Iterate->new;
 207
 208   my %acts;
 209   %acts =
 210     (
 211      $req->admin_tags,
 212      catalog=> sub { escape_html($catalogs[$catalog_index]{$_[0]}) },
 213      iterate_catalogs => sub { ++$catalog_index < @catalogs  },
 214      shopid=>sub { $shopid },
 215      shop => [ \&tag_hash, $shop ],
 216      script=>sub { $ENV{SCRIPT_NAME} },
 217      message => sub { $message },
 218      embed =>
 219      sub {
 220        my ($which, $template) = split ' ', $_[0];
 221        $which eq 'catalog' or return "Unknown object $which embedded";
 222        return embedded_catalog($req, $catalogs[$catalog_index], $template);
 223      },
 224      movecat =>
 225      sub {
 226        my ($arg, $acts, $funcname, $templater) = @_;
 227
 228        $req->user_can(edit_reorder_children => $shopid)
 229          or return '';
 230        @catalogs > 1 or return '';
 231        # links to move catalogs up/down
 232        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 233        defined $img_prefix or $img_prefix = '';
 234        defined $urladd or $urladd = '';
 235        my $refreshto = $ENV{SCRIPT_NAME} . $urladd;
 236        my $down_url = '';
 237        if ($catalog_index < $#catalogs) {
 238          $down_url = "$CGI_URI/admin/move.pl?id=$catalogs[$catalog_index]{id}&d=swap&other=$catalogs[$catalog_index+1]{id}";
 239        }
 240        my $up_url = '';
 241        if ($catalog_index > 0) {
 242          $up_url = "$CGI_URI/admin/move.pl?id=$catalogs[$catalog_index]{id}&d=swap&other=$catalogs[$catalog_index-1]{id}";
 243        }
 244        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 245      },
 246      ifShowStepKids => sub { $session->{showstepkids} },
 247      $it->make_iterator(undef, 'product', 'products', \@products, \$product_index),
 248      move =>
 249      sub {
 250        my ($arg, $acts, $funcname, $templater) = @_;
 251
 252        $req->user_can(edit_reorder_children => $shop)
 253          or return '';
 254        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 255        defined $img_prefix or $img_prefix = '';
 256        defined $urladd or $urladd = '';
 257        @products > 1 or return '';
 258        # links to move products up/down
 259        my $refreshto = $ENV{SCRIPT_NAME}."$urladd#cat".$shop->{id};
 260        my $down_url = '';
 261        if ($product_index < $#products) {
 262          if ($session->{showstepkids}) {
 263            $down_url = "$CGI_URI/admin/move.pl?stepparent=$shop->{id}&d=swap&id=$products[$product_index]{id}&other=$products[$product_index+1]{id}";
 264          }
 265          else {
 266            $down_url = "$CGI_URI/admin/move.pl?id=$products[$product_index]{id}&d=swap&other=$products[$product_index+1]{id}";
 267          }
 268        }
 269        my $up_url = '';
 270        if ($product_index > 0) {
 271          if ($session->{showstepkids}) {
 272            $up_url = "$CGI_URI/admin/move.pl?stepparent=$shop->{id}&d=swap&id=$products[$product_index]{id}&other=$products[$product_index-1]{id}";
 273          }
 274          else {
 275            $up_url = "$CGI_URI/admin/move.pl?id=$products[$product_index]{id}&d=swap&other=$products[$product_index-1]{id}";
 276          }
 277        }
 278        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 279      },
 280     );
 281
 282   return $req->dyn_response('admin/product_list', \%acts);
 283 }
 284
 285 sub req_product_detail {
 286   my ($class, $req) = @_;
 287
 288   my $cgi = $req->cgi;
 289   my $id = $cgi->param('id');
 290   if ($id and
 291       my $product = Products->getByPkey($id)) {
 292     return product_form($req, $product, '', '', 'admin/product_detail');
 293   }
 294   else {
 295     return $class->req_product_list($req);
 296   }
 297 }
 298
 299 sub product_form {
 300   my ($req, $product, $action, $message, $template) = @_;
 301
 302   my $cgi = $req->cgi;
 303   $message ||= $cgi->param('m') || $cgi->param('message') || '';
 304   $template ||= 'admin/product_detail';
 305   my @catalogs;
 306   my $shopid = $req->cfg->entryErr('articles', 'shop');
 307   my @work = [ $shopid, '' ];
 308   while (@work) {
 309     my ($parent, $title) = @{shift @work};
 310
 311     push(@catalogs, { id=>$parent, display=>$title }) if $title;
 312     my @kids = sort { $b->{displayOrder} <=> $a->{displayOrder} }
 313       grep $_->{generator} eq 'Generate::Catalog',
 314       Articles->children($parent);
 315     $title .= ' / ' if $title;
 316     unshift(@work, map [ $_->{id}, $title.$_->{title} ], @kids);
 317   }
 318   my @files;
 319   if ($product->{id}) {
 320     require BSE::TB::ArticleFiles;
 321     @files = BSE::TB::ArticleFiles->getBy(articleId=>$product->{id});
 322   }
 323   my $file_index;
 324
 325   my @templates;
 326   push(@templates, "shopitem.tmpl")
 327     if grep -e "$_/shopitem.tmpl", BSE::Template->template_dirs($req->cfg);
 328   for my $dir (BSE::Template->template_dirs($req->cfg)) {
 329     if (opendir PROD_TEMPL, "$dir/products") {
 330       push @templates, map "products/$_",
 331         grep -f "$dir/products/$_" && /\.tmpl$/i, readdir PROD_TEMPL;
 332       closedir PROD_TEMPL;
 333     }
 334   }
 335   my %seen_templates;
 336   @templates = sort { lc($a) cmp lc($b) }
 337     grep !$seen_templates{$_}++, @templates;
 338
 339   my $stepcat_index;
 340   use OtherParents;
 341   # ugh
 342   my $realproduct;
 343   $realproduct = UNIVERSAL::isa($product, 'Product') ? $product : Products->getByPkey($product->{id});
 344   my @stepcats;
 345   @stepcats = OtherParents->getBy(childId=>$product->{id})
 346     if $product->{id};
 347   my @stepcat_targets = $realproduct->step_parents if $realproduct;
 348   my %stepcat_targets = map { $_->{id}, $_ } @stepcat_targets;
 349   my @stepcat_possibles = grep !$stepcat_targets{$_->{id}}, @catalogs;
 350   my @images;
 351   @images = $product->images
 352     if $product->{id};
 353 #    @images = $imageEditor->images()
 354 #      if $product->{id};
 355   my $image_index;
 356
 357   my $blank = qq!<img src="$IMAGES_URI/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
 358
 359   my %acts;
 360   %acts =
 361     (
 362      BSE::Util::Tags->basic(\%acts, $cgi, $req->cfg),
 363      BSE::Util::Tags->admin(\%acts, $req->cfg),
 364      BSE::Util::Tags->secure($req),
 365      catalogs =>
 366      sub {
 367        return popup_menu(-name=>'parentid',
 368                          -values=>[ map $_->{id}, @catalogs ],
 369                          -labels=>{ map { @$_{qw/id display/} } @catalogs },
 370                          -default=>($product->{parentid} || $PRODUCTPARENT));
 371      },
 372      product => [ \&tag_hash, $product ],
 373      action => sub { $action },
 374      message => sub { $message },
 375      script=>sub { $ENV{SCRIPT_NAME} },
 376      ifImage => sub { $product->{imageName} },
 377      hiddenNote => sub { $product->{listed} ? "&nbsp;" : "Hidden" },
 378      templates =>
 379      sub {
 380        return popup_menu(-name=>'template', -values=>\@templates,
 381                          -default=>$product->{id} ? $product->{template} :
 382                          $templates[0]);
 383      },
 384      ifStepcats => sub { @stepcats },
 385      iterate_stepcats_reset => sub { $stepcat_index = -1; },
 386      iterate_stepcats => sub { ++$stepcat_index < @stepcats },
 387      stepcat => sub { escape_html($stepcats[$stepcat_index]{$_[0]}) },
 388      stepcat_targ =>
 389      sub {
 390        escape_html($stepcat_targets[$stepcat_index]{$_[0]});
 391      },
 392      movestepcat =>
 393      sub {
 394        my ($arg, $acts, $funcname, $templater) = @_;
 395        return ''
 396          unless $req->user_can(edit_reorder_stepparents => $product),
 397        @stepcats > 1 or return '';
 398        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
 399        $img_prefix = '' unless defined $img_prefix;
 400        $urladd = '' unless defined $urladd;
 401        my $refreshto = escape_uri($ENV{SCRIPT_NAME}
 402                                    ."?id=$product->{id}&$template=1$urladd#step");
 403        my $down_url = "";
 404        if ($stepcat_index < $#stepcats) {
 405          $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";
 406        }
 407        my $up_url = "";
 408        if ($stepcat_index > 0) {
 409          $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";
 410        }
 411        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
 412      },
 413      ifStepcatPossibles => sub { @stepcat_possibles },
 414      stepcat_possibles => sub {
 415        popup_menu(-name=>'stepcat',
 416                   -values=>[ map $_->{id}, @stepcat_possibles ],
 417                   -labels=>{ map { $_->{id}, $_->{display}} @catalogs });
 418      },
 419      BSE::Util::Tags->
 420      make_iterator(\@files, 'file', 'files', \$file_index),
 421      BSE::Util::Tags->
 422      make_iterator(\@images, 'image', 'images', \$image_index),
 423     );
 424
 425   return $req->dyn_response($template, \%acts);
 426 }
 427
 428 #####################
 429 # order management
 430
 431 sub order_list_low {
 432   my ($req, $template, $title, @orders) = @_;
 433
 434   my $cgi = $req->cgi;
 435
 436   my $from = $cgi->param('from');
 437   my $to = $cgi->param('to');
 438   use BSE::Util::SQL qw/now_sqldate sql_to_date date_to_sql/;
 439   use BSE::Util::Valid qw/valid_date/;
 440   my $today = now_sqldate();
 441   for my $what ($from, $to) {
 442     if (defined $what) {
 443       if ($what eq 'today') {
 444         $what = $today;
 445       }
 446       elsif (valid_date($what)) {
 447         $what = date_to_sql($what);
 448       }
 449       else {
 450         undef $what;
 451       }
 452     }
 453   }
 454   my $message = $cgi->param('m');
 455   defined $message or $message = '';
 456   $message = escape_html($message);
 457   if (defined $from || defined $to) {
 458     $from ||= '1900-01-01';
 459     $to ||= '2999-12-31';
 460     $cgi->param('from', sql_to_date($from));
 461     $cgi->param('to', sql_to_date($to));
 462     $to = $to."Z";
 463     @orders = grep $from le $_->{orderDate} && $_->{orderDate} le $to,
 464     @orders;
 465   }
 466   my @orders_work;
 467   my $order_index = -1;
 468   my %acts;
 469   %acts =
 470     (
 471      BSE::Util::Tags->basic(\%acts, $cgi, $req->cfg),
 472      BSE::Util::Tags->admin(\%acts, $req->cfg),
 473      BSE::Util::Tags->secure($req),
 474      #order=> sub { escape_html($orders_work[$order_index]{$_[0]}) },
 475      DevHelp::Tags->make_iterator2
 476      ( [ \&iter_orders, \@orders ],
 477        'order', 'orders', \@orders_work, \$order_index, 'NoCache'),
 478      script => sub { $ENV{SCRIPT_NAME} },
 479      title => sub { $title },
 480      ifHaveParam => sub { defined $cgi->param($_[0]) },
 481      ifParam => sub { $cgi->param($_[0]) },
 482      cgi =>
 483      sub {
 484        my $value = $cgi->param($_[0]);
 485        defined $value or $value = '';
 486        escape_html($value);
 487      },
 488      message => $message,
 489     );
 490   $req->dyn_response("admin/$template", \%acts);
 491 }
 492
 493 sub iter_orders {
 494   my ($orders, $args) = @_;
 495
 496   return bse_sort({ id => 'n', total => 'n', filled=>'n' }, $args, @$orders);
 497 }
 498
 499 sub req_order_list {
 500   my ($class, $req) = @_;
 501
 502   my $orders = BSE::TB::Orders->new;
 503   my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
 504     grep $_->{complete}, $orders->all;
 505   my $template = $req->cgi->param('template');
 506   unless (defined $template && $template =~ /^\w+$/) {
 507     $template = 'order_list';
 508   }
 509
 510   return order_list_low($req, $template, 'Order list', @orders);
 511 }
 512
 513 sub req_order_list_filled {
 514   my ($class, $req) = @_;
 515
 516   my $orders = BSE::TB::Orders->new;
 517   my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
 518     grep $_->{complete} && $_->{filled} && $_->{paidFor}, $orders->all;
 519
 520   return order_list_low($req, 'order_list_filled', 'Order list - Filled orders', @orders);
 521 }
 522
 523 sub req_order_list_unfilled {
 524   my ($class, $req) = @_;
 525
 526   my $orders = BSE::TB::Orders->new;
 527   my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
 528     grep $_->{complete} && !$_->{filled} && $_->{paidFor}, $orders->all;
 529
 530   return order_list_low($req, 'order_list_unfilled',
 531                         'Order list - Unfilled orders', @orders);
 532
 533 }
 534
 535 sub req_order_list_unpaid {
 536   my ($class, $req) = @_;
 537
 538   my $orders = BSE::TB::Orders->new;
 539   my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
 540     grep $_->{complete} && !$_->{paidFor}, $orders->all;
 541
 542   return order_list_low($req, 'order_list_unpaid',
 543                         'Order list - Incomplete orders', @orders);
 544 }
 545
 546 sub req_order_list_incomplete {
 547   my ($class, $req) = @_;
 548
 549   my $orders = BSE::TB::Orders->new;
 550   my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
 551     grep !$_->{complete}, $orders->all;
 552
 553   return order_list_low($req, 'order_list_incomplete',
 554                         'Order list - Incomplete orders', @orders);
 555 }
 556
 557 sub tag_siteuser {
 558   my ($order, $rsiteuser, $arg) = @_;
 559
 560   unless ($$rsiteuser) {
 561     $$rsiteuser = $order->siteuser || {};
 562   }
 563
 564   my $siteuser = $$rsiteuser;
 565   return '' unless $siteuser->{id};
 566
 567   my $value = $siteuser->{$arg};
 568   defined $value or $value = '';
 569
 570   return escape_html($value);
 571 }
 572
 573 sub req_order_detail {
 574   my ($class, $req, $message) = @_;
 575
 576   my $cgi = $req->cgi;
 577   my $id = $cgi->param('id');
 578   if ($id and
 579       my $order = BSE::TB::Orders->getByPkey($id)) {
 580     $message ||= $cgi->param('m') || '';
 581     my @lines = $order->items;
 582     my @products = map { Products->getByPkey($_->{productId}) } @lines;
 583     my $line_index = -1;
 584     my $product;
 585     my @options;
 586     my $option_index = -1;
 587     my $siteuser;
 588     my %acts;
 589     %acts =
 590       (
 591        BSE::Util::Tags->basic(\%acts, $cgi, $req->cfg),
 592        BSE::Util::Tags->admin(\%acts, $req->cfg),
 593        BSE::Util::Tags->secure($req),
 594        item => sub { escape_html($lines[$line_index]{$_[0]}) },
 595        iterate_items_reset => sub { $line_index = -1 },
 596        iterate_items =>
 597        sub {
 598          if (++$line_index < @lines ) {
 599            $option_index = -1;
 600            @options = order_item_opts($req,
 601                                       $lines[$line_index],
 602                                       $products[$line_index]);
 603            return 1;
 604          }
 605          return 0;
 606        },
 607        order => [ \&tag_hash, $order ],
 608        extension =>
 609        sub {
 610          sprintf("%.2f", $lines[$line_index]{units} * $lines[$line_index]{$_[0]}/100.0)
 611        },
 612        product => sub { escape_html($products[$line_index]{$_[0]}) },
 613        script => sub { $ENV{SCRIPT_NAME} },
 614        iterate_options_reset => sub { $option_index = -1 },
 615        iterate_options => sub { ++$option_index < @options },
 616        option => sub { escape_html($options[$option_index]{$_[0]}) },
 617        ifOptions => sub { @options },
 618        options => sub { nice_options(@options) },
 619        message => sub { $message },
 620        siteuser => [ \&tag_siteuser, $order, \$siteuser, ],
 621       );
 622
 623     return $req->dyn_response('admin/order_detail', \%acts);
 624   }
 625   else {
 626     return $class->req_order_list($req);
 627   }
 628 }
 629
 630 sub req_order_filled {
 631   my ($class, $req) = @_;
 632
 633   my $id = $req->cgi->param('id');
 634   if ($id and
 635       my $order = BSE::TB::Orders->getByPkey($id)) {
 636     my $filled = $req->cgi->param('filled');
 637     $order->{filled} = $filled;
 638     if ($order->{filled}) {
 639       $order->{whenFilled} = epoch_to_sql_datetime(time);
 640       my $user = $req->user;
 641       if ($user) {
 642         $order->{whoFilled} = $user->{logon};
 643       }
 644       else {
 645         $order->{whoFilled} = defined($ENV{REMOTE_USER})
 646           ? $ENV{REMOTE_USER} : "-unknown-";
 647       }
 648     }
 649     $order->save();
 650     if ($req->cgi->param('detail')) {
 651       return $class->req_order_detail($req);
 652     }
 653     else {
 654       return $class->req_order_list($req);
 655     }
 656   }
 657   else {
 658     return $class->req_order_list($req);
 659   }
 660 }
 661
 662 sub req_order_paid {
 663   my ($class, $req) = @_;
 664
 665   return $class->_set_order_paid($req, 1);
 666 }
 667
 668 sub req_order_unpaid {
 669   my ($class, $req) = @_;
 670
 671   return $class->_set_order_paid($req, 0);
 672 }
 673
 674 sub _set_order_paid {
 675   my ($class, $req, $value) = @_;
 676
 677   my $id = $req->cgi->param('id');
 678   if ($id and
 679       my $order = BSE::TB::Orders->getByPkey($id)) {
 680     if ($order->paidFor != $value) {
 681       if ($value) {
 682         $order->set_paymentType(PAYMENT_MANUAL);
 683       }
 684       else {
 685         $order->paymentType == PAYMENT_MANUAL
 686           or return $class->req_order_detail($req, "You can only unpay manually paid orders");
 687       }
 688
 689       $order->set_paidFor($value);
 690       my $user = $req->user;
 691       my $name = $user ? $user->logon : "--unknown--";
 692       require POSIX;
 693       $order->{instructions} .= "\nMarked " . ($value ? "paid" : "unpaid" ) . " by $name " . POSIX::strftime("%H:%M %d/%m/%Y", localtime);
 694       $order->save();
 695     }
 696
 697     return BSE::Template->get_refresh("$ENV{SCRIPT_NAME}?a_order_detail=1&id=$id", $req->cfg);
 698   }
 699   else {
 700     return $class->req_order_list($req);
 701   }
 702 }
 703
 704 sub req_paypal_refund {
 705   my ($self, $req) = @_;
 706
 707   my $id = $req->cgi->param('id');
 708   if ($id and
 709       my $order = BSE::TB::Orders->getByPkey($id)) {
 710     require BSE::PayPal;
 711     my $msg;
 712     unless (BSE::PayPal->refund_order(order => $order,
 713                                       req => $req,
 714                                       msg => \$msg)) {
 715       return $self->req_order_detail($req, $msg);
 716     }
 717
 718     return $req->get_refresh($req->url(shopadmin => { "a_order_detail" => 1, id => $id }));
 719   }
 720   else {
 721     $req->flash_error("Missing or invalid order id");
 722     return $self->req_order_list($req);
 723   }
 724 }
 725
 726 #####################
 727 # utilities
 728 # perhaps some of these belong in a class...
 729
 730 # format an ANSI SQL date for display
 731 sub display_date {
 732   my ($date) = @_;
 733
 734   if ( my ($year, $month, $day) =
 735        ($date =~ /^(\d+)-(\d+)-(\d+)/)) {
 736     return sprintf("%02d/%02d/%04d", $day, $month, $year);
 737   }
 738   return $date;
 739 }
 740
 741 # convert a user entered date from dd/mm/yyyy to ANSI sql format
 742 # we try to parse flexibly here
 743 sub sql_date {
 744   my $str = shift;
 745   my ($year, $month, $day);
 746
 747   # look for a date
 748   if (($day, $month, $year) = ($$str =~ m!(\d+)/(\d+)/(\d+)!)) {
 749     $year += 2000 if $year < 100;
 750
 751     return $$str = sprintf("%04d-%02d-%02d", $year, $month, $day);
 752   }
 753   return undef;
 754 }
 755
 756 sub money_to_cents {
 757   my $money = shift;
 758
 759   $$money =~ /^\s*(\d+(\.\d*)|\.\d+)/
 760     or return undef;
 761   return $$money = sprintf("%.0f ", $$money * 100);
 762 }
 763
 764 # convert an epoch time to sql format
 765 sub epoch_to_sql {
 766   use POSIX 'strftime';
 767   my ($time) = @_;
 768
 769   return strftime('%Y-%m-%d', localtime $time);
 770 }
 771
 772 # convert an epoch time to sql format
 773 sub epoch_to_sql_datetime {
 774   use POSIX 'strftime';
 775   my ($time) = @_;
 776
 777   return strftime('%Y-%m-%d %H:%M', localtime $time);
 778 }
 779
 780 1;
 781
 782 __END__
 783
 784 =head1 NAME
 785
 786 shopadmin.pl - administration for the online-store tables
 787
 788 =head1 SYNOPSYS
 789
 790 (This is a CGI script.)
 791
 792 =head1 DESCRIPTION
 793
 794 shopadmin.pl gives a UI to edit the product table, and view the orders and
 795 order_item tables.
 796
 797 =head1 TEMPLATES
 798
 799 shopadmin.pl uses a few templates from the templates/admin directory.
 800
 801 =head2 product_list.tmpl
 802
 803 =over 4
 804
 805 =item product I<name>
 806
 807 Access to product fields.
 808
 809 =item date I<name>
 810
 811 Formats the I<name> field of the product as a date.
 812
 813 =item money I<name>
 814
 815 Formats the I<name> integer field as a 2 decimal place money value.
 816
 817 =item iterator ... products
 818
 819 Iterates over the products database in reverse expire order.
 820
 821 =item script
 822
 823 The name of the current script for use in URLs.
 824
 825 =item message
 826
 827 An error message that may have been passed in the 'message' parameter.
 828
 829 =item hiddenNote
 830
 831 'Deleted' if the expire date of the current product has passed.
 832
 833 =back
 834
 835 =head2 add_product.tmpl
 836 =head2 edit_product.tmpl
 837 =head2 product_detail.tmpl
 838
 839 These use the same tags.
 840
 841 =over 4
 842
 843 =item product I<name>
 844
 845 The specified field of the product.
 846
 847 =item date I<name>
 848
 849 Formats the given field of the product as a date.
 850
 851 =item money I<name>
 852
 853 Formats the given integer field of the product as money.
 854
 855 =item action
 856
 857 Either 'Add New' or 'Edit'.
 858
 859 =item message
 860
 861 The message parameter passed into the script.
 862
 863 =item script
 864
 865 The name of the script, for use in urls.
 866
 867 =item ifImage
 868
 869 Conditional, true if the product has an image.
 870
 871 =item hiddenNote
 872
 873 "Hidden" if the product is hidden.
 874
 875 =back
 876
 877 =head2 order_list.tmpl
 878
 879 Used to display the list of orders.  You can also specify a template
 880 parameter to the order_list target, and perform filtering and sorting
 881 within the template.
 882
 883 =over 4
 884
 885 =item order I<name>
 886
 887 The given field of the order.
 888
 889 =item iterator ... orders [filter-sort-spec]
 890
 891 Iterates over the orders in reverse orderDate order.
 892
 893 The [filter-sort-spec] can contain none, either or both of the following:
 894
 895 =over
 896
 897 =item filter= field op value, ...
 898
 899 filter the data by checking the given expression.
 900
 901 eg. filter= filled == 0
 902
 903 =item sort= [+|-] keyword, ...
 904
 905 Sorts the result by the specified fields, in reverse if preceded by '-'.
 906
 907 =back
 908
 909 =item money I<name>
 910
 911 The given field of the current order formatted as money.
 912
 913 =item date I<name>
 914
 915 The given field of the current order formatted as a date.
 916
 917 =item script
 918
 919 The name of the script, for use in urls.
 920
 921 =back
 922
 923 =head2 order_detail.tmpl
 924
 925 Used to display the details for an order.
 926
 927 =over 4
 928
 929 =item item I<name>
 930
 931 Displays the given field of a line item
 932
 933 =item iterator ... items
 934
 935 Iterates over the line items in the order.
 936
 937 =item order I<name>
 938
 939 The given field of the order.
 940
 941 =item money I<func> I<args>
 942
 943 Formats the given functions return value as money.
 944
 945 =item date I<func> I<args>
 946
 947 Formats the  given function return value as a date.
 948
 949 =item extension I<name>
 950
 951 Takes the given field for the current item multiplied by the units column.
 952
 953 =item product I<name>
 954
 955 The given product field of the product for the current item.
 956
 957 =item script
 958
 959 The name of the current script (for use in urls).
 960
 961 =item iterator ... options
 962
 963 Iterates over the options set for the current order item.
 964
 965 =item option I<field>
 966
 967 Access to a field of the option, any of id, value, desc or label.
 968
 969 =item ifOptions
 970
 971 Conditional tag, true if the current product has any options.
 972
 973 =item options
 974
 975 A laid-out list of the options set for the current order item.
 976
 977 =back
 978
 979 =cut
 980