]> git.imager.perl.org - bse.git/blame - site/cgi-bin/modules/BSE/UI/AdminShop.pm
allow purchase of products with missing options
[bse.git] / site / cgi-bin / modules / BSE / UI / AdminShop.pm
CommitLineData
4d764c34
TC
1package BSE::UI::AdminShop;
2use strict;
3use base 'BSE::UI::AdminDispatch';
10dd37f9
AO
4use BSE::TB::Products;
5use BSE::TB::Product;
4d764c34
TC
6use BSE::TB::Orders;
7use BSE::TB::OrderItems;
8use BSE::Template;
4d764c34 9use Constants qw(:shop $SHOPID $PRODUCTPARENT
771ab646 10 $SHOP_URI $CGI_URI $AUTO_GENERATE);
f40af7e2 11use BSE::TB::Images;
e0ed81d7 12use BSE::TB::Articles;
4d764c34 13use BSE::Sort;
ea71fc0d 14use BSE::Util::Tags qw(tag_hash tag_error_img tag_object_plain tag_object tag_article);
4d764c34
TC
15use BSE::Util::Iterate;
16use BSE::WebUtil 'refresh_to_admin';
3f9c8a96 17use BSE::Util::HTML qw(:default popup_menu);
4d764c34 18use BSE::Arrows;
b62cae00 19use BSE::Shop::Util qw(:payment order_item_opts nice_options payment_types);
771ab646 20use BSE::CfgInfo qw(cfg_dist_image_uri);
023761bd
TC
21use BSE::Util::SQL qw/now_sqldate sql_to_date date_to_sql sql_date sql_datetime/;
22use BSE::Util::Valid qw/valid_date/;
4d764c34 23
b55d4af1 24our $VERSION = "1.030";
cb7fd78d 25
4d764c34
TC
26my %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',
14604ada
TC
35 order_paid => 'shop_order_paid',
36 order_unpaid => 'shop_order_unpaid',
080fc207 37 order_save => 'shop_order_save',
4d764c34
TC
38 product_detail => '',
39 product_list => '',
13a986ee 40 paypal_refund => 'bse_shop_order_refund_paypal',
023761bd
TC
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',
4d764c34
TC
48 );
49
50sub actions {
51 \%actions;
52}
53
54sub rights {
55 \%actions;
56}
57
58sub default_action {
59 'product_list'
60}
61
62sub action_prefix {
63 ''
64}
65
023761bd
TC
66my %csrfp =
67 (
68 coupon_add => { token => "admin_bse_coupon_add", target => "coupon_addform" },
69 coupon_save => { token => "admin_bse_coupon_edit", target => "coupon_edit" },
446ab035 70 coupon_delete => { token => "admin_bse_coupon_delete", target => "coupon_deleteform" },
023761bd
TC
71 );
72
73sub csrfp_tokens {
74 \%csrfp;
75}
76
4d764c34
TC
77#####################
78# product management
79
80sub embedded_catalog {
81 my ($req, $catalog, $template) = @_;
82
83 my $session = $req->session;
84 use POSIX 'strftime';
10dd37f9 85 my $products = BSE::TB::Products->new;
4d764c34
TC
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 }
f09e8b4f 94 @list = grep UNIVERSAL::isa($_->{generator}, 'BSE::Generate::Product'), $catalog->allkids;
4d764c34
TC
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} }
46541e94 104 grep $_->{generator} eq 'BSE::Generate::Catalog',
e0ed81d7 105 BSE::TB::Articles->children($catalog->{id});
4d764c34 106
771ab646
TC
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" />!;
4d764c34
TC
109
110 my %acts;
111 %acts =
112 (
88c41621 113 $req->admin_tags,
4d764c34 114 catalog => [ \&tag_hash, $catalog ],
4d764c34
TC
115 iterate_products_reset => sub { $list_index = -1; },
116 iterate_products =>
117 sub {
118 return ++$list_index < @list;
119 },
21fa9a5c
TC
120 product =>
121 sub {
122 $list_index >= 0 && $list_index < @list
123 or return '** outside products iterator **';
ea71fc0d
TC
124 my $product = $list[$list_index];
125 return tag_article($product, $req->cfg, $_[0]);
21fa9a5c 126 },
4d764c34
TC
127 ifProducts => sub { @list },
128 iterate_subcats_reset =>
129 sub {
130 $subcat_index = -1;
131 },
132 iterate_subcats => sub { ++$subcat_index < @subcats },
ea71fc0d 133 subcat => sub { tag_article($subcats[$subcat_index], $req->cfg, $_[0]) },
4d764c34
TC
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
203sub 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');
e0ed81d7 209 my $shop = BSE::TB::Articles->getByPkey($shopid);
4d764c34 210 my @catalogs = sort { $b->{displayOrder} <=> $a->{displayOrder} }
e0ed81d7 211 grep $_->{generator} eq 'BSE::Generate::Catalog', BSE::TB::Articles->children($shopid);
4d764c34 212 my $catalog_index = -1;
023761bd 213 $message = $req->message($message);
4d764c34
TC
214 if (defined $cgi->param('showstepkids')) {
215 $session->{showstepkids} = $cgi->param('showstepkids');
216 }
217 exists $session->{showstepkids} or $session->{showstepkids} = 1;
10dd37f9 218 my $products = BSE::TB::Products->new;
4d764c34
TC
219 my @products = sort { $b->{displayOrder} <=> $a->{displayOrder} }
220 $products->getBy(parentid => $shopid);
221 my $product_index;
222
771ab646
TC
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" />!;
4d764c34
TC
225
226 my $it = BSE::Util::Iterate->new;
227
228 my %acts;
229 %acts =
230 (
88c41621 231 $req->admin_tags,
ea71fc0d 232 catalog=> sub { tag_article($catalogs[$catalog_index], $req->cfg, $_[0]) },
4d764c34
TC
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
305sub req_product_detail {
306 my ($class, $req) = @_;
307
308 my $cgi = $req->cgi;
309 my $id = $cgi->param('id');
310 if ($id and
10dd37f9 311 my $product = BSE::TB::Products->getByPkey($id)) {
4d764c34
TC
312 return product_form($req, $product, '', '', 'admin/product_detail');
313 }
314 else {
315 return $class->req_product_list($req);
316 }
317}
318
319sub product_form {
320 my ($req, $product, $action, $message, $template) = @_;
321
322 my $cgi = $req->cgi;
323 $message ||= $cgi->param('m') || $cgi->param('message') || '';
7a4ea074 324 $template ||= 'admin/product_detail';
4d764c34
TC
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} }
46541e94 333 grep $_->{generator} eq 'BSE::Generate::Catalog',
e0ed81d7 334 BSE::TB::Articles->children($parent);
4d764c34
TC
335 $title .= ' / ' if $title;
336 unshift(@work, map [ $_->{id}, $title.$_->{title} ], @kids);
337 }
338 my @files;
339 if ($product->{id}) {
6430ee52
TC
340 require BSE::TB::ArticleFiles;
341 @files = BSE::TB::ArticleFiles->getBy(articleId=>$product->{id});
4d764c34
TC
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;
0c2d3f00 360 use BSE::TB::OtherParents;
4d764c34
TC
361 # ugh
362 my $realproduct;
10dd37f9 363 $realproduct = UNIVERSAL::isa($product, 'BSE::TB::Product') ? $product : BSE::TB::Products->getByPkey($product->{id});
4d764c34 364 my @stepcats;
0c2d3f00 365 @stepcats = BSE::TB::OtherParents->getBy(childId=>$product->{id})
4d764c34
TC
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;
4d764c34 376
771ab646
TC
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" />!;
4d764c34
TC
379
380 my %acts;
381 %acts =
382 (
573f6f84 383 $req->admin_tags,
4d764c34
TC
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 },
ea71fc0d 391 product => [ \&tag_article, $product, $req->cfg ],
4d764c34
TC
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" },
4d764c34
TC
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
833289fc
TC
447=item tag all_order_count
448X<tags, shop admin, all_order_count>C<all_order_count>
449
450Returns a count of orders matching a set of conditions.
451
452=cut
453
454sub 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
4d764c34
TC
471#####################
472# order management
473
474sub order_list_low {
833289fc 475 my ($req, $template, $title, $conds, $options) = @_;
4d764c34
TC
476
477 my $cgi = $req->cgi;
478
833289fc
TC
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
4d764c34
TC
485 my $from = $cgi->param('from');
486 my $to = $cgi->param('to');
4d764c34
TC
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 }
833289fc
TC
501 if ($datelimit) {
502 $from ||= sql_date(time() - 30 * 86_400);
503 }
4d764c34
TC
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));
833289fc
TC
509 push @$conds,
510 [ between => 'orderDate', $from, $to." 23:59:59" ];
4d764c34 511 }
173020d7
TC
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
833289fc
TC
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;
173020d7
TC
548 for my $key (qw(from to stage name), @simple_search_fields) {
549 for my $value (grep /\S/, $cgi->param($key)) {
833289fc
TC
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;
4d764c34
TC
561 my %acts;
562 %acts =
563 (
833289fc
TC
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 ),
4d764c34
TC
576 title => sub { $title },
577 ifHaveParam => sub { defined $cgi->param($_[0]) },
578 ifParam => sub { $cgi->param($_[0]) },
4d764c34 579 message => $message,
833289fc
TC
580 ifError => 0,
581 all_order_count => \&tag_all_order_count,
582 search_param => $search_param,
173020d7
TC
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 ],
4d764c34
TC
589 );
590 $req->dyn_response("admin/$template", \%acts);
591}
592
173020d7
TC
593=item tag stage_select (search)
594
595stage_select for order list filtering.
596
597=cut
598
599sub 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
4d764c34
TC
617sub iter_orders {
618 my ($orders, $args) = @_;
619
620 return bse_sort({ id => 'n', total => 'n', filled=>'n' }, $args, @$orders);
621}
622
833289fc
TC
623=item target order_list
624X<shopadmin targets, order_list>X<order_list target>
625
626List all completed orders.
627
628By default limits to the last 30 days.
629
630=cut
631
4d764c34
TC
632sub req_order_list {
633 my ($class, $req) = @_;
634
4d764c34
TC
635 my $template = $req->cgi->param('template');
636 unless (defined $template && $template =~ /^\w+$/) {
637 $template = 'order_list';
638 }
639
833289fc
TC
640 my @conds =
641 (
642 [ '<>', complete => 0 ],
643 );
644
645 return order_list_low($req, $template, 'Order list', \@conds);
4d764c34
TC
646}
647
833289fc
TC
648=item target order_list_filled
649X<shopadmin targets, order_list_filled>X<order_list_filled target>
650
651List all filled orders.
652
653By default limits to the last 30 days.
654
655=cut
656
4d764c34
TC
657sub req_order_list_filled {
658 my ($class, $req) = @_;
659
833289fc
TC
660 my @conds =
661 (
662 [ '<>', complete => 0 ],
663 [ '<>', filled => 0 ],
664 #[ '<>', paidFor => 0 ],
665 );
4d764c34 666
833289fc
TC
667 return order_list_low($req, 'order_list_filled', 'Order list - Filled orders',
668 \@conds);
4d764c34
TC
669}
670
833289fc
TC
671=item target order_list_unfilled
672X<shopadmin targets, order_list_unfilled>X<order_list_unfilled target>
673
674List completed but unfilled orders.
675
676Unlike the other order lists, this lists oldest order first, and does
677not limit to the last 30 days.
678
679=cut
680
4d764c34
TC
681sub req_order_list_unfilled {
682 my ($class, $req) = @_;
683
833289fc
TC
684 my @conds =
685 (
686 [ '<>', complete => 0 ],
687 [ filled => 0 ],
688 );
4d764c34
TC
689
690 return order_list_low($req, 'order_list_unfilled',
833289fc
TC
691 'Order list - Unfilled orders',
692 \@conds, { order => 'id asc', datelimit => 0 });
4d764c34
TC
693}
694
695sub req_order_list_unpaid {
696 my ($class, $req) = @_;
697
833289fc
TC
698 my @conds =
699 (
700 [ '<>', complete => 0 ],
701 [ paidFor => 0 ],
702 );
4d764c34
TC
703
704 return order_list_low($req, 'order_list_unpaid',
833289fc 705 'Order list - Unpaid orders', \@conds);
4d764c34
TC
706}
707
833289fc
TC
708=item target order_list_incomplete
709X<shopadmin targets, order_list_incomplete>X<order_list_incomplete>
710
711List incomplete orders, ie. orders that the user abandoned before the
712payment step was complete.
713
714By default limits to the last 30 days.
715
716=cut
717
4d764c34
TC
718sub req_order_list_incomplete {
719 my ($class, $req) = @_;
720
833289fc
TC
721 my @conds =
722 (
723 [ complete => 0 ]
724 );
4d764c34
TC
725
726 return order_list_low($req, 'order_list_incomplete',
833289fc 727 'Order list - Incomplete orders', \@conds);
4d764c34
TC
728}
729
4d764c34
TC
730sub 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
080fc207
TC
746sub tag_shipping_method_select {
747 my ($self, $order) = @_;
748
6f0799a4 749 my @methods = all_shippers();
080fc207
TC
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
f0722dd2
TC
761sub 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
b62cae00
TC
776=item target order_detail
777
778Display the details of an order.
779
780Variables set:
781
782=over
783
784=item *
785
786order - the order being displayed
787
788=item *
789
790payment_types - a list of configured payment types
791
792=item *
793
794payment_type_desc - a description of the current payment type
795
796=back
797
798=cut
799
4d764c34 800sub req_order_detail {
080fc207 801 my ($class, $req, $errors) = @_;
4d764c34
TC
802
803 my $cgi = $req->cgi;
804 my $id = $cgi->param('id');
805 if ($id and
806 my $order = BSE::TB::Orders->getByPkey($id)) {
080fc207 807 my $message = $req->message($errors);
4d764c34 808 my @lines = $order->items;
10dd37f9 809 my @products = map { BSE::TB::Products->getByPkey($_->{productId}) } @lines;
4d764c34
TC
810 my $line_index = -1;
811 my $product;
812 my @options;
813 my $option_index = -1;
814 my $siteuser;
080fc207
TC
815 my $it = BSE::Util::Iterate->new;
816
b62cae00
TC
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");
4d764c34
TC
822 my %acts;
823 %acts =
824 (
080fc207 825 $req->admin_tags,
4d764c34
TC
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;
58baa27b
TC
832 @options = order_item_opts($req,
833 $lines[$line_index],
834 $products[$line_index]);
4d764c34
TC
835 return 1;
836 }
837 return 0;
838 },
f0722dd2 839 order => [ \&tag_object, $order ],
4d764c34
TC
840 extension =>
841 sub {
842 sprintf("%.2f", $lines[$line_index]{units} * $lines[$line_index]{$_[0]}/100.0)
843 },
65c27d05 844 product => sub { tag_article($products[$line_index], $req->cfg, $_[0]) },
4d764c34
TC
845 script => sub { $ENV{SCRIPT_NAME} },
846 iterate_options_reset => sub { $option_index = -1 },
847 iterate_options => sub { ++$option_index < @options },
c4f0aab9 848 option => sub { escape_html($options[$option_index]{$_[0]}) },
4d764c34
TC
849 ifOptions => sub { @options },
850 options => sub { nice_options(@options) },
080fc207
TC
851 message => $message,
852 error_img => [ \&tag_error_img, $errors ],
4d764c34 853 siteuser => [ \&tag_siteuser, $order, \$siteuser, ],
080fc207
TC
854 $it->make
855 (
856 single => "shipping_method",
857 plural => "shipping_methods",
6f0799a4 858 code => \&all_shippers,
080fc207
TC
859 ),
860 shipping_method_select =>
861 [ tag_shipping_method_select => $class, $order ],
f0722dd2
TC
862 stage_select =>
863 [ tag_stage_select => $class, $req, $order ],
864 stage_description => escape_html($order->stage_description($req->language)),
4d764c34
TC
865 );
866
867 return $req->dyn_response('admin/order_detail', \%acts);
868 }
869 else {
870 return $class->req_order_list($req);
871 }
872}
873
874sub 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
b62cae00
TC
906=item target order_paid
907
908Mark the order identified by C<id> as paid.
909
910Optionally accepts C<paymentType> which replaces the current payment
911type.
912
913Requires csrfp token C<shop_order_paid>.
914
915=cut
916
14604ada 917sub req_order_paid {
b62cae00 918 my ($self, $req) = @_;
14604ada 919
b62cae00
TC
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);
14604ada
TC
924}
925
b62cae00
TC
926=item target order_unpaid
927
928Mark the order identified by C<id> as unpaid.
929
930Requires csrfp token C<shop_order_unpaid>.
931
932=cut
933
14604ada 934sub req_order_unpaid {
b62cae00 935 my ($self, $req) = @_;
14604ada 936
b62cae00
TC
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);
14604ada
TC
941}
942
943sub _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) {
b62cae00
TC
951 my $pay_type = $req->cgi->param("paymentType");
952 if (defined $pay_type && $pay_type =~ /^[0-9]+$/) {
953 $order->set_paymentType($pay_type);
954 }
14604ada
TC
955 }
956 else {
b62cae00 957 $order->is_manually_paid
14604ada
TC
958 or return $class->req_order_detail($req, "You can only unpay manually paid orders");
959 }
960
961 $order->set_paidFor($value);
b62cae00 962
7070c3db
TC
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
b62cae00
TC
968 if ($value) {
969 $req->audit
970 (
971 component => "shopadmin:order:paid",
d9c45dcc 972 level => "notice",
b62cae00 973 object => $order,
68d44fe0 974 msg => "Mark Order No. " . $order->id . " as Paid",
b62cae00
TC
975 );
976 }
977 else {
978 $req->audit
979 (
980 component => "shopadmin:order:unpaid",
d9c45dcc 981 level => "notice",
b62cae00 982 object => $order,
68d44fe0 983 msg => "Mark Order No. " . $order->id . " as Unpaid",
b62cae00
TC
984 );
985 }
14604ada
TC
986 $order->save();
987 }
988
1b0b485d
TC
989 return $req->get_refresh
990 ($req->url("shopadmin", { a_order_detail => 1, id => $id }));
14604ada
TC
991 }
992 else {
993 return $class->req_order_list($req);
994 }
995}
996
13a986ee
TC
997sub 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
080fc207
TC
1019=item order_save
1020
1021Make changes to an order, only a limited set of fields can be changed.
1022
f0722dd2 1023Parameters, all optional:
080fc207
TC
1024
1025=over
1026
1027=item *
1028
1029id - id of the order. Required.
1030
1031=item *
1032
1033shipping_method - if automated shipping calculations are disabled, the
1034id of the dummy shipping method to set for the order.
1035
1036=item *
1037
1038freight_tracking - the freight tracking code for the shipment.
1039
f0722dd2
TC
1040=item *
1041
1042stage - order stage, one of unprocessed, backorder, picked, shipped,
1043cancelled.
1044
080fc207
TC
1045=back
1046
1047Requires csrfp token C<shop_order_save>.
1048
1049=cut
1050
1051sub 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;
6f0799a4
TC
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";
080fc207
TC
1090 }
1091 }
1092
f0722dd2
TC
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
080fc207
TC
1108 keys %errors
1109 and return $self->req_order_detail($req, \%errors);
1110
1111 if ($save) {
080fc207
TC
1112 if ($new_freight_tracking) {
1113 $req->audit
1114 (
1115 component => "shopadmin:orders:saveorder",
1116 object => $order,
68d44fe0 1117 msg => "Set Order No. " . $order->id . " freight tracking code to '" . $order->freight_tracking . "'",
d9c45dcc 1118 level => "notice",
080fc207
TC
1119 );
1120 }
1121 if ($new_shipping_name) {
1122 $req->audit
1123 (
1124 component => "shopadmin:orders:saveorder",
1125 object => $order,
68d44fe0 1126 msg => "Set Order No. " . $order->id . " shippping method to '" . $order->shipping_name . "/" . $order->shipping_method . "'",
d9c45dcc 1127 level => "notice",
080fc207
TC
1128 );
1129 }
f0722dd2
TC
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");
080fc207
TC
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
023761bd
TC
1146my %coupon_sorts =
1147 (
1148 expiry => "expiry desc",
1149 release => "release desc",
1150 code => "code asc",
1151 );
1152
1153=item coupon_list
1154
1155Display a list of coupons.
1156
1157Accepts two optional parameters:
1158
1159=over
1160
1161=item *
1162
1163C<sort> which can be any of:
1164
1165=over
1166
1167=item *
1168
1169C<expiry> - sort by expiry date descending
1170
1171=item *
1172
1173C<release> - sort by release date descending
1174
1175=item *
1176
1177C<code> - sort by code ascending
1178
1179=back
1180
1181The default and fallback for unknown values is C<expiry>.
1182
1183=item *
1184
1185C<all> - if a true value, returns all coupons, otherwise only coupons
1186modified in the last 60 days, or with a release or expiry date in the
1187last 60 days are returned.
1188
1189=back
1190
1191Allows standard admin tags and variables with the following additional
1192variable:
1193
1194=over
1195
1196=item *
1197
1198C<coupons> - an array of coupons
1199
1200=item *
1201
1202C<coupons_all> - true if all coupons were requested
1203
1204=item *
1205
1206C<coupons_sort> - the
1207
1208=back
1209
1210In ajax context returns:
1211
1212 {
1213 success => 1,
1214 coupons => [ coupon, ... ]
1215 }
1216
1217where each coupon is a hash containing the coupon data, and the key
1218tiers is a list of tier ids.
1219
1220Template: F<admin/coupons/list>
1221
1222=cut
1223
1224sub 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
b55d4af1
TC
1275# coupon behaviour classes wrapped for use in templates
1276
1277sub _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
023761bd
TC
1294=item coupon_addform
1295
1296Display a form for adding new coupons.
1297
1298Template: F<admin/coupons/add>
1299
78e38142
TC
1300Template variables:
1301
1302=over
1303
1304=item *
1305
1306C<fields> - coupon fields.
1307
1308=item *
1309
1310C<coupon> - set to undef.
1311
1312=item *
1313
1314C<errors> - an errors from an attempted save.
1315
1316=item *
1317
1318C<tiers> - a list of defined price tiers.
1319
1320=back
1321
023761bd
TC
1322=cut
1323
1324sub 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 || {});
78e38142
TC
1335 require BSE::TB::PriceTiers;
1336 $req->set_variable(tiers => [ BSE::TB::PriceTiers->all ]);
b55d4af1 1337 $req->set_variable(behaviours => $self->_coupon_behaviours);
023761bd
TC
1338
1339 return $req->dyn_response("admin/coupons/add", \%acts);
1340}
1341
1342=item coupon_add
1343
1344Add a new coupon.
1345
1346Accepts coupon fields.
1347
1348Tiers are accepted as separate values for the tiers field.
1349
1350CSRF token: C<admin_bse_coupon_add>
1351
1352=cut
1353
1354sub 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);
023761bd
TC
1362 my $values = $req->cgi_fields(fields => $fields);
1363
b55d4af1
TC
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
023761bd
TC
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
7f8a63a1
TC
1390 $req->audit
1391 (
1392 component => "shopadmin:coupon:add",
88c9c249 1393 level => "notice",
7f8a63a1
TC
1394 msg => "Coupon '" . $coupon->code . "' created",
1395 object => $coupon,
1396 dump => $coupon->json_data,
1397 );
1398
023761bd
TC
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
1413sub _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
1437sub _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
1457Edit a coupon.
1458
1459Requires C<id> as a coupon id to edit.
1460
1461Template: F<admin/coupons/edit>
1462
78e38142
TC
1463Template variables:
1464
1465=over
1466
1467=item *
1468
1469C<fields> - coupon fields.
1470
1471=item *
1472
1473C<coupon> - the coupon being edited
1474
1475=item *
1476
1477C<errors> - an errors from an attempted save.
1478
1479=item *
1480
1481C<tiers> - a list of defined price tiers.
1482
1483=back
1484
023761bd
TC
1485=cut
1486
1487sub 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;
2ced88e0 1499 $req->set_variable(fields => $coupon->fields);
023761bd
TC
1500 $req->set_variable(coupon => $coupon);
1501 $req->set_variable(errors => $errors || {});
78e38142
TC
1502 require BSE::TB::PriceTiers;
1503 $req->set_variable(tiers => [ BSE::TB::PriceTiers->all ]);
b55d4af1 1504 $req->set_variable(behaviours => $self->_coupon_behaviours);
023761bd
TC
1505
1506 return $req->dyn_response("admin/coupons/edit", \%acts);
1507}
1508
1509=item coupon_save
1510
1511Save changes to a coupon, accepts:
1512
1513=over
1514
1515=item *
1516
1517C<id> - id of the coupon to save.
1518
1519=item *
1520
1521other coupon fields.
1522
1523=back
1524
1525CSRF token: C<admin_bse_coupon_save>
1526
1527=cut
1528
1529sub 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;
2ced88e0 1537 my $fields = $coupon->fields;
023761bd
TC
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
b55d4af1
TC
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
023761bd
TC
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
7f8a63a1
TC
1568 my $old = $coupon->json_data;
1569
023761bd 1570 my $tiers = delete $values->{tiers};
b55d4af1 1571 my $config_obj = delete $values->{config_obj};
023761bd
TC
1572 for my $key (keys %$values) {
1573 $coupon->set($key => $values->{$key});
1574 }
1575 $coupon->set_tiers($tiers);
b55d4af1 1576 $coupon->set_config_obj($config_obj);
023761bd
TC
1577 $coupon->save;
1578
7f8a63a1
TC
1579 $req->audit
1580 (
1581 component => "shopadmin:coupon:edit",
88c9c249 1582 level => "notice",
7f8a63a1
TC
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
023761bd
TC
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
1609Prompt for deletion of a coupon
1610
1611Requires C<id> as a coupon id to elete.
1612
1613Template: F<admin/coupons/delete>
1614
1615=cut
1616
1617sub 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
2ced88e0
TC
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
023761bd
TC
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
1640Delete a coupon
1641
1642Requires C<id> as a coupon id to delete.
1643
1644CSRF token: C<admin_bse_coupon_delete>
1645
1646=cut
1647
1648sub 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
2ced88e0
TC
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
023761bd 1660 my $code = $coupon->code;
7f8a63a1
TC
1661
1662 $req->audit
1663 (
1664 component => "shopadmin:coupon:delete",
88c9c249 1665 level => "notice",
7f8a63a1
TC
1666 msg => "Coupon '$code' deleted",
1667 object => $coupon,
1668 dump => $coupon->json_data,
1669 );
1670
023761bd
TC
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
4d764c34
TC
1683#####################
1684# utilities
1685# perhaps some of these belong in a class...
1686
4d764c34
TC
1687
1688# convert an epoch time to sql format
1689sub 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
1697sub epoch_to_sql_datetime {
1698 use POSIX 'strftime';
1699 my ($time) = @_;
1700
1701 return strftime('%Y-%m-%d %H:%M', localtime $time);
1702}
1703
6f0799a4
TC
1704
1705sub 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
4d764c34
TC
17221;
1723
1724__END__
1725
1726=head1 NAME
1727
1728shopadmin.pl - administration for the online-store tables
1729
1730=head1 SYNOPSYS
1731
1732(This is a CGI script.)
1733
1734=head1 DESCRIPTION
1735
1736shopadmin.pl gives a UI to edit the product table, and view the orders and
1737order_item tables.
1738
1739=head1 TEMPLATES
1740
1741shopadmin.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
1749Access to product fields.
1750
1751=item date I<name>
1752
1753Formats the I<name> field of the product as a date.
1754
1755=item money I<name>
1756
1757Formats the I<name> integer field as a 2 decimal place money value.
1758
1759=item iterator ... products
1760
1761Iterates over the products database in reverse expire order.
1762
1763=item script
1764
1765The name of the current script for use in URLs.
1766
1767=item message
1768
1769An 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
1781These use the same tags.
1782
1783=over 4
1784
1785=item product I<name>
1786
1787The specified field of the product.
1788
1789=item date I<name>
1790
1791Formats the given field of the product as a date.
1792
1793=item money I<name>
1794
1795Formats the given integer field of the product as money.
1796
1797=item action
1798
1799Either 'Add New' or 'Edit'.
1800
1801=item message
1802
1803The message parameter passed into the script.
1804
1805=item script
1806
1807The name of the script, for use in urls.
1808
1809=item ifImage
1810
1811Conditional, 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
1821Used to display the list of orders. You can also specify a template
1822parameter to the order_list target, and perform filtering and sorting
1823within the template.
1824
1825=over 4
1826
1827=item order I<name>
1828
1829The given field of the order.
1830
1831=item iterator ... orders [filter-sort-spec]
1832
1833Iterates over the orders in reverse orderDate order.
1834
1835The [filter-sort-spec] can contain none, either or both of the following:
1836
1837=over
1838
1839=item filter= field op value, ...
1840
1841filter the data by checking the given expression.
1842
1843eg. filter= filled == 0
1844
1845=item sort= [+|-] keyword, ...
1846
1847Sorts the result by the specified fields, in reverse if preceded by '-'.
1848
1849=back
1850
1851=item money I<name>
1852
1853The given field of the current order formatted as money.
1854
1855=item date I<name>
1856
1857The given field of the current order formatted as a date.
1858
1859=item script
1860
1861The name of the script, for use in urls.
1862
1863=back
1864
1865=head2 order_detail.tmpl
1866
1867Used to display the details for an order.
1868
1869=over 4
1870
1871=item item I<name>
1872
1873Displays the given field of a line item
1874
1875=item iterator ... items
1876
1877Iterates over the line items in the order.
1878
1879=item order I<name>
1880
1881The given field of the order.
1882
1883=item money I<func> I<args>
1884
1885Formats the given functions return value as money.
1886
1887=item date I<func> I<args>
1888
1889Formats the given function return value as a date.
1890
1891=item extension I<name>
1892
1893Takes the given field for the current item multiplied by the units column.
1894
1895=item product I<name>
1896
1897The given product field of the product for the current item.
1898
1899=item script
1900
1901The name of the current script (for use in urls).
1902
1903=item iterator ... options
1904
1905Iterates over the options set for the current order item.
1906
1907=item option I<field>
1908
1909Access to a field of the option, any of id, value, desc or label.
1910
1911=item ifOptions
1912
1913Conditional tag, true if the current product has any options.
1914
1915=item options
1916
1917A laid-out list of the options set for the current order item.
1918
1919=back
1920
1921=cut
1922