re-work coupons to allow multiple coupon types
[bse.git] / site / cgi-bin / modules / BSE / UI / AdminShop.pm
1 package BSE::UI::AdminShop;
2 use strict;
3 use base 'BSE::UI::AdminDispatch';
4 use BSE::TB::Products;
5 use BSE::TB::Product;
6 use BSE::TB::Orders;
7 use BSE::TB::OrderItems;
8 use BSE::Template;
9 use Constants qw(:shop $SHOPID $PRODUCTPARENT 
10                  $SHOP_URI $CGI_URI $AUTO_GENERATE);
11 use BSE::TB::Images;
12 use BSE::TB::Articles;
13 use BSE::Sort;
14 use BSE::Util::Tags qw(tag_hash tag_error_img tag_object_plain tag_object tag_article);
15 use BSE::Util::Iterate;
16 use BSE::WebUtil 'refresh_to_admin';
17 use BSE::Util::HTML qw(:default popup_menu);
18 use BSE::Arrows;
19 use BSE::Shop::Util qw(:payment order_item_opts nice_options payment_types);
20 use BSE::CfgInfo qw(cfg_dist_image_uri);
21 use BSE::Util::SQL qw/now_sqldate sql_to_date date_to_sql sql_date sql_datetime/;
22 use BSE::Util::Valid qw/valid_date/;
23
24 our $VERSION = "1.030";
25
26 my %actions =
27   (
28    order_list => 'shop_order_list',
29    order_list_filled => 'shop_order_list',
30    order_list_unfilled => 'shop_order_list',
31    order_list_unpaid => 'shop_order_list',
32    order_list_incomplete => 'shop_order_list',
33    order_detail => 'shop_order_detail',
34    order_filled => 'shop_order_filled',
35    order_paid => 'shop_order_paid',
36    order_unpaid => 'shop_order_unpaid',
37    order_save => 'shop_order_save',
38    product_detail => '',
39    product_list => '',
40    paypal_refund => 'bse_shop_order_refund_paypal',
41    coupon_list => 'bse_shop_coupon_list',
42    coupon_addform => 'bse_shop_coupon_add',
43    coupon_add => 'bse_shop_coupon_add',
44    coupon_edit => 'bse_shop_coupon_edit',
45    coupon_save => 'bse_shop_coupon_edit',
46    coupon_deleteform => 'bse_shop_coupon_delete',
47    coupon_delete => 'bse_shop_coupon_delete',
48   );
49
50 sub actions {
51   \%actions;
52 }
53
54 sub rights {
55   \%actions;
56 }
57
58 sub default_action {
59   'product_list'
60 }
61
62 sub action_prefix {
63   ''
64 }
65
66 my %csrfp =
67   (
68    coupon_add => { token => "admin_bse_coupon_add", target => "coupon_addform" },
69    coupon_save => { token => "admin_bse_coupon_edit", target => "coupon_edit" },
70    coupon_delete => { token => "admin_bse_coupon_delete", target => "coupon_deleteform" },
71   );
72
73 sub csrfp_tokens {
74   \%csrfp;
75 }
76
77 #####################
78 # product management
79
80 sub embedded_catalog {
81   my ($req, $catalog, $template) = @_;
82
83   my $session = $req->session;
84   use POSIX 'strftime';
85   my $products = BSE::TB::Products->new;
86   my @list;
87   if ($session->{showstepkids}) {
88     my @allkids = $catalog->allkids;
89     my %allgen = map { $_->{generator} => 1 } @allkids;
90     for my $gen (keys %allgen) {
91       (my $file = $gen . ".pm") =~ s!::!/!g;
92       require $file;
93     }
94     @list = grep UNIVERSAL::isa($_->{generator}, 'BSE::Generate::Product'), $catalog->allkids;
95     @list = map { $products->getByPkey($_->{id}) } @list;
96   }
97   else {
98     @list = sort { $b->{displayOrder} <=> $a->{displayOrder} } 
99       $products->getBy(parentid=>$catalog->{id});
100   }
101   my $list_index = -1;
102   my $subcat_index = -1;
103   my @subcats = sort { $b->{displayOrder} <=> $a->{displayOrder} } 
104     grep $_->{generator} eq 'BSE::Generate::Catalog', 
105     BSE::TB::Articles->children($catalog->{id});
106
107   my $image_uri = cfg_dist_image_uri();
108   my $blank = qq!<img src="$image_uri/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
109
110   my %acts;
111   %acts =
112     (
113      $req->admin_tags,
114      catalog => [ \&tag_hash, $catalog ],
115      iterate_products_reset => sub { $list_index = -1; },
116      iterate_products =>
117      sub {
118        return ++$list_index < @list;
119      },
120      product => 
121      sub { 
122        $list_index >= 0 && $list_index < @list
123          or return '** outside products iterator **';
124        my $product = $list[$list_index];
125        return tag_article($product, $req->cfg, $_[0]);
126      },
127      ifProducts => sub { @list },
128      iterate_subcats_reset =>
129      sub {
130        $subcat_index = -1;
131      },
132      iterate_subcats => sub { ++$subcat_index < @subcats },
133      subcat => sub { tag_article($subcats[$subcat_index], $req->cfg, $_[0]) },
134      ifSubcats => sub { @subcats },
135      hiddenNote => 
136      sub { $list[$list_index]{listed} == 0 ? "Hidden" : "&nbsp;" },
137      move =>
138      sub {
139        my ($arg, $acts, $funcname, $templater) = @_;
140
141        $req->user_can(edit_reorder_children => $catalog)
142          or return '';
143        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
144        defined $img_prefix or $img_prefix = '';
145        defined $urladd or $urladd = '';
146        @list > 1 or return '';
147        # links to move products up/down
148        my $refreshto = $ENV{SCRIPT_NAME}."$urladd#cat".$catalog->{id};
149        my $down_url = '';
150        if ($list_index < $#list) {
151          if ($session->{showstepkids}) {
152            $down_url = "$CGI_URI/admin/move.pl?stepparent=$catalog->{id}&d=swap&id=$list[$list_index]{id}&other=$list[$list_index+1]{id}";
153          }
154          else {
155            $down_url = "$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=swap&other=$list[$list_index+1]{id}";
156          }
157        }
158        my $up_url = '';
159        if ($list_index > 0) {
160          if ($session->{showstepkids}) {
161            $up_url = "$CGI_URI/admin/move.pl?stepparent=$catalog->{id}&d=swap&id=$list[$list_index]{id}&other=$list[$list_index-1]{id}";
162          }
163          else {
164            $up_url = "$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=swap&other=$list[$list_index-1]{id}";
165          }
166        }
167        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
168      },
169      script=>sub { $ENV{SCRIPT_NAME} },
170      embed =>
171      sub {
172        my ($which, $template) = split ' ', $_[0];
173        $which eq 'subcat' or return "Unknown object $which embedded";
174        return embedded_catalog($req, $subcats[$subcat_index], $template);
175      },
176      movecat =>
177      sub {
178        my ($arg, $acts, $funcname, $templater) = @_;
179
180        $req->user_can(edit_reorder_children => $catalog)
181          or return '';
182        @subcats > 1 or return '';
183        # links to move catalogs up/down
184        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
185        defined $img_prefix or $img_prefix = '';
186        defined $urladd or $urladd = '';
187        my $refreshto = $ENV{SCRIPT_NAME}.$urladd;
188        my $down_url = "";
189        if ($subcat_index < $#subcats) {
190          $down_url = "$CGI_URI/admin/move.pl?id=$subcats[$subcat_index]{id}&d=swap&other=$subcats[$subcat_index+1]{id}&all=1";
191        }
192        my $up_url = "";
193        if ($subcat_index > 0) {
194          $up_url = "$CGI_URI/admin/move.pl?id=$subcats[$subcat_index]{id}&d=swap&other=$subcats[$subcat_index-1]{id}&all=1";
195        }
196        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
197      },
198     );
199
200   return BSE::Template->get_page('admin/'.$template, $req->cfg, \%acts);
201 }
202
203 sub req_product_list {
204   my ($class, $req, $message) = @_;
205
206   my $cgi = $req->cgi;
207   my $session = $req->session;
208   my $shopid = $req->cfg->entryErr('articles', 'shop');
209   my $shop = BSE::TB::Articles->getByPkey($shopid);
210   my @catalogs = sort { $b->{displayOrder} <=> $a->{displayOrder} }
211     grep $_->{generator} eq 'BSE::Generate::Catalog', BSE::TB::Articles->children($shopid);
212   my $catalog_index = -1;
213   $message = $req->message($message);
214   if (defined $cgi->param('showstepkids')) {
215     $session->{showstepkids} = $cgi->param('showstepkids');
216   }
217   exists $session->{showstepkids} or $session->{showstepkids} = 1;
218   my $products = BSE::TB::Products->new;
219   my @products = sort { $b->{displayOrder} <=> $a->{displayOrder} }
220     $products->getBy(parentid => $shopid);
221   my $product_index;
222
223   my $image_uri = cfg_dist_image_uri();
224   my $blank = qq!<img src="$image_uri/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
225
226   my $it = BSE::Util::Iterate->new;
227
228   my %acts;
229   %acts =
230     (
231      $req->admin_tags,
232      catalog=> sub { tag_article($catalogs[$catalog_index], $req->cfg, $_[0]) },
233      iterate_catalogs => sub { ++$catalog_index < @catalogs  },
234      shopid=>sub { $shopid },
235      shop => [ \&tag_hash, $shop ],
236      script=>sub { $ENV{SCRIPT_NAME} },
237      message => sub { $message },
238      embed =>
239      sub {
240        my ($which, $template) = split ' ', $_[0];
241        $which eq 'catalog' or return "Unknown object $which embedded";
242        return embedded_catalog($req, $catalogs[$catalog_index], $template);
243      },
244      movecat =>
245      sub {
246        my ($arg, $acts, $funcname, $templater) = @_;
247
248        $req->user_can(edit_reorder_children => $shopid)
249          or return '';
250        @catalogs > 1 or return '';
251        # links to move catalogs up/down
252        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
253        defined $img_prefix or $img_prefix = '';
254        defined $urladd or $urladd = '';
255        my $refreshto = $ENV{SCRIPT_NAME} . $urladd;
256        my $down_url = '';
257        if ($catalog_index < $#catalogs) {
258          $down_url = "$CGI_URI/admin/move.pl?id=$catalogs[$catalog_index]{id}&d=swap&other=$catalogs[$catalog_index+1]{id}";
259        }
260        my $up_url = '';
261        if ($catalog_index > 0) {
262          $up_url = "$CGI_URI/admin/move.pl?id=$catalogs[$catalog_index]{id}&d=swap&other=$catalogs[$catalog_index-1]{id}";
263        }
264        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
265      },
266      ifShowStepKids => sub { $session->{showstepkids} },
267      $it->make_iterator(undef, 'product', 'products', \@products, \$product_index),
268      move =>
269      sub {
270        my ($arg, $acts, $funcname, $templater) = @_;
271
272        $req->user_can(edit_reorder_children => $shop)
273          or return '';
274        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
275        defined $img_prefix or $img_prefix = '';
276        defined $urladd or $urladd = '';
277        @products > 1 or return '';
278        # links to move products up/down
279        my $refreshto = $ENV{SCRIPT_NAME}."$urladd#cat".$shop->{id};
280        my $down_url = '';
281        if ($product_index < $#products) {
282          if ($session->{showstepkids}) {
283            $down_url = "$CGI_URI/admin/move.pl?stepparent=$shop->{id}&d=swap&id=$products[$product_index]{id}&other=$products[$product_index+1]{id}";
284          }
285          else {
286            $down_url = "$CGI_URI/admin/move.pl?id=$products[$product_index]{id}&d=swap&other=$products[$product_index+1]{id}";
287          }
288        }
289        my $up_url = '';
290        if ($product_index > 0) {
291          if ($session->{showstepkids}) {
292            $up_url = "$CGI_URI/admin/move.pl?stepparent=$shop->{id}&d=swap&id=$products[$product_index]{id}&other=$products[$product_index-1]{id}";
293          }
294          else {
295            $up_url = "$CGI_URI/admin/move.pl?id=$products[$product_index]{id}&d=swap&other=$products[$product_index-1]{id}";
296          }
297        }
298        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
299      },
300     );
301
302   return $req->dyn_response('admin/product_list', \%acts);
303 }
304
305 sub req_product_detail {
306   my ($class, $req) = @_;
307
308   my $cgi = $req->cgi;
309   my $id = $cgi->param('id');
310   if ($id and
311       my $product = BSE::TB::Products->getByPkey($id)) {
312     return product_form($req, $product, '', '', 'admin/product_detail');
313   }
314   else {
315     return $class->req_product_list($req);
316   }
317 }
318
319 sub product_form {
320   my ($req, $product, $action, $message, $template) = @_;
321   
322   my $cgi = $req->cgi;
323   $message ||= $cgi->param('m') || $cgi->param('message') || '';
324   $template ||= 'admin/product_detail';
325   my @catalogs;
326   my $shopid = $req->cfg->entryErr('articles', 'shop');
327   my @work = [ $shopid, '' ];
328   while (@work) {
329     my ($parent, $title) = @{shift @work};
330
331     push(@catalogs, { id=>$parent, display=>$title }) if $title;
332     my @kids = sort { $b->{displayOrder} <=> $a->{displayOrder} } 
333       grep $_->{generator} eq 'BSE::Generate::Catalog',
334       BSE::TB::Articles->children($parent);
335     $title .= ' / ' if $title;
336     unshift(@work, map [ $_->{id}, $title.$_->{title} ], @kids);
337   }
338   my @files;
339   if ($product->{id}) {
340     require BSE::TB::ArticleFiles;
341     @files = BSE::TB::ArticleFiles->getBy(articleId=>$product->{id});
342   }
343   my $file_index;
344
345   my @templates;
346   push(@templates, "shopitem.tmpl")
347     if grep -e "$_/shopitem.tmpl", BSE::Template->template_dirs($req->cfg);
348   for my $dir (BSE::Template->template_dirs($req->cfg)) {
349     if (opendir PROD_TEMPL, "$dir/products") {
350       push @templates, map "products/$_",
351         grep -f "$dir/products/$_" && /\.tmpl$/i, readdir PROD_TEMPL;
352       closedir PROD_TEMPL;
353     }
354   }
355   my %seen_templates;
356   @templates = sort { lc($a) cmp lc($b) } 
357     grep !$seen_templates{$_}++, @templates;
358
359   my $stepcat_index;
360   use BSE::TB::OtherParents;
361   # ugh
362   my $realproduct;
363   $realproduct = UNIVERSAL::isa($product, 'BSE::TB::Product') ? $product : BSE::TB::Products->getByPkey($product->{id});
364   my @stepcats;
365   @stepcats = BSE::TB::OtherParents->getBy(childId=>$product->{id}) 
366     if $product->{id};
367   my @stepcat_targets = $realproduct->step_parents if $realproduct;
368   my %stepcat_targets = map { $_->{id}, $_ } @stepcat_targets;
369   my @stepcat_possibles = grep !$stepcat_targets{$_->{id}}, @catalogs;
370   my @images;
371   @images = $product->images
372     if $product->{id};
373 #    @images = $imageEditor->images()
374 #      if $product->{id};
375   my $image_index;
376
377   my $image_uri = cfg_dist_image_uri();
378   my $blank = qq!<img src="$image_uri/trans_pixel.gif" width="17" height="13" border="0" align="absbottom" />!;
379
380   my %acts;
381   %acts =
382     (
383      $req->admin_tags,
384      catalogs => 
385      sub {
386        return popup_menu(-name=>'parentid',
387                          -values=>[ map $_->{id}, @catalogs ],
388                          -labels=>{ map { @$_{qw/id display/} } @catalogs },
389                          -default=>($product->{parentid} || $PRODUCTPARENT));
390      },
391      product => [ \&tag_article, $product, $req->cfg ],
392      action => sub { $action },
393      message => sub { $message },
394      script=>sub { $ENV{SCRIPT_NAME} },
395      ifImage => sub { $product->{imageName} },
396      hiddenNote => sub { $product->{listed} ? "&nbsp;" : "Hidden" },
397      templates => 
398      sub {
399        return popup_menu(-name=>'template', -values=>\@templates,
400                          -default=>$product->{id} ? $product->{template} :
401                          $templates[0]);
402      },
403      ifStepcats => sub { @stepcats },
404      iterate_stepcats_reset => sub { $stepcat_index = -1; },
405      iterate_stepcats => sub { ++$stepcat_index < @stepcats },
406      stepcat => sub { escape_html($stepcats[$stepcat_index]{$_[0]}) },
407      stepcat_targ =>
408      sub {
409        escape_html($stepcat_targets[$stepcat_index]{$_[0]});
410      },
411      movestepcat =>
412      sub {
413        my ($arg, $acts, $funcname, $templater) = @_;
414        return ''
415          unless $req->user_can(edit_reorder_stepparents => $product),
416        @stepcats > 1 or return '';
417        my ($img_prefix, $urladd) = DevHelp::Tags->get_parms($arg, $acts, $templater);
418        $img_prefix = '' unless defined $img_prefix;
419        $urladd = '' unless defined $urladd;
420        my $refreshto = escape_uri($ENV{SCRIPT_NAME}
421                                    ."?id=$product->{id}&$template=1$urladd#step");
422        my $down_url = "";
423        if ($stepcat_index < $#stepcats) {
424          $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";
425        }
426        my $up_url = "";
427        if ($stepcat_index > 0) {
428          $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";
429        }
430        return make_arrows($req->cfg, $down_url, $up_url, $refreshto, $img_prefix);
431      },
432      ifStepcatPossibles => sub { @stepcat_possibles },
433      stepcat_possibles => sub {
434        popup_menu(-name=>'stepcat',
435                   -values=>[ map $_->{id}, @stepcat_possibles ],
436                   -labels=>{ map { $_->{id}, $_->{display}} @catalogs });
437      },
438      BSE::Util::Tags->
439      make_iterator(\@files, 'file', 'files', \$file_index),
440      BSE::Util::Tags->
441      make_iterator(\@images, 'image', 'images', \$image_index),
442     );
443
444   return $req->dyn_response($template, \%acts);
445 }
446
447 =item tag all_order_count
448 X<tags, shop admin, all_order_count>C<all_order_count>
449
450 Returns a count of orders matching a set of conditions.
451
452 =cut
453
454 sub tag_all_order_count {
455   my ($args, $acts, $funcname, $templater) = @_;
456
457   my $query;
458   if ($args =~ /\S/) {
459     if (eval "\$query = [ $args ]; 1 ") {
460       return BSE::TB::Orders->getCount($query);
461     }
462     else {
463       return "<!-- error handling args: $@ -->";
464     }
465   }
466   else {
467     return BSE::TB::Orders->getCount();
468   }
469 }
470
471 #####################
472 # order management
473
474 sub order_list_low {
475   my ($req, $template, $title, $conds, $options) = @_;
476
477   my $cgi = $req->cgi;
478
479   $options ||= {};
480   my $order = delete $options->{order};
481   defined $order or $order = 'id desc';
482   my $datelimit = delete $options->{datelimit};
483   defined $datelimit or $datelimit = 1;
484
485   my $from = $cgi->param('from');
486   my $to = $cgi->param('to');
487   my $today = now_sqldate();
488   for my $what ($from, $to) {
489     if (defined $what) {
490       if ($what eq 'today') {
491         $what = $today;
492       }
493       elsif (valid_date($what)) {
494         $what = date_to_sql($what);
495       }
496       else {
497         undef $what;
498       }
499     }
500   }
501   if ($datelimit) {
502     $from ||= sql_date(time() - 30 * 86_400);
503   }
504   if (defined $from || defined $to) {
505     $from ||= '1900-01-01';
506     $to ||= '2999-12-31';
507     $cgi->param('from', sql_to_date($from));
508     $cgi->param('to', sql_to_date($to));
509     push @$conds,
510       [ between => 'orderDate', $from, $to." 23:59:59" ];
511   }
512
513   my @simple_search_fields = qw/userId billEmail billFirstName billLastName billOrganization/;
514   for my $key (@simple_search_fields) {
515     my $value = $cgi->param($key);
516     if (defined $value && $value =~ /\S/) {
517       push @$conds, [ like => $key => '%' . $value . '%' ];
518     }
519   }
520
521   my @stage = grep /\S/, map split (",", $_), $cgi->param("stage");
522   if (@stage) {
523     push @$conds,
524       [ or =>
525         map [ stage => $_ ], @stage
526       ];
527   }
528
529   my $name = $cgi->param("name");
530   if (defined $name && $name =~ /\S/) {
531     push @$conds,
532       [ or =>
533         map [ like => $_ => '%' . $name . '%' ],
534         qw(billFirstName billLastName billEmail userId)
535       ];
536   }
537
538   my @ids = BSE::TB::Orders->getColumnBy
539     (
540      "id",
541      $conds,
542      { order => $order }
543     );
544
545   my $search_param;
546   {
547     my @param;
548     for my $key (qw(from to stage name), @simple_search_fields) {
549       for my $value (grep /\S/, $cgi->param($key)) {
550         push @param, "$key=" . escape_uri($value);
551       }
552     }
553     $search_param = join('&amp;', map escape_html($_), @param);
554   }
555
556   my $message = $cgi->param('m');
557   defined $message or $message = '';
558   $message = escape_html($message);
559
560   my $it = BSE::Util::Iterate::Objects->new;
561   my %acts;
562   %acts =
563     (
564      $req->admin_tags,
565      $it->make_paged
566      (
567       data => \@ids,
568       fetch => [ getByPkey => 'BSE::TB::Orders' ],
569       cgi => $req->cgi,
570       single => "order",
571       plural => "orders",
572       session => $req->session,
573       name => "orderlist",
574       perpage_parm => "pp=50",
575      ),
576      title => sub { $title },
577      ifHaveParam => sub { defined $cgi->param($_[0]) },
578      ifParam => sub { $cgi->param($_[0]) },
579      message => $message,
580      ifError => 0,
581      all_order_count => \&tag_all_order_count,
582      search_param => $search_param,
583      query => sub {
584        require JSON;
585        my $json = JSON->new;
586        return $json->encode($conds);
587      },
588      stage_select => [ \&tag_stage_select_search, $req ],
589     );
590   $req->dyn_response("admin/$template", \%acts);
591 }
592
593 =item tag stage_select (search)
594
595 stage_select for order list filtering.
596
597 =cut
598
599 sub tag_stage_select_search {
600   my ($req) = @_;
601
602   my @stages = BSE::TB::Orders->settable_stages;
603   unshift @stages, "";
604   
605   my %stage_labels = BSE::TB::Orders->stage_labels;
606   $stage_labels{""} = "(No stage filter)";
607   my $stage = $req->cgi->param("stage") || "";
608   return popup_menu
609     (
610      -name => "stage",
611      -values => \@stages,
612      -default => $stage,
613      -labels => \%stage_labels,
614     );
615 }
616
617 sub iter_orders {
618   my ($orders, $args) = @_;
619
620   return bse_sort({ id => 'n', total => 'n', filled=>'n' }, $args, @$orders);
621 }
622
623 =item target order_list
624 X<shopadmin targets, order_list>X<order_list target>
625
626 List all completed orders.
627
628 By default limits to the last 30 days.
629
630 =cut
631
632 sub req_order_list {
633   my ($class, $req) = @_;
634
635   my $template = $req->cgi->param('template');
636   unless (defined $template && $template =~ /^\w+$/) {
637     $template = 'order_list';
638   }
639
640   my @conds = 
641     (
642      [ '<>', complete => 0 ],
643     );
644
645   return order_list_low($req, $template, 'Order list', \@conds);
646 }
647
648 =item target order_list_filled
649 X<shopadmin targets, order_list_filled>X<order_list_filled target>
650
651 List all filled orders.
652
653 By default limits to the last 30 days.
654
655 =cut
656
657 sub req_order_list_filled {
658   my ($class, $req) = @_;
659
660   my @conds =
661     (
662      [ '<>', complete => 0 ],
663      [ '<>', filled => 0 ],
664      #[ '<>', paidFor => 0 ],
665     );
666
667   return order_list_low($req, 'order_list_filled', 'Order list - Filled orders',
668                        \@conds);
669 }
670
671 =item target order_list_unfilled
672 X<shopadmin targets, order_list_unfilled>X<order_list_unfilled target>
673
674 List completed but unfilled orders.
675
676 Unlike the other order lists, this lists oldest order first, and does
677 not limit to the last 30 days.
678
679 =cut
680
681 sub req_order_list_unfilled {
682   my ($class, $req) = @_;
683
684   my @conds =
685     (
686      [ '<>', complete => 0 ],
687      [ filled => 0 ],
688     );
689
690   return order_list_low($req, 'order_list_unfilled', 
691                         'Order list - Unfilled orders',
692                         \@conds, { order => 'id asc', datelimit => 0 });
693 }
694
695 sub req_order_list_unpaid {
696   my ($class, $req) = @_;
697
698   my @conds =
699     (
700      [ '<>', complete => 0 ],
701      [ paidFor => 0 ],
702     );
703
704   return order_list_low($req, 'order_list_unpaid', 
705                         'Order list - Unpaid orders', \@conds);
706 }
707
708 =item target order_list_incomplete
709 X<shopadmin targets, order_list_incomplete>X<order_list_incomplete>
710
711 List incomplete orders, ie. orders that the user abandoned before the
712 payment step was complete.
713
714 By default limits to the last 30 days.
715
716 =cut
717
718 sub req_order_list_incomplete {
719   my ($class, $req) = @_;
720
721   my @conds =
722     (
723      [ complete => 0 ]
724     );
725
726   return order_list_low($req, 'order_list_incomplete', 
727                         'Order list - Incomplete orders', \@conds);
728 }
729
730 sub tag_siteuser {
731   my ($order, $rsiteuser, $arg) = @_;
732
733   unless ($$rsiteuser) {
734     $$rsiteuser = $order->siteuser || {};
735   }
736
737   my $siteuser = $$rsiteuser;
738   return '' unless $siteuser->{id};
739
740   my $value = $siteuser->{$arg};
741   defined $value or $value = '';
742
743   return escape_html($value);
744 }
745
746 sub tag_shipping_method_select {
747   my ($self, $order) = @_;
748
749   my @methods = all_shippers();
750
751   return popup_menu
752     (
753      -name => "shipping_name",
754      -values => [ map $_->{id}, @methods ],
755      -labels => { map { $_->{id} => $_->{name} } @methods },
756      -id => "shipping_name",
757      -default => $order->shipping_name,
758     );
759 }
760
761 sub tag_stage_select {
762   my ($self, $req, $order) = @_;
763
764   my @stages = BSE::TB::Orders->settable_stages;
765   
766   my %stage_labels = BSE::TB::Orders->stage_labels;
767   return popup_menu
768     (
769      -name => "stage",
770      -values => \@stages,
771      -default => $order->stage,
772      -labels => \%stage_labels,
773     );
774 }
775
776 =item target order_detail
777
778 Display the details of an order.
779
780 Variables set:
781
782 =over
783
784 =item *
785
786 order - the order being displayed
787
788 =item *
789
790 payment_types - a list of configured payment types
791
792 =item *
793
794 payment_type_desc - a description of the current payment type
795
796 =back
797
798 =cut
799
800 sub req_order_detail {
801   my ($class, $req, $errors) = @_;
802
803   my $cgi = $req->cgi;
804   my $id = $cgi->param('id');
805   if ($id and
806       my $order = BSE::TB::Orders->getByPkey($id)) {
807     my $message = $req->message($errors);
808     my @lines = $order->items;
809     my @products = map { BSE::TB::Products->getByPkey($_->{productId}) } @lines;
810     my $line_index = -1;
811     my $product;
812     my @options;
813     my $option_index = -1;
814     my $siteuser;
815     my $it = BSE::Util::Iterate->new;
816
817     $req->set_variable(order => $order);
818     my @pay_types = payment_types();
819     $req->set_variable(payment_types => \@pay_types);
820     my ($pay_type) = grep $_->{id} == $order->paymentType, @pay_types;
821     $req->set_variable(payment_type_desc => $pay_type ? $pay_type->{desc} : "Unknown");
822     my %acts;
823     %acts =
824       (
825        $req->admin_tags,
826        item => sub { escape_html($lines[$line_index]{$_[0]}) },
827        iterate_items_reset => sub { $line_index = -1 },
828        iterate_items => 
829        sub { 
830          if (++$line_index < @lines ) {
831            $option_index = -1;
832            @options = order_item_opts($req,
833                                       $lines[$line_index],
834                                       $products[$line_index]);
835            return 1;
836          }
837          return 0;
838        },
839        order => [ \&tag_object, $order ],
840        extension =>
841        sub {
842          sprintf("%.2f", $lines[$line_index]{units} * $lines[$line_index]{$_[0]}/100.0)
843        },
844        product => sub { tag_article($products[$line_index], $req->cfg, $_[0]) },
845        script => sub { $ENV{SCRIPT_NAME} },
846        iterate_options_reset => sub { $option_index = -1 },
847        iterate_options => sub { ++$option_index < @options },
848        option => sub { escape_html($options[$option_index]{$_[0]}) },
849        ifOptions => sub { @options },
850        options => sub { nice_options(@options) },
851        message => $message,
852        error_img => [ \&tag_error_img, $errors ],
853        siteuser => [ \&tag_siteuser, $order, \$siteuser, ],
854        $it->make
855        (
856         single => "shipping_method",
857         plural => "shipping_methods",
858         code => \&all_shippers,
859        ),
860        shipping_method_select =>
861        [ tag_shipping_method_select => $class, $order ],
862        stage_select =>
863        [ tag_stage_select => $class, $req, $order ],
864        stage_description => escape_html($order->stage_description($req->language)),
865       );
866
867     return $req->dyn_response('admin/order_detail', \%acts);
868   }
869   else {
870     return $class->req_order_list($req);
871   }
872 }
873
874 sub req_order_filled {
875   my ($class, $req) = @_;
876
877   my $id = $req->cgi->param('id');
878   if ($id and
879       my $order = BSE::TB::Orders->getByPkey($id)) {
880     my $filled = $req->cgi->param('filled');
881     $order->{filled} = $filled;
882     if ($order->{filled}) {
883       $order->{whenFilled} = epoch_to_sql_datetime(time);
884       my $user = $req->user;
885       if ($user) {
886         $order->{whoFilled} = $user->{logon};
887       }
888       else {
889         $order->{whoFilled} = defined($ENV{REMOTE_USER})
890           ? $ENV{REMOTE_USER} : "-unknown-";
891       }
892     }
893     $order->save();
894     if ($req->cgi->param('detail')) {
895       return $class->req_order_detail($req);
896     }
897     else {
898       return $class->req_order_list($req);
899     }
900   }
901   else {
902     return $class->req_order_list($req);
903   }
904 }
905
906 =item target order_paid
907
908 Mark the order identified by C<id> as paid.
909
910 Optionally accepts C<paymentType> which replaces the current payment
911 type.
912
913 Requires csrfp token C<shop_order_paid>.
914
915 =cut
916
917 sub req_order_paid {
918   my ($self, $req) = @_;
919
920   $req->check_csrf("shop_order_paid")
921     or return $self->req_order_list($req, "Bad or missing csrf token: " . $req->csrf_error);
922
923   return $self->_set_order_paid($req, 1);
924 }
925
926 =item target order_unpaid
927
928 Mark the order identified by C<id> as unpaid.
929
930 Requires csrfp token C<shop_order_unpaid>.
931
932 =cut
933
934 sub req_order_unpaid {
935   my ($self, $req) = @_;
936
937   $req->check_csrf("shop_order_unpaid")
938     or return $self->req_order_list($req, "Bad or missing csrf token: " . $req->csrf_error);
939
940   return $self->_set_order_paid($req, 0);
941 }
942
943 sub _set_order_paid {
944   my ($class, $req, $value) = @_;
945
946   my $id = $req->cgi->param('id');
947   if ($id and
948       my $order = BSE::TB::Orders->getByPkey($id)) {
949     if ($order->paidFor != $value) {
950       if ($value) {
951         my $pay_type = $req->cgi->param("paymentType");
952         if (defined $pay_type && $pay_type =~ /^[0-9]+$/) {
953           $order->set_paymentType($pay_type);
954         }
955       }
956       else {
957         $order->is_manually_paid
958           or return $class->req_order_detail($req, "You can only unpay manually paid orders");
959       }
960
961       $order->set_paidFor($value);
962
963       # we want to reset paid_manually if we reset paidFor, so if the
964       # customer pays via the public interface the order doesn't get
965       # treated as manually paid
966       $order->set_paid_manually($value);
967
968       if ($value) {
969         $req->audit
970           (
971            component => "shopadmin:order:paid",
972            level => "notice",
973            object => $order,
974            msg => "Mark Order No. " . $order->id . " as Paid",
975           );
976       }
977       else {
978         $req->audit
979           (
980            component => "shopadmin:order:unpaid",
981            level => "notice",
982            object => $order,
983            msg => "Mark Order No. " . $order->id . " as Unpaid",
984           );
985       }
986       $order->save();
987     }
988
989     return $req->get_refresh
990       ($req->url("shopadmin", { a_order_detail => 1, id => $id }));
991   }
992   else {
993     return $class->req_order_list($req);
994   }
995 }
996
997 sub req_paypal_refund {
998   my ($self, $req) = @_;
999
1000   my $id = $req->cgi->param('id');
1001   if ($id and
1002       my $order = BSE::TB::Orders->getByPkey($id)) {
1003     require BSE::PayPal;
1004     my $msg;
1005     unless (BSE::PayPal->refund_order(order => $order,
1006                                       req => $req,
1007                                       msg => \$msg)) {
1008       return $self->req_order_detail($req, $msg);
1009     }
1010
1011     return $req->get_refresh($req->url(shopadmin => { "a_order_detail" => 1, id => $id }));
1012   }
1013   else {
1014     $req->flash_error("Missing or invalid order id");
1015     return $self->req_order_list($req);
1016   }
1017 }
1018
1019 =item order_save
1020
1021 Make changes to an order, only a limited set of fields can be changed.
1022
1023 Parameters, all optional:
1024
1025 =over
1026
1027 =item *
1028
1029 id - id of the order.  Required.
1030
1031 =item *
1032
1033 shipping_method - if automated shipping calculations are disabled, the
1034 id of the dummy shipping method to set for the order.
1035
1036 =item *
1037
1038 freight_tracking - the freight tracking code for the shipment.
1039
1040 =item *
1041
1042 stage - order stage, one of unprocessed, backorder, picked, shipped,
1043 cancelled.
1044
1045 =back
1046
1047 Requires csrfp token C<shop_order_save>.
1048
1049 =cut
1050
1051 sub req_order_save {
1052   my ($self, $req) = @_;
1053
1054   $req->check_csrf("shop_order_save")
1055     or return $self->req_product_list($req, "Bad or missing csrf token: " . $req->csrf_error);
1056
1057   my $cgi = $req->cgi;
1058   my $id = $cgi->param("id");
1059   $id && $id =~ /^[0-9]+$/
1060     or return $self->req_product_list($req, "No order id supplied");
1061
1062   my $order = BSE::TB::Orders->getByPkey($id)
1063     or return $self->req_product_list($req, "No such order id");
1064
1065   my %errors;
1066   my $save = 0;
1067
1068   my $new_freight_tracking = 0;
1069   my $code = $cgi->param("freight_tracking");
1070   if (defined $code && $code ne $order->freight_tracking) {
1071     $order->set_freight_tracking($code);
1072     ++$new_freight_tracking;
1073     ++$save;
1074   }
1075
1076   my $new_shipping_name = 0;
1077   my $shipping_name = $cgi->param("shipping_name");
1078   if (defined $shipping_name
1079       && $shipping_name ne $order->shipping_name) {
1080     my @ship = all_shippers();
1081     my ($entry) = grep $_->{id} eq $shipping_name, @ship;
1082     if ($entry) {
1083       $order->set_shipping_name($entry->{id});
1084       $order->set_shipping_method($entry->{name});
1085       ++$new_shipping_name;
1086       ++$save;
1087     }
1088     else {
1089       $errors{shipping_method} = "msg:bse/admin/shop/saveorder/badmethod:$shipping_name";
1090     }
1091   }
1092
1093   my $new_stage = 0;
1094   my ($stage) = $cgi->param("stage");
1095   my ($stage_note) = $cgi->param("stage_note");
1096   if (defined $stage && $stage ne $order->stage
1097      || defined $stage_note && $stage_note =~ /\S/) {
1098     my @stages = BSE::TB::Orders->settable_stages;
1099     if (grep $_ eq $stage, @stages) {
1100       ++$new_stage;
1101       ++$save;
1102     }
1103     else {
1104       $errors{stage} = "msg:bse/admin/shop/saveorder/badstage:$stage";
1105     }
1106   }
1107
1108   keys %errors
1109     and return $self->req_order_detail($req, \%errors);
1110
1111   if ($save) {
1112     if ($new_freight_tracking) {
1113       $req->audit
1114         (
1115          component => "shopadmin:orders:saveorder",
1116          object => $order,
1117          msg => "Set Order No. " . $order->id . " freight tracking code to '" . $order->freight_tracking . "'",
1118          level => "notice",
1119         );
1120     }
1121     if ($new_shipping_name) {
1122       $req->audit
1123         (
1124          component => "shopadmin:orders:saveorder",
1125          object => $order,
1126          msg => "Set Order No. " . $order->id . " shippping method to '" . $order->shipping_name . "/" . $order->shipping_method . "'",
1127          level => "notice",
1128         );
1129     }
1130     if ($new_stage) {
1131       $order->new_stage(scalar $req->user, $stage, $stage_note);
1132     }
1133
1134     $order->save;
1135     $req->flash("msg:bse/admin/shop/saveorder/saved");
1136   }
1137   else {
1138     $req->flash("msg:bse/admin/shop/saveorder/nochanges");
1139   }
1140
1141   my $url = $cgi->param("r") || $req->url("shopadmin", { a_order_detail => 1, id => $order->id });
1142
1143   return $req->get_refresh($url);
1144 }
1145
1146 my %coupon_sorts =
1147   (
1148    expiry => "expiry desc",
1149    release => "release desc",
1150    code => "code asc",
1151   );
1152
1153 =item coupon_list
1154
1155 Display a list of coupons.
1156
1157 Accepts two optional parameters:
1158
1159 =over
1160
1161 =item *
1162
1163 C<sort> which can be any of:
1164
1165 =over
1166
1167 =item *
1168
1169 C<expiry> - sort by expiry date descending
1170
1171 =item *
1172
1173 C<release> - sort by release date descending
1174
1175 =item *
1176
1177 C<code> - sort by code ascending
1178
1179 =back
1180
1181 The default and fallback for unknown values is C<expiry>.
1182
1183 =item *
1184
1185 C<all> - if a true value, returns all coupons, otherwise only coupons
1186 modified in the last 60 days, or with a release or expiry date in the
1187 last 60 days are returned.
1188
1189 =back
1190
1191 Allows standard admin tags and variables with the following additional
1192 variable:
1193
1194 =over
1195
1196 =item *
1197
1198 C<coupons> - an array of coupons
1199
1200 =item *
1201
1202 C<coupons_all> - true if all coupons were requested
1203
1204 =item *
1205
1206 C<coupons_sort> - the 
1207
1208 =back
1209
1210 In ajax context returns:
1211
1212   {
1213     success => 1,
1214     coupons => [ coupon, ... ]
1215   }
1216
1217 where each coupon is a hash containing the coupon data, and the key
1218 tiers is a list of tier ids.
1219
1220 Template: F<admin/coupons/list>
1221
1222 =cut
1223
1224 sub req_coupon_list {
1225   my ($self, $req) = @_;
1226
1227   my $sort = $req->cgi->param('sort') || 'expiry';
1228   $sort =~ /^(expiry|code|release)/ or $sort = 'expiry';
1229   my $all = $req->cgi->param('all')  || 0;
1230   my @cond;
1231   unless ($all) {
1232     my $past_60_days = sql_datetime(time() - 60 * 86_400);
1233     @cond = 
1234       (
1235        [ or =>
1236          [ '>', last_modified => $past_60_days ],
1237          [ '>', expiry => $past_60_days ],
1238          [ '>', release => $past_60_days ],
1239        ]
1240       );
1241   }
1242   my $scode = $req->cgi->param('scode');
1243   if ($scode) {
1244     if ($scode =~ /^=(.*)/) {
1245       push @cond, [ '=', code => $1 ];
1246     }
1247     else {
1248       push @cond, [ 'like', code => $scode . '%' ];
1249     }
1250   }
1251   require BSE::TB::Coupons;
1252   my @coupons = BSE::TB::Coupons->getBy2
1253     (
1254      \@cond,
1255      { order => $coupon_sorts{$sort} }
1256     );
1257
1258   if ($req->is_ajax) {
1259     return $req->json_content
1260       (
1261        success => 1,
1262        coupons => [ map $_->json_data, @coupons ],
1263       );
1264   }
1265
1266   $req->set_variable(coupons => \@coupons);
1267   $req->set_variable(coupons_all => $all);
1268   $req->set_variable(coupons_sort => $sort);
1269
1270   my %acts = $req->admin_tags;
1271
1272   return $req->dyn_response('admin/coupons/list', \%acts);
1273 }
1274
1275 # coupon behaviour classes wrapped for use in templates
1276
1277 sub _coupon_behaviours {
1278   my ($self) = @_;
1279
1280   require BSE::TB::Coupons;
1281   my $bclasses = BSE::TB::Coupons->behaviour_classes();
1282   return
1283     [
1284      map
1285      +{
1286        id => $_,
1287        behaviour => Squirrel::Template::Expr::WrapClass->new($bclasses->{$_})
1288       },
1289      sort { lc $bclasses->{$a}->class_description cmp lc $bclasses->{$b}->class_description}
1290      keys %$bclasses
1291     ]
1292 }
1293
1294 =item coupon_addform
1295
1296 Display a form for adding new coupons.
1297
1298 Template: F<admin/coupons/add>
1299
1300 Template variables:
1301
1302 =over
1303
1304 =item *
1305
1306 C<fields> - coupon fields.
1307
1308 =item *
1309
1310 C<coupon> - set to undef.
1311
1312 =item *
1313
1314 C<errors> - an errors from an attempted save.
1315
1316 =item *
1317
1318 C<tiers> - a list of defined price tiers.
1319
1320 =back
1321
1322 =cut
1323
1324 sub req_coupon_addform {
1325   my ($self, $req, $errors) = @_;
1326
1327   my %acts = $req->admin_tags;
1328
1329   $req->message($errors);
1330
1331   require BSE::TB::Coupons;
1332   $req->set_variable(fields => BSE::TB::Coupon->fields);
1333   $req->set_variable(coupon => undef);
1334   $req->set_variable(errors => $errors || {});
1335   require BSE::TB::PriceTiers;
1336   $req->set_variable(tiers => [ BSE::TB::PriceTiers->all ]);
1337   $req->set_variable(behaviours => $self->_coupon_behaviours);
1338
1339   return $req->dyn_response("admin/coupons/add", \%acts);
1340 }
1341
1342 =item coupon_add
1343
1344 Add a new coupon.
1345
1346 Accepts coupon fields.
1347
1348 Tiers are accepted as separate values for the tiers field.
1349
1350 CSRF token: C<admin_bse_coupon_add>
1351
1352 =cut
1353
1354 sub req_coupon_add {
1355   my ($self, $req) = @_;
1356
1357   require BSE::TB::Coupons;
1358   my $fields = BSE::TB::Coupon->fields;
1359   my %errors;
1360   $req->validate(fields => $fields, errors => \%errors,
1361                  rules => BSE::TB::Coupon->rules);
1362   my $values = $req->cgi_fields(fields => $fields);
1363
1364   unless ($errors{classid}) {
1365     my $bh = BSE::TB::Coupons->behaviour_class($values->{classid});
1366     my $bfields = $bh->config_fields();
1367     my $brules = $bh->config_rules();
1368     $req->validate(fields => $bfields, rules => $brules,
1369                    errors => \%errors);
1370     unless (keys %errors) {
1371       $values->{config_obj} = $req->cgi_fields(fields => $bfields);
1372       $bh->config_valid($values->{config_obj}, \%errors);
1373     }
1374   }
1375
1376   unless ($errors{code}) {
1377     my ($other) = BSE::TB::Coupons->getBy(code => $values->{code});
1378     $other
1379       and $errors{code} = "msg:bse/admin/shop/coupons/adddup:$values->{code}";
1380   }
1381
1382   if (keys %errors) {
1383     $req->is_ajax
1384       and return $req->field_error(\%errors);
1385     return $self->req_coupon_addform($req, \%errors);
1386   }
1387
1388   my $coupon = BSE::TB::Coupons->make(%$values);
1389
1390   $req->audit
1391     (
1392      component => "shopadmin:coupon:add",
1393      level => "notice",
1394      msg => "Coupon '" . $coupon->code . "' created",
1395      object => $coupon,
1396      dump => $coupon->json_data,
1397     );
1398
1399   if ($req->is_ajax) {
1400     return $req->json_content
1401       (
1402        success => 1,
1403        coupon => $coupon->json_data,
1404       );
1405   }
1406   else {
1407     $req->flash_notice("msg:bse/admin/shop/coupons/add", [ $coupon ]);
1408
1409     return $req->get_def_refresh($req->cfg->admin_url2("shopadmin", "coupon_list"));
1410   }
1411 }
1412
1413 sub _get_coupon {
1414   my ($self, $req, $rresult) = @_;
1415
1416   my $cgi = $req->cgi;
1417   my $id = $cgi->param("id");
1418   require BSE::TB::Coupons;
1419   my $coupon;
1420   if ($id) {
1421     $coupon = BSE::TB::Coupons->getByPkey($id);
1422   }
1423   else {
1424     my $code = $cgi->param("code");
1425     if ($code) {
1426       ($coupon) = BSE::TB::Coupons->getBy(code => $code);
1427     }
1428   }
1429   unless ($coupon) {
1430     $$rresult = $self->req_coupon_list($req, { id => "Missing id or code" });
1431     return;
1432   }
1433
1434   return $coupon;
1435 }
1436
1437 sub _get_coupon_id {
1438   my ($self, $req, $rresult) = @_;
1439
1440   my $cgi = $req->cgi;
1441   my $id = $cgi->param("id");
1442   require BSE::TB::Coupons;
1443   my $coupon;
1444   if ($id) {
1445     $coupon = BSE::TB::Coupons->getByPkey($id);
1446   }
1447   unless ($coupon) {
1448     $$rresult = $self->req_coupon_list($req, { id => "Missing id or code" });
1449     return;
1450   }
1451
1452   return $coupon;
1453 }
1454
1455 =item coupon_edit
1456
1457 Edit a coupon.
1458
1459 Requires C<id> as a coupon id to edit.
1460
1461 Template: F<admin/coupons/edit>
1462
1463 Template variables:
1464
1465 =over
1466
1467 =item *
1468
1469 C<fields> - coupon fields.
1470
1471 =item *
1472
1473 C<coupon> - the coupon being edited
1474
1475 =item *
1476
1477 C<errors> - an errors from an attempted save.
1478
1479 =item *
1480
1481 C<tiers> - a list of defined price tiers.
1482
1483 =back
1484
1485 =cut
1486
1487 sub req_coupon_edit {
1488   my ($self, $req, $errors) = @_;
1489
1490   my $result;
1491   my $coupon = $self->_get_coupon_id($req, \$result)
1492     or return $result;
1493
1494   my %acts = $req->admin_tags;
1495
1496   $req->message($errors);
1497
1498   require BSE::TB::Coupons;
1499   $req->set_variable(fields => $coupon->fields);
1500   $req->set_variable(coupon => $coupon);
1501   $req->set_variable(errors => $errors || {});
1502   require BSE::TB::PriceTiers;
1503   $req->set_variable(tiers => [ BSE::TB::PriceTiers->all ]);
1504   $req->set_variable(behaviours => $self->_coupon_behaviours);
1505
1506   return $req->dyn_response("admin/coupons/edit", \%acts);
1507 }
1508
1509 =item coupon_save
1510
1511 Save changes to a coupon, accepts:
1512
1513 =over
1514
1515 =item *
1516
1517 C<id> - id of the coupon to save.
1518
1519 =item *
1520
1521 other coupon fields.
1522
1523 =back
1524
1525 CSRF token: C<admin_bse_coupon_save>
1526
1527 =cut
1528
1529 sub req_coupon_save {
1530   my ($self, $req) = @_;
1531
1532   my $result;
1533   my $coupon = $self->_get_coupon_id($req, \$result)
1534     or return $result;
1535
1536   require BSE::TB::Coupons;
1537   my $fields = $coupon->fields;
1538   my %errors;
1539   $req->validate(fields => $fields, errors => \%errors,
1540                  rules => BSE::TB::Coupon->rules);
1541
1542   my $values = $req->cgi_fields(fields => $fields);
1543
1544   unless ($errors{classid}) {
1545     my $bh = BSE::TB::Coupons->behaviour_class($values->{classid});
1546     my $bfields = $bh->config_fields();
1547     my $brules = $bh->config_rules();
1548     $req->validate(fields => $bfields, rules => $brules,
1549                    errors => \%errors);
1550     unless (keys %errors) {
1551       $values->{config_obj} = $req->cgi_fields(fields => $bfields);
1552       $bh->config_valid($values->{config_obj}, \%errors);
1553     }
1554   }
1555
1556   unless ($errors{code}) {
1557     my ($other) = BSE::TB::Coupons->getBy(code => $values->{code});
1558     $other && $other->id != $coupon->id
1559       and $errors{code} = "msg:bse/admin/shop/coupons/editdup:$values->{code}";
1560   }
1561
1562   if (keys %errors) {
1563     $req->is_ajax
1564       and return $req->field_error(\%errors);
1565     return $self->req_coupon_edit($req, \%errors);
1566   }
1567
1568   my $old = $coupon->json_data;
1569
1570   my $tiers = delete $values->{tiers};
1571   my $config_obj = delete $values->{config_obj};
1572   for my $key (keys %$values) {
1573     $coupon->set($key => $values->{$key});
1574   }
1575   $coupon->set_tiers($tiers);
1576   $coupon->set_config_obj($config_obj);
1577   $coupon->save;
1578
1579   $req->audit
1580     (
1581      component => "shopadmin:coupon:edit",
1582      level => "notice",
1583      msg => "Coupon '" . $coupon->code . "' modified",
1584      object => $coupon,
1585      dump =>
1586      {
1587       old => $old,
1588       new => $coupon->json_data,
1589       type => "edit",
1590      }
1591     );
1592
1593   if ($req->is_ajax) {
1594     return $req->json_content
1595       (
1596        success => 1,
1597        coupon => $coupon->json_data,
1598       );
1599   }
1600   else {
1601     $req->flash_notice("msg:bse/admin/shop/coupons/save", [ $coupon ]);
1602
1603     return $req->get_def_refresh($req->cfg->admin_url2("shopadmin", "coupon_list"));
1604   }
1605 }
1606
1607 =item coupon_deleteform
1608
1609 Prompt for deletion of a coupon
1610
1611 Requires C<id> as a coupon id to elete.
1612
1613 Template: F<admin/coupons/delete>
1614
1615 =cut
1616
1617 sub req_coupon_deleteform {
1618   my ($self, $req) = @_;
1619
1620   my $result;
1621   my $coupon = $self->_get_coupon_id($req, \$result)
1622     or return $result;
1623
1624   unless ($coupon->is_removable) {
1625     $req->flash_error("msg:bse/admin/shop/coupons/not_deletable", [ $coupon ]);
1626     return $self->req_coupon_list($req);
1627   }
1628
1629   my %acts = $req->admin_tags;
1630
1631   require BSE::TB::Coupons;
1632   $req->set_variable(fields => BSE::TB::Coupon->fields);
1633   $req->set_variable(coupon => $coupon);
1634
1635   return $req->dyn_response("admin/coupons/delete", \%acts);
1636 }
1637
1638 =item coupon_delete
1639
1640 Delete a coupon
1641
1642 Requires C<id> as a coupon id to delete.
1643
1644 CSRF token: C<admin_bse_coupon_delete>
1645
1646 =cut
1647
1648 sub req_coupon_delete {
1649   my ($self, $req) = @_;
1650
1651   my $result;
1652   my $coupon = $self->_get_coupon_id($req, \$result)
1653     or return $result;
1654
1655   unless ($coupon->is_removable) {
1656     $req->flash_error("msg:bse/admin/shop/coupons/not_deletable", [ $coupon ]);
1657     return $self->req_coupon_list($req);
1658   }
1659
1660   my $code = $coupon->code;
1661
1662   $req->audit
1663     (
1664      component => "shopadmin:coupon:delete",
1665      level => "notice",
1666      msg => "Coupon '$code' deleted",
1667      object => $coupon,
1668      dump => $coupon->json_data,
1669     );
1670
1671   $coupon->remove;
1672
1673   if ($req->is_ajax) {
1674     return $req->json_content(success => 1);
1675   }
1676   else {
1677     $req->flash_notice("msg:bse/admin/shop/coupons/delete", [ $code ]);
1678
1679     return $req->get_def_refresh($req->cfg->admin_url2("shopadmin", "coupon_list"));
1680   }
1681 }
1682
1683 #####################
1684 # utilities
1685 # perhaps some of these belong in a class...
1686
1687
1688 # convert an epoch time to sql format
1689 sub epoch_to_sql {
1690   use POSIX 'strftime';
1691   my ($time) = @_;
1692
1693   return strftime('%Y-%m-%d', localtime $time);
1694 }
1695
1696 # convert an epoch time to sql format
1697 sub epoch_to_sql_datetime {
1698   use POSIX 'strftime';
1699   my ($time) = @_;
1700
1701   return strftime('%Y-%m-%d %H:%M', localtime $time);
1702 }
1703
1704
1705 sub all_shippers {
1706   require BSE::Shipping;
1707
1708   my $cfg = BSE::Cfg->single;
1709   my @shippers = BSE::TB::Orders->dummy_shipping_methods;
1710   if ($cfg->entry("shop", "shipping", 0)) {
1711     my @normal = BSE::Shipping->get_couriers($cfg);
1712     push @shippers, map 
1713       +{
1714         id => $_->name,
1715         name => $_->description
1716        }, @normal;
1717   }
1718
1719   return @shippers;
1720 }
1721
1722 1;
1723
1724 __END__
1725
1726 =head1 NAME
1727
1728 shopadmin.pl - administration for the online-store tables
1729
1730 =head1 SYNOPSYS
1731
1732 (This is a CGI script.)
1733
1734 =head1 DESCRIPTION
1735
1736 shopadmin.pl gives a UI to edit the product table, and view the orders and 
1737 order_item tables.
1738
1739 =head1 TEMPLATES
1740
1741 shopadmin.pl uses a few templates from the templates/admin directory.
1742
1743 =head2 product_list.tmpl
1744
1745 =over 4
1746
1747 =item product I<name>
1748
1749 Access to product fields.
1750
1751 =item date I<name>
1752
1753 Formats the I<name> field of the product as a date.
1754
1755 =item money I<name>
1756
1757 Formats the I<name> integer field as a 2 decimal place money value.
1758
1759 =item iterator ... products
1760
1761 Iterates over the products database in reverse expire order.
1762
1763 =item script
1764
1765 The name of the current script for use in URLs.
1766
1767 =item message
1768
1769 An error message that may have been passed in the 'message' parameter.
1770
1771 =item hiddenNote
1772
1773 'Deleted' if the expire date of the current product has passed.
1774
1775 =back
1776
1777 =head2 add_product.tmpl
1778 =head2 edit_product.tmpl
1779 =head2 product_detail.tmpl
1780
1781 These use the same tags.
1782
1783 =over 4
1784
1785 =item product I<name>
1786
1787 The specified field of the product.
1788
1789 =item date I<name>
1790
1791 Formats the given field of the product as a date.
1792
1793 =item money I<name>
1794
1795 Formats the given integer field of the product as money.
1796
1797 =item action
1798
1799 Either 'Add New' or 'Edit'.
1800
1801 =item message
1802
1803 The message parameter passed into the script.
1804
1805 =item script
1806
1807 The name of the script, for use in urls.
1808
1809 =item ifImage
1810
1811 Conditional, true if the product has an image.
1812
1813 =item hiddenNote
1814
1815 "Hidden" if the product is hidden.
1816
1817 =back
1818
1819 =head2 order_list.tmpl
1820
1821 Used to display the list of orders.  You can also specify a template
1822 parameter to the order_list target, and perform filtering and sorting
1823 within the template.
1824
1825 =over 4
1826
1827 =item order I<name>
1828
1829 The given field of the order.
1830
1831 =item iterator ... orders [filter-sort-spec]
1832
1833 Iterates over the orders in reverse orderDate order.
1834
1835 The [filter-sort-spec] can contain none, either or both of the following:
1836
1837 =over
1838
1839 =item filter= field op value, ...
1840
1841 filter the data by checking the given expression.
1842
1843 eg. filter= filled == 0
1844
1845 =item sort= [+|-] keyword, ...
1846
1847 Sorts the result by the specified fields, in reverse if preceded by '-'.
1848
1849 =back
1850
1851 =item money I<name>
1852
1853 The given field of the current order formatted as money.
1854
1855 =item date I<name>
1856
1857 The given field of the current order formatted as a date.
1858
1859 =item script
1860
1861 The name of the script, for use in urls.
1862
1863 =back
1864
1865 =head2 order_detail.tmpl
1866
1867 Used to display the details for an order.
1868
1869 =over 4
1870
1871 =item item I<name>
1872
1873 Displays the given field of a line item
1874
1875 =item iterator ... items
1876
1877 Iterates over the line items in the order.
1878
1879 =item order I<name>
1880
1881 The given field of the order.
1882
1883 =item money I<func> I<args>
1884
1885 Formats the given functions return value as money.
1886
1887 =item date I<func> I<args>
1888
1889 Formats the  given function return value as a date.
1890
1891 =item extension I<name>
1892
1893 Takes the given field for the current item multiplied by the units column.
1894
1895 =item product I<name>
1896
1897 The given product field of the product for the current item.
1898
1899 =item script
1900
1901 The name of the current script (for use in urls).
1902
1903 =item iterator ... options
1904
1905 Iterates over the options set for the current order item.
1906
1907 =item option I<field>
1908
1909 Access to a field of the option, any of id, value, desc or label.
1910
1911 =item ifOptions
1912
1913 Conditional tag, true if the current product has any options.
1914
1915 =item options
1916
1917 A laid-out list of the options set for the current order item.
1918
1919 =back
1920
1921 =cut
1922